├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .hlint.yaml ├── .vim.custom ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── Setup.lhs ├── cabal.haskell-ci ├── cabal.project ├── distributive.cabal ├── src ├── Control │ ├── Comonad │ │ └── Rep │ │ │ └── Store.hs │ └── Monad │ │ └── Rep │ │ ├── Reader.hs │ │ └── State.hs ├── Data │ ├── Distributive.hs │ ├── HKD │ │ ├── Record.hs │ │ ├── Record │ │ │ └── Internal.hs │ │ ├── Rep.hs │ │ └── Rep │ │ │ └── Endo.hs │ ├── Machine │ │ ├── Mealy.hs │ │ └── Moore.hs │ ├── Profunctor │ │ ├── Closed.hs │ │ ├── Mapping.hs │ │ ├── Rep.hs │ │ └── Sieve.hs │ ├── Rep.hs │ ├── Rep │ │ ├── Coyoneda.hs │ │ ├── Endo.hs │ │ └── Internal.hs │ ├── Vec.hs │ └── Vec │ │ └── Internal.hs └── Trustworthy.hs └── tests ├── GenericsSpec.hs └── Spec.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.14.3 12 | # 13 | # REGENDATA ("0.14.3",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-18.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.0.2 32 | compilerKind: ghc 33 | compilerVersion: 9.0.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-8.10.7 37 | compilerKind: ghc 38 | compilerVersion: 8.10.7 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-8.8.4 42 | compilerKind: ghc 43 | compilerVersion: 8.8.4 44 | setup-method: hvr-ppa 45 | allow-failure: false 46 | - compiler: ghc-8.6.5 47 | compilerKind: ghc 48 | compilerVersion: 8.6.5 49 | setup-method: hvr-ppa 50 | allow-failure: false 51 | fail-fast: false 52 | steps: 53 | - name: apt 54 | run: | 55 | apt-get update 56 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 57 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 58 | mkdir -p "$HOME/.ghcup/bin" 59 | curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup" 60 | chmod a+x "$HOME/.ghcup/bin/ghcup" 61 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" 62 | "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 63 | else 64 | apt-add-repository -y 'ppa:hvr/ghc' 65 | apt-get update 66 | apt-get install -y "$HCNAME" 67 | mkdir -p "$HOME/.ghcup/bin" 68 | curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup" 69 | chmod a+x "$HOME/.ghcup/bin/ghcup" 70 | "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 71 | fi 72 | env: 73 | HCKIND: ${{ matrix.compilerKind }} 74 | HCNAME: ${{ matrix.compiler }} 75 | HCVER: ${{ matrix.compilerVersion }} 76 | - name: Set PATH and environment variables 77 | run: | 78 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 79 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 80 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 81 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 82 | HCDIR=/opt/$HCKIND/$HCVER 83 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 84 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 85 | echo "HC=$HC" >> "$GITHUB_ENV" 86 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 87 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 88 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 89 | else 90 | HC=$HCDIR/bin/$HCKIND 91 | echo "HC=$HC" >> "$GITHUB_ENV" 92 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 93 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 94 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 95 | fi 96 | 97 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 98 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 99 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 100 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 101 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 102 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 103 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 104 | env: 105 | HCKIND: ${{ matrix.compilerKind }} 106 | HCNAME: ${{ matrix.compiler }} 107 | HCVER: ${{ matrix.compilerVersion }} 108 | - name: env 109 | run: | 110 | env 111 | - name: write cabal config 112 | run: | 113 | mkdir -p $CABAL_DIR 114 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 147 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 148 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 149 | rm -f cabal-plan.xz 150 | chmod a+x $HOME/.cabal/bin/cabal-plan 151 | cabal-plan --version 152 | - name: install cabal-docspec 153 | run: | 154 | mkdir -p $HOME/.cabal/bin 155 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20211114/cabal-docspec-0.0.0.20211114.xz > cabal-docspec.xz 156 | echo 'e224700d9e8c9ec7ec6bc3f542ba433cd9925a5d356676c62a9bd1f2c8be8f8a cabal-docspec.xz' | sha256sum -c - 157 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 158 | rm -f cabal-docspec.xz 159 | chmod a+x $HOME/.cabal/bin/cabal-docspec 160 | cabal-docspec --version 161 | - name: checkout 162 | uses: actions/checkout@v2 163 | with: 164 | path: source 165 | - name: initial cabal.project for sdist 166 | run: | 167 | touch cabal.project 168 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 169 | cat cabal.project 170 | - name: sdist 171 | run: | 172 | mkdir -p sdist 173 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 174 | - name: unpack 175 | run: | 176 | mkdir -p unpacked 177 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 178 | - name: generate cabal.project 179 | run: | 180 | PKGDIR_distributive="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/distributive-[0-9.]*')" 181 | echo "PKGDIR_distributive=${PKGDIR_distributive}" >> "$GITHUB_ENV" 182 | rm -f cabal.project cabal.project.local 183 | touch cabal.project 184 | touch cabal.project.local 185 | echo "packages: ${PKGDIR_distributive}" >> cabal.project 186 | echo "package distributive" >> cabal.project 187 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 188 | cat >> cabal.project <> cabal.project.local 227 | cat cabal.project 228 | cat cabal.project.local 229 | - name: dump install plan 230 | run: | 231 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 232 | cabal-plan 233 | - name: cache 234 | uses: actions/cache@v2 235 | with: 236 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 237 | path: ~/.cabal/store 238 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 239 | - name: install dependencies 240 | run: | 241 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 242 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 243 | - name: build 244 | run: | 245 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 246 | - name: tests 247 | run: | 248 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 249 | - name: docspec 250 | run: | 251 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 252 | cabal-docspec $ARG_COMPILER 253 | - name: cabal check 254 | run: | 255 | cd ${PKGDIR_distributive} || false 256 | ${CABAL} -vnormal check 257 | - name: haddock 258 | run: | 259 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 260 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | docs 4 | wiki 5 | TAGS 6 | tags 7 | wip 8 | .DS_Store 9 | .*.swp 10 | .*.swo 11 | *.o 12 | *.hi 13 | *~ 14 | *# 15 | .stack-work/ 16 | cabal-dev 17 | *.chi 18 | *.chs.h 19 | *.dyn_o 20 | *.dyn_hi 21 | .hpc 22 | .hsenv 23 | .cabal-sandbox/ 24 | cabal.sandbox.config 25 | *.prof 26 | *.aux 27 | *.hp 28 | *.eventlog 29 | cabal.project.local 30 | cabal.project.local~ 31 | .HTF/ 32 | .ghc.environment.* 33 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [--cpp-define=HLINT, --cpp-ansi] 2 | 3 | - ignore: {name: Use section} 4 | - ignore: {name: Redundant lambda} 5 | - ignore: {name: Use const} 6 | - ignore: {name: Avoid lambda} 7 | - ignore: {name: Avoid lambda using `infix`} 8 | - ignore: {name: Use sequenceA, within: [Data.Rep.Internal]} 9 | -------------------------------------------------------------------------------- /.vim.custom: -------------------------------------------------------------------------------- 1 | " Add the following to your .vimrc to automatically load this on startup 2 | 3 | " if filereadable(".vim.custom") 4 | " so .vim.custom 5 | " endif 6 | 7 | function StripTrailingWhitespace() 8 | let myline=line(".") 9 | let mycolumn = col(".") 10 | silent %s/ *$// 11 | call cursor(myline, mycolumn) 12 | endfunction 13 | 14 | " enable syntax highlighting 15 | syntax on 16 | 17 | " search for the tags file anywhere between here and / 18 | set tags=TAGS;/ 19 | 20 | " highlight tabs and trailing spaces 21 | set listchars=tab:‗‗,trail:‗ 22 | set list 23 | 24 | " f2 runs hasktags 25 | map :exec ":!hasktags -x -c --ignore src" 26 | 27 | " strip trailing whitespace before saving 28 | " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() 29 | 30 | " rebuild hasktags after saving 31 | au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" 32 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 1 [unreleased] 2 | -------------- 3 | * Rebuilt on top of Aaron Vargo's suggestion to use distribution over a higher-kinded 4 | data type to improve the asymptotic performance of recursive distributive instances. 5 | `Distributive` has been renamed to `Representable` and is now as powerful as the older 6 | `Representable` from `adjunctions`. 7 | * Removed flags. 8 | * Inverted dependency with `comonad`. 9 | 10 | 0.6.2.1 [2020.12.30] 11 | -------------------- 12 | * The build-type has been changed from `Custom` to `Simple`. 13 | To achieve this, the `doctests` test suite has been removed in favor of using 14 | [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) 15 | to run the doctests. 16 | 17 | 0.6.2 [2020.04.10] 18 | ------------------ 19 | * Make the `Distributive` instance for `Tagged` poly-kinded. 20 | 21 | 0.6.1 [2019.09.06] 22 | ------------------ 23 | * Add a `Distributive` instance for `WrappedMonad m`. 24 | 25 | 0.6 [2018.07.02] 26 | ---------------- 27 | * Remove `fmapCollect`. (See 28 | [here](https://github.com/ekmett/distributive/commit/1020655f15714514048d0dc842ffe4adcec89a7b) 29 | for an explanation of why it was removed.) 30 | * Avoid incurring some dependencies when using recent GHCs. 31 | 32 | 0.5.3 33 | ----- 34 | * Support `doctest-0.12` 35 | 36 | 0.5.2 37 | ----- 38 | * Revamp `Setup.hs` to use `cabal-doctest`. This makes `distributive` build 39 | with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and 40 | sandboxes. 41 | * Fix bugs in `Data.Distributive.Generic` that cause generic `Distributive` 42 | instances not to work properly for datatypes with recursive types 43 | * Add `genericCollect` to `Data.Distributive.Generic`, and switch the underlying 44 | machinery in that module to work on a `collect`-like method instead of a 45 | `distribute`-like one 46 | * Add a test suite for regression-testing `Data.Distributive.Generic` 47 | 48 | 0.5.1 49 | ----- 50 | * Add `Distributive` instances for datatypes from `Data.Semigroup` and `GHC.Generics` 51 | * Add `MINIMAL` pragma for `Distributive` 52 | 53 | 0.5.0.2 54 | ------- 55 | * A more elegant fix for builds on GHC 7.2 56 | 57 | 0.5.0.1 58 | ------- 59 | * Fix builds on GHC 7.2 60 | 61 | 0.5 62 | --- 63 | * Added flags for removing some dependencies. 64 | * Support `doctests` when building to non-standard locations (such as when using `stack`.) 65 | * Support `base-orphans` 66 | 67 | 0.4.4 68 | ----- 69 | * `transformers 0.4` compatibility 70 | 71 | 0.4.3.1 72 | ----- 73 | * Fixed builds with older versions of GHC 74 | 75 | 0.4.2 76 | ------- 77 | * Added `Data.Distributive.Generic`. 78 | 79 | 0.4.1 80 | ----- 81 | * `Control.Monad.Instances` is deprecated in GHC 7.8. Don't import it there. 82 | 83 | 0.4 84 | --- 85 | * Added support for `Data.Tagged` and `Data.Proxy`. 86 | 87 | 0.3.1 88 | ----- 89 | * Minor documentation fix 90 | 91 | 0.3 92 | --- 93 | * Added instances for `Control.Applicative.Backwards` and `Data.Functor.Reverse` from `transformers` 0.3, taking them from `transformers-compat` if necessary for `transformers` 0.2 94 | 95 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # License 2 | 3 | Licensed under either of 4 | * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0) 5 | * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause) 6 | at your option. 7 | 8 | ## BSD 2-Clause License 9 | 10 | - Copyright 2011-2021 Edward Kmett 11 | - Copyright 2018-2021 Aaron Vargo 12 | - Copyright 2021 Oleg Grenrus 13 | 14 | All rights reserved. 15 | 16 | Redistribution and use in source and binary forms, with or without 17 | modification, are permitted provided that the following conditions 18 | are met: 19 | 20 | 1. Redistributions of source code must retain the above copyright 21 | notice, this list of conditions and the following disclaimer. 22 | 23 | 2. Redistributions in binary form must reproduce the above copyright 24 | notice, this list of conditions and the following disclaimer in the 25 | documentation and/or other materials provided with the distribution. 26 | 27 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 28 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 29 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 30 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 31 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 32 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 33 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 34 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 35 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 36 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 37 | POSSIBILITY OF SUCH DAMAGE. 38 | 39 | ## Apache License 40 | 41 | _Version 2.0, January 2004_ 42 | _<>_ 43 | 44 | ### Terms and Conditions for use, reproduction, and distribution 45 | 46 | #### 1. Definitions 47 | 48 | “License” shall mean the terms and conditions for use, reproduction, and 49 | distribution as defined by Sections 1 through 9 of this document. 50 | 51 | “Licensor” shall mean the copyright owner or entity authorized by the copyright 52 | owner that is granting the License. 53 | 54 | “Legal Entity” shall mean the union of the acting entity and all other entities 55 | that control, are controlled by, or are under common control with that entity. 56 | For the purposes of this definition, “control” means **(i)** the power, direct or 57 | indirect, to cause the direction or management of such entity, whether by 58 | contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the 59 | outstanding shares, or **(iii)** beneficial ownership of such entity. 60 | 61 | “You” (or “Your”) shall mean an individual or Legal Entity exercising 62 | permissions granted by this License. 63 | 64 | “Source” form shall mean the preferred form for making modifications, including 65 | but not limited to software source code, documentation source, and configuration 66 | files. 67 | 68 | “Object” form shall mean any form resulting from mechanical transformation or 69 | translation of a Source form, including but not limited to compiled object code, 70 | generated documentation, and conversions to other media types. 71 | 72 | “Work” shall mean the work of authorship, whether in Source or Object form, made 73 | available under the License, as indicated by a copyright notice that is included 74 | in or attached to the work (an example is provided in the Appendix below). 75 | 76 | “Derivative Works” shall mean any work, whether in Source or Object form, that 77 | is based on (or derived from) the Work and for which the editorial revisions, 78 | annotations, elaborations, or other modifications represent, as a whole, an 79 | original work of authorship. For the purposes of this License, Derivative Works 80 | shall not include works that remain separable from, or merely link (or bind by 81 | name) to the interfaces of, the Work and Derivative Works thereof. 82 | 83 | “Contribution” shall mean any work of authorship, including the original version 84 | of the Work and any modifications or additions to that Work or Derivative Works 85 | thereof, that is intentionally submitted to Licensor for inclusion in the Work 86 | by the copyright owner or by an individual or Legal Entity authorized to submit 87 | on behalf of the copyright owner. For the purposes of this definition, 88 | “submitted” means any form of electronic, verbal, or written communication sent 89 | to the Licensor or its representatives, including but not limited to 90 | communication on electronic mailing lists, source code control systems, and 91 | issue tracking systems that are managed by, or on behalf of, the Licensor for 92 | the purpose of discussing and improving the Work, but excluding communication 93 | that is conspicuously marked or otherwise designated in writing by the copyright 94 | owner as “Not a Contribution.” 95 | 96 | “Contributor” shall mean Licensor and any individual or Legal Entity on behalf 97 | of whom a Contribution has been received by Licensor and subsequently 98 | incorporated within the Work. 99 | 100 | #### 2. Grant of Copyright License 101 | 102 | Subject to the terms and conditions of this License, each Contributor hereby 103 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 104 | irrevocable copyright license to reproduce, prepare Derivative Works of, 105 | publicly display, publicly perform, sublicense, and distribute the Work and such 106 | Derivative Works in Source or Object form. 107 | 108 | #### 3. Grant of Patent License 109 | 110 | Subject to the terms and conditions of this License, each Contributor hereby 111 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 112 | irrevocable (except as stated in this section) patent license to make, have 113 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where 114 | such license applies only to those patent claims licensable by such Contributor 115 | that are necessarily infringed by their Contribution(s) alone or by combination 116 | of their Contribution(s) with the Work to which such Contribution(s) was 117 | submitted. If You institute patent litigation against any entity (including a 118 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a 119 | Contribution incorporated within the Work constitutes direct or contributory 120 | patent infringement, then any patent licenses granted to You under this License 121 | for that Work shall terminate as of the date such litigation is filed. 122 | 123 | #### 4. Redistribution 124 | 125 | You may reproduce and distribute copies of the Work or Derivative Works thereof 126 | in any medium, with or without modifications, and in Source or Object form, 127 | provided that You meet the following conditions: 128 | 129 | * **(a)** You must give any other recipients of the Work or Derivative Works a copy of 130 | this License; and 131 | * **(b)** You must cause any modified files to carry prominent notices stating that You 132 | changed the files; and 133 | * **(c)** You must retain, in the Source form of any Derivative Works that You distribute, 134 | all copyright, patent, trademark, and attribution notices from the Source form 135 | of the Work, excluding those notices that do not pertain to any part of the 136 | Derivative Works; and 137 | * **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any 138 | Derivative Works that You distribute must include a readable copy of the 139 | attribution notices contained within such NOTICE file, excluding those notices 140 | that do not pertain to any part of the Derivative Works, in at least one of the 141 | following places: within a NOTICE text file distributed as part of the 142 | Derivative Works; within the Source form or documentation, if provided along 143 | with the Derivative Works; or, within a display generated by the Derivative 144 | Works, if and wherever such third-party notices normally appear. The contents of 145 | the NOTICE file are for informational purposes only and do not modify the 146 | License. You may add Your own attribution notices within Derivative Works that 147 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 148 | provided that such additional attribution notices cannot be construed as 149 | modifying the License. 150 | 151 | You may add Your own copyright statement to Your modifications and may provide 152 | additional or different license terms and conditions for use, reproduction, or 153 | distribution of Your modifications, or for any such Derivative Works as a whole, 154 | provided Your use, reproduction, and distribution of the Work otherwise complies 155 | with the conditions stated in this License. 156 | 157 | #### 5. Submission of Contributions 158 | 159 | Unless You explicitly state otherwise, any Contribution intentionally submitted 160 | for inclusion in the Work by You to the Licensor shall be under the terms and 161 | conditions of this License, without any additional terms or conditions. 162 | Notwithstanding the above, nothing herein shall supersede or modify the terms of 163 | any separate license agreement you may have executed with Licensor regarding 164 | such Contributions. 165 | 166 | #### 6. Trademarks 167 | 168 | This License does not grant permission to use the trade names, trademarks, 169 | service marks, or product names of the Licensor, except as required for 170 | reasonable and customary use in describing the origin of the Work and 171 | reproducing the content of the NOTICE file. 172 | 173 | #### 7. Disclaimer of Warranty 174 | 175 | Unless required by applicable law or agreed to in writing, Licensor provides the 176 | Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, 177 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, 178 | including, without limitation, any warranties or conditions of TITLE, 179 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are 180 | solely responsible for determining the appropriateness of using or 181 | redistributing the Work and assume any risks associated with Your exercise of 182 | permissions under this License. 183 | 184 | #### 8. Limitation of Liability 185 | 186 | In no event and under no legal theory, whether in tort (including negligence), 187 | contract, or otherwise, unless required by applicable law (such as deliberate 188 | and grossly negligent acts) or agreed to in writing, shall any Contributor be 189 | liable to You for damages, including any direct, indirect, special, incidental, 190 | or consequential damages of any character arising as a result of this License or 191 | out of the use or inability to use the Work (including but not limited to 192 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or 193 | any and all other commercial damages or losses), even if such Contributor has 194 | been advised of the possibility of such damages. 195 | 196 | #### 9. Accepting Warranty or Additional Liability 197 | 198 | While redistributing the Work or Derivative Works thereof, You may choose to 199 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or 200 | other liability obligations and/or rights consistent with this License. However, 201 | in accepting such obligations, You may act only on Your own behalf and on Your 202 | sole responsibility, not on behalf of any other Contributor, and only if You 203 | agree to indemnify, defend, and hold each Contributor harmless for any liability 204 | incurred by, or claims asserted against, such Contributor by reason of your 205 | accepting any such warranty or additional liability. 206 | 207 | _END OF TERMS AND CONDITIONS_ 208 | 209 | ### APPENDIX: How to apply the Apache License to your work 210 | 211 | To apply the Apache License to your work, attach the following boilerplate 212 | notice, with the fields enclosed by brackets `[]` replaced with your own 213 | identifying information. (Don't include the brackets!) The text should be 214 | enclosed in the appropriate comment syntax for the file format. We also 215 | recommend that a file or class name and description of purpose be included on 216 | the same “printed page” as the copyright notice for easier identification within 217 | third-party archives. 218 | 219 | Copyright [yyyy] [name of copyright owner] 220 | 221 | Licensed under the Apache License, Version 2.0 (the "License"); 222 | you may not use this file except in compliance with the License. 223 | You may obtain a copy of the License at 224 | 225 | http://www.apache.org/licenses/LICENSE-2.0 226 | 227 | Unless required by applicable law or agreed to in writing, software 228 | distributed under the License is distributed on an "AS IS" BASIS, 229 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 230 | See the License for the specific language governing permissions and 231 | limitations under the License. 232 | 233 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | distributive 2 | ============ 3 | 4 | 5 | [![Hackage](https://img.shields.io/hackage/v/distributive.svg)](https://hackage.haskell.org/package/distributive) [![Build Status](https://github.com/ekmett/distributive/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/distributive/actions?query=workflow%3AHaskell-CI) 6 | 7 | This package provides the notion that is categorically dual to `Traversable`. 8 | 9 | A `Distributive` `Functor` is one that you can push any functor inside of. 10 | 11 | ```haskell 12 | distribute :: (Functor f, Distributive g) => f (g a) -> g (f a) 13 | ``` 14 | 15 | Compare this with the corresponding Traversable notion, `sequenceA`. 16 | 17 | ```haskell 18 | sequenceA :: (Applicative f, Traversable g) => g (f a) -> f (g a) 19 | ``` 20 | 21 | This package includes instances for common types, and includes other methods similar to `traverse` which fuse the use of `fmap`. 22 | 23 | We only require `Functor` rather than some dual notion to `Applicative`, because the latter cannot meaningfully exist in Haskell 24 | since all comonoids there are trivial. 25 | 26 | Contact Information 27 | ------------------- 28 | 29 | Contributions and bug reports are welcome! 30 | 31 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 32 | 33 | -Edward Kmett 34 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | import Distribution.Simple (defaultMain) 3 | main :: IO () 4 | main = defaultMain 5 | \end{code} 6 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: bionic 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | -- irc-channels: irc.freenode.org#haskell-lens 5 | irc-if-in-origin-repo: True 6 | docspec: True 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | allow-newer: 4 | constraints-extras:constraints 5 | 6 | source-repository-package 7 | type: git 8 | branch: main 9 | location: https://github.com/ekmett/bifunctors.git 10 | 11 | source-repository-package 12 | type: git 13 | branch: main 14 | location: https://github.com/ekmett/comonad.git 15 | 16 | source-repository-package 17 | type: git 18 | branch: main 19 | location: https://github.com/ekmett/constraints.git 20 | 21 | source-repository-package 22 | type: git 23 | branch: main 24 | location: https://github.com/ekmett/contravariant.git 25 | 26 | source-repository-package 27 | type: git 28 | branch: main 29 | location: https://github.com/ekmett/profunctors.git 30 | 31 | source-repository-package 32 | type: git 33 | branch: main 34 | location: https://github.com/ekmett/numeric-fin.git 35 | 36 | source-repository-package 37 | type: git 38 | branch: main 39 | location: https://github.com/ekmett/hkd.git 40 | 41 | -------------------------------------------------------------------------------- /distributive.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: distributive 3 | category: Data Structures 4 | version: 1 5 | license: BSD-2-Clause OR Apache-2.0 6 | license-file: LICENSE.md 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/distributive/ 11 | bug-reports: http://github.com/ekmett/distributive/issues 12 | copyright: Copyright 2011-2021 Edward A. Kmett, 13 | Copyright 2017-2021 Aaron Vargo, 14 | Copyright 2021 Oleg Grenrus 15 | synopsis: Representable (aka distributive) functors 16 | description: 17 | Representable (aka distributive) functors. 18 | . 19 | Representable functors can distribute out through any other Functor, 20 | because they are isomorphic to a function from some fixed type. 21 | 22 | tested-with: 23 | GHC == 8.6.5, 24 | GHC == 8.8.4, 25 | GHC == 8.10.7, 26 | GHC == 9.0.2 27 | 28 | extra-source-files: 29 | .vim.custom 30 | CHANGELOG.md 31 | README.md 32 | 33 | source-repository head 34 | type: git 35 | location: git://github.com/ekmett/distributive.git 36 | subdir: distributive 37 | 38 | library 39 | build-depends: 40 | , base >= 4.10 && < 5 41 | , base-orphans >= 0.5.2 && < 1 42 | , bifunctors ^>= 6 43 | , comonad ^>= 6 44 | , containers 45 | , contravariant ^>= 1.6 46 | , dependent-sum ^>= 0.7.1 47 | , ghc-prim 48 | , hkd ^>= 0.2 49 | , indexed-traversable ^>= 0.1 50 | , mtl ^>= 2.2 51 | , numeric-fin ^>= 0 52 | , profunctors ^>= 6 53 | , some ^>= 1.0 54 | , tagged >= 0.7 && < 1 55 | , transformers ^>= 0.5 56 | , vector ^>= 0.12 57 | 58 | hs-source-dirs: src 59 | 60 | other-modules: 61 | Trustworthy 62 | exposed-modules: 63 | Data.Rep 64 | Data.Rep.Coyoneda 65 | Data.Rep.Endo 66 | Data.Rep.Internal 67 | Data.Vec 68 | Data.Vec.Internal 69 | Data.HKD.Record 70 | Data.HKD.Record.Internal 71 | Data.HKD.Rep 72 | Data.HKD.Rep.Endo 73 | Data.Machine.Mealy 74 | Data.Machine.Moore 75 | Data.Profunctor.Closed 76 | Data.Profunctor.Mapping 77 | Data.Profunctor.Rep 78 | Data.Profunctor.Sieve 79 | Control.Comonad.Rep.Store 80 | Control.Monad.Rep.Reader 81 | Control.Monad.Rep.State 82 | 83 | exposed-modules: 84 | Data.Distributive 85 | 86 | ghc-options: -Wall -fexpose-all-unfoldings -fspecialize-aggressively 87 | 88 | if impl(ghc >= 9.0) 89 | -- these flags may abort compilation with GHC-8.10 90 | -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 91 | ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode 92 | 93 | default-language: Haskell2010 94 | default-extensions: 95 | AllowAmbiguousTypes 96 | BangPatterns 97 | BlockArguments 98 | ConstraintKinds 99 | DataKinds 100 | DefaultSignatures 101 | DeriveAnyClass 102 | DeriveDataTypeable 103 | DeriveGeneric 104 | DeriveTraversable 105 | EmptyCase 106 | ExistentialQuantification 107 | ExplicitNamespaces 108 | FlexibleContexts 109 | FlexibleInstances 110 | FunctionalDependencies 111 | GADTs 112 | InstanceSigs 113 | LambdaCase 114 | LiberalTypeSynonyms 115 | MagicHash 116 | NoStarIsType 117 | PartialTypeSignatures 118 | PatternSynonyms 119 | PolyKinds 120 | QuantifiedConstraints 121 | RankNTypes 122 | RoleAnnotations 123 | ScopedTypeVariables 124 | StandaloneDeriving 125 | TupleSections 126 | TypeApplications 127 | TypeFamilies 128 | TypeOperators 129 | UndecidableInstances 130 | UndecidableSuperClasses 131 | ViewPatterns 132 | 133 | other-extensions: 134 | CPP 135 | GeneralizedNewtypeDeriving 136 | Safe 137 | Trustworthy 138 | Unsafe 139 | UnboxedTuples 140 | 141 | test-suite spec 142 | type: exitcode-stdio-1.0 143 | hs-source-dirs: tests 144 | build-tool-depends: 145 | hspec-discover:hspec-discover 146 | 147 | build-depends: 148 | base >= 4 && < 5, 149 | distributive, 150 | generic-deriving >= 1.11 && < 2, 151 | hspec >= 2 && < 3 152 | 153 | main-is: Spec.hs 154 | other-modules: GenericsSpec 155 | ghc-options: -Wall -threaded -rtsopts 156 | default-language: Haskell2010 157 | -------------------------------------------------------------------------------- /src/Control/Comonad/Rep/Store.hs: -------------------------------------------------------------------------------- 1 | {-# Language DerivingStrategies #-} 2 | {-# Language Safe #-} 3 | 4 | -- | 5 | -- Copyright : (c) Edward Kmett 2011-2021 6 | -- (c) Sjoerd Visscher 2011 7 | -- License : BSD-2-Clause OR Apache-2.0 8 | -- Maintainer : ekmett@gmail.com 9 | -- Stability : experimental 10 | -- 11 | -- This is a generalized 'Store' 'Comonad', parameterized by a 'Representable' 'Functor'. 12 | -- The representation of that 'Functor' serves as the index of the store. 13 | -- 14 | -- This can be useful if the representable functor serves to memoize its 15 | -- contents and will be inspected often. 16 | 17 | module Control.Comonad.Rep.Store 18 | ( Store 19 | , pattern Store 20 | , runStore 21 | , StoreT(StoreT, ..) 22 | , runStoreT 23 | , ComonadStore(..) 24 | ) where 25 | 26 | import Control.Comonad 27 | import Control.Comonad.Env.Class 28 | import Control.Comonad.Hoist.Class 29 | import Control.Comonad.Store.Class 30 | import Control.Comonad.Traced.Class 31 | import Control.Comonad.Trans.Class 32 | import Control.Monad.Identity 33 | import Data.Rep 34 | import Data.Data 35 | import Data.Foldable.WithIndex 36 | import Data.Functor.WithIndex 37 | import Data.Traversable.WithIndex 38 | import GHC.Generics 39 | 40 | -- | A memoized store comonad parameterized by a representable functor @g@, where 41 | -- the representatation of @g@, @Log g@ is the index of the store. 42 | -- 43 | type Store g = StoreT g Identity 44 | 45 | -- | Construct a store comonad computation from a function and a current index. 46 | -- (The inverse of 'runStore'.) 47 | pattern Store :: Representable g => (Log g -> a) -> Log g -> Store g a 48 | pattern Store f l = StoreDist (Tabulate f) l 49 | 50 | pattern StoreDist :: g a -> Log g -> Store g a 51 | pattern StoreDist f l = StoreDistT (Identity f) l 52 | 53 | -- | Unwrap a store comonad computation as a function and a current index. 54 | -- (The inverse of 'store'.) 55 | runStore :: Representable g 56 | => Store g a -- ^ a store to access 57 | -> (Log g -> a, Log g) -- ^ initial state 58 | runStore (StoreDistT (Identity ga) k) = (index ga, k) 59 | {-# inline runStore #-} 60 | 61 | -- --------------------------------------------------------------------------- 62 | -- | A store transformer comonad parameterized by: 63 | -- 64 | -- * @g@ - A representable functor used to memoize results for an index @Log g@ 65 | -- 66 | -- * @w@ - The inner comonad. 67 | data StoreT g w a = StoreDistT (w (g a)) (Log g) 68 | deriving stock (Generic, Generic1, Functor, Foldable, Traversable) 69 | -- deriving anyclass (FunctorWithIndex (Log w, Log g)) 70 | 71 | pattern StoreT :: (Functor w, Representable g) => w (Log g -> a) -> Log g -> StoreT g w a 72 | pattern StoreT w s <- StoreDistT (fmap index -> w) s where 73 | StoreT w s = StoreDistT (fmap tabulate w) s 74 | 75 | runStoreT :: (Functor w, Indexable g) => StoreT g w a -> (w (Log g -> a), Log g) 76 | runStoreT (StoreDistT w s) = (index <$> w, s) 77 | {-# inline runStoreT #-} 78 | 79 | deriving stock instance 80 | ( Typeable g 81 | , Typeable w 82 | , Typeable a 83 | , Data (w (g a)) 84 | , Data (Log g) 85 | ) => Data (StoreT g w a) 86 | 87 | instance 88 | ( FunctorWithIndex i w 89 | , FunctorWithIndex j g 90 | ) => FunctorWithIndex (i, j) (StoreT g w) where 91 | imap f (StoreDistT wg lg) = StoreDistT (imap (\i -> imap \j -> f (i,j)) wg) lg 92 | 93 | instance 94 | ( FoldableWithIndex i w 95 | , FoldableWithIndex j g 96 | ) => FoldableWithIndex (i, j) (StoreT g w) where 97 | ifoldMap f (StoreDistT wg _) = ifoldMap (\i -> ifoldMap \j -> f (i,j)) wg 98 | 99 | instance 100 | ( TraversableWithIndex i w 101 | , TraversableWithIndex j g 102 | ) => TraversableWithIndex (i, j) (StoreT g w) where 103 | itraverse f (StoreDistT wg lg) = (`StoreDistT` lg) <$> itraverse (\i -> itraverse \j -> f (i,j)) wg 104 | 105 | instance (Comonad w, Representable g, Log g ~ s) => ComonadStore s (StoreT g w) where 106 | pos (StoreDistT _ s) = s 107 | {-# inline pos #-} 108 | peek s (StoreDistT w _) = extract w `index` s 109 | {-# inline peek #-} 110 | peeks f (StoreDistT w s) = extract w `index` f s 111 | {-# inline peeks #-} 112 | seek s (StoreDistT w _) = StoreDistT w s 113 | {-# inline seek #-} 114 | seeks f (StoreDistT w s) = StoreDistT w (f s) 115 | {-# inline seeks #-} 116 | 117 | instance (ComonadApply w, Semigroup (Log g), Representable g) => ComonadApply (StoreT g w) where 118 | StoreDistT ff m <@> StoreDistT fa n = StoreDistT (apRep <$> ff <@> fa) (m <> n) 119 | {-# inline (<@>) #-} 120 | 121 | instance (Applicative w, Monoid (Log g), Representable g) => Applicative (StoreT g w) where 122 | pure a = StoreDistT (pure (pureRep a)) mempty 123 | {-# inline pure #-} 124 | StoreDistT ff m <*> StoreDistT fa n = StoreDistT (apRep <$> ff <*> fa) (m `mappend` n) 125 | {-# inline (<*>) #-} 126 | 127 | instance (Comonad w, Representable g) => Comonad (StoreT g w) where 128 | duplicate (StoreDistT wf s) = StoreDistT (extend (tabulate . StoreDistT) wf) s 129 | {-# inline duplicate #-} 130 | extract (StoreDistT wf s) = index (extract wf) s 131 | {-# inline extract #-} 132 | 133 | instance Representable g => ComonadTrans (StoreT g) where 134 | lower (StoreDistT w s) = fmap (`index` s) w 135 | {-# inline lower #-} 136 | 137 | instance ComonadHoist (StoreT g) where 138 | cohoist f (StoreDistT w s) = StoreDistT (f w) s 139 | {-# inline cohoist #-} 140 | 141 | instance (ComonadTraced m w, Representable g) => ComonadTraced m (StoreT g w) where 142 | trace m = trace m . lower 143 | {-# inline trace #-} 144 | 145 | instance (ComonadEnv m w, Representable g) => ComonadEnv m (StoreT g w) where 146 | ask = ask . lower 147 | {-# inline ask #-} 148 | 149 | -- instance (Representable g, ComonadCofree f w) => ComonadCofree f (StoreT g w) where 150 | -- unwrap (StoreDistT w s) = fmap (`StoreDistT` s) (unwrap w) 151 | -- {-# inline unwrap #-} 152 | -------------------------------------------------------------------------------- /src/Control/Monad/Rep/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language Trustworthy #-} 3 | 4 | -- | 5 | -- Copyright : (c) Edward Kmett 2011-2021, 6 | -- (c) Conal Elliott 2008 7 | -- License : BSD-2-Clause OR Apache-2.0 8 | -- Maintainer : Edward Kmett 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | -- A 'ReaderT' monad that uses a 'Representable' functor instead 13 | -- of a function. 14 | 15 | module Control.Monad.Rep.Reader 16 | ( 17 | -- * Representable functor monad 18 | Reader 19 | , pattern Reader 20 | , runReader 21 | -- * Monad Transformer 22 | , ReaderT(.., ReaderT, runReaderT) 23 | , liftCatch 24 | , liftCallCC 25 | ) where 26 | 27 | import Control.Applicative 28 | import Control.Monad 29 | import Control.Monad.Cont.Class 30 | import Control.Monad.Error.Class 31 | import Control.Monad.Fail 32 | import Control.Monad.Fix 33 | import Control.Monad.Zip 34 | import Control.Monad.IO.Class 35 | import Control.Monad.Reader.Class 36 | import Control.Monad.Signatures 37 | import Control.Monad.State.Class 38 | import Control.Monad.Trans.Class 39 | import Control.Monad.Writer.Class as Writer 40 | import Data.Coerce 41 | import Data.Data 42 | import Data.Function.Coerce 43 | import Data.Functor.Contravariant 44 | import Data.Functor.Identity 45 | import Data.Rep 46 | import Data.HKD 47 | import GHC.Generics 48 | 49 | type Reader f = ReaderT f Identity 50 | 51 | pattern Reader :: Representable f => (Log f -> a) -> Reader f a 52 | pattern Reader { runReader } <- ReaderT (Coerce runReader) 53 | 54 | {-# complete Reader #-} 55 | 56 | -- | This 'representable monad transformer' transforms any monad @m@ with a 'Representable' 'Monad'. 57 | -- This monad in turn is also representable if @m@ is 'Representable'. 58 | type role ReaderT representational nominal nominal 59 | newtype ReaderT f m b = ReaderRepT { runReaderRepT :: f (m b) } 60 | deriving (Generic, Generic1, Data) 61 | 62 | pattern ReaderT :: Representable f => (Log f -> m a) -> ReaderT f m a 63 | pattern ReaderT { runReaderT } = ReaderRepT (Tabulate runReaderT) 64 | {-# complete ReaderT #-} 65 | 66 | instance (Functor f, Functor m) => Functor (ReaderT f m) where 67 | fmap = \f -> ReaderRepT #. fmap (fmap f) .# runReaderRepT 68 | 69 | instance (Indexable f, Indexable m) => Indexable (ReaderT f m) where 70 | type Log (ReaderT f m) = (Log f, Log m) 71 | index = \(ReaderRepT f) (x, y) -> index (index f x) y 72 | {-# inline index #-} 73 | 74 | instance (Representable f, Representable m) => Representable (ReaderT f m) where 75 | scatter = \k f -> coerce $ scatter k ((Comp1 . runReaderRepT) #. f) 76 | tabulate = \f -> ReaderRepT $ tabulate \i -> tabulate \j -> f (i, j) 77 | {-# inline tabulate #-} 78 | 79 | instance (Representable f, Applicative m) => Applicative (ReaderT f m) where 80 | pure = ReaderRepT #. (pureRep . pure) 81 | {-# inline pure #-} 82 | (<*>) = \(ReaderRepT ff) (ReaderRepT fa) -> ReaderRepT $ liftR2 (<*>) ff fa 83 | {-# inline (<*>) #-} 84 | (*>) = \(ReaderRepT fa) (ReaderRepT fb) -> ReaderRepT $ liftR2 (*>) fa fb 85 | {-# inline (*>) #-} 86 | (<*) = \(ReaderRepT fa) (ReaderRepT fb) -> ReaderRepT $ liftR2 (<*) fa fb 87 | {-# inline (<*) #-} 88 | 89 | instance (Representable f, Monad m) => Monad (ReaderT f m) where 90 | (>>=) = \(ReaderRepT fm) f -> 91 | ReaderRepT $ liftR2 (>>=) fm $ distribute (runReaderRepT . f) 92 | {-# inline (>>=) #-} 93 | #if !(MIN_VERSION_base(4,13,0)) 94 | fail = lift . Control.Monad.fail 95 | {-# inline fail #-} 96 | #endif 97 | 98 | instance (Representable f, MonadFail m) => MonadFail (ReaderT f m) where 99 | fail = lift . Control.Monad.Fail.fail 100 | {-# inline fail #-} 101 | 102 | instance (Representable f, Monad m, Log f ~ e) => MonadReader e (ReaderT f m) where 103 | ask = ReaderRepT $ tabulate pure 104 | {-# inline ask #-} 105 | local = \f m -> ReaderT \r -> runReaderT m (f r) 106 | {-# inline local #-} 107 | reader = ReaderT . fmap pure 108 | {-# inline reader #-} 109 | 110 | instance Representable f => MonadTrans (ReaderT f) where 111 | lift = ReaderRepT #. pureRep 112 | {-# inline lift #-} 113 | 114 | liftReaderT :: Representable f => m a -> ReaderT f m a 115 | liftReaderT = ReaderRepT #. pureRep 116 | {-# inline liftReaderT #-} 117 | 118 | instance (Representable f, MonadIO m) => MonadIO (ReaderT f m) where 119 | liftIO = lift . liftIO 120 | {-# inline liftIO #-} 121 | 122 | instance (Representable f, MonadWriter w m) => MonadWriter w (ReaderT f m) where 123 | tell = lift . tell 124 | {-# inline tell #-} 125 | listen = ReaderRepT #. fmap listen .# runReaderRepT 126 | {-# inline listen #-} 127 | pass = ReaderRepT #. fmap pass .# runReaderRepT 128 | {-# inline pass #-} 129 | 130 | instance (Foldable f, Foldable m) => Foldable (ReaderT f m) where 131 | foldMap f = foldMap (foldMap f) .# runReaderRepT 132 | {-# inline foldMap #-} 133 | 134 | instance (Traversable f, Traversable m) => Traversable (ReaderT f m) where 135 | traverse f = fmap ReaderRepT . traverse (traverse f) .# runReaderRepT 136 | {-# inline traverse #-} 137 | 138 | instance (Representable f, MonadState s m) => MonadState s (ReaderT f m) where 139 | get = lift get 140 | {-# inline get #-} 141 | put = lift . put 142 | {-# inline put #-} 143 | state = lift . state 144 | {-# inline state #-} 145 | 146 | instance (Representable f, MonadError e m) => MonadError e (ReaderT f m) where 147 | throwError = lift . throwError 148 | {-# inline throwError #-} 149 | catchError = liftCatch catchError 150 | {-# inline catchError #-} 151 | 152 | data DCatch x e m f = DCatch (ReaderT f m x) (e -> ReaderT f m x) 153 | 154 | withReaderRepT :: (f (m a) -> g (n b)) -> ReaderT f m a -> ReaderT g n b 155 | withReaderRepT f = ReaderRepT #. f .# runReaderRepT 156 | 157 | instance FFunctor (DCatch x y m) where 158 | ffmap f (DCatch l r) = DCatch (withReaderRepT f l) (withReaderRepT f . r) 159 | {-# inline ffmap #-} 160 | 161 | -- | Lift a @catchE@ operation to the new monad. 162 | liftCatch :: Representable f => Catch e m a -> Catch e (ReaderT f m) a 163 | -- liftCatch = \f m h -> ReaderT \ r -> f (runReaderT m r) (\ e -> runReaderT (h e) r) 164 | liftCatch = \ f m h -> 165 | ReaderRepT $ distrib (DCatch m h) \(DCatch m' h') -> coerce f m' h' 166 | {-# inline liftCatch #-} 167 | 168 | newtype DCompReaderT g m a f = DCompReaderT (g (ReaderT f m a)) 169 | 170 | instance Functor g => FFunctor (DCompReaderT g m a) where 171 | ffmap f (DCompReaderT k) = DCompReaderT (fmap (withReaderRepT f) k) 172 | {-# inline ffmap #-} 173 | 174 | -- | Lift a @callCC@ operation to the new monad. 175 | liftCallCC :: forall f m a b. Representable f => CallCC m a b -> CallCC (ReaderT f m) a b 176 | liftCallCC = \callCC' f -> 177 | ReaderRepT $ distrib (DCompReaderT f) \(DCompReaderT f') -> 178 | callCC' \c -> coerce $ f' (ReaderRepT #. pureRep . c) 179 | {-# inline liftCallCC #-} 180 | 181 | instance (Representable f, MonadCont m) => MonadCont (ReaderT f m) where 182 | callCC = liftCallCC callCC 183 | {-# inline callCC #-} 184 | 185 | instance (Representable f, Alternative m) => Alternative (ReaderT f m) where 186 | empty = liftReaderT empty 187 | {-# inline empty #-} 188 | (<|>) = \(ReaderRepT fm) -> ReaderRepT #. liftR2 (<|>) fm .# runReaderRepT 189 | {-# inline (<|>) #-} 190 | 191 | instance (Representable f, MonadPlus m) => MonadPlus (ReaderT f m) 192 | 193 | instance (Representable f, MonadFix m) => MonadFix (ReaderT f m) where 194 | mfix = \f -> ReaderRepT $ distrib (DCompReaderT f) $ mfix . coerce 195 | {-# inline mfix #-} 196 | 197 | instance (Representable f, MonadZip m) => MonadZip (ReaderT f m) where 198 | mzipWith = \f (ReaderRepT m) -> ReaderRepT #. liftR2 (mzipWith f) m .# runReaderRepT 199 | {-# inline mzipWith #-} 200 | 201 | instance (Representable f, Contravariant m) => Contravariant (ReaderT f m) where 202 | contramap = \f -> ReaderRepT #. fmap (contramap f) .# runReaderRepT 203 | {-# INLINE contramap #-} 204 | -------------------------------------------------------------------------------- /src/Control/Monad/Rep/State.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language DerivingStrategies #-} 3 | {-# Language Trustworthy #-} 4 | 5 | -- | 6 | -- Copyright : (c) Edward Kmett 2011-2021, 7 | -- (c) Sjoerd Visscher 2011 8 | -- License : BSD-2-Clause OR Apache-2.0 9 | -- Maintainer : Edward Kmett 10 | -- Stability : experimental 11 | -- Portability : non-portable 12 | -- 13 | -- A generalized State monad, parameterized by a 'Representable' functor. 14 | -- The 'Log' of that functor serves as the state. 15 | 16 | module Control.Monad.Rep.State 17 | ( State 18 | , pattern State 19 | , runState 20 | , evalState 21 | , execState 22 | , mapState 23 | , StateT(.., StateT, runStateT) 24 | , evalStateT 25 | , execStateT 26 | , mapStateT 27 | , liftCallCC 28 | , liftCallCC' 29 | , liftCatch 30 | , liftListen 31 | , liftPass 32 | ) where 33 | 34 | import Control.Applicative 35 | import Control.Monad 36 | import Control.Monad.Cont.Class 37 | import Control.Monad.Error.Class 38 | import Control.Monad.Fail 39 | import Control.Monad.Fix 40 | import Control.Monad.Reader.Class 41 | import Control.Monad.Signatures 42 | import Control.Monad.State.Class 43 | import Control.Monad.Trans.Class 44 | import Control.Monad.Writer.Class 45 | import Data.Coerce 46 | import Data.Data 47 | import Data.Function.Coerce 48 | import Data.Functor.Contravariant 49 | import Data.Functor.Identity 50 | import Data.Rep 51 | import Data.HKD 52 | import GHC.Generics 53 | 54 | -- | A memoized state monad parameterized by a 'Representable' functor @g@, where 55 | -- 'Log' g is the state to carry. 56 | -- 57 | -- 'return' leaves the state unchanged, while '(>>=)' uses the final state of 58 | -- the first computation as the initial state of the second. 59 | type State g = StateT g Identity 60 | 61 | pattern State :: Representable g => (Log g -> (a, Log g)) -> State g a 62 | pattern State { runState } <- StateT (Coerce runState) 63 | 64 | {-# complete State #-} 65 | 66 | -- | Evaluate a state computation with the given initial state 67 | -- and return the final value, discarding the final state. 68 | -- 69 | -- * @'evalState' m s = 'fst' ('runState' m s)@ 70 | evalState 71 | :: Representable g 72 | => State g a -- ^state-passing computation to execute 73 | -> Log g -- ^initial value 74 | -> a -- ^return value of the state computation 75 | evalState m s = fst (runState m s) 76 | {-# inline evalState #-} 77 | 78 | -- | Evaluate a state computation with the given initial state 79 | -- and return the final state, discarding the final value. 80 | -- 81 | -- * @'execState' m s = 'snd' ('runState' m s)@ 82 | execState 83 | :: Representable g 84 | => State g a -- ^state-passing computation to execute 85 | -> Log g -- ^initial value 86 | -> Log g -- ^final state 87 | execState m s = snd (runState m s) 88 | {-# inline execState #-} 89 | 90 | -- | Map both the return value and final state of a computation using 91 | -- the given function. 92 | -- 93 | -- * @'runState' ('mapState' f m) = f . 'runState' m@ 94 | mapState 95 | :: Functor g 96 | => ((a, Log g) -> (b, Log g)) 97 | -> State g a 98 | -> State g b 99 | mapState f = mapStateT (Identity #. f .# runIdentity) 100 | {-# inline mapState #-} 101 | 102 | -- | A state transformer monad parameterized by: 103 | -- 104 | -- * @g@ - A representable functor used to memoize results for a state @Log g@ 105 | -- 106 | -- * @m@ - The inner monad. 107 | -- 108 | -- The 'return' function leaves the state unchanged, while @>>=@ uses 109 | -- the final state of the first computation as the initial state of 110 | -- the second. 111 | type role StateT nominal nominal nominal 112 | newtype StateT g m a = StateDistT 113 | { runStateDistT :: g (m (a, Log g)) 114 | } deriving (Generic) -- Generic1 would require me to flip the (,) breaking State compat 115 | 116 | deriving stock instance 117 | ( Typeable g 118 | , Typeable m 119 | , Typeable a 120 | , Data (g (m (a, Log g))) 121 | ) => Data (StateT g m a) 122 | 123 | -- | Emulate a traditional state monad 124 | pattern StateT :: Representable g => (Log g -> m (a, Log g)) -> StateT g m a 125 | pattern StateT { runStateT } = StateDistT (Tabulate runStateT) 126 | 127 | {-# complete StateT #-} 128 | 129 | mapStateT :: Functor g => (m (a, Log g) -> n (b, Log g)) -> StateT g m a -> StateT g n b 130 | mapStateT = \f -> StateDistT #. fmap f .# runStateDistT 131 | {-# inline mapStateT #-} 132 | 133 | -- | Evaluate a state computation with the given initial state 134 | -- and return the final value, discarding the final state. 135 | -- 136 | -- * @'evalStateT' m s = 'fmap' 'fst' ('runStateT' m s)@ 137 | evalStateT :: (Representable g, Functor m) => StateT g m a -> Log g -> m a 138 | evalStateT = \m -> fmap fst . runStateT m 139 | {-# inline evalStateT #-} 140 | 141 | -- | Evaluate a state computation with the given initial state 142 | -- and return the final state, discarding the final value. 143 | -- 144 | -- * @'execStateT' m s = 'fmap' 'snd' ('runStateT' m s)@ 145 | execStateT :: (Representable g, Functor m) => StateT g m a -> Log g -> m (Log g) 146 | execStateT = \m -> fmap snd . runStateT m 147 | {-# inline execStateT #-} 148 | 149 | instance (Functor g, Functor m) => Functor (StateT g m) where 150 | fmap = \f -> StateDistT #. fmap (fmap (\ ~(a, s) -> (f a, s))) .# runStateDistT 151 | {-# inline fmap #-} 152 | 153 | instance (Representable g, Functor m, Monad m) => Applicative (StateT g m) where 154 | pure = StateDistT #. leftAdjunctRep pure 155 | {-# inline pure #-} 156 | (<*>) = \mf ma -> mf >>= \f -> fmap f ma 157 | {-# inline (<*>) #-} 158 | 159 | instance (Representable g, Monad m) => Monad (StateT g m) where 160 | (>>=) = \(StateDistT m) f -> StateDistT $ fmap (>>= rightAdjunctRep (runStateT . f)) m 161 | {-# inline (>>=) #-} 162 | #if !(MIN_VERSION_base(4,13,0)) 163 | fail = lift . Control.Monad.fail 164 | {-# inline fail #-} 165 | #endif 166 | 167 | instance (Representable g, MonadFail m) => MonadFail (StateT g m) where 168 | fail = lift . Control.Monad.Fail.fail 169 | {-# inline fail #-} 170 | 171 | instance Representable f => MonadTrans (StateT f) where 172 | lift = \m -> StateT $ \s -> (,s) <$> m 173 | {-# inline lift #-} 174 | 175 | liftStateT :: (Representable f, Functor m) => m a -> StateT f m a 176 | liftStateT = \m -> StateT $ \s -> (,s) <$> m 177 | {-# inline liftStateT #-} 178 | 179 | instance (Representable g, Monad m, Log g ~ s) => MonadState s (StateT g m) where 180 | get = StateT $ \s -> pure (s, s) 181 | {-# inline get #-} 182 | put = \s -> StateDistT $ pureRep $ pure ((),s) 183 | {-# inline put #-} 184 | state = \f -> StateT $ pure . f 185 | {-# inline state #-} 186 | 187 | instance (Representable g, MonadReader e m) => MonadReader e (StateT g m) where 188 | ask = lift ask 189 | {-# inline ask #-} 190 | local = mapStateT . local 191 | {-# inline local #-} 192 | reader = lift . reader 193 | {-# inline reader #-} 194 | 195 | instance (Representable g, MonadWriter w m) => MonadWriter w (StateT g m) where 196 | tell = lift . tell 197 | {-# inline tell #-} 198 | listen = liftListen listen 199 | {-# inline listen #-} 200 | pass = liftPass pass 201 | {-# inline pass #-} 202 | 203 | liftListen :: (Representable f, Functor m) => Listen w m (a, Log f) -> Listen w (StateT f m) a 204 | liftListen = \listen' -> mapStateT $ 205 | fmap (\((a,s'), w) -> ((a,w), s')) . listen' 206 | {-# inline liftListen #-} 207 | 208 | liftPass :: (Representable f, Functor m) => Pass w m (a, Log f) -> Pass w (StateT f m) a 209 | liftPass = \pass' -> mapStateT $ \m -> pass' $ (\((a, f), s') -> ((a, s'), f)) <$> m 210 | {-# inline liftPass #-} 211 | 212 | instance (Representable g, MonadCont m) => MonadCont (StateT g m) where 213 | callCC = liftCallCC' callCC 214 | {-# inline callCC #-} 215 | 216 | -- | Uniform lifting of a @callCC@ operation to the new monad. 217 | -- This version rolls back to the original state on entering the 218 | -- continuation. 219 | liftCallCC 220 | :: Representable g 221 | => ((((a,Log g) -> m (b,Log g)) -> m (a,Log g)) -> m (a,Log g)) 222 | -> ((a -> StateT g m b) -> StateT g m a) 223 | -> StateT g m a 224 | liftCallCC = \callCC' f -> StateT $ \s -> 225 | callCC' $ \c -> 226 | runStateT (f (\a -> StateDistT $ pureRep $ c (a, s))) s 227 | {-# inline liftCallCC #-} 228 | 229 | -- | In-situ lifting of a @callCC@ operation to the new monad. 230 | -- This version uses the current state on entering the continuation. 231 | -- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). 232 | liftCallCC' 233 | :: Representable g => ((((a,Log g) -> m (b,Log g)) -> m (a,Log g)) -> m (a,Log g)) 234 | -> ((a -> StateT g m b) -> StateT g m a) 235 | -> StateT g m a 236 | liftCallCC' = \callCC' f -> StateT $ \s -> 237 | callCC' $ \c -> runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s 238 | {-# inline liftCallCC' #-} 239 | 240 | instance (Representable f, MonadPlus m) => Alternative (StateT f m) where 241 | empty = liftStateT mzero 242 | {-# inline empty #-} 243 | (<|>) = \(StateDistT fm) (StateDistT fn) -> StateDistT (liftR2 mplus fm fn) 244 | {-# inline (<|>) #-} 245 | 246 | instance (Representable f, MonadPlus m) => MonadPlus (StateT f m) 247 | 248 | instance (Representable f, MonadError e m) => MonadError e (StateT f m) where 249 | throwError = lift . throwError 250 | {-# inline throwError #-} 251 | catchError = liftCatch catchError 252 | {-# inline catchError #-} 253 | 254 | data DCatch x y z f = DCatch (f x) (y -> f z) 255 | 256 | instance FFunctor (DCatch x y m) where 257 | ffmap = \ f (DCatch l r) -> DCatch (f l) (f . r) 258 | {-# inline ffmap #-} 259 | 260 | -- | Lift a @catchE@ operation to the new monad. 261 | liftCatch :: Representable f => Catch e m (a, Log f) -> Catch e (StateT f m) a 262 | liftCatch = \catchE (StateDistT m) h -> 263 | StateDistT $ distrib (DCatch m (runStateDistT #. h)) $ \(DCatch m' h') -> coerce catchE m' h' 264 | {-# INLINE liftCatch #-} 265 | 266 | instance (Representable f, MonadFix m) => MonadFix (StateT f m) where 267 | -- mfix f = StateT $ \s -> mfix \ ~(a, _) -> runStateT (f a) s 268 | mfix = \f -> 269 | StateDistT $ distrib (FCompose (runStateDistT #. f)) $ \f' -> mfix (coerce f' . fst) 270 | {-# inline mfix #-} 271 | 272 | instance (Representable f, Contravariant m) => Contravariant (StateT f m) where 273 | contramap = \f (StateDistT m) -> StateDistT $ contramap (\ ~(a, s') -> (f a, s')) <$> m 274 | {-# inline contramap #-} 275 | -------------------------------------------------------------------------------- /src/Data/Distributive.hs: -------------------------------------------------------------------------------- 1 | {-# Language Unsafe #-} 2 | 3 | module Data.Distributive {-# DEPRECATED "Import Data.Rep" #-} 4 | ( Distributive 5 | , collect 6 | , cotraverse 7 | , distribute 8 | ) where 9 | 10 | import Data.Rep 11 | 12 | type Distributive = Representable 13 | -------------------------------------------------------------------------------- /src/Data/HKD/Record.hs: -------------------------------------------------------------------------------- 1 | {-# Language Trustworthy #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2021 Edward Kmett, 5 | -- License : BSD-2-Style OR Apache-2.0 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : non-portable 9 | -- 10 | -- Heterogeneous vectors. 11 | 12 | module Data.HKD.Record 13 | ( Index(Index, IZ, IS, KnownIZ, KnownIS) 14 | , toIndex 15 | , Length 16 | , KnownLength 17 | , lowerFin, liftFin 18 | --, lowerVec, liftVec 19 | , len 20 | , Record(Nil, Cons) 21 | , withLen 22 | ) where 23 | 24 | import Data.HKD.Index.Internal 25 | import Data.HKD.Record.Internal 26 | -------------------------------------------------------------------------------- /src/Data/HKD/Record/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# Language DerivingVia #-} 2 | {-# Language Unsafe #-} 3 | {-# options_haddock not-home #-} 4 | 5 | -- | 6 | -- Copyright : (C) 2021 Edward Kmett, 7 | -- License : BSD-2-Style OR Apache-2.0 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : non-portable 11 | 12 | module Data.HKD.Record.Internal where 13 | 14 | import Control.Applicative 15 | import Data.Function.Coerce 16 | import Data.HKD 17 | import Data.HKD.Index.Internal 18 | import Data.HKD.Rep 19 | import Data.Kind 20 | import Data.Proxy 21 | import Data.Traversable.WithIndex 22 | import Data.Type.Equality 23 | import Data.Vec.Internal 24 | import Data.Vector as V 25 | import GHC.Exts 26 | import GHC.TypeNats 27 | import Unsafe.Coerce 28 | 29 | type role Record nominal representational 30 | newtype Record (as :: [i]) (f :: i -> Type) = UnsafeRecord 31 | { safeRecord :: Vector Any 32 | } 33 | 34 | instance FFunctor (Record as) where 35 | ffmap f = 36 | UnsafeRecord #. 37 | V.map (unsafeCoerce f) .# 38 | safeRecord 39 | {-# inline ffmap #-} 40 | 41 | instance FFunctorWithIndex (Index as) (Record as) where 42 | ifmap f = 43 | UnsafeRecord #. 44 | V.imap (unsafeCoerce f) .# 45 | safeRecord 46 | {-# inline ifmap #-} 47 | 48 | instance FFoldable (Record as) where 49 | ffoldMap f = 50 | V.foldMap (unsafeCoerce f) .# 51 | safeRecord 52 | {-# inline ffoldMap #-} 53 | 54 | instance FFoldableWithIndex (Index as) (Record as) where 55 | iffoldMap f = 56 | V.ifoldr (\i a r -> f (UnsafeIndex i) (unsafeCoerce a) <> r) mempty .# 57 | safeRecord 58 | {-# inline iffoldMap #-} 59 | 60 | instance FTraversable (Record as) where 61 | ftraverse = \(f :: forall x. f x -> m (g x)) -> 62 | fmap UnsafeRecord . 63 | traverse(\a -> Any <$> f (unsafeCoerce a)) .# 64 | safeRecord 65 | {-# inline ftraverse #-} 66 | 67 | instance FTraversableWithIndex (Index as) (Record as) where 68 | iftraverse = \f (UnsafeRecord xs) -> 69 | let !n = V.length xs 70 | in (UnsafeRecord #. V.fromListN n) <$> 71 | itraverse 72 | (\i a -> Any <$> f (UnsafeIndex i) (unsafeCoerce a)) 73 | (V.toList xs) 74 | {-# inline iftraverse #-} 75 | 76 | instance FIndexable (Record as) where 77 | type FLog (Record as) = Index as 78 | findex (UnsafeRecord as) (UnsafeIndex i) = unsafeCoerce (as ! i) 79 | {-# inline findex #-} 80 | 81 | instance KnownLength as => FRepresentable (Record as) where 82 | fscatter k f (ffmap f -> w) = 83 | UnsafeRecord $ 84 | generate (len @as) \i -> 85 | Any $ k $ ffmap (\r -> F1 $ findex r (UnsafeIndex i)) w 86 | {-# inline fscatter #-} 87 | ftabulate f = 88 | UnsafeRecord $ 89 | generate (len @as) (Any . f .# UnsafeIndex) 90 | {-# inline ftabulate #-} 91 | 92 | instance FApply (Record as) where 93 | fliftA2 f as = 94 | UnsafeRecord #. 95 | V.zipWith (unsafeCoerce f) (safeRecord as) .# 96 | safeRecord 97 | {-# inline fliftA2 #-} 98 | 99 | deriving via FDist (Record as) instance KnownLength as => FApplicative (Record as) 100 | 101 | type family AllF (p :: i -> Constraint) (as :: [i]) :: Constraint where 102 | AllF _ '[] = () 103 | AllF p (a ': as) = (p a, AllF p as) 104 | 105 | class AllF p as => All (p :: i -> Constraint) (as :: [i]) where 106 | para :: r '[] -> (forall b bs. (p b, All p bs) => Proxy# b -> r bs -> r (b ': bs)) -> r as 107 | 108 | instance All p '[] where 109 | para nil _ = nil 110 | {-# inline para #-} 111 | 112 | instance (p a, All p as) => All (p :: i -> Constraint) (a ': as) where 113 | para nil kons = kons (proxy# :: Proxy# a) (para @i @p nil kons) 114 | {-# inline para #-} 115 | 116 | withLen :: forall as f r. Record as f -> (KnownLength as => r) -> r 117 | withLen v r = case someNatVal (fromIntegral $ V.length (safeRecord v)) of 118 | SomeNat (Proxy :: Proxy n') -> case unsafeCoerce Refl of 119 | (Refl :: Length as :~: n') -> r 120 | {-# inline withLen #-} 121 | 122 | data IRec (f :: i -> Type) (as :: [i]) = IRec {-# unpack #-} !Int [Any] 123 | 124 | instance (KnownLength as, All p as) => FAll (p :: i -> Constraint) (Record as) where 125 | fall = case len @as of 126 | n -> 127 | case para @i @p @as (IRec n []) $ 128 | \ (_ :: Proxy# b) (IRec (subtract 1 -> i) t) -> 129 | IRec i $ Any (Dict1 :: Dict1 p b) : t 130 | of 131 | IRec 0 r -> UnsafeRecord $ V.fromListN n r 132 | _ -> error "Data.HKD.Internal.Record.fall: the impossible happened" 133 | {-# inline[0] fall #-} 134 | 135 | {- 136 | instance (EqC f, All EqC as) => Eq (Record (as :: [Type]) f) where 137 | xs == ys = 138 | withLen xs $ 139 | Monoid.getAll $ 140 | ffoldMap getConst $ 141 | fliftD3 142 | (\Dict1 x y -> Const $ Monoid.All $ x == y) 143 | (fall @_ @Eq) xs ys 144 | 145 | instance (EqC f, All EqC as) => Eq (Record (as :: [Type]) f) where 146 | xs == ys = 147 | withLen xs $ 148 | Monoid.getAll $ 149 | ffoldMap getConst $ 150 | fliftD3 151 | (\Dict1 x y -> Const $ Monoid.All $ x == y) 152 | (fall @_ @Eq) xs ys 153 | -} 154 | 155 | {- 156 | instance (Eq1 f, All Eq as) => Eq (Record (as :: [Type]) f) where 157 | xs == ys = Monoid.getAll $ 158 | {-# inline (==) #-} 159 | 160 | instance (Ord1 f, All Ord as, All Eq as) => Ord (Record (as :: [Type]) f) where 161 | compare xs ys = 162 | ffoldMap getConst $ 163 | withLen xs $ 164 | fliftD3 165 | (\Dict1 x y -> Const $ liftCompare compare x y) 166 | (fall @Type @Ord) xs ys 167 | {-# inline compare #-} 168 | -} 169 | 170 | data Record' :: [i] -> (i -> Type) -> Type where 171 | Nil' :: Record' '[] f 172 | Cons' :: f a -> Record as f -> Record' (a ': as) f 173 | 174 | upRecord :: Record as f -> Record' as f 175 | upRecord (UnsafeRecord xs) 176 | | V.length xs == 0 = unsafeCoerce Nil' 177 | | otherwise = unsafeCoerce Cons' (xs V.! 0) (UnsafeRecord (V.tail xs)) 178 | 179 | pattern Nil :: () => as ~ '[] => Record as f 180 | pattern Nil <- (upRecord -> Nil') where 181 | Nil = UnsafeRecord V.empty 182 | 183 | -- TODO: construction 184 | pattern Cons :: () => (as ~ (b ': bs)) => f b -> Record bs f -> Record as f 185 | pattern Cons b bs <- (upRecord -> Cons' b bs) -- where 186 | -- Cons b bs = undefined 187 | 188 | pattern Any :: a -> Any 189 | pattern Any a <- (unsafeCoerce -> a) where 190 | Any a = unsafeCoerce a 191 | 192 | liftVec :: Vec (Length as) a -> Record as (Const a) 193 | liftVec (Vec as) = UnsafeRecord (unsafeCoerce as) 194 | {-# inline liftVec #-} 195 | 196 | lowerVec :: Record as (Const a) -> Vec (Length as) a 197 | lowerVec (UnsafeRecord as) = UnsafeVec (unsafeCoerce as) 198 | {-# inline lowerVec #-} 199 | -------------------------------------------------------------------------------- /src/Data/HKD/Rep.hs: -------------------------------------------------------------------------------- 1 | {-# Language Trustworthy #-} 2 | 3 | module Data.HKD.Rep 4 | ( type (%) 5 | , FIndexable(..) 6 | , FRepresentable(..) 7 | , fdistrib 8 | , fdistribute 9 | , fcollect 10 | , fcotraverse 11 | , pattern FTabulate 12 | -- * DerivingVia 13 | , FDist(..) 14 | -- * FFunctor 15 | , ffmapRep 16 | -- * FApply 17 | , fliftR2 18 | , fliftR3 19 | , fliftR4 20 | , fliftR5 21 | -- * FApplicative 22 | , fpureRep 23 | -- * FMonad 24 | , fbindRep 25 | -- * Others 26 | , faskRep 27 | , ftraceRep 28 | , ifmapRep 29 | , iffoldMapRep 30 | , iftraverseRep 31 | -- * Default logarithms 32 | , FLogarithm(..) 33 | , FTab(..) 34 | , findexFLogarithm 35 | , ftabulateFLogarithm 36 | , ftabulateGeneric 37 | , findexGeneric 38 | , fscatterGeneric 39 | , fscatterDefault 40 | , Indices 41 | 42 | -- * Uniqueness of logarithms 43 | , flogToFLogarithm 44 | , flogFromFLogarithm 45 | , geqFLog 46 | , gcompareFLog 47 | 48 | -- * Logarithm lens 49 | , _flogarithm 50 | , _flog 51 | , _flogGEq 52 | 53 | -- * LKD 54 | , lowerLogarithm 55 | , liftLogarithm 56 | 57 | -- * Constrained Representable operations 58 | , FAll(..) 59 | , cfdistrib 60 | 61 | -- * Zapping adjunctions 62 | , FVariant 63 | , fzapWith 64 | ) where 65 | 66 | import Data.Rep.Internal 67 | -------------------------------------------------------------------------------- /src/Data/HKD/Rep/Endo.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language Safe #-} 3 | {-# Language PatternSynonyms #-} 4 | {-# Language TypeOperators #-} 5 | {-# Language RankNTypes #-} 6 | -- | 7 | -- Copyright : (C) 2021 Edward Kmett 8 | -- License : BSD-2-Style OR Apache-2.0 9 | -- Maintainer : Edward Kmett 10 | -- Stability : provisional 11 | -- Portability : non-portable 12 | -- 13 | -- Tabulated endomorphisms 14 | module Data.HKD.Rep.Endo 15 | ( FEndo(.., FEndo, appFEndo) 16 | ) where 17 | 18 | import Data.HKD 19 | import Data.HKD.Rep 20 | 21 | -- | Tabulated endomorphisms. 22 | -- 23 | -- Many representable functors can be used to memoize functions. 24 | newtype FEndo f = FEndoDist { runFEndoDist :: f (FLog f) } 25 | 26 | pattern FEndo :: FRepresentable f => (FLog f ~> FLog f) -> FEndo f 27 | pattern FEndo { appFEndo } = FEndoDist (FTabulate appFEndo) 28 | 29 | {-# complete FEndo #-} 30 | 31 | instance FRepresentable f => Semigroup (FEndo f) where 32 | (<>) = \ f g -> FEndo (appFEndo f . appFEndo g) 33 | {-# inline (<>) #-} 34 | 35 | instance FRepresentable f => Monoid (FEndo f) where 36 | mempty = FEndoDist faskRep 37 | {-# inline mempty #-} 38 | 39 | -------------------------------------------------------------------------------- /src/Data/Machine/Mealy.hs: -------------------------------------------------------------------------------- 1 | {-# Language DerivingVia #-} 2 | {-# Language Trustworthy #-} 3 | 4 | -- | 5 | -- Copyright : (C) 2012-2021 Edward Kmett 6 | -- License : BSD-2-Style OR Apache-2.0 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -- 12 | 13 | module Data.Machine.Mealy 14 | ( Mealy(..) 15 | , logMealy 16 | , unfoldMealy 17 | , driveMealy 18 | ) where 19 | 20 | import Control.Applicative 21 | import Control.Arrow 22 | import Control.Category 23 | import Control.Monad.Fix 24 | import Control.Monad.Zip 25 | import Control.Monad.Reader.Class 26 | import Data.Coerce 27 | import Data.Foldable 28 | import Data.Functor.WithIndex 29 | import Data.Machine.Moore 30 | import Data.Profunctor 31 | import Data.Profunctor.Unsafe 32 | import Data.List.NonEmpty (NonEmpty(..)) 33 | import Data.Rep 34 | import GHC.Generics 35 | import Numeric 36 | import Prelude hiding (id,(.)) 37 | -- @Data.Sequence@ is merely safe-inferred, so we get complained at if we claim to be @Safe@ but we also 38 | -- get complained at if we claim to be @Trustworthy@. @import Trustworthy ()@ downgrades us cleanly 39 | -- to @Trustworthy@ without complaint. Did I mention that I find the design of SafeHaskell to be 40 | -- nearly unusable at present? If you are wondering why this module has to be included your trusted 41 | -- code base, this is why. 42 | import Trustworthy () 43 | 44 | type role Mealy representational nominal 45 | newtype Mealy a b = Mealy { runMealy :: a -> Moore a b } 46 | deriving stock (Functor, Generic, Generic1) 47 | deriving 48 | ( Applicative, Monad, MonadFix, MonadZip 49 | , MonadReader (NonEmpty a) 50 | , FunctorWithIndex (NonEmpty a) 51 | ) via Dist (Mealy a) 52 | deriving 53 | ( Semigroup, Monoid, Num, Fractional, Floating 54 | ) via Dist (Mealy a) b 55 | 56 | instance Category Mealy where 57 | id = Mealy go where 58 | go a = Moore a go 59 | {-# inline id #-} 60 | 61 | (.) = \(Mealy bc0) (Mealy ab0) -> Mealy (go bc0 ab0) where 62 | go bc ab a = case ab a of 63 | Moore b nab -> case bc b of 64 | Moore c nbc -> Moore c (go nbc nab) 65 | {-# inline (.) #-} 66 | 67 | instance Arrow Mealy where 68 | arr f = Mealy go where 69 | go a = Moore (f a) go 70 | {-# inline arr #-} 71 | 72 | first = \(Mealy m0) -> Mealy (go m0) where 73 | go m (a,c) = case m a of 74 | Moore b n -> Moore (b, c) (go n) 75 | {-# inline first #-} 76 | 77 | second = \(Mealy m0) -> Mealy (go m0) where 78 | go m (c,a) = case m a of 79 | Moore b n -> Moore (c, b) (go n) 80 | {-# inline second #-} 81 | 82 | (***) = \(Mealy x0) (Mealy y0) -> Mealy (go x0 y0) where 83 | go x y (a,b) = case x a of 84 | Moore xa nxa -> case y b of 85 | Moore yb nyb -> Moore (xa, yb) (go nxa nyb) 86 | {-# inline (***) #-} 87 | 88 | (&&&) = \(Mealy x0) (Mealy y0) -> Mealy (go x0 y0) where 89 | go x y a = case x a of 90 | Moore xa nxa -> case y a of 91 | Moore yb nya -> Moore (xa, yb) (go nxa nya) 92 | {-# inline (&&&) #-} 93 | 94 | instance ArrowChoice Mealy where 95 | left = \(Mealy m0) -> Mealy $ go m0 where 96 | go m = \case 97 | Left l -> case m l of 98 | Moore b m' -> Moore (Left b) (go m') 99 | Right r -> Moore (Right r) (go m) 100 | {-# inline left #-} 101 | right = \(Mealy m0) -> Mealy $ go m0 where 102 | go m = \case 103 | Left l -> Moore (Left l) (go m) 104 | Right r -> case m r of 105 | Moore b m' -> Moore (Right b) (go m') 106 | {-# inline right #-} 107 | (+++) = \(Mealy m0) (Mealy n0) -> Mealy $ go m0 n0 where 108 | go m n = \case 109 | Left b -> case m b of 110 | Moore c m' -> Moore (Left c) (go m' n) 111 | Right b -> case n b of 112 | Moore c n' -> Moore (Right c) (go m n') 113 | {-# inline (+++) #-} 114 | (|||) = \(Mealy m0) (Mealy n0) -> Mealy $ go m0 n0 where 115 | go m n = \case 116 | Left b -> case m b of 117 | Moore d m' -> Moore d (go m' n) 118 | Right b -> case n b of 119 | Moore d n' -> Moore d (go m n') 120 | {-# inline (|||) #-} 121 | 122 | instance Profunctor Mealy where 123 | rmap = fmap 124 | {-# INLINE rmap #-} 125 | lmap f = \(Mealy m) -> Mealy $ go m where 126 | go m a = case m (f a) of 127 | Moore b n -> Moore b (go n) 128 | {-# INLINE lmap #-} 129 | dimap f g = \(Mealy m) -> Mealy $ go m where 130 | go m a = case m (f a) of 131 | Moore b n -> Moore (g b) (go n) 132 | {-# INLINE dimap #-} 133 | (#.) _ = Mealy . coerce . runMealy -- why can't these use #. and .#? 134 | {-# INLINE (#.) #-} 135 | g .# _ = coerce g 136 | {-# INLINE (.#) #-} 137 | 138 | instance Strong Mealy where 139 | first' = first 140 | {-# INLINE first' #-} 141 | second' = second 142 | {-# INLINE second' #-} 143 | 144 | instance Choice Mealy where 145 | left' = left 146 | right' = right 147 | {-# INLINE left' #-} 148 | {-# INLINE right' #-} 149 | 150 | instance Indexable (Mealy a) where 151 | type Log (Mealy a) = NonEmpty a 152 | index = \(Mealy f) (x:|xs) -> index (f x) xs 153 | {-# inline index #-} 154 | 155 | instance Representable (Mealy a) where 156 | tabulate = \f -> Mealy \a -> tabulate (f . (a :|)) 157 | {-# inline tabulate #-} 158 | 159 | -- | A 'Mealy' machine modeled with explicit state. 160 | unfoldMealy :: (s -> a -> (b, s)) -> s -> Mealy a b 161 | unfoldMealy f = Mealy . go where 162 | go s a = case f s a of 163 | (b, t) -> Moore b (go t) 164 | {-# inline unfoldMealy #-} 165 | 166 | logMealy :: Semigroup a => Mealy a a 167 | logMealy = Mealy \a -> Moore a (h a) where 168 | h a = \((a <>) -> b) -> Moore b (h b) 169 | {-# inline logMealy #-} 170 | 171 | driveMealy :: Foldable f => Mealy a b -> f a -> Mealy a b 172 | driveMealy = foldl' \(Mealy m) a -> case m a of 173 | Moore _ f -> Mealy f 174 | {-# inline driveMealy #-} 175 | -------------------------------------------------------------------------------- /src/Data/Machine/Moore.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language DerivingVia #-} 3 | {-# Language Trustworthy #-} 4 | 5 | -- | 6 | -- Copyright : (C) 2012-2021 Edward Kmett 7 | -- License : BSD-2-Style OR Apache-2.0 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : non-portable 11 | -- 12 | -- 13 | 14 | module Data.Machine.Moore 15 | ( Moore(..) 16 | , logMoore 17 | , unfoldMoore 18 | ) where 19 | 20 | import Control.Applicative 21 | #ifdef MIN_VERSION_comonad 22 | import Control.Comonad 23 | #endif 24 | import Control.Monad.Fix 25 | import Control.Monad.Zip 26 | import Control.Monad.Reader.Class 27 | import Data.Rep 28 | import Data.Coerce 29 | import Data.Profunctor.Closed 30 | import Data.Profunctor.Unsafe 31 | import Data.Profunctor.Strong 32 | import Data.Profunctor.Sieve 33 | import qualified Data.Profunctor.Rep as Pro 34 | import Data.Functor.WithIndex 35 | import GHC.Generics 36 | import Numeric 37 | import Prelude 38 | 39 | type role Moore representational representational 40 | data Moore a b = Moore b (a -> Moore a b) 41 | deriving stock (Functor, Generic, Generic1) 42 | deriving 43 | ( Applicative, Monad, MonadFix, MonadZip, MonadReader [a], FunctorWithIndex [a] 44 | #ifdef MIN_VERSION_comonad 45 | , Comonad, ComonadApply 46 | #endif 47 | ) via Dist (Moore a) 48 | deriving (Semigroup, Monoid, Num, Fractional, Floating) via Dist (Moore a) b 49 | 50 | instance Indexable (Moore a) where 51 | type Log (Moore a) = [a] 52 | index = \(Moore b k) -> \case 53 | [] -> b 54 | (a:as) -> index (k a) as 55 | {-# inline index #-} 56 | 57 | instance Representable (Moore a) where 58 | tabulate = \f -> Moore (f []) \a -> tabulate (f.(a:)) 59 | {-# inline tabulate #-} 60 | 61 | -- | Accumulate the input as a sequence. 62 | logMoore :: Monoid m => Moore m m 63 | logMoore = h mempty where 64 | h m = Moore m \a -> h (m <> a) 65 | {-# inline logMoore #-} 66 | 67 | -- | Construct a Moore machine from a state valuation and transition function 68 | unfoldMoore :: (s -> b) -> (s -> a -> s) -> s -> Moore a b 69 | unfoldMoore = \f g s -> Moore (f s) (unfoldMoore f g . g s) 70 | {-# inline unfoldMoore #-} 71 | 72 | instance Profunctor Moore where 73 | rmap = fmap 74 | {-# INLINE rmap #-} 75 | lmap f = go where 76 | go (Moore b g) = Moore b (go . g . f) 77 | {-# INLINE lmap #-} 78 | dimap f g = go where 79 | go (Moore b h) = Moore (g b) (go . h . f) 80 | {-# INLINE dimap #-} 81 | (#.) _ = coerce 82 | {-# INLINE (#.) #-} 83 | (.#) g _ = coerce g 84 | {-# INLINE (.#) #-} 85 | 86 | instance Cosieve Moore [] where 87 | cosieve (Moore b k) = \case 88 | [] -> b 89 | (a:as) -> cosieve (k a) as 90 | {-# INLINE cosieve #-} 91 | 92 | instance Costrong Moore where 93 | unfirst = Pro.unfirstCorep 94 | unsecond = Pro.unsecondCorep 95 | {-# INLINE unfirst #-} 96 | {-# INLINE unsecond #-} 97 | 98 | instance Pro.Corepresentable Moore where 99 | type Corep Moore = [] 100 | cotabulate = \f -> Moore (f []) \a -> Pro.cotabulate (f.(a:)) 101 | {-# INLINE cotabulate #-} 102 | 103 | instance Closed Moore where 104 | closed = \m -> Pro.cotabulate \fs x -> cosieve m (fmap ($ x) fs) 105 | {-# INLINE closed #-} 106 | -------------------------------------------------------------------------------- /src/Data/Profunctor/Closed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE Trustworthy #-} 9 | 10 | -- | 11 | -- Copyright : (C) 2014-2018 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : experimental 15 | -- Portability : portable 16 | 17 | module Data.Profunctor.Closed 18 | ( Closed(..) 19 | , Closure(..) 20 | , close 21 | , unclose 22 | , Environment(..) 23 | , curry' 24 | ) where 25 | 26 | import Control.Applicative 27 | import Control.Arrow 28 | import Control.Category 29 | import Control.Comonad 30 | import Data.Bifunctor.Product (Product(..)) 31 | import Data.Bifunctor.Sum (Sum(..)) 32 | import Data.Bifunctor.Tannen (Tannen(..)) 33 | import Data.Coerce (Coercible, coerce) 34 | import Data.Profunctor 35 | import Data.Profunctor.Adjunction 36 | import Data.Profunctor.Functor 37 | import Data.Profunctor.Monad 38 | import Data.Profunctor.Cayley 39 | import Data.Profunctor.Composition 40 | import Data.Profunctor.Unsafe 41 | import Data.Profunctor.Yoneda 42 | import Data.Rep 43 | import Data.Semigroup hiding (Product, Sum) 44 | import Data.Tagged 45 | import Data.Tuple 46 | import Prelude hiding ((.),id) 47 | 48 | -------------------------------------------------------------------------------- 49 | -- * Closed 50 | -------------------------------------------------------------------------------- 51 | 52 | -- | A strong profunctor allows the monoidal structure to pass through. 53 | -- 54 | -- A closed profunctor allows the closed structure to pass through. 55 | class Profunctor p => Closed p where 56 | -- | Laws: 57 | -- 58 | -- @ 59 | -- 'lmap' ('.' f) '.' 'closed' ≡ 'rmap' ('.' f) '.' 'closed' 60 | -- 'closed' '.' 'closed' ≡ 'dimap' 'uncurry' 'curry' '.' 'closed' 61 | -- 'dimap' 'const' ('$'()) '.' 'closed' ≡ 'id' 62 | -- @ 63 | closed :: p a b -> p (x -> a) (x -> b) 64 | 65 | instance Closed Tagged where 66 | closed (Tagged b) = Tagged (const b) 67 | 68 | instance Closed (->) where 69 | closed = (.) 70 | 71 | instance Functor f => Closed (Costar f) where 72 | closed (Costar fab) = Costar $ \fxa x -> fab (fmap ($ x) fxa) 73 | 74 | instance Functor f => Closed (Cokleisli f) where 75 | closed (Cokleisli fab) = Cokleisli $ \fxa x -> fab (fmap ($ x) fxa) 76 | 77 | instance (Closed p, Closed q) => Closed (Product p q) where 78 | closed (Pair p q) = Pair (closed p) (closed q) 79 | 80 | instance (Closed p, Closed q) => Closed (Sum p q) where 81 | closed (L2 p) = L2 (closed p) 82 | closed (R2 q) = R2 (closed q) 83 | 84 | instance (Functor f, Closed p) => Closed (Tannen f p) where 85 | closed (Tannen fp) = Tannen (fmap closed fp) 86 | 87 | -- instance Monoid r => Closed (Forget r) where 88 | -- closed _ = Forget $ \_ -> mempty 89 | 90 | curry' :: Closed p => p (a, b) c -> p a (b -> c) 91 | curry' = lmap (,) . closed 92 | 93 | -------------------------------------------------------------------------------- 94 | -- * Closure 95 | -------------------------------------------------------------------------------- 96 | 97 | -- | 'Closure' adjoins a 'Closed' structure to any 'Profunctor'. 98 | -- 99 | -- Analogous to 'Data.Profunctor.Tambara.Tambara' for 'Strong'. 100 | 101 | newtype Closure p a b = Closure { runClosure :: forall x. p (x -> a) (x -> b) } 102 | 103 | instance Profunctor p => Profunctor (Closure p) where 104 | dimap f g (Closure p) = Closure $ dimap (fmap f) (fmap g) p 105 | lmap f (Closure p) = Closure $ lmap (fmap f) p 106 | rmap f (Closure p) = Closure $ rmap (fmap f) p 107 | 108 | (#.) :: forall a b c q. Coercible c b => q b c -> Closure p a b -> Closure p a c 109 | _ #. Closure p = Closure $ fmap (coerce (id :: c -> c) :: b -> c) #. p 110 | 111 | (.#) :: forall a b c q. Coercible b a => Closure p b c -> q a b -> Closure p a c 112 | Closure p .# _ = Closure $ p .# fmap (coerce (id :: b -> b) :: a -> b) 113 | 114 | instance ProfunctorFunctor Closure where 115 | promap f (Closure p) = Closure (f p) 116 | 117 | instance ProfunctorComonad Closure where 118 | proextract p = dimap const ($ ()) $ runClosure p 119 | produplicate (Closure p) = Closure $ Closure $ dimap uncurry curry p 120 | 121 | instance Profunctor p => Closed (Closure p) where 122 | closed p = runClosure $ produplicate p 123 | 124 | instance Strong p => Strong (Closure p) where 125 | first' (Closure p) = Closure $ dimap hither yon $ first' p 126 | 127 | instance Category p => Category (Closure p) where 128 | id = Closure id 129 | Closure p . Closure q = Closure (p . q) 130 | 131 | hither :: (s -> (a,b)) -> (s -> a, s -> b) 132 | hither h = (fst . h, snd . h) 133 | 134 | yon :: (s -> a, s -> b) -> s -> (a,b) 135 | yon h s = (fst h s, snd h s) 136 | 137 | instance Arrow p => Arrow (Closure p) where 138 | arr f = Closure (arr (f .)) 139 | first (Closure f) = Closure $ arr yon . first f . arr hither 140 | 141 | instance ArrowLoop p => ArrowLoop (Closure p) where 142 | loop (Closure f) = Closure $ loop (arr hither . f . arr yon) 143 | 144 | instance ArrowZero p => ArrowZero (Closure p) where 145 | zeroArrow = Closure zeroArrow 146 | 147 | instance ArrowPlus p => ArrowPlus (Closure p) where 148 | Closure f <+> Closure g = Closure (f <+> g) 149 | 150 | instance Profunctor p => Functor (Closure p a) where 151 | fmap = rmap 152 | 153 | instance (Profunctor p, Arrow p) => Applicative (Closure p a) where 154 | pure x = arr (const x) 155 | f <*> g = arr (uncurry id) . (f &&& g) 156 | 157 | instance (Profunctor p, ArrowPlus p) => Alternative (Closure p a) where 158 | empty = zeroArrow 159 | f <|> g = f <+> g 160 | 161 | instance (Profunctor p, Arrow p, Semigroup b) => Semigroup (Closure p a b) where 162 | (<>) = liftA2 (<>) 163 | 164 | instance (Profunctor p, Arrow p, Semigroup b, Monoid b) => Monoid (Closure p a b) where 165 | mempty = pure mempty 166 | #if !(MIN_VERSION_base(4,11,0)) 167 | mappend = (<>) 168 | #endif 169 | 170 | -- | 171 | -- @ 172 | -- 'close' '.' 'unclose' ≡ 'id' 173 | -- 'unclose' '.' 'close' ≡ 'id' 174 | -- @ 175 | close :: Closed p => (p :-> q) -> p :-> Closure q 176 | close f p = Closure $ f $ closed p 177 | 178 | -- | 179 | -- @ 180 | -- 'close' '.' 'unclose' ≡ 'id' 181 | -- 'unclose' '.' 'close' ≡ 'id' 182 | -- @ 183 | unclose :: Profunctor q => (p :-> Closure q) -> p :-> q 184 | unclose f p = dimap const ($ ()) $ runClosure $ f p 185 | 186 | -------------------------------------------------------------------------------- 187 | -- * Environment 188 | -------------------------------------------------------------------------------- 189 | 190 | data Environment p a b where 191 | Environment :: ((z -> y) -> b) -> p x y -> (a -> z -> x) -> Environment p a b 192 | 193 | instance Functor (Environment p a) where 194 | fmap f (Environment l m r) = Environment (f . l) m r 195 | 196 | instance Profunctor (Environment p) where 197 | dimap f g (Environment l m r) = Environment (g . l) m (r . f) 198 | lmap f (Environment l m r) = Environment l m (r . f) 199 | rmap g (Environment l m r) = Environment (g . l) m r 200 | w #. Environment l m r = Environment (w #. l) m r 201 | Environment l m r .# w = Environment l m (r .# w) 202 | 203 | instance ProfunctorFunctor Environment where 204 | promap f (Environment l m r) = Environment l (f m) r 205 | 206 | instance ProfunctorMonad Environment where 207 | proreturn p = Environment ($ ()) p const 208 | projoin (Environment l (Environment m n o) p) = Environment (lm . curry) n op where 209 | op a (b, c) = o (p a b) c 210 | lm zr = l (m.zr) 211 | 212 | instance ProfunctorAdjunction Environment Closure where 213 | counit (Environment g (Closure p) f) = dimap f g p 214 | unit p = Closure (Environment id p id) 215 | 216 | instance Closed (Environment p) where 217 | closed (Environment l m r) = Environment l' m r' where 218 | r' wa (z,w) = r (wa w) z 219 | l' zx2y x = l (\z -> zx2y (z,x)) 220 | 221 | instance (Closed p, Closed q) => Closed (Procompose p q) where 222 | closed (Procompose x y) = Procompose (closed x) (closed y) 223 | {-# INLINE closed #-} 224 | 225 | instance (Functor f, Closed p) => Closed (Cayley f p) where 226 | closed = Cayley . fmap closed . runCayley 227 | {-# INLINE closed #-} 228 | 229 | instance Closed p => Closed (Yoneda p) where 230 | closed = proreturn . closed . extractYoneda 231 | {-# INLINE closed #-} 232 | 233 | instance Closed p => Closed (Coyoneda p) where 234 | closed = returnCoyoneda . closed . proextract 235 | {-# INLINE closed #-} 236 | 237 | instance Representable f => Closed (Star f) where 238 | closed (Star afb) = Star $ \xa -> distribute $ \x -> afb (xa x) 239 | 240 | instance (Representable f, Monad f) => Closed (Kleisli f) where 241 | closed (Kleisli afb) = Kleisli $ \xa -> distribute $ \x -> afb (xa x) 242 | -------------------------------------------------------------------------------- /src/Data/Profunctor/Mapping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE Safe #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (C) 2015-2018 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : portable 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Data.Profunctor.Mapping 17 | ( Mapping(..) 18 | , CofreeMapping(..) 19 | , FreeMapping(..) 20 | -- * Traversing in terms of Mapping 21 | , wanderMapping 22 | -- * Closed in terms of Mapping 23 | , traverseMapping 24 | , closedMapping 25 | ) where 26 | 27 | import Control.Arrow (Kleisli(..)) 28 | import Data.Bifunctor.Tannen 29 | import Data.Rep 30 | import Data.Functor.Compose 31 | import Data.Functor.Identity 32 | import Data.Profunctor 33 | import Data.Profunctor.Cayley 34 | import Data.Profunctor.Closed 35 | import Data.Profunctor.Composition 36 | import Data.Profunctor.Functor 37 | import Data.Profunctor.Monad 38 | import Data.Profunctor.Traversing 39 | import Data.Profunctor.Unsafe 40 | import Data.Profunctor.Yoneda 41 | 42 | class (Traversing p, Closed p) => Mapping p where 43 | -- | Laws: 44 | -- 45 | -- @ 46 | -- 'map'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'map'' 47 | -- 'map'' '.' 'map'' ≡ 'dimap' 'Data.Functor.Compose.Compose' 'Data.Functor.Compose.getCompose' '.' 'map'' 48 | -- 'dimap' 'Data.Functor.Identity.Identity' 'Data.Functor.Identity.runIdentity' '.' 'map'' ≡ 'id' 49 | -- @ 50 | map' :: Functor f => p a b -> p (f a) (f b) 51 | map' = roam fmap 52 | 53 | roam :: ((a -> b) -> s -> t) 54 | -> p a b -> p s t 55 | roam f = dimap (\s -> Bar $ \ab -> f ab s) lent . map' 56 | 57 | newtype Bar t b a = Bar 58 | { runBar :: (a -> b) -> t } 59 | deriving Functor 60 | 61 | lent :: Bar t a a -> t 62 | lent m = runBar m id 63 | 64 | instance Mapping (->) where 65 | map' = fmap 66 | roam f = f 67 | 68 | instance (Monad m, Representable m) => Mapping (Kleisli m) where 69 | map' (Kleisli f) = Kleisli (collect f) 70 | roam f = Kleisli #. genMap f .# runKleisli 71 | 72 | genMap :: Representable f => ((a -> b) -> s -> t) -> (a -> f b) -> s -> f t 73 | genMap abst afb s = fmap (\ab -> abst ab s) (distribute afb) 74 | 75 | -- see 76 | instance (Applicative m, Representable m) => Mapping (Star m) where 77 | map' (Star f) = Star (collect f) 78 | roam f = Star #. genMap f .# runStar 79 | 80 | instance (Functor f, Mapping p) => Mapping (Tannen f p) where 81 | map' = Tannen . fmap map' . runTannen 82 | 83 | wanderMapping :: Mapping p => (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t 84 | wanderMapping f = roam ((runIdentity .) #. f .# (Identity .)) 85 | 86 | traverseMapping :: (Mapping p, Functor f) => p a b -> p (f a) (f b) 87 | traverseMapping = map' 88 | 89 | closedMapping :: Mapping p => p a b -> p (x -> a) (x -> b) 90 | closedMapping = map' 91 | 92 | newtype CofreeMapping p a b = CofreeMapping { runCofreeMapping :: forall f. Functor f => p (f a) (f b) } 93 | 94 | deriving stock instance (forall f. Functor f => Functor (p (f a))) => Functor (CofreeMapping p a) 95 | 96 | instance (forall f. Functor f => Foldable (p (f a))) => Foldable (CofreeMapping p a) where 97 | foldMap f (CofreeMapping g) = foldMap (f . runIdentity) g 98 | {-# inline foldMap #-} 99 | 100 | instance Profunctor p => Profunctor (CofreeMapping p) where 101 | lmap f (CofreeMapping p) = CofreeMapping (lmap (fmap f) p) 102 | rmap g (CofreeMapping p) = CofreeMapping (rmap (fmap g) p) 103 | dimap f g (CofreeMapping p) = CofreeMapping (dimap (fmap f) (fmap g) p) 104 | 105 | instance Profunctor p => Strong (CofreeMapping p) where 106 | second' = map' 107 | 108 | instance Profunctor p => Choice (CofreeMapping p) where 109 | right' = map' 110 | 111 | instance Profunctor p => Closed (CofreeMapping p) where 112 | closed = map' 113 | 114 | instance Profunctor p => Traversing (CofreeMapping p) where 115 | traverse' = map' 116 | wander f = roam $ (runIdentity .) #. f .# (Identity .) 117 | 118 | instance Profunctor p => Mapping (CofreeMapping p) where 119 | -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .# 120 | map' (CofreeMapping p) = CofreeMapping (dimap Compose getCompose p) 121 | roam f (CofreeMapping p) = 122 | CofreeMapping $ 123 | dimap (Compose #. fmap (\s -> Bar $ \ab -> f ab s)) (fmap lent .# getCompose) p 124 | 125 | instance ProfunctorFunctor CofreeMapping where 126 | promap f (CofreeMapping p) = CofreeMapping (f p) 127 | 128 | instance ProfunctorComonad CofreeMapping where 129 | proextract (CofreeMapping p) = runIdentity #. p .# Identity 130 | produplicate (CofreeMapping p) = CofreeMapping (CofreeMapping (dimap Compose getCompose p)) 131 | 132 | -- | @FreeMapping -| CofreeMapping@ 133 | data FreeMapping p a b where 134 | FreeMapping :: Functor f => (f y -> b) -> p x y -> (a -> f x) -> FreeMapping p a b 135 | 136 | instance Functor (FreeMapping p a) where 137 | fmap f (FreeMapping l m r) = FreeMapping (f . l) m r 138 | 139 | instance Profunctor (FreeMapping p) where 140 | lmap f (FreeMapping l m r) = FreeMapping l m (r . f) 141 | rmap g (FreeMapping l m r) = FreeMapping (g . l) m r 142 | dimap f g (FreeMapping l m r) = FreeMapping (g . l) m (r . f) 143 | g #. FreeMapping l m r = FreeMapping (g #. l) m r 144 | FreeMapping l m r .# f = FreeMapping l m (r .# f) 145 | 146 | instance Strong (FreeMapping p) where 147 | second' = map' 148 | 149 | instance Choice (FreeMapping p) where 150 | right' = map' 151 | 152 | instance Closed (FreeMapping p) where 153 | closed = map' 154 | 155 | instance Traversing (FreeMapping p) where 156 | traverse' = map' 157 | wander f = roam ((runIdentity .) #. f .# (Identity .)) 158 | 159 | instance Mapping (FreeMapping p) where 160 | map' (FreeMapping l m r) = FreeMapping (fmap l .# getCompose) m (Compose #. fmap r) 161 | 162 | instance ProfunctorFunctor FreeMapping where 163 | promap f (FreeMapping l m r) = FreeMapping l (f m) r 164 | 165 | instance ProfunctorMonad FreeMapping where 166 | proreturn p = FreeMapping runIdentity p Identity 167 | projoin (FreeMapping l (FreeMapping l' m r') r) = FreeMapping ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r)) 168 | 169 | instance (Mapping p, Mapping q) => Mapping (Procompose p q) where 170 | map' (Procompose p q) = Procompose (map' p) (map' q) 171 | {-# INLINE map' #-} 172 | 173 | instance (Functor f, Mapping p) => Mapping (Cayley f p) where 174 | map' = Cayley . fmap map' . runCayley 175 | 176 | instance Mapping p => Mapping (Yoneda p) where 177 | map' = proreturn . map' . extractYoneda 178 | {-# INLINE map' #-} 179 | 180 | instance Mapping p => Mapping (Coyoneda p) where 181 | map' = returnCoyoneda . map' . proextract 182 | {-# INLINE map' #-} 183 | 184 | -------------------------------------------------------------------------------- /src/Data/Profunctor/Rep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE Safe #-} 12 | {-# OPTIONS_GHC -Wno-orphans #-} 13 | 14 | -- | 15 | -- Copyright : (C) 2011-2021 Edward Kmett 16 | -- License : BSD-style (see the file LICENSE) 17 | -- 18 | -- Maintainer : Edward Kmett 19 | -- Stability : provisional 20 | -- Portability : Type-Families 21 | 22 | module Data.Profunctor.Rep 23 | ( 24 | -- * Representable Profunctors 25 | Representable(..) 26 | , tabulated 27 | , firstRep, secondRep 28 | -- * Corepresentable Profunctors 29 | , Corepresentable(..) 30 | , cotabulated 31 | , unfirstCorep, unsecondCorep 32 | , closedCorep 33 | -- * Prep -| Star 34 | , Prep(..) 35 | , prepAdj 36 | , unprepAdj 37 | , prepUnit 38 | , prepCounit 39 | -- * Coprep -| Costar 40 | , Coprep(..) 41 | , coprepAdj 42 | , uncoprepAdj 43 | , coprepUnit 44 | , coprepCounit 45 | ) where 46 | 47 | import Control.Applicative 48 | import Control.Arrow 49 | import Control.Comonad 50 | import Control.Monad ((>=>)) 51 | import Data.Functor.Compose 52 | import Data.Functor.Identity 53 | import Data.Kind 54 | import Data.Profunctor 55 | import Data.Profunctor.Composition 56 | import Data.Profunctor.Sieve 57 | import Data.Proxy 58 | import Data.Tagged 59 | 60 | -- * Representable Profunctors 61 | 62 | -- | A 'Profunctor' @p@ is 'Representable' if there exists a 'Functor' @f@ such that 63 | -- @p d c@ is isomorphic to @d -> f c@. 64 | class (Sieve p (Rep p), Strong p) => Representable p where 65 | type Rep p :: Type -> Type 66 | -- | Laws: 67 | -- 68 | -- @ 69 | -- 'tabulate' '.' 'sieve' ≡ 'id' 70 | -- 'sieve' '.' 'tabulate' ≡ 'id' 71 | -- @ 72 | tabulate :: (d -> Rep p c) -> p d c 73 | 74 | -- | Default definition for 'first'' given that p is 'Representable'. 75 | firstRep :: Representable p => p a b -> p (a, c) (b, c) 76 | firstRep p = tabulate $ \(a,c) -> (,c) <$> sieve p a 77 | 78 | -- | Default definition for 'second'' given that p is 'Representable'. 79 | secondRep :: Representable p => p a b -> p (c, a) (c, b) 80 | secondRep p = tabulate $ \(c,a) -> (c,) <$> sieve p a 81 | 82 | instance Representable (->) where 83 | type Rep (->) = Identity 84 | tabulate f = runIdentity . f 85 | {-# INLINE tabulate #-} 86 | 87 | instance (Monad m, Functor m) => Representable (Kleisli m) where 88 | type Rep (Kleisli m) = m 89 | tabulate = Kleisli 90 | {-# INLINE tabulate #-} 91 | 92 | instance Functor f => Representable (Star f) where 93 | type Rep (Star f) = f 94 | tabulate = Star 95 | {-# INLINE tabulate #-} 96 | 97 | instance Representable (Forget r) where 98 | type Rep (Forget r) = Const r 99 | tabulate = Forget . (getConst .) 100 | {-# INLINE tabulate #-} 101 | 102 | {- TODO: coproducts and products 103 | instance (Representable p, Representable q) => Representable (Bifunctor.Product p q) 104 | type Rep (Bifunctor.Product p q) = Functor.Product p q 105 | 106 | instance (Corepresentable p, Corepresentable q) => Corepresentable (Bifunctor.Product p q) where 107 | type Rep (Bifunctor.Product p q) = Functor.Sum p q 108 | -} 109 | 110 | type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) 111 | 112 | -- | 'tabulate' and 'sieve' form two halves of an isomorphism. 113 | -- 114 | -- This can be used with the combinators from the @lens@ package. 115 | -- 116 | -- @'tabulated' :: 'Representable' p => 'Iso'' (d -> 'Rep' p c) (p d c)@ 117 | tabulated :: (Representable p, Representable q) => Iso (d -> Rep p c) (d' -> Rep q c') (p d c) (q d' c') 118 | tabulated = dimap tabulate (fmap sieve) 119 | {-# INLINE tabulated #-} 120 | 121 | -- * Corepresentable Profunctors 122 | 123 | -- | A 'Profunctor' @p@ is 'Corepresentable' if there exists a 'Functor' @f@ such that 124 | -- @p d c@ is isomorphic to @f d -> c@. 125 | class (Cosieve p (Corep p), Costrong p) => Corepresentable p where 126 | type Corep p :: Type -> Type 127 | -- | Laws: 128 | -- 129 | -- @ 130 | -- 'cotabulate' '.' 'cosieve' ≡ 'id' 131 | -- 'cosieve' '.' 'cotabulate' ≡ 'id' 132 | -- @ 133 | cotabulate :: (Corep p d -> c) -> p d c 134 | 135 | -- | Default definition for 'unfirst' given that @p@ is 'Corepresentable'. 136 | unfirstCorep :: Corepresentable p => p (a, d) (b, d) -> p a b 137 | unfirstCorep p = cotabulate f 138 | where f fa = b where (b, d) = cosieve p $ (,d) <$> fa 139 | 140 | -- | Default definition for 'unsecond' given that @p@ is 'Corepresentable'. 141 | unsecondCorep :: Corepresentable p => p (d, a) (d, b) -> p a b 142 | unsecondCorep p = cotabulate f 143 | where f fa = b where (d, b) = cosieve p $ (d,) <$> fa 144 | 145 | -- | Default definition for 'closed' given that @p@ is 'Corepresentable' 146 | closedCorep :: Corepresentable p => p a b -> p (x -> a) (x -> b) 147 | closedCorep p = cotabulate $ \fs x -> cosieve p (fmap ($ x) fs) 148 | 149 | instance Corepresentable (->) where 150 | type Corep (->) = Identity 151 | cotabulate f = f . Identity 152 | {-# INLINE cotabulate #-} 153 | 154 | instance Functor w => Corepresentable (Cokleisli w) where 155 | type Corep (Cokleisli w) = w 156 | cotabulate = Cokleisli 157 | {-# INLINE cotabulate #-} 158 | 159 | instance Corepresentable Tagged where 160 | type Corep Tagged = Proxy 161 | cotabulate f = Tagged (f Proxy) 162 | {-# INLINE cotabulate #-} 163 | 164 | instance Functor f => Corepresentable (Costar f) where 165 | type Corep (Costar f) = f 166 | cotabulate = Costar 167 | {-# INLINE cotabulate #-} 168 | 169 | -- | 'cotabulate' and 'cosieve' form two halves of an isomorphism. 170 | -- 171 | -- This can be used with the combinators from the @lens@ package. 172 | -- 173 | -- @'cotabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@ 174 | cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p d -> c) (Corep q d' -> c') (p d c) (q d' c') 175 | cotabulated = dimap cotabulate (fmap cosieve) 176 | {-# INLINE cotabulated #-} 177 | 178 | -------------------------------------------------------------------------------- 179 | -- * Prep 180 | -------------------------------------------------------------------------------- 181 | 182 | -- | @'Prep' -| 'Star' :: [Hask, Hask] -> Prof@ 183 | -- 184 | -- This gives rise to a monad in @Prof@, @('Star'.'Prep')@, and 185 | -- a comonad in @[Hask,Hask]@ @('Prep'.'Star')@ 186 | -- 187 | -- 'Prep' has a polymorphic kind since @5.6@. 188 | 189 | -- Prep :: (Type -> k -> Type) -> (k -> Type) 190 | data Prep p a where 191 | Prep :: x -> p x a -> Prep p a 192 | 193 | instance Profunctor p => Functor (Prep p) where 194 | fmap f (Prep x p) = Prep x (rmap f p) 195 | 196 | instance (Applicative (Rep p), Representable p) => Applicative (Prep p) where 197 | pure a = Prep () $ tabulate $ const $ pure a 198 | Prep xf pf <*> Prep xa pa = Prep (xf,xa) (tabulate go) where 199 | go (xf',xa') = sieve pf xf' <*> sieve pa xa' 200 | 201 | instance (Monad (Rep p), Representable p) => Monad (Prep p) where 202 | Prep xa pa >>= f = Prep xa $ tabulate $ sieve pa >=> \a -> case f a of 203 | Prep xb pb -> sieve pb xb 204 | 205 | prepAdj :: (forall a. Prep p a -> g a) -> p :-> Star g 206 | prepAdj k p = Star $ \x -> k (Prep x p) 207 | 208 | unprepAdj :: (p :-> Star g) -> Prep p a -> g a 209 | unprepAdj k (Prep x p) = runStar (k p) x 210 | 211 | prepUnit :: p :-> Star (Prep p) 212 | prepUnit p = Star $ \x -> Prep x p 213 | 214 | prepCounit :: Prep (Star f) a -> f a 215 | prepCounit (Prep x p) = runStar p x 216 | 217 | -------------------------------------------------------------------------------- 218 | -- * Coprep 219 | -------------------------------------------------------------------------------- 220 | 221 | -- | 'Prep' has a polymorphic kind since @5.6@. 222 | 223 | -- Coprep :: (k -> Type -> Type) -> (k -> Type) 224 | newtype Coprep p a = Coprep { runCoprep :: forall r. p a r -> r } 225 | 226 | instance Profunctor p => Functor (Coprep p) where 227 | fmap f (Coprep g) = Coprep (g . lmap f) 228 | 229 | -- | @'Coprep' -| 'Costar' :: [Hask, Hask]^op -> Prof@ 230 | -- 231 | -- Like all adjunctions this gives rise to a monad and a comonad. 232 | -- 233 | -- This gives rise to a monad on Prof @('Costar'.'Coprep')@ and 234 | -- a comonad on @[Hask, Hask]^op@ given by @('Coprep'.'Costar')@ which 235 | -- is a monad in @[Hask,Hask]@ 236 | coprepAdj :: (forall a. f a -> Coprep p a) -> p :-> Costar f 237 | coprepAdj k p = Costar $ \f -> runCoprep (k f) p 238 | 239 | uncoprepAdj :: (p :-> Costar f) -> f a -> Coprep p a 240 | uncoprepAdj k f = Coprep $ \p -> runCostar (k p) f 241 | 242 | coprepUnit :: p :-> Costar (Coprep p) 243 | coprepUnit p = Costar $ \f -> runCoprep f p 244 | 245 | coprepCounit :: f a -> Coprep (Costar f) a 246 | coprepCounit f = Coprep $ \p -> runCostar p f 247 | 248 | -- | The composition of two 'Representable' 'Profunctor's is 'Representable' by 249 | -- the composition of their representations. 250 | instance (Representable p, Representable q) => Representable (Procompose p q) where 251 | type Rep (Procompose p q) = Compose (Rep q) (Rep p) 252 | tabulate f = Procompose (tabulate id) (tabulate (getCompose . f)) 253 | {-# INLINE tabulate #-} 254 | 255 | instance (Corepresentable p, Corepresentable q) => Corepresentable (Procompose p q) where 256 | type Corep (Procompose p q) = Compose (Corep p) (Corep q) 257 | cotabulate f = Procompose (cotabulate (f . Compose)) (cotabulate id) 258 | {-# INLINE cotabulate #-} 259 | 260 | -- ORPHAN 261 | instance (Corepresentable p, Corepresentable q) => Costrong (Procompose p q) where 262 | unfirst = unfirstCorep 263 | {-# INLINE unfirst #-} 264 | unsecond = unsecondCorep 265 | {-# INLINE unsecond #-} 266 | 267 | -------------------------------------------------------------------------------- /src/Data/Profunctor/Sieve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE Safe #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (C) 2015-2021 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- 11 | -- Maintainer : Edward Kmett 12 | -- Stability : provisional 13 | -- Portability : MPTCs, fundeps 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Data.Profunctor.Sieve 17 | ( Sieve(..) 18 | , Cosieve(..) 19 | ) where 20 | 21 | import Control.Applicative 22 | import Control.Arrow 23 | import Control.Comonad 24 | import Data.Functor.Compose 25 | import Data.Functor.Identity 26 | import Data.Profunctor 27 | import Data.Profunctor.Composition 28 | import Data.Proxy 29 | import Data.Tagged 30 | 31 | -- | A 'Profunctor' @p@ is a 'Sieve' __on__ @f@ if it is a subprofunctor of @'Star' f@. 32 | -- 33 | -- That is to say it is a subset of @Hom(-,f=)@ closed under 'lmap' and 'rmap'. 34 | -- 35 | -- Alternately, you can view it as a sieve __in__ the comma category @Hask/f@. 36 | class (Profunctor p, Functor f) => Sieve p f | p -> f where 37 | sieve :: p a b -> a -> f b 38 | 39 | instance Sieve (->) Identity where 40 | sieve f = Identity . f 41 | {-# INLINE sieve #-} 42 | 43 | instance (Monad m, Functor m) => Sieve (Kleisli m) m where 44 | sieve = runKleisli 45 | {-# INLINE sieve #-} 46 | 47 | instance Functor f => Sieve (Star f) f where 48 | sieve = runStar 49 | {-# INLINE sieve #-} 50 | 51 | instance Sieve (Forget r) (Const r) where 52 | sieve = (Const .) . runForget 53 | {-# INLINE sieve #-} 54 | 55 | -- | A 'Profunctor' @p@ is a 'Cosieve' __on__ @f@ if it is a subprofunctor of @'Costar' f@. 56 | -- 57 | -- That is to say it is a subset of @Hom(f-,=)@ closed under 'lmap' and 'rmap'. 58 | -- 59 | -- Alternately, you can view it as a cosieve __in__ the comma category @f/Hask@. 60 | class (Profunctor p, Functor f) => Cosieve p f | p -> f where 61 | cosieve :: p a b -> f a -> b 62 | 63 | instance Cosieve (->) Identity where 64 | cosieve f (Identity d) = f d 65 | {-# INLINE cosieve #-} 66 | 67 | instance Functor w => Cosieve (Cokleisli w) w where 68 | cosieve = runCokleisli 69 | {-# INLINE cosieve #-} 70 | 71 | instance Cosieve Tagged Proxy where 72 | cosieve (Tagged a) _ = a 73 | {-# INLINE cosieve #-} 74 | 75 | instance Functor f => Cosieve (Costar f) f where 76 | cosieve = runCostar 77 | {-# INLINE cosieve #-} 78 | 79 | instance (Sieve p f, Sieve q g) => Sieve (Procompose p q) (Compose g f) where 80 | sieve (Procompose g f) d = Compose $ sieve g <$> sieve f d 81 | {-# INLINE sieve #-} 82 | 83 | instance (Cosieve p f, Cosieve q g) => Cosieve (Procompose p q) (Compose f g) where 84 | cosieve (Procompose g f) (Compose d) = cosieve g $ cosieve f <$> d 85 | {-# INLINE cosieve #-} 86 | 87 | -------------------------------------------------------------------------------- /src/Data/Rep.hs: -------------------------------------------------------------------------------- 1 | {-# Language PatternSynonyms #-} 2 | {-# Language Trustworthy #-} 3 | -- | 4 | -- Copyright : (C) 2011-2021 Edward Kmett, 5 | -- (c) 2017-2021 Aaron Vargo, 6 | -- (c) 2021 Oleg Grenrus 7 | -- License : BSD-2-Clause OR Apache-2.0 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : non-portable 11 | -- 12 | -- For most distributive data types you can use @GHC.Generics@ and @DeriveAnyClass@ 13 | -- along with the `Dist` newtype to fill in a ton of instances. 14 | -- 15 | -- @ 16 | -- data V3 a = V3 a a a 17 | -- deriving stock 18 | -- ( Show, Read, Eq, Ord 19 | -- , Functor, Foldable, Traversable 20 | -- , Generic, Generic1, Data ) 21 | -- deriving anyclass Representable 22 | -- deriving 23 | -- ( Applicative, Monad, MonadFix, MonadZip 24 | -- , MonadReader (Fin 3) 25 | -- , FunctorWithIndex (Fin 3) 26 | -- , FoldableWithIndex (Fin 3) 27 | -- , TraversableWithIndex (Fin 3) 28 | -- , Eq1, Ord1 ) via Dist V3 29 | -- deriving (Num, Fractional, Floating) via Dist V3 a 30 | -- @ 31 | -- 32 | -- If you want a special form for the 'Log' of your functor you can 33 | -- implement tabulate and index directly and `Dist` can still be used. 34 | -- 35 | -- See 'Data.Machine.Moore' for an example of this pattern. 36 | module Data.Rep 37 | ( Indexable(..) 38 | , Representable(..) 39 | , dist 40 | , distrib 41 | , distribute 42 | , distributeLim 43 | , distributeForall 44 | , collect 45 | , cotraverse 46 | , pattern Tabulate 47 | -- * Default definitions 48 | -- ** via Generics 49 | , indexGeneric 50 | , scatterGeneric 51 | , tabulateGeneric 52 | -- ** via index/tabulate 53 | , scatterDefault 54 | -- ** Canonical 'Logarithm's 55 | , Logarithm(..) 56 | , tabulateLogarithm 57 | , indexLogarithm 58 | , _logarithm 59 | , logFromLogarithm 60 | , logToLogarithm 61 | , _log 62 | , eqLog 63 | , neLog 64 | , gtLog 65 | , geLog 66 | , ltLog 67 | , leLog 68 | , compareLog 69 | , Fin(Fin,FZ,FS,fromFin,KnownFZ,KnownFS) 70 | , pattern IntFin 71 | , toFin 72 | , absurdFin 73 | , indexFin 74 | , tabulateFin 75 | -- * Generically deriving indexing by Fin 76 | , DefaultTabulateFin 77 | , gtabulateFin 78 | , DefaultIndexFin 79 | , gindexFin 80 | -- ** via DerivingVia 81 | , Dist(..) 82 | -- ** for other classes 83 | -- *** Functor 84 | , fmapRep 85 | -- *** Applicative 86 | , pureRep 87 | , apRep 88 | , liftR2 89 | , liftR3 90 | , liftR4 91 | , liftR5 92 | -- *** Monad 93 | , bindRep 94 | -- *** MonadFix 95 | , mfixRep 96 | -- *** MonadZip 97 | , mzipWithRep 98 | -- *** MonadReader 99 | , askRep 100 | , localRep 101 | -- *** Comonad 102 | , extractRep, extractRepBy 103 | , extendRep, extendRepBy 104 | , duplicateRep, duplicateRepBy 105 | -- *** ComonadTrace 106 | , traceRep 107 | -- *** FunctorWithIndex 108 | , imapRep 109 | -- *** FoldableWithIndex 110 | , ifoldMapRep 111 | -- *** TraversableWithIndex 112 | , itraverseRep 113 | -- * Eq/Eq1 114 | , eqRep 115 | , neRep 116 | , liftEqRep 117 | -- * Ord/Ord1 118 | , compareRep 119 | , liftCompareRep 120 | -- *** As right adjoints 121 | , leftAdjunctRep 122 | , rightAdjunctRep 123 | -- * Zapping Adjunctions 124 | , Variant 125 | , zapWith 126 | ) where 127 | 128 | import Data.Rep.Internal 129 | import Numeric.Fin 130 | -------------------------------------------------------------------------------- /src/Data/Rep/Coyoneda.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language Safe #-} 3 | 4 | -- | 5 | -- Copyright : (C) 2021 Edward Kmett, Emily Pillmore 6 | -- License : BSD-2-Clause OR Apache-2.0 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | 11 | module Data.Rep.Coyoneda 12 | ( Coyoneda(CoyonedaDist, Coyoneda) 13 | , liftCoyonedaDist 14 | , liftCoyoneda 15 | , lowerCoyoneda 16 | , hoistCoyoneda 17 | ) where 18 | 19 | import Control.Applicative 20 | import Control.Monad 21 | import Control.Monad.Fix 22 | import Control.Monad.Zip 23 | import Control.Monad.Trans 24 | import Data.Functor.Classes 25 | import Data.Functor.Compose 26 | import Data.Functor.Identity 27 | import Data.Rep 28 | import Text.Read hiding (lift) 29 | #ifdef MIN_VERSION_comonad 30 | import Control.Comonad 31 | import Control.Comonad.Trans.Class 32 | #endif 33 | 34 | type role Coyoneda representational nominal 35 | data Coyoneda f a where 36 | CoyonedaDist :: Representable g => g a -> f (Log g) -> Coyoneda f a 37 | 38 | -- I'm not sure whether this pattern can be made work on GHC-8.0, 39 | -- or it's unworkaroundable bug 40 | pattern Coyoneda :: (b -> a) -> f b -> Coyoneda f a 41 | pattern Coyoneda ga flg <- CoyonedaDist (Tabulate ga) flg where 42 | Coyoneda ga flg = CoyonedaDist ga flg 43 | 44 | {-# complete Coyoneda :: Coyoneda #-} 45 | 46 | instance (Show1 f, Functor f) => Show1 (Coyoneda f) where 47 | liftShowsPrec = \ sp sl d (CoyonedaDist f a) -> 48 | showsUnaryWith (liftShowsPrec sp sl) "liftCoyoneda" d (fmap (index f) a) 49 | {-# inline liftShowsPrec #-} 50 | 51 | instance Read1 f => Read1 (Coyoneda f) where 52 | liftReadsPrec = \ rp rl -> readsData $ 53 | readsUnaryWith (liftReadsPrec rp rl) "liftCoyoneda" liftCoyoneda 54 | {-# inline liftReadsPrec #-} 55 | 56 | instance Eq1 f => Eq1 (Coyoneda f) where 57 | liftEq = \eq (CoyonedaDist f xs) (CoyonedaDist g ys) -> 58 | liftEq (\x y -> eq (index f x) (index g y)) xs ys 59 | {-# inline liftEq #-} 60 | 61 | instance Ord1 f => Ord1 (Coyoneda f) where 62 | liftCompare = \cmp (CoyonedaDist f xs) (CoyonedaDist g ys) -> 63 | liftCompare (\x y -> cmp (index f x) (index g y)) xs ys 64 | {-# inline liftCompare #-} 65 | 66 | instance (Functor f, Eq1 f, Eq a) => Eq (Coyoneda f a) where 67 | (==) = eq1 68 | {-# inline (==) #-} 69 | 70 | instance (Functor f, Ord1 f, Ord a) => Ord (Coyoneda f a) where 71 | compare = compare1 72 | {-# inline compare #-} 73 | 74 | instance (Functor f, Show1 f, Show a) => Show (Coyoneda f a) where 75 | showsPrec = showsPrec1 76 | {-# inline showsPrec #-} 77 | 78 | instance Read (f a) => Read (Coyoneda f a) where 79 | readPrec = parens $ prec 10 $ do 80 | Ident "liftCoyoneda" <- lexP 81 | liftCoyoneda <$> step readPrec 82 | {-# inline readPrec #-} 83 | 84 | instance Functor (Coyoneda f) where 85 | fmap = \f (CoyonedaDist ga fl) -> CoyonedaDist (fmap f ga) fl 86 | {-# inline fmap #-} 87 | 88 | instance Applicative f => Applicative (Coyoneda f) where 89 | pure = \a -> CoyonedaDist (Identity a) (pure FZ) 90 | {-# inline pure #-} 91 | 92 | liftA2 = \abc (CoyonedaDist ga flg) (CoyonedaDist hb flh) -> 93 | CoyonedaDist (Compose $ fmap (\a -> fmap (abc a) hb) ga) (liftA2 (,) flg flh) 94 | {-# inline liftA2 #-} 95 | 96 | (<*>) = \(CoyonedaDist gab flg) (CoyonedaDist ha flh) -> 97 | CoyonedaDist (Compose $ fmap (\ab -> fmap ab ha) gab) (liftA2 (,) flg flh) 98 | {-# inline (<*>) #-} 99 | 100 | (<*) = \(CoyonedaDist ga flg) (CoyonedaDist _ flh) -> CoyonedaDist ga (flg <* flh) 101 | {-# inline (<*) #-} 102 | 103 | (*>) = \(CoyonedaDist _ flg) (CoyonedaDist ha flh) -> CoyonedaDist ha (flg *> flh) 104 | {-# inline (*>) #-} 105 | 106 | instance Alternative f => Alternative (Coyoneda f) where 107 | empty = liftCoyoneda empty 108 | {-# inline empty #-} 109 | (<|>) = \m n -> liftCoyoneda $ lowerCoyoneda m <|> lowerCoyoneda n 110 | {-# inline (<|>) #-} 111 | 112 | instance MonadIO f => MonadIO (Coyoneda f) where 113 | liftIO = lift . liftIO 114 | {-# inline liftIO #-} 115 | 116 | instance MonadZip f => MonadZip (Coyoneda f) where 117 | mzipWith = \abc (CoyonedaDist ga flg) (CoyonedaDist hb flh) -> 118 | CoyonedaDist (Compose $ fmap (\a -> fmap (abc a) hb) ga) (mzipWith (,) flg flh) 119 | {-# inline mzipWith #-} 120 | 121 | instance Monad f => Monad (Coyoneda f) where 122 | (>>=) = \(CoyonedaDist f v) k -> 123 | lift (v >>= lowerCoyoneda . k . index f) 124 | {-# inline (>>=) #-} 125 | 126 | instance MonadFix f => MonadFix (Coyoneda f) where 127 | mfix = \f -> lift $ mfix (lowerCoyoneda . f) 128 | {-# INLINE mfix #-} 129 | 130 | instance MonadTrans Coyoneda where 131 | lift = CoyonedaDist id 132 | {-# inline lift #-} 133 | 134 | instance Foldable f => Foldable (Coyoneda f) where 135 | foldMap = \f (CoyonedaDist (fmap f -> g') flg) -> 136 | foldMap (index g') flg 137 | {-# inline foldMap #-} 138 | 139 | instance Traversable f => Traversable (Coyoneda f) where 140 | traverse = \f (CoyonedaDist (fmap f -> g') flg) -> 141 | liftCoyoneda <$> traverse (index g') flg 142 | {-# inline traverse #-} 143 | 144 | instance MonadPlus f => MonadPlus (Coyoneda f) where 145 | mzero = lift mzero 146 | {-# inline mzero #-} 147 | mplus = \m n -> lift $ lowerCoyoneda m `mplus` lowerCoyoneda n 148 | {-# inline mplus #-} 149 | 150 | instance Indexable f => Indexable (Coyoneda f) where 151 | type Log (Coyoneda f) = Log f 152 | index = \(CoyonedaDist g flg) lf -> index g (index flg lf) 153 | {-# inline index #-} 154 | 155 | instance Representable f => Representable (Coyoneda f) where 156 | scatter = \wid2r h2cyf wh -> liftCoyoneda (scatter wid2r (lowerCoyoneda . h2cyf) wh) 157 | tabulate = \logf2a -> CoyonedaDist (tabulate @f logf2a) askRep 158 | {-# inline scatter #-} 159 | {-# inline tabulate #-} 160 | 161 | liftCoyonedaDist :: forall g f. Representable g => f (Log g) -> Coyoneda f (Log g) 162 | liftCoyonedaDist = CoyonedaDist (askRep @g) 163 | {-# inline liftCoyonedaDist #-} 164 | 165 | liftCoyoneda :: f a -> Coyoneda f a 166 | liftCoyoneda = CoyonedaDist id 167 | {-# inline liftCoyoneda #-} 168 | 169 | lowerCoyoneda :: Functor f => Coyoneda f a -> f a 170 | lowerCoyoneda = \(CoyonedaDist f m) -> fmap (index f) m 171 | {-# inline lowerCoyoneda #-} 172 | 173 | -- | Lift a natural transformation from @f@ to @g@ to a natural transformation 174 | -- from @Coyoneda f@ to @Coyoneda g@. 175 | hoistCoyoneda :: (forall a. f a -> g a) -> (Coyoneda f b -> Coyoneda g b) 176 | hoistCoyoneda = \f (CoyonedaDist g x) -> CoyonedaDist g (f x) 177 | {-# inline hoistCoyoneda #-} 178 | 179 | #ifdef MIN_VERSION_comonad 180 | instance ComonadTrans Coyoneda where 181 | lower (CoyonedaDist g fa) = index g <$> fa 182 | {-# inline lower #-} 183 | 184 | instance Comonad f => Comonad (Coyoneda f) where 185 | extend k (CoyonedaDist f v) = Coyoneda id $ extend (k . CoyonedaDist f) v 186 | {-# INLINE extend #-} 187 | extract (CoyonedaDist f v) = index f (extract v) 188 | {-# INLINE extract #-} 189 | #endif 190 | -------------------------------------------------------------------------------- /src/Data/Rep/Endo.hs: -------------------------------------------------------------------------------- 1 | {-# Language Safe #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2021 Edward Kmett 5 | -- License : BSD-2-Clause OR Apache-2.0 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : non-portable 9 | -- 10 | -- Tabulated endomorphisms 11 | -- 12 | module Data.Rep.Endo 13 | ( Endo(.., Endo, appEndo) 14 | ) where 15 | 16 | import Data.Rep 17 | 18 | -- | Tabulated endomorphisms. 19 | -- 20 | -- Many representable functors can be used to memoize functions. 21 | type role Endo nominal 22 | newtype Endo f = EndoDist { runEndoDist :: f (Log f) } 23 | 24 | pattern Endo :: Representable f => (Log f -> Log f) -> Endo f 25 | pattern Endo { appEndo } = EndoDist (Tabulate appEndo) 26 | 27 | {-# complete Endo :: Endo #-} 28 | 29 | instance Representable f => Semigroup (Endo f) where 30 | (<>) = \f g -> Endo (appEndo f . appEndo g) 31 | {-# inline (<>) #-} 32 | 33 | instance Representable f => Monoid (Endo f) where 34 | mempty = EndoDist askRep 35 | {-# inline mempty #-} 36 | 37 | --instance (Representable f, Traversable f) => Eq (Endo f) where 38 | -- (==) = liftEqDist (on (==) logToLogarithm) 39 | -------------------------------------------------------------------------------- /src/Data/Rep/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language DerivingVia #-} 3 | {-# Language GeneralizedNewtypeDeriving #-} 4 | {-# Language Unsafe #-} 5 | {-# options_haddock not-home #-} 6 | 7 | -- | 8 | -- Copyright : (c) 2011-2021 Edward Kmett, 9 | -- (c) 2017-2021 Aaron Vargo, 10 | -- (c) 2021 Oleg Grenrus 11 | -- License : BSD-2-Clause OR Apache-2.0 12 | -- Maintainer : Edward Kmett 13 | -- Stability : provisional 14 | -- Portability : non-portable (ghc 8.6+) 15 | 16 | module Data.Rep.Internal where 17 | 18 | import Control.Applicative 19 | import Control.Applicative.Backwards 20 | import Control.Arrow 21 | import Control.Monad.Fix 22 | import Control.Monad.Reader 23 | import Control.Monad.Trans.Identity 24 | import Control.Monad.Zip 25 | import Data.Coerce 26 | import Data.Complex 27 | import Data.Data 28 | import Data.Dependent.Sum 29 | import Data.Function.Coerce 30 | import Data.Foldable (fold) 31 | import Data.Foldable.WithIndex 32 | import Data.Function 33 | import Data.Functor 34 | import Data.Functor.Classes 35 | import Data.Functor.Compose 36 | import Data.Functor.Identity 37 | import Data.Functor.Product 38 | import Data.Functor.Reverse 39 | import Data.Functor.WithIndex 40 | import Data.GADT.Compare 41 | import Data.HKD 42 | import Data.HKD.Contravariant 43 | import Data.HKD.Index.Internal 44 | import Data.Kind 45 | import Data.Maybe 46 | import qualified Data.Monoid as Monoid 47 | import Data.Ord (Down(..)) 48 | import Data.Orphans () 49 | import Data.Profunctor 50 | import qualified Data.Semigroup as Semigroup 51 | import Data.Some 52 | import Data.Traversable 53 | import Data.Traversable.WithIndex 54 | import Data.Type.Bool 55 | import Data.Type.Coercion 56 | import Data.Type.Equality 57 | import Data.Void 58 | import GHC.Generics 59 | import GHC.TypeLits 60 | import Numeric 61 | import Numeric.Fin.Internal 62 | import Unsafe.Coerce 63 | 64 | #ifdef MIN_VERSION_tagged 65 | import Data.Tagged 66 | #endif 67 | 68 | #ifdef MIN_VERSION_comonad 69 | import Control.Comonad 70 | import Control.Comonad.Trans.Traced 71 | #endif 72 | 73 | #if MIN_VERSION_ghc_prim(0,7,0) 74 | import GHC.Tuple (Solo) 75 | #endif 76 | 77 | class Indexable f where 78 | -- | Defaults to @'Log' ('Rep1' f)@ when @f@ is non-recursive, otherwise to 'Logarithm'. 79 | type Log f 80 | type Log f = DefaultLog f 81 | 82 | type KnownSize f :: Maybe Nat 83 | type KnownSize f = DefaultKnownSize f 84 | 85 | -- | Defaults to 'indexLogarithm' when @'Log' f = 'Logarithm' f@, otherwise to 'indexGeneric' 86 | index :: f a -> Log f -> a 87 | default index :: DefaultIndex f => f a -> Log f -> a 88 | index = defaultIndex 89 | {-# inline index #-} 90 | 91 | -- | A 'Representable' functor is a functor which is isomorphic to @(->) x@ for 92 | -- some type @x@, and can be thought of as a container of a fixed size which 93 | -- contains nothing other than its elements, with @x@ being the type of its 94 | -- indicies. We call the type @x@ @'Log' f@, and the two halves of the 95 | -- isomorphism 'tabulate' and 'index'. 96 | -- 97 | -- However, the above definition's reliance on indexing makes it asymptotically 98 | -- inefficient for structures without random access. This class therefore 99 | -- provides an alternative, equivalent definition of representable functors as 100 | -- "better distributive functors". In its simplest form, this is a functor which 101 | -- supports the operation 102 | -- 103 | -- @ 104 | -- 'dist' :: 'FFunctor' w => w f -> f (w 'Identity') 105 | -- @ 106 | -- 107 | -- satisfying the law 108 | -- 109 | -- @ 110 | -- 'dist' . 'F1' = 'fmap' ('F1' . 'Identity') 111 | -- @ 112 | -- 113 | -- See the docs for 'dist'. 114 | -- 115 | -- However, one will usually want to 'fmap' immediately after using 'dist', so 116 | -- it makes sense to instead define this class in terms of 'distrib', so that 117 | -- the two operations can be fused. However, 'distrib' (as well as 'dist') would 118 | -- prevent this class from being derived with GeneralizedNewtypeDeriving or 119 | -- DerivingVia, so this class is instead defined in terms of 'scatter'. 120 | -- 121 | -- There are a few different ways to implement this class: 122 | -- 123 | -- If you have a 'Generic1' instance for your functor, you should be able to 124 | -- derive this class. This may be inefficient for recursive types, 125 | -- where the derived instance may be recursive in a way which prevents 126 | -- specialization of the 'FFunctor' argument to 'scatter'. 127 | -- 128 | -- You can provide an implementation of 'scatter' satisfying the law 129 | -- 130 | -- @ 131 | -- 'scatter' k phi . 'F1' ≡ 'fmap' (k . 'F1' . 'Identity') . phi 132 | -- @ 133 | -- 134 | -- You can provide an isomorphism by implementing 'Log', 'tabulate', and 'index', satisfying 135 | -- 136 | -- @ 137 | -- 'tabulate' . 'index' ≡ 'id' 138 | -- 'index' . 'tabulate' ≡ 'id' 139 | -- @ 140 | -- 141 | -- and define 142 | -- 143 | -- @ 144 | -- 'scatter' = 'scatterDefault' 145 | -- @ 146 | -- 147 | -- 'scatterDefault' will be asymptotically inefficient when 'index' is not O(1). 148 | -- 149 | -- When providing an isomorphism, you can use @'Logarithm' f@ and 150 | -- 'indexLogarithm' as definitions for @'Log' f@ and 'index', in which case you 151 | -- then only need an appropriate definition for 'tabulate'. 152 | class (Indexable f, Functor f) => Representable f where 153 | -- | Defaults to 'tabulateLogarithm' when @'Log' f = 'Logarithm' f@, otherwise to 'tabulateGeneric' 154 | tabulate :: (Log f -> a) -> f a 155 | default tabulate :: DefaultTabulate f => (Log f -> a) -> f a 156 | tabulate = defaultTabulate 157 | {-# inline tabulate #-} 158 | 159 | -- |@ 160 | -- 'scatter' k phi wg ≡ 'distrib' ('ffmap' phi wg) k 161 | -- @ 162 | -- 163 | -- Version of 'distrib' with an extra map to make it compatible with 164 | -- GeneralizedNewtypeDeriving. The extra map isn't particularly useful 165 | -- otherwise. Implementations will often immediately @'ffmap' phi wg@ and 166 | -- then essentially implement 'distrib'. 167 | -- 168 | -- Implementations must satisfy the law 169 | -- 170 | -- @ 171 | -- 'scatter' k phi . 'F1' ≡ 'fmap' (k . 'F1' . 'Identity') . phi 172 | -- @ 173 | -- 174 | -- Defaults to 'scatterGeneric'. 175 | scatter :: FFunctor w => (w Identity -> r) -> (g ~> f) -> w g -> f r 176 | default scatter 177 | :: (Generic1 f, Representable (Rep1 f), FFunctor w) 178 | => (w Identity -> r) -> (g ~> f) -> w g -> f r 179 | scatter = scatterGeneric 180 | {-# inline scatter #-} 181 | 182 | -- | derive tabulate via 'Generic1' when @'Log' f@ is (a possible newtype of) 183 | -- @'Log' ('Rep1' f)@ 184 | tabulateGeneric 185 | :: forall f a. 186 | (Representable (Rep1 f), Generic1 f, Coercible (Log f) (Log (Rep1 f))) 187 | => (Log f -> a) -> f a 188 | tabulateGeneric = coerce (to1 . tabulate :: (Log (Rep1 f) -> a) -> f a) 189 | {-# inline tabulateGeneric #-} 190 | 191 | -- | derive 'index' via 'Generic1' when @'Log' f@ is (a possible newtype of) 192 | -- @'Log' ('Rep1' f)@ 193 | indexGeneric 194 | :: forall f a. 195 | (Indexable (Rep1 f), Generic1 f, Coercible (Log f) (Log (Rep1 f))) 196 | => f a -> Log f -> a 197 | indexGeneric = coerce (index . from1 :: f a -> Log (Rep1 f) -> a) 198 | {-# inline indexGeneric #-} 199 | 200 | -- | derive 'scatter' via 'Generic1' 201 | scatterGeneric 202 | :: (Representable (Rep1 f), Generic1 f, FFunctor w) 203 | => (w Identity -> r) -> (g ~> f) -> w g -> f r 204 | scatterGeneric = \k phi -> to1 . scatter k (from1 . phi) 205 | {-# inline scatterGeneric #-} 206 | 207 | -- | This pattern synonym lets you work with any 'Representable' functor as if 208 | -- it were a function. 209 | pattern Tabulate :: Representable f => (Log f -> a) -> f a 210 | pattern Tabulate i <- (index -> i) where 211 | Tabulate i = tabulate i 212 | {-# COMPLETE Tabulate #-} 213 | 214 | -- * Generic derivation 215 | 216 | data LogType 217 | = UseLogarithm 218 | | UseLogFin 219 | | UseLogRep 220 | 221 | type family HasLogType f t :: LogType where 222 | HasLogType f (Logarithm f) = 'UseLogarithm 223 | HasLogType f (Fin x) = If (x == Size f) 'UseLogFin 'UseLogRep 224 | HasLogType f t = 'UseLogRep 225 | 226 | type LogTypeOf f = HasLogType f (Log f) 227 | 228 | type DefaultLog f = DefaultLog' (GInvalid (Rep1 f)) f 229 | 230 | type family DefaultLog' (containsRec1 :: Bool) f :: Type where 231 | DefaultLog' 'True f = Logarithm f 232 | DefaultLog' 'False f = DefaultLog'' (GUnknownSize (Rep1 f)) f 233 | 234 | type family DefaultLog'' (hasUnknownSize :: Bool) f :: Type where 235 | DefaultLog'' 'True f = Log (Rep1 f) 236 | DefaultLog'' 'False f = Fin (Size f) 237 | 238 | type family DefaultTabulateImplC (t :: LogType) f :: Constraint where 239 | DefaultTabulateImplC 'UseLogarithm f = (Representable f, Log f ~ Logarithm f) 240 | DefaultTabulateImplC 'UseLogRep f = (Generic1 f, Representable (Rep1 f), Coercible (Log f) (Log (Rep1 f))) 241 | DefaultTabulateImplC 'UseLogFin f = (Generic1 f, GTabulateFin (Rep1 f), Size f ~ GSize (Rep1 f), Log f ~ Fin (GSize (Rep1 f))) 242 | 243 | type family DefaultIndexImplC (t :: LogType) f :: Constraint where 244 | DefaultIndexImplC 'UseLogarithm f = (Log f ~ Logarithm f) 245 | DefaultIndexImplC 'UseLogRep f = (Generic1 f, Representable (Rep1 f), Coercible (Log f) (Log (Rep1 f))) 246 | DefaultIndexImplC 'UseLogFin f = (Generic1 f, GIndexFin (Rep1 f), Size f ~ GSize (Rep1 f), Log f ~ Fin (GSize (Rep1 f))) 247 | 248 | -- individual type classes, so GHC needs to do less work 249 | class DefaultTabulateImplC logType f => DefaultTabulate' (logType :: LogType) f where 250 | defaultTabulate' :: (Log f -> a) -> f a 251 | 252 | instance DefaultTabulateImplC 'UseLogarithm f => DefaultTabulate' 'UseLogarithm f where 253 | defaultTabulate' = tabulateLogarithm 254 | {-# inline defaultTabulate' #-} 255 | 256 | instance DefaultTabulateImplC 'UseLogRep f => DefaultTabulate' 'UseLogRep f where 257 | defaultTabulate' = tabulateGeneric 258 | {-# inline defaultTabulate' #-} 259 | 260 | instance DefaultTabulateImplC 'UseLogFin f => DefaultTabulate' 'UseLogFin f where 261 | defaultTabulate' = gtabulateFin 262 | {-# inline defaultTabulate' #-} 263 | 264 | type DefaultTabulate f = DefaultTabulate' (LogTypeOf f) f 265 | 266 | defaultTabulate :: forall f a. DefaultTabulate f => (Log f -> a) -> f a 267 | defaultTabulate = defaultTabulate' @(LogTypeOf f) 268 | {-# inline defaultTabulate #-} 269 | 270 | class DefaultIndexImplC logType f => DefaultIndex' (logType :: LogType) f where 271 | defaultIndex' :: f a -> Log f -> a 272 | 273 | instance DefaultIndexImplC 'UseLogarithm f => DefaultIndex' 'UseLogarithm f where 274 | defaultIndex' = indexLogarithm 275 | {-# inline defaultIndex' #-} 276 | 277 | instance DefaultIndexImplC 'UseLogRep f => DefaultIndex' 'UseLogRep f where 278 | defaultIndex' = indexGeneric 279 | {-# inline defaultIndex' #-} 280 | 281 | instance DefaultIndexImplC 'UseLogFin f => DefaultIndex' 'UseLogFin f where 282 | defaultIndex' = gindexFin 283 | {-# inline defaultIndex' #-} 284 | 285 | type DefaultIndex f = DefaultIndex' (LogTypeOf f) f 286 | 287 | defaultIndex :: forall f a. DefaultIndex f => f a -> (Log f -> a) 288 | defaultIndex = defaultIndex' @(LogTypeOf f) 289 | {-# inline defaultIndex #-} 290 | 291 | -- | @ 292 | -- 'distrib' wf k ≡ 'fmap' k ('dist' wf) ≡ 'tabulate' \\i -> k '$' 'ffmap' ('Identity' . (`'index'` i)) wf 293 | -- @ 294 | -- 295 | -- Encodes the common pattern of using 'fmap' after 'dist', and allows the two 296 | -- operations to be fused. Can be asymptotically faster than 'tabulate'/'index' 297 | -- for 'Representable' functors without random access. 298 | distrib :: (Representable f, FFunctor w) => w f -> (w Identity -> r) -> f r 299 | distrib = \ w k -> scatter k id w 300 | {-# inline distrib #-} 301 | 302 | -- | @ 303 | -- 'dist' wf ≡ 'tabulate' \\i -> 'ffmap' ('Identity' '.' (`'index'` i)) wf 304 | -- @ 305 | -- 306 | -- However, 'dist' can be asymptotically faster than 'tabulate'/'index' for 307 | -- 'Representable' functors without random access, as it may walk through the 308 | -- @f@s in @wf@ rather than repeatedly 'index' into them. 309 | -- 310 | -- When combined with 'fmap' (see 'distrib'), 'dist' is powerful enough to 311 | -- implement any operation on 'Representable' functors which doesn't depend on 'Log'. 312 | -- 313 | -- One intuition for 'dist' is that it transposes a 2D container: 314 | -- 315 | -- * A @w f@ can be thought of as a 2D container with rows given by the 316 | -- container @f@, where different rows may have different element types 317 | -- (determined by @w@). E.g. @data Foo f = Foo (f Int) (f Bool)@ can be thought 318 | -- of as the type of 2D containers consisting of a row of ints and a row of 319 | -- bools. 320 | -- 321 | -- * 'dist' takes a 2D container with rows given by a representable functor — 322 | -- i.e. where the rows all have the same length — and returns a row of its columns 323 | -- 324 | -- * The type of a column is @w Identity@, as a column is a 2D container with 325 | -- rows of length one 326 | dist :: (Representable f, FFunctor w) => w f -> f (w Identity) 327 | dist = scatter id id 328 | {-# inline dist #-} 329 | 330 | -- | Implements 'scatter' in terms of 'tabulate' and 'index'. 331 | -- 332 | -- This can be used as a definition for 'scatter' when providing a definition 333 | -- for 'tabulate', but will be asymptotically inefficient when 'index' is not O(1). 334 | scatterDefault 335 | :: (Representable f, FFunctor w) 336 | => (w Identity -> r) 337 | -> (g ~> f) 338 | -> w g -> f r 339 | scatterDefault = \k phi wg -> 340 | let wf = ffmap phi wg 341 | in tabulate \i -> k $ ffmap (Identity . (`index` i)) wf 342 | {-# inline scatterDefault #-} 343 | 344 | -- | Default definition for 'tabulate' when @'Log' f = 'Logarithm' f@. Can be used 345 | -- to manipulate 'Logarithm's regardless of the choice of 'Log' for your 'Representable' 346 | -- functor. 347 | tabulateLogarithm :: Representable f => (Logarithm f -> a) -> f a 348 | tabulateLogarithm = \f -> distrib (NT id) \(NT g) -> f $ Logarithm \x -> runIdentity $ g x 349 | {-# inline tabulateLogarithm #-} 350 | 351 | -- | @f '~>' 'Identity'@ 352 | -- 353 | -- When @f@ is 'Representable' this is isomorphic to @'Log' f@, and may be used 354 | -- as a definition for @'Log' f@. This makes it possible to derive 355 | -- 'Representable' without constructing a 'Log' specific to @f@, which is 356 | -- necessary to show that "better distributive functors" are in fact equivalent 357 | -- to 'Representable' functors. 358 | newtype Logarithm f = Logarithm { runLogarithm :: forall a. f a -> a } 359 | 360 | -- | Default definition for 'index' when @'Log' f = 'Logarithm' f@ 361 | indexLogarithm :: f a -> Logarithm f -> a 362 | indexLogarithm = \fa (Logarithm fa2a) -> fa2a fa 363 | {-# inline indexLogarithm #-} 364 | 365 | instance FContravariant Logarithm where 366 | fcontramap = \f g -> Logarithm (runLogarithm g . f) 367 | {-# inline fcontramap #-} 368 | 369 | -- | Tabulation. 370 | newtype Tab a f = Tab { runTab :: Logarithm f -> a } 371 | 372 | instance FFunctor (Tab a) where 373 | ffmap = \ f g -> Tab (runTab g . fcontramap f) 374 | {-# inline ffmap #-} 375 | 376 | -- | The dual of 'Data.Traversable.sequenceA' 377 | -- 378 | -- >>> distribute [(+1),(+2)] 1 379 | -- [2,3] 380 | -- 381 | -- @ 382 | -- 'distribute' ≡ 'collect' 'id' 383 | -- 'distribute' . 'distribute' ≡ 'id' 384 | -- @ 385 | distribute 386 | :: (Functor f, Representable g) 387 | => f (g a) -> g (f a) 388 | distribute = \f -> distrib (FCompose f) \(FCompose f') -> runIdentity <$> f' 389 | {-# inline distribute #-} 390 | 391 | -- | 392 | -- @ 393 | -- 'collect' f ≡ 'distribute' . 'fmap' f 394 | -- 'fmap' f ≡ 'runIdentity' . 'collect' ('Identity' . f) 395 | -- 'fmap' 'distribute' . 'collect' f ≡ 'getCompose' . 'collect' ('Compose' . f) 396 | -- @ 397 | collect 398 | :: (Functor f, Representable g) 399 | => (a -> g b) 400 | -> f a -> g (f b) 401 | collect = \ f fa -> distrib (FCompose f) \(FCompose f') -> coerce f' <$> fa 402 | {-# inline collect #-} 403 | 404 | -- | The dual of 'Data.Traversable.traverse' 405 | -- 406 | -- @ 407 | -- 'cotraverse' f ≡ 'fmap' f . 'distribute' 408 | -- @ 409 | cotraverse 410 | :: (Functor f, Representable g) 411 | => (f a -> b) 412 | -> f (g a) -> g b 413 | cotraverse = \fab fga -> 414 | distrib (FCompose fga) \(FCompose f') -> fab (runIdentity <$> f') 415 | {-# inline cotraverse #-} 416 | 417 | instance Indexable (Coe a) where 418 | type Log (Coe a) = a 419 | index = runCoe 420 | {-# inline index #-} 421 | 422 | instance Representable (Coe a) where 423 | tabulate = Fun 424 | {-# inline tabulate #-} 425 | scatter k f (ffmap f -> w) = Fun \a -> k $ ffmap (\g -> Identity $ runCoe g a) w 426 | {-# inline scatter #-} 427 | 428 | instance (Indexable f, Indexable g) => Indexable (f :*: g) where 429 | type Log (f :*: g) = Either (Log f) (Log g) 430 | index = \(f :*: g) -> \case 431 | Left x -> index f x 432 | Right y -> index g y 433 | {-# inline index #-} 434 | 435 | instance (Representable f, Representable g) => Representable (f :*: g) where 436 | scatter = \ k f (ffmap f -> w) -> 437 | scatter k (\(l :*: _) -> l) w 438 | :*: scatter k (\(_ :*: r) -> r) w 439 | tabulate = \ f -> tabulate (f . Left) :*: tabulate (f . Right) 440 | {-# inline scatter #-} 441 | {-# inline tabulate #-} 442 | 443 | deriving newtype instance Indexable f => Indexable (M1 i c f) 444 | deriving newtype instance Representable f => Representable (M1 i c f) 445 | 446 | instance Indexable U1 where 447 | type Log U1 = Void 448 | index = \_ -> absurd 449 | {-# inline index #-} 450 | 451 | instance Representable U1 where 452 | scatter = \_ _ _ -> U1 453 | tabulate = \_ -> U1 454 | {-# inline scatter #-} 455 | {-# inline tabulate #-} 456 | 457 | deriving newtype instance Indexable f => Indexable (Rec1 f) 458 | deriving newtype instance Representable f => Representable (Rec1 f) 459 | 460 | instance Indexable Par1 where 461 | type Log Par1 = () 462 | index = \x _ -> unPar1 x 463 | {-# inline index #-} 464 | 465 | instance Representable Par1 where 466 | scatter = \k f -> coerce $ k . ffmap ((Identity . unPar1) #. f) 467 | tabulate = \f -> Par1 $ f () 468 | {-# inline scatter #-} 469 | {-# inline tabulate #-} 470 | 471 | instance (Indexable f, Indexable g) => Indexable (f :.: g) where 472 | type Log (f :.: g) = (Log f, Log g) 473 | index = \ (Comp1 f) (x, y) -> index (index f x) y 474 | {-# inline index #-} 475 | 476 | instance (Representable f, Representable g) => Representable (f :.: g) where 477 | scatter = \ k phi wg -> 478 | Comp1 $ 479 | scatter 480 | (scatter k coerce .# runAppDot) 481 | id 482 | (AppDot (ffmap phi wg)) 483 | tabulate = \f -> Comp1 $ tabulate \i -> tabulate \j -> f (i, j) 484 | {-# inline scatter #-} 485 | {-# inline tabulate #-} 486 | 487 | instance (Indexable f, Indexable g) => Indexable (Compose f g) where 488 | type Log (Compose f g) = Log (Rep1 (Compose f g)) 489 | index (Compose fg) (i,j) = index (index fg i) j 490 | {-# inline index #-} 491 | 492 | instance (Representable f, Representable g) => Representable (Compose f g) where 493 | tabulate f = Compose $ tabulate \i -> tabulate \j -> f (i,j) 494 | {-# inline tabulate #-} 495 | scatter = \ k phi wg -> 496 | Compose $ 497 | scatter 498 | (scatter k coerce .# runAppCompose) 499 | id 500 | (AppCompose (ffmap phi wg)) 501 | {-# inline scatter #-} 502 | 503 | instance (Indexable f, Indexable g) => Indexable (Product f g) where 504 | type Log (Product f g) = Log (Rep1 (Product f g)) 505 | index = indexGeneric 506 | {-# inline index #-} 507 | 508 | instance (Representable f, Representable g) => Representable (Product f g) where 509 | tabulate = tabulateGeneric 510 | {-# inline tabulate #-} 511 | 512 | instance Indexable Proxy 513 | instance Representable Proxy 514 | 515 | instance Indexable Identity 516 | instance Representable Identity 517 | 518 | #if MIN_VERSION_ghc_prim(0,7,0) 519 | instance Indexable Solo 520 | instance Representable Solo 521 | #endif 522 | 523 | instance Indexable ((->) x) where 524 | type Log ((->) x) = x 525 | index = id 526 | {-# inline index #-} 527 | 528 | instance Representable ((->) x) where 529 | scatter = \ k phi wg x -> k $ ffmap (\g -> Identity $ phi g x) wg 530 | tabulate = id 531 | {-# inline scatter #-} 532 | {-# inline tabulate #-} 533 | 534 | instance Indexable Down 535 | instance Representable Down 536 | instance Indexable Monoid.Product 537 | instance Representable Monoid.Product 538 | instance Indexable Monoid.Sum 539 | instance Representable Monoid.Sum 540 | 541 | deriving newtype instance Indexable f => Indexable (Backwards f) 542 | deriving newtype instance Representable f => Representable (Backwards f) 543 | deriving newtype instance Indexable f => Indexable (Reverse f) 544 | deriving newtype instance Representable f => Representable (Reverse f) 545 | deriving newtype instance Indexable f => Indexable (Monoid.Alt f) 546 | deriving newtype instance Representable f => Representable (Monoid.Alt f) 547 | instance Indexable Monoid.Dual 548 | instance Representable Monoid.Dual 549 | 550 | deriving newtype instance Indexable f => Indexable (Monoid.Ap f) 551 | deriving newtype instance Representable f => Representable (Monoid.Ap f) 552 | 553 | instance Indexable Semigroup.First 554 | instance Representable Semigroup.First 555 | instance Indexable Semigroup.Last 556 | instance Representable Semigroup.Last 557 | instance Indexable Semigroup.Min 558 | instance Representable Semigroup.Min 559 | instance Indexable Semigroup.Max 560 | instance Representable Semigroup.Max 561 | 562 | deriving newtype instance (Indexable f, Monad f) => Indexable (WrappedMonad f) 563 | deriving newtype instance (Representable f, Monad f) => Representable (WrappedMonad f) 564 | 565 | instance Indexable f => Indexable (Kleisli f a) where 566 | type Log (Kleisli f a) = (a, Log f) 567 | index = index .# (Comp1 . runKleisli) 568 | {-# inline index #-} 569 | 570 | instance Representable f => Representable (Kleisli f a) where 571 | scatter = \k f -> coerce $ scatter k ((Comp1 . runKleisli) #. f) 572 | tabulate = (Kleisli . unComp1) #. tabulate 573 | {-# inline scatter #-} 574 | {-# inline tabulate #-} 575 | 576 | #ifdef MIN_VERSION_tagged 577 | instance Indexable (Tagged r) 578 | instance Representable (Tagged r) 579 | #endif 580 | 581 | instance Indexable Complex where 582 | type Log Complex = Bool 583 | index = \ (r :+ i) -> \case 584 | False -> r 585 | True -> i 586 | {-# inline index #-} 587 | 588 | instance Representable Complex where 589 | tabulate = \ f -> f False :+ f True 590 | {-# inline tabulate #-} 591 | 592 | deriving newtype instance Indexable f => Indexable (IdentityT f) 593 | deriving newtype instance Representable f => Representable (IdentityT f) 594 | 595 | deriving via (((->) e :.: f) :: Type -> Type) 596 | instance Indexable f => Indexable (ReaderT e f) 597 | 598 | deriving via (((->) e :.: f) :: Type -> Type) 599 | instance Representable f => Representable (ReaderT e f) 600 | 601 | -- * DerivingVia 602 | 603 | -- | Provides defaults definitions for other classes in terms of 604 | -- 'Representable'. Supplied for use with @DerivingVia@ in GHC 8.6+ 605 | -- 606 | -- Deriving 'Representable', 'Foldable', or 'Traversable' via 'Dist' f leads to non-termination 607 | -- but all other instances are fine for use and are defined in terms of these three. 608 | 609 | type role Dist representational nominal 610 | newtype Dist f a = Dist { runDist :: f a } 611 | deriving stock (Foldable, Traversable) 612 | 613 | instance Representable f => Functor (Dist f) where 614 | fmap = fmapRep 615 | {-# inline fmap #-} 616 | (<$) = const . pure 617 | {-# inline (<$) #-} 618 | 619 | -- | A default definition for 'fmap' from 'Functor' in terms of 'Representable' 620 | fmapRep :: Representable f => (a -> b) -> f a -> f b 621 | fmapRep = \ f fa -> distrib (F1 fa) \(F1 a) -> coerce f a 622 | {-# inline fmapRep #-} 623 | 624 | instance Indexable f => Indexable (Dist f) where 625 | type Log (Dist f) = Log f 626 | index = index .# runDist 627 | {-# inline index #-} 628 | 629 | instance Representable f => Representable (Dist f) where 630 | scatter = \ k f -> Dist #. scatter k (runDist #. f) 631 | tabulate = Dist #. tabulate 632 | {-# inline scatter #-} 633 | {-# inline tabulate #-} 634 | 635 | -- * Applicative 636 | 637 | instance Representable f => Applicative (Dist f) where 638 | pure = pureRep 639 | {-# inline pure #-} 640 | (<*>) = apRep 641 | {-# inline (<*>) #-} 642 | _ *> m = m 643 | {-# inline (*>) #-} 644 | (<*) = const 645 | {-# inline (<*) #-} 646 | liftA2 = liftR2 647 | {-# inline liftA2 #-} 648 | 649 | -- | A default definition for 'pure' from 'Applicative' in terms of 'Representable' 650 | pureRep :: Representable f => a -> f a 651 | pureRep = scatter getConst id .# Const 652 | -- pureRep = distrib Proxy . const 653 | {-# inline pureRep #-} 654 | 655 | -- | A default definition for '(<*>)' from 'Applicative' in terms of 'Representable' 656 | apRep :: Representable f => f (a -> b) -> f a -> f b 657 | apRep = \fab fa -> 658 | distrib (F2 fab fa) \(F2 ab a) -> coerce ab a 659 | {-# inline apRep #-} 660 | 661 | -- | A default definition 'liftA2' from 'Applicative' in terms of 'Representable' 662 | liftR2 :: Representable f => (a -> b -> c) -> f a -> f b -> f c 663 | liftR2 = \f fa fb -> 664 | distrib (F2 fa fb) \(F2 a b) -> coerce f a b 665 | {-# inline liftR2 #-} 666 | 667 | -- | An implementation of 'liftA3' in terms of 'Representable'. 668 | liftR3 :: Representable f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d 669 | liftR3 = \ f fa fb fc -> 670 | distrib (F3 fa fb fc) \(F3 a b c) -> coerce f a b c 671 | {-# inline liftR3 #-} 672 | 673 | -- | An implementation of 'liftA4' in terms of 'Representable'. 674 | liftR4 :: Representable f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e 675 | liftR4 = \f fa fb fc fd -> 676 | distrib (F4 fa fb fc fd) \(F4 a b c d) -> coerce f a b c d 677 | {-# inline liftR4 #-} 678 | 679 | -- | An implementation of 'liftA5' in terms of 'Representable'. 680 | liftR5 :: Representable f => (a -> b -> c -> d -> e -> x) -> f a -> f b -> f c -> f d -> f e -> f x 681 | liftR5 = \f fa fb fc fd fe -> 682 | distrib (F5 fa fb fc fd fe) \(F5 a b c d e) -> coerce f a b c d e 683 | {-# inline liftR5 #-} 684 | 685 | -- * Monad 686 | 687 | instance Representable f => Monad (Dist f) where 688 | (>>=) = bindRep 689 | {-# inline (>>=) #-} 690 | #if !MIN_VERSION_base(4,13,0) 691 | -- | What are you still doing using 'fail', anyways? 692 | fail x = tabulate $ \_ -> error x 693 | #endif 694 | 695 | -- | A default implementation of '(>>=)' in terms of 'Representable' 696 | bindRep :: Representable f => f a -> (a -> f b) -> f b 697 | bindRep = \ m f -> distrib (F1 m :*: FCompose f) \(F1 a :*: FCompose f') -> coerce f' a 698 | {-# inline bindRep #-} 699 | 700 | -- * MonadFix 701 | 702 | instance Representable f => MonadFix (Dist f) where 703 | mfix = mfixRep 704 | {-# inline mfix #-} 705 | 706 | -- | A default definition for 'mfix' in terms of 'Representable' 707 | mfixRep :: Representable f => (a -> f a) -> f a 708 | mfixRep = \ama -> distrib (FCompose ama) (fix . coerce) 709 | {-# inline mfixRep #-} 710 | 711 | instance Representable f => MonadZip (Dist f) where 712 | mzipWith = liftR2 713 | {-# inline mzipWith #-} 714 | munzip = fmap fst &&& fmap snd 715 | {-# inline munzip #-} 716 | 717 | instance (Representable f, e ~ Log f) => MonadReader e (Dist f) where 718 | ask = askRep 719 | {-# inline ask #-} 720 | local = localRep 721 | {-# inline local #-} 722 | reader = tabulate 723 | {-# inline reader #-} 724 | 725 | instance (Representable f, Num a) => Num (Dist f a) where 726 | (+) = liftA2 (+) 727 | (-) = liftA2 (-) 728 | (*) = liftA2 (*) 729 | negate = fmap negate 730 | abs = fmap abs 731 | signum = fmap signum 732 | fromInteger = pure . fromInteger 733 | {-# inline (+) #-} 734 | {-# inline (-) #-} 735 | {-# inline (*) #-} 736 | {-# inline negate #-} 737 | {-# inline abs #-} 738 | {-# inline signum #-} 739 | {-# inline fromInteger #-} 740 | 741 | instance (Representable f, Fractional a) => Fractional (Dist f a) where 742 | (/) = liftA2 (/) 743 | recip = fmap recip 744 | fromRational = pure . fromRational 745 | {-# inline (/) #-} 746 | {-# inline recip #-} 747 | {-# inline fromRational #-} 748 | 749 | instance (Representable f, Floating a) => Floating (Dist f a) where 750 | pi = pure pi 751 | exp = fmap exp 752 | log = fmap log 753 | sqrt = fmap sqrt 754 | (**) = liftA2 (**) 755 | logBase = liftA2 logBase 756 | sin = fmap sin 757 | cos = fmap cos 758 | tan = fmap tan 759 | asin = fmap asin 760 | acos = fmap acos 761 | atan = fmap atan 762 | sinh = fmap sinh 763 | cosh = fmap cosh 764 | tanh = fmap tanh 765 | asinh = fmap asinh 766 | acosh = fmap acosh 767 | atanh = fmap atanh 768 | log1p = fmap log1p 769 | expm1 = fmap expm1 770 | log1pexp = fmap log1pexp 771 | log1mexp = fmap log1mexp 772 | {-# inline pi #-} 773 | {-# inline exp #-} 774 | {-# inline log #-} 775 | {-# inline sqrt #-} 776 | {-# inline (**) #-} 777 | {-# inline logBase #-} 778 | {-# inline sin #-} 779 | {-# inline cos #-} 780 | {-# inline tan #-} 781 | {-# inline asin #-} 782 | {-# inline acos #-} 783 | {-# inline atan #-} 784 | {-# inline sinh #-} 785 | {-# inline cosh #-} 786 | {-# inline tanh #-} 787 | {-# inline asinh #-} 788 | {-# inline acosh #-} 789 | {-# inline atanh #-} 790 | {-# inline log1p #-} 791 | {-# inline expm1 #-} 792 | {-# inline log1pexp #-} 793 | {-# inline log1mexp #-} 794 | 795 | instance (Representable f, Semigroup a) => Semigroup (Dist f a) where 796 | (<>) = liftR2 (<>) 797 | {-# inline (<>) #-} 798 | 799 | instance (Representable f, Monoid a) => Monoid (Dist f a) where 800 | mempty = pure mempty 801 | {-# noinline[0] mempty #-} 802 | 803 | instance (Representable f, Foldable f, Eq a) => Eq (Dist f a) where 804 | (==) = eqRep 805 | {-# inline (==) #-} 806 | (/=) = neRep 807 | {-# inline (/=) #-} 808 | 809 | eqRep 810 | :: (Representable f, Foldable f, Eq a) 811 | => f a -> f a -> Bool 812 | eqRep = \ xs ys -> 813 | Monoid.getAll $ fold $ liftR2 (\x y -> Monoid.All (x == y)) xs ys 814 | {-# inline eqRep #-} 815 | 816 | neRep 817 | :: (Representable f, Foldable f, Eq a) 818 | => f a -> f a -> Bool 819 | neRep = \ xs ys -> 820 | Monoid.getAny $ fold $ liftR2 (\x y -> Monoid.Any (x /= y)) xs ys 821 | 822 | instance (Representable f, Foldable f, Ord a) => Ord (Dist f a) where 823 | compare = \xs ys -> fold $ liftR2 compare xs ys 824 | {-# inline compare #-} 825 | 826 | compareRep 827 | :: (Representable f, Foldable f, Ord a) 828 | => f a -> f a -> Ordering 829 | compareRep = \xs ys -> fold $ liftR2 compare xs ys 830 | {-# inline compareRep #-} 831 | 832 | liftCompareRep 833 | :: (Representable f, Foldable f) 834 | => (a -> b -> Ordering) 835 | -> f a -> f b -> Ordering 836 | liftCompareRep = \f xs ys -> fold $ liftR2 f xs ys 837 | {-# inline liftCompareRep #-} 838 | 839 | liftEqRep :: (Representable f, Foldable f) => (a -> b -> Bool) -> f a -> f b -> Bool 840 | liftEqRep = \f xs ys -> 841 | Monoid.getAll $ fold $ liftR2 (\x y -> Monoid.All (f x y)) xs ys 842 | {-# inline liftEqRep #-} 843 | 844 | instance (Representable f, Foldable f) => Eq1 (Dist f) where 845 | liftEq = liftEqRep 846 | {-# inline liftEq #-} 847 | 848 | instance (Representable f, Foldable f) => Ord1 (Dist f) where 849 | liftCompare = liftCompareRep 850 | {-# inline liftCompare #-} 851 | 852 | -- * MonadZip 853 | 854 | -- | A default definition for 'mzipWith' in terms of 'Representable' 855 | mzipWithRep :: Representable f => (a -> b -> c) -> f a -> f b -> f c 856 | mzipWithRep = liftR2 857 | {-# inline mzipWithRep #-} 858 | 859 | -- * Comonad 860 | 861 | #ifdef MIN_VERSION_comonad 862 | instance (Representable f, Monoid (Log f)) => Comonad (Dist f) where 863 | extract = extractRep 864 | {-# inline extract #-} 865 | duplicate = duplicateRep 866 | {-# inline duplicate #-} 867 | extend = extendRep 868 | {-# inline extend #-} 869 | 870 | instance (Representable f, Monoid (Log f)) => ComonadApply (Dist f) where 871 | (<@>) = apRep 872 | {-# inline (<@>) #-} 873 | (<@) = const 874 | {-# inline (<@) #-} 875 | (@>) = \_ x -> x 876 | {-# inline (@>) #-} 877 | #endif 878 | 879 | -- | A default definition for 'extract' from @Comonad@ in terms of 'Representable' 880 | extractRep :: (Indexable f, Monoid (Log f)) => f a -> a 881 | extractRep = flip index mempty 882 | {-# inline extractRep #-} 883 | 884 | -- | A default definition for 'extend' from @Comonad@ in terms of 'Representable' 885 | extendRep :: (Representable f, Semigroup (Log f)) => (f a -> b) -> f a -> f b 886 | extendRep = \f g -> tabulate \i -> f $ tabulate \j -> index g (i <> j) 887 | {-# inline extendRep #-} 888 | 889 | -- | A default definition for 'duplicate' from @Comonad@ in terms of 'Representable' 890 | duplicateRep :: (Representable f, Semigroup (Log f)) => f a -> f (f a) 891 | duplicateRep = \f -> tabulate \i -> tabulate \j -> index f (i <> j) 892 | {-# inline duplicateRep #-} 893 | 894 | -- | A default definition for 'extract' from @Comonad@ in terms of 'Representable' 895 | -- where the user chooses to supply a 'unit' logarithm other than 'mempty' 896 | extractRepBy :: Indexable f => Log f -> f a -> a 897 | extractRepBy = flip index 898 | {-# inline extractRepBy #-} 899 | 900 | -- | A default definition for 'extend' from @Comonad@ in terms of 'Representable' 901 | -- where the user chooses to supply a semigroup on logarithms other than '<>' 902 | extendRepBy :: Representable f => (Log f -> Log f -> Log f) -> (f a -> b) -> f a -> f b 903 | extendRepBy = \t f g -> tabulate \i -> f $ tabulate \j -> index g (t i j) 904 | 905 | {-# inline extendRepBy #-} 906 | -- | A default definition for 'duplicate' from @Comonad@ in terms of 'Representable' 907 | -- where the user chooses to supply an semigroup on logarithms other than '<>' 908 | duplicateRepBy :: Representable f => (Log f -> Log f -> Log f) -> f a -> f (f a) 909 | duplicateRepBy = \t f -> tabulate \i -> tabulate \j -> index f (t i j) 910 | {-# inline duplicateRepBy #-} 911 | 912 | -- * MonadReader 913 | 914 | -- deriving via (f :.: ((->) e)) instance Representable f => Representable (TracedT e f) 915 | 916 | -- | A default definition for 'ask' from 'MonadReader' in terms of 'Representable' 917 | askRep :: Representable f => f (Log f) 918 | askRep = tabulate id 919 | {-# noinline[0] askRep #-} 920 | 921 | -- | A default definition for 'local' from 'MonadReader' in terms of 'Representable' 922 | localRep :: Representable f => (Log f -> Log f) -> f a -> f a 923 | localRep = \f m -> tabulate (index m . f) 924 | {-# inline localRep #-} 925 | 926 | -- * ComonadTrace 927 | 928 | -- | A default definition for 'trace' from @ComonadTrace@ in terms of 'Representable' 929 | traceRep :: Indexable f => Log f -> f a -> a 930 | traceRep = flip index 931 | {-# inline traceRep #-} 932 | 933 | -- * FunctorWithIndex 934 | 935 | instance (Representable f, Log f ~ i) => FunctorWithIndex i (Dist f) where 936 | imap = imapRep 937 | {-# inline imap #-} 938 | 939 | -- | A default definition for 'imap' from @FunctorWithIndex@ in terms of 'Representable' 940 | imapRep 941 | :: Representable f 942 | => (Log f -> a -> b) -> f a -> f b 943 | imapRep = \f xs -> tabulate (f <*> index xs) 944 | {-# inline imapRep #-} 945 | 946 | -- * FoldableWithIndex 947 | 948 | instance (Representable f, Foldable f, Log f ~ i) => FoldableWithIndex i (Dist f) where 949 | ifoldMap = ifoldMapRep 950 | {-# inline ifoldMap #-} 951 | 952 | -- | A default definition for 'ifoldMap' from @FoldableWithIndex@ in terms of 'Representable' 953 | ifoldMapRep 954 | :: forall f m a. 955 | (Representable f, Foldable f, Monoid m) 956 | => (Log f -> a -> m) -> f a -> m 957 | ifoldMapRep = \ix xs -> fold (tabulate (\i -> ix i $ index xs i) :: f m) 958 | {-# inline ifoldMapRep #-} 959 | 960 | -- * TraversableWithIndex 961 | 962 | instance (Representable f, Traversable f, Log f ~ i) => TraversableWithIndex i (Dist f) where 963 | itraverse = itraverseRep 964 | {-# inline itraverse #-} 965 | 966 | -- | A default definition for 'itraverse' from @TraversableWithIndex@ in terms of 'Representable' 967 | itraverseRep 968 | :: forall f m a b. 969 | (Representable f, Traversable f, Applicative m) 970 | => (Log f -> a -> m b) -> f a -> m (f b) 971 | itraverseRep = \ix xs -> sequenceA $ tabulate (ix <*> index xs) 972 | {-# inline itraverseRep #-} 973 | 974 | leftAdjunctRep :: Representable u => ((a, Log u) -> b) -> a -> u b 975 | leftAdjunctRep = \f a -> tabulate (\s -> f (a,s)) 976 | {-# inline leftAdjunctRep #-} 977 | 978 | rightAdjunctRep :: Indexable u => (a -> u b) -> (a, Log u) -> b 979 | rightAdjunctRep = \f ~(a, k) -> f a `index` k 980 | {-# inline rightAdjunctRep #-} 981 | 982 | logarithmPath :: (Representable f, Traversable f) => Logarithm f -> Path 983 | logarithmPath = \ f -> runLogarithm f $ runTrail (traverse id $ pureRep end) id 984 | {-# inline logarithmPath #-} 985 | 986 | logPath :: forall f. (Representable f, Traversable f) => Log f -> Path 987 | logPath = index (runTrail (traverse id $ pureRep @f end) id) 988 | {-# inline logPath #-} 989 | 990 | #ifdef MIN_VERSION_comonad 991 | 992 | -- these are a special case of (Comonad f, Monad g) => Monoid (f ~> g) 993 | instance Comonad f => Semigroup (Logarithm f) where 994 | (<>) = \(Logarithm f) (Logarithm g) -> Logarithm \x -> f $ g $ duplicate x 995 | {-# inline (<>) #-} 996 | 997 | instance Comonad f => Monoid (Logarithm f) where 998 | mempty = Logarithm extract 999 | {-# inline mempty #-} 1000 | 1001 | #endif 1002 | 1003 | instance (Representable f, Traversable f) => Eq (Logarithm f) where 1004 | (==) = on (==) logarithmPath 1005 | {-# inline (==) #-} 1006 | 1007 | instance (Representable f, Traversable f) => Ord (Logarithm f) where 1008 | (<) = on (<) logarithmPath 1009 | (<=) = on (<=) logarithmPath 1010 | (>=) = on (>=) logarithmPath 1011 | (>) = on (>) logarithmPath 1012 | compare = on compare logarithmPath 1013 | {-# inline compare #-} 1014 | {-# inline (<) #-} 1015 | {-# inline (<=) #-} 1016 | {-# inline (>=) #-} 1017 | {-# inline (>) #-} 1018 | 1019 | -- | Use explicit type application to call this function. e.g. @'eqLog' \@f@ 1020 | -- 1021 | -- Compare two logarithms for equality 1022 | eqLog :: forall f. (Representable f, Traversable f) => Log f -> Log f -> Bool 1023 | eqLog = on (==) (logPath @f) 1024 | 1025 | -- | Use explicit type application to call this function. e.g. @'neLog' \@f@ 1026 | -- 1027 | -- Compare two logarithms for disequality 1028 | neLog :: forall f. (Representable f, Traversable f) => Log f -> Log f -> Bool 1029 | neLog = on (/=) (logPath @f) 1030 | 1031 | -- | Use explicit type application to call this function. e.g. @'ltLog' \@f@ 1032 | ltLog :: forall f. (Representable f, Traversable f) => Log f -> Log f -> Bool 1033 | ltLog = on (<) (logPath @f) 1034 | 1035 | -- | Use explicit type application to call this function. e.g. @'leLog' \@f@ 1036 | leLog :: forall f. (Representable f, Traversable f) => Log f -> Log f -> Bool 1037 | leLog = on (<=) (logPath @f) 1038 | 1039 | -- | Use explicit type application to call this function. e.g. @'gtLog' \@f@ 1040 | gtLog :: forall f. (Representable f, Traversable f) => Log f -> Log f -> Bool 1041 | gtLog = on (>) (logPath @f) 1042 | 1043 | -- | Use explicit type application to call this function. e.g. @'geLog' \@f@ 1044 | geLog :: forall f. (Representable f, Traversable f) => Log f -> Log f -> Bool 1045 | geLog = on (>=) (logPath @f) 1046 | 1047 | -- | Use explicit type application to call this function. e.g. @'compareLog' \@f@ 1048 | -- 1049 | -- Compare two logarithms 1050 | compareLog :: forall f. (Representable f, Traversable f) => Log f -> Log f -> Ordering 1051 | compareLog = on compare (logPath @f) 1052 | 1053 | -- | For any 'Traversable', each logarithm identifies a 'Lens'. 1054 | _logarithm :: Traversable f => Logarithm f -> Lens' (f a) a 1055 | _logarithm = \(Logarithm f) a2ga fa -> 1056 | case f $ runTrail (traverse (\a -> (a,) <$> end) fa) id of 1057 | (a, p) -> a2ga a <&> \a' -> runEvil (traverse (\a'' -> Evil a'' (const a')) fa) p 1058 | {-# inline _logarithm #-} 1059 | 1060 | -- | We can convert a 'Logarithm' of a 'Representable' functor to any choice of 'Log', as the two forms are canonically isomorphic. 1061 | -- 1062 | -- @ 1063 | -- 'index' f . 'logFromLogarithm' ≡ 'indexLogarithm' f 1064 | -- 'tabulate' (f . 'logFromLogarithm') ≡ 'tabulateLogarithm' f 1065 | -- 'logFromLogarithm' '.' 'logToLogarithm' ≡ 'id' 1066 | -- 'logToLogarithm' '.' 'logFromLogarithm' ≡ 'id' 1067 | -- @ 1068 | logFromLogarithm :: Representable f => Logarithm f -> Log f 1069 | logFromLogarithm = \(Logarithm f) -> f askRep 1070 | {-# inline logFromLogarithm #-} 1071 | 1072 | -- | We can convert any 'Log' to a 'Logarithm' as the two types are canonically isomorphic. 1073 | -- 1074 | -- @ 1075 | -- 'indexLogarithm' f . 'logToLogarithm' ≡ 'index' f 1076 | -- 'tabulateLogarithm' (f . 'logToLogarithm') ≡ 'tabulate' f 1077 | -- 'logFromLogarithm' '.' 'logToLogarithm' ≡ 'id' 1078 | -- 'logToLogarithm' '.' 'logFromLogarithm' ≡ 'id' 1079 | -- @ 1080 | logToLogarithm :: Indexable f => Log f -> Logarithm f 1081 | logToLogarithm = \f -> Logarithm (traceRep f) 1082 | {-# inline logToLogarithm #-} 1083 | 1084 | -- | For any 'Traversable' 'Representable' each 'Log' determines a 'Lens'. 1085 | -- 1086 | -- @ 1087 | -- '_log' f = '_logarithm' ('logToLogarithm' f) 1088 | -- @ 1089 | _log :: (Traversable f, Representable f) => Log f -> Lens' (f a) a 1090 | _log = \lg a2ga fa -> 1091 | case index (runTrail (traverse (\a -> (a,) <$> end) fa) id) lg of 1092 | (a, p) -> a2ga a <&> \a' -> runEvil (traverse (\a'' -> Evil a'' (const a')) fa) p 1093 | {-# inline _log #-} 1094 | 1095 | -- | Construct the lens using @'Eq' ('Log' f)@ instead of with @'Traversable' f@ 1096 | _logEq :: (Representable f, Eq (Log f)) => Log f -> Lens' (f a) a 1097 | _logEq = \i a2ga fa -> a2ga (index fa i) <&> \a' -> imapRep (\j a -> if i == j then a' else a) fa 1098 | {-# inline _logEq #-} 1099 | 1100 | type role AppCompose representational nominal nominal 1101 | newtype AppCompose w g f = AppCompose { runAppCompose :: w (Compose f g) } 1102 | 1103 | instance FFunctor w => FFunctor (AppCompose w g) where 1104 | ffmap f = AppCompose #. ffmap (Compose #. f .# getCompose) .# runAppCompose 1105 | {-# inline ffmap #-} 1106 | 1107 | -- | By definition representable functors preserve limits. 1108 | distributeLim :: Representable f => Lim (Compose f g) -> f (Lim g) 1109 | distributeLim xs = distrib (AppCompose xs) \(AppCompose xs') -> ffmap coerce xs' 1110 | {-# inline distributeLim #-} 1111 | 1112 | -- | By definition representable functors preserve limits. forall is a limit. 1113 | distributeForall :: Representable f => (forall a. f (g a)) -> f (Lim g) 1114 | distributeForall xs = distrib (AppCompose (Lim (Compose xs))) \(AppCompose xs') -> ffmap coerce xs' 1115 | {-# inline distributeForall #-} 1116 | 1117 | type (%) f g i = f (g i) 1118 | infixr 9 % 1119 | 1120 | -- | A higher-kinded 'Logarithm' 1121 | -- 1122 | type role FLogarithm representational nominal 1123 | newtype FLogarithm f a = FLogarithm { runFLogarithm :: forall g. f g -> g a } 1124 | 1125 | -- | A higher-kinded 'Tab' 1126 | type role FTab representational representational 1127 | newtype FTab g f = FTab { runFTab :: FLogarithm f ~> g } 1128 | 1129 | instance FFunctor (FTab g) where 1130 | ffmap f (FTab k) = FTab (\(FLogarithm j) -> k $ FLogarithm (j . f)) 1131 | {-# inline ffmap #-} 1132 | 1133 | class FIndexable (f :: (k -> Type) -> Type) where 1134 | -- | A higher-kinded 'Log' 1135 | type FLog f :: k -> Type 1136 | type FLog f = DefaultFLog f 1137 | 1138 | type KnownIndices f :: Maybe [k] 1139 | type KnownIndices f = DefaultKnownIndices f 1140 | 1141 | -- | A higher-kinded 'index' 1142 | findex :: f a -> FLog f ~> a 1143 | default findex 1144 | :: (Generic1 f, DefaultFIndex f) 1145 | => f a -> FLog f ~> a 1146 | findex = defaultFIndex @(GFInvalid (Rep1 f)) 1147 | {-# inline findex #-} 1148 | 1149 | class (FIndexable f, FFunctor f) => FRepresentable (f :: (k -> Type) -> Type) where 1150 | 1151 | -- | A higher-kinded 'scatter' 1152 | fscatter :: FFunctor w => (w % F1 ~> r) -> (g ~> f) -> w g -> f r 1153 | default fscatter 1154 | :: (Generic1 f, FRepresentable (Rep1 f), FFunctor w) 1155 | => (w % F1 ~> r) -> (g ~> f) -> w g -> f r 1156 | fscatter = fscatterGeneric 1157 | {-# inline fscatter #-} 1158 | 1159 | -- | A higher-kinded 'tabulate' 1160 | ftabulate :: (FLog f ~> a) -> f a 1161 | default ftabulate 1162 | :: (Generic1 f, DefaultFTabulate f) 1163 | => (FLog f ~> a) -> f a 1164 | ftabulate = defaultFTabulate @(GFInvalid (Rep1 f)) 1165 | {-# inline ftabulate #-} 1166 | 1167 | -- | A higher-kinded 'distrib' 1168 | fdistrib 1169 | :: (FFunctor w, FRepresentable f) 1170 | => w f -> (w % F1 ~> r) -> f r 1171 | fdistrib = \ w k -> fscatter k id w 1172 | {-# inline fdistrib #-} 1173 | 1174 | -- | A higher-kinded 'tabulateLogarithm' 1175 | ftabulateFLogarithm 1176 | :: FRepresentable f => (FLogarithm f ~> a) -> f a 1177 | ftabulateFLogarithm 1178 | = \f -> fdistrib (FTab f) \(FTab f') -> f' (FLogarithm runF1) 1179 | {-# inline ftabulateFLogarithm #-} 1180 | 1181 | -- | A higher-kinded 'indexLogarithm' 1182 | findexFLogarithm :: f a -> FLogarithm f ~> a 1183 | findexFLogarithm = \fa (FLogarithm k) -> k fa 1184 | {-# inline findexFLogarithm #-} 1185 | 1186 | -- | A higher-kinded 'tabulateGeneric' 1187 | ftabulateGeneric 1188 | :: forall f a. 1189 | (FRepresentable (Rep1 f), Generic1 f, Coercible (FLog f) (FLog (Rep1 f))) 1190 | => (FLog f ~> a) -> f a 1191 | ftabulateGeneric = \f -> to1 $ ftabulate (\x -> f (coerce x)) 1192 | {-# inline ftabulateGeneric #-} 1193 | 1194 | -- | A higher-kinded 'indexGeneric' 1195 | findexGeneric 1196 | :: forall f a. 1197 | (FIndexable (Rep1 f), Generic1 f, Coercible (FLog f) (FLog (Rep1 f))) 1198 | => f a -> FLog f ~> a 1199 | findexGeneric = \fa flog -> findex (from1 fa) (coerce flog) 1200 | {-# inline findexGeneric #-} 1201 | 1202 | -- | A higher-kinded 'scatterGeneric' 1203 | fscatterGeneric 1204 | :: (FRepresentable (Rep1 f), Generic1 f, FFunctor w) 1205 | => (w % F1 ~> r) -> (g ~> f) -> w g -> f r 1206 | fscatterGeneric = \k phi -> to1 . fscatter k (from1 . phi) 1207 | {-# inline fscatterGeneric #-} 1208 | 1209 | fscatterDefault 1210 | :: (FRepresentable f, FFunctor w) 1211 | => (w % F1 ~> r) 1212 | -> (g ~> f) 1213 | -> w g -> f r 1214 | fscatterDefault = \k phi wg -> 1215 | ftabulate \x -> k $ ffmap (\g -> F1 $ findex (phi g) x) wg 1216 | {-# inline fscatterDefault #-} 1217 | 1218 | -- | A higher-kinded 'Tabulate' 1219 | pattern FTabulate :: FRepresentable f => (FLog f ~> a) -> f a 1220 | pattern FTabulate i <- (findex -> i) where 1221 | FTabulate i = ftabulate i 1222 | {-# COMPLETE FTabulate #-} 1223 | 1224 | type family DefaultFLog' (containsRec1 :: Bool) (f :: (i -> Type) -> Type) :: i -> Type where 1225 | DefaultFLog' 'True f = FLogarithm f 1226 | DefaultFLog' 'False f = FLog (Rep1 f) 1227 | 1228 | type family DefaultFImplC (containsRec1 :: Bool) f :: Constraint where 1229 | DefaultFImplC 'True f = (FRepresentable f, FLog f ~ FLogarithm f) 1230 | DefaultFImplC 'False f = (Generic1 f, FRepresentable (Rep1 f), Coercible (FLog f) (FLog (Rep1 f))) 1231 | 1232 | -- individual type classes, so there is GHC needs to less work 1233 | class DefaultFImplC containsRec1 f => DefaultFTabulate' (containsRec1 :: Bool) f where 1234 | defaultFTabulate :: (FLog f ~> a) -> f a 1235 | 1236 | instance DefaultFImplC 'True f => DefaultFTabulate' 'True f where 1237 | defaultFTabulate = ftabulateFLogarithm 1238 | {-# inline defaultFTabulate #-} 1239 | 1240 | instance DefaultFImplC 'False f => DefaultFTabulate' 'False f where 1241 | defaultFTabulate = ftabulateGeneric 1242 | {-# inline defaultFTabulate #-} 1243 | 1244 | class DefaultFImplC containsRec1 f => DefaultFIndex' (containsRec1 :: Bool) f where 1245 | defaultFIndex :: f a -> FLog f ~> a 1246 | 1247 | instance DefaultFImplC 'True f => DefaultFIndex' 'True f where 1248 | defaultFIndex = findexFLogarithm 1249 | {-# inline defaultFIndex #-} 1250 | 1251 | instance DefaultFImplC 'False f => DefaultFIndex' 'False f where 1252 | defaultFIndex = findexGeneric 1253 | {-# inline defaultFIndex #-} 1254 | 1255 | type DefaultFLog f = DefaultFLog' (GFInvalid (Rep1 f)) f 1256 | type DefaultFTabulate f = DefaultFTabulate' (GFInvalid (Rep1 f)) f 1257 | type DefaultFIndex f = DefaultFIndex' (GFInvalid (Rep1 f)) f 1258 | 1259 | -- | A higher-kinded 'distribute' 1260 | -- 1261 | -- @ 1262 | -- 'fdistribute' = 'fcollect' 'id' 1263 | -- @ 1264 | fdistribute 1265 | :: (Functor f, FRepresentable g) 1266 | => f (g a) -> g (Compose f a) 1267 | fdistribute = \f -> 1268 | fdistrib (FCompose f) \(FCompose f') -> 1269 | Compose $ fmap coerce f' 1270 | {-# inline fdistribute #-} 1271 | 1272 | -- | A higher-kinded 'collect' 1273 | -- 1274 | -- @ 1275 | -- 'fcollect' f = 'fdistribute' . 'fmap' f 1276 | -- @ 1277 | fcollect 1278 | :: (Functor f, FRepresentable g) 1279 | => (a -> g b) 1280 | -> f a -> g (Compose f b) 1281 | fcollect = \f fa -> 1282 | fdistrib (FCompose f) \(FCompose f') -> 1283 | Compose $ fmap (coerce f') fa 1284 | {-# inline fcollect #-} 1285 | 1286 | -- | A higher-kinded 'cotraverse' 1287 | -- 1288 | -- @ 1289 | -- 'fcotraverse' f = 'fmap' f . 'fdistribute' 1290 | -- @ 1291 | fcotraverse 1292 | :: (Functor f, FRepresentable g) 1293 | => (f % a ~> b) 1294 | -> f (g a) -> g b 1295 | fcotraverse = \fab fga -> 1296 | fdistrib (FCompose fga) \(FCompose f') -> 1297 | fab (fmap coerce f') 1298 | {-# inline fcotraverse #-} 1299 | 1300 | instance (FIndexable f, FIndexable g) => FIndexable (f :*: g) where 1301 | type FLog (f :*: g) = FLog f :+: FLog g 1302 | findex = \(f :*: g) -> \case 1303 | L1 x -> findex f x 1304 | R1 y -> findex g y 1305 | {-# inline findex #-} 1306 | 1307 | instance (FRepresentable f, FRepresentable g) => FRepresentable (f :*: g) where 1308 | fscatter = \k f (ffmap f -> w) -> 1309 | fscatter k (\(l :*: _) -> l) w 1310 | :*: fscatter k (\(_ :*: r) -> r) w 1311 | ftabulate = \f -> ftabulate (f . L1) :*: ftabulate (f . R1) 1312 | {-# inline fscatter #-} 1313 | {-# inline ftabulate #-} 1314 | 1315 | deriving newtype instance FIndexable f => FIndexable (M1 i c f) 1316 | deriving newtype instance FRepresentable f => FRepresentable (M1 i c f) 1317 | 1318 | instance FIndexable U1 where 1319 | type FLog U1 = V1 1320 | findex = \_ -> \case 1321 | {-# inline findex #-} 1322 | 1323 | instance FRepresentable U1 where 1324 | fscatter = \_ _ _ -> U1 1325 | ftabulate = \_ -> U1 1326 | {-# inline fscatter #-} 1327 | {-# inline ftabulate #-} 1328 | 1329 | deriving newtype instance FIndexable f => FIndexable (Rec1 f) 1330 | deriving newtype instance FRepresentable f => FRepresentable (Rec1 f) 1331 | 1332 | instance (Indexable f, FIndexable g) => FIndexable (f :.: g) where 1333 | type FLog (f :.: g) = K1 R (Log f) :*: FLog g 1334 | findex = \(Comp1 f) (K1 x :*: y) -> findex (index f x) y 1335 | {-# inline findex #-} 1336 | 1337 | instance (Representable f, FRepresentable g) => FRepresentable (f :.: g) where 1338 | fscatter = \k phi wg -> Comp1 $ 1339 | scatter (fscatter k coerce .# runAppDot) id $ AppDot (ffmap phi wg) 1340 | ftabulate = \f -> Comp1 $ tabulate \i -> ftabulate \j -> f (K1 i :*: j) 1341 | {-# inline fscatter #-} 1342 | {-# inline ftabulate #-} 1343 | 1344 | instance (Indexable f, FIndexable g) => FIndexable (Compose f g) where 1345 | type FLog (Compose f g) = K1 R (Log f) :*: FLog g 1346 | findex = \(Compose f) (K1 x :*: y) -> findex (index f x) y 1347 | {-# inline findex #-} 1348 | 1349 | instance (Representable f, FRepresentable g) => FRepresentable (Compose f g) where 1350 | ftabulate = \f -> Compose $ tabulate \i -> ftabulate \j -> f (K1 i :*: j) 1351 | {-# inline ftabulate #-} 1352 | fscatter = \k phi wg -> Compose $ 1353 | scatter (fscatter k coerce .# runAppCompose) id $ AppCompose (ffmap phi wg) 1354 | {-# inline fscatter #-} 1355 | 1356 | instance (FIndexable f, FIndexable g) => FIndexable (Product f g) where 1357 | type FLog (Product f g) = FLog (Rep1 (Product f g)) 1358 | findex = findexGeneric 1359 | {-# inline findex #-} 1360 | 1361 | instance (FRepresentable f, FRepresentable g) => FRepresentable (Product f g) where 1362 | ftabulate = ftabulateGeneric 1363 | {-# inline ftabulate #-} 1364 | 1365 | instance FIndexable Proxy 1366 | instance FRepresentable Proxy 1367 | 1368 | deriving newtype instance FIndexable f => FIndexable (Backwards f) 1369 | deriving newtype instance FIndexable f => FIndexable (Reverse f) 1370 | deriving newtype instance FIndexable f => FIndexable (Monoid.Alt f) 1371 | deriving newtype instance FIndexable f => FIndexable (Monoid.Ap f) 1372 | 1373 | deriving newtype instance FRepresentable f => FRepresentable (Backwards f) 1374 | deriving newtype instance FRepresentable f => FRepresentable (Reverse f) 1375 | deriving newtype instance FRepresentable f => FRepresentable (Monoid.Alt f) 1376 | deriving newtype instance FRepresentable f => FRepresentable (Monoid.Ap f) 1377 | 1378 | instance FIndexable (F1 a) where 1379 | type FLog (F1 a) = (:~:) a 1380 | findex = \f Refl -> runF1 f 1381 | {-# inline findex #-} 1382 | 1383 | instance FRepresentable (F1 a) where 1384 | fscatter = \k f w -> F1 $ k $ ffmap f w 1385 | ftabulate = \f -> F1 (f Refl) 1386 | {-# inline fscatter #-} 1387 | {-# inline ftabulate #-} 1388 | 1389 | instance FIndexable (NT f) where 1390 | type FLog (NT f) = f 1391 | findex = runNT 1392 | {-# inline findex #-} 1393 | 1394 | instance FRepresentable (NT f) where 1395 | fscatter = fscatterDefault 1396 | ftabulate = NT 1397 | {-# inline ftabulate #-} 1398 | {-# inline fscatter #-} 1399 | 1400 | instance FIndexable Lim where 1401 | type FLog Lim = U1 1402 | findex f = const $ runLim f 1403 | {-# inline findex #-} 1404 | 1405 | instance FRepresentable Lim where 1406 | fscatter = \k f w -> Lim $ k $ ffmap (\x -> F1 $ runLim $ f x) w 1407 | ftabulate = \f -> Lim $ f U1 1408 | {-# inline ftabulate #-} 1409 | {-# inline fscatter #-} 1410 | 1411 | -- TODO: FLog (F2 a b) = Index '[a,b], etc. 1412 | 1413 | instance FIndexable (F2 a b) where 1414 | type FLog (F2 a b) = FLogarithm (F2 a b) 1415 | findex = findexFLogarithm 1416 | {-# inline findex #-} 1417 | 1418 | instance FRepresentable (F2 a b) where 1419 | ftabulate = ftabulateFLogarithm 1420 | fscatter = \k f (ffmap f -> w) -> 1421 | F2 (k $ ffmap (\(F2 x _) -> F1 x) w) 1422 | (k $ ffmap (\(F2 _ y) -> F1 y) w) 1423 | {-# inline ftabulate #-} 1424 | {-# inline fscatter #-} 1425 | 1426 | instance FIndexable (F3 a b c) where 1427 | type FLog (F3 a b c) = FLogarithm (F3 a b c) 1428 | findex = findexFLogarithm 1429 | {-# inline findex #-} 1430 | 1431 | instance FRepresentable (F3 a b c) where 1432 | ftabulate = ftabulateFLogarithm 1433 | fscatter = \k f (ffmap f -> w) -> 1434 | F3 (k $ ffmap (\(F3 x _ _) -> F1 x) w) 1435 | (k $ ffmap (\(F3 _ x _) -> F1 x) w) 1436 | (k $ ffmap (\(F3 _ _ x) -> F1 x) w) 1437 | {-# inline ftabulate #-} 1438 | {-# inline fscatter #-} 1439 | 1440 | instance FIndexable (F4 a b c d) where 1441 | type FLog (F4 a b c d) = FLogarithm (F4 a b c d) 1442 | findex = findexFLogarithm 1443 | {-# inline findex #-} 1444 | 1445 | instance FRepresentable (F4 a b c d) where 1446 | ftabulate = ftabulateFLogarithm 1447 | fscatter = \k f (ffmap f -> w) -> 1448 | F4 (k $ ffmap (\(F4 x _ _ _) -> F1 x) w) 1449 | (k $ ffmap (\(F4 _ x _ _) -> F1 x) w) 1450 | (k $ ffmap (\(F4 _ _ x _) -> F1 x) w) 1451 | (k $ ffmap (\(F4 _ _ _ x) -> F1 x) w) 1452 | {-# inline ftabulate #-} 1453 | {-# inline fscatter #-} 1454 | 1455 | instance FIndexable (F5 a b c d e) where 1456 | type FLog (F5 a b c d e) = FLogarithm (F5 a b c d e) 1457 | findex = findexFLogarithm 1458 | {-# inline findex #-} 1459 | 1460 | instance FRepresentable (F5 a b c d e) where 1461 | ftabulate = ftabulateFLogarithm 1462 | fscatter = \k f (ffmap f -> w) -> 1463 | F5 (k $ ffmap (\(F5 x _ _ _ _) -> F1 x) w) 1464 | (k $ ffmap (\(F5 _ x _ _ _) -> F1 x) w) 1465 | (k $ ffmap (\(F5 _ _ x _ _) -> F1 x) w) 1466 | (k $ ffmap (\(F5 _ _ _ x _) -> F1 x) w) 1467 | (k $ ffmap (\(F5 _ _ _ _ x) -> F1 x) w) 1468 | {-# inline ftabulate #-} 1469 | {-# inline fscatter #-} 1470 | 1471 | -- | A higher-kinded 'Dist' 1472 | type role FDist representational nominal 1473 | newtype FDist f a = FDist { runFDist :: f a } 1474 | deriving stock (Data, Generic, Generic1) 1475 | deriving newtype (FFoldable) 1476 | 1477 | instance (FRepresentable f, FTraversable f) => FTraversable (FDist f) where 1478 | ftraverse = \f -> fmap FDist . ftraverse f .# runFDist 1479 | {-# inline ftraverse #-} 1480 | 1481 | deriving newtype instance FIndexable f => FIndexable (FDist f) 1482 | deriving newtype instance FRepresentable f => FRepresentable (FDist f) 1483 | 1484 | -- | A default definition for 'ffmap' from 'FFunctor' in terms of 'FRepresentable' 1485 | ffmapRep :: FRepresentable f => (a ~> b) -> f a -> f b 1486 | ffmapRep = \f -> fscatter (f .# (runF1 . runF1)) id .# F1 1487 | {-# inline ffmapRep #-} 1488 | 1489 | instance FRepresentable f => FFunctor (FDist f) where 1490 | ffmap = ffmapRep 1491 | {-# inline ffmap #-} 1492 | 1493 | instance FRepresentable f => FApply (FDist f) where 1494 | fliftA2 = fliftR2 1495 | {-# inline fliftA2 #-} 1496 | 1497 | fliftR2 :: FRepresentable f => (forall x. a x -> b x -> c x) -> f a -> f b -> f c 1498 | fliftR2 = \f m n -> 1499 | fdistrib (F2 m n) \(F2 (F1 m') (F1 n')) -> f m' n' 1500 | {-# inline fliftR2 #-} 1501 | 1502 | fliftR3 :: FRepresentable f => (forall x. a x -> b x -> c x -> d x) -> f a -> f b -> f c -> f d 1503 | fliftR3 = \f m n o -> 1504 | fdistrib (F3 m n o) \(F3 (F1 m') (F1 n') (F1 o')) -> f m' n' o' 1505 | {-# inline fliftR3 #-} 1506 | 1507 | fliftR4 :: FRepresentable f => (forall x. a x -> b x -> c x -> d x -> e x) -> f a -> f b -> f c -> f d -> f e 1508 | fliftR4 = \f m n o p -> 1509 | fdistrib (F4 m n o p) \(F4 (F1 m') (F1 n') (F1 o') (F1 p')) -> f m' n' o' p' 1510 | {-# inline fliftR4 #-} 1511 | 1512 | fliftR5 :: FRepresentable f => (forall x. a x -> b x -> c x -> d x -> e x -> r x) -> f a -> f b -> f c -> f d -> f e -> f r 1513 | fliftR5 = \f m n o p q -> 1514 | fdistrib (F5 m n o p q) \(F5 (F1 m') (F1 n') (F1 o') (F1 p') (F1 q')) -> f m' n' o' p' q' 1515 | {-# inline fliftR5 #-} 1516 | 1517 | instance FRepresentable f => FApplicative (FDist f) where 1518 | fpure = fpureRep 1519 | {-# inline fpure #-} 1520 | 1521 | -- | A default definition of 'fpure' from 'FApplicative' in terms of 'FRepresentable' 1522 | fpureRep :: FRepresentable f => (forall x. a x) -> f a 1523 | fpureRep = \ax -> fscatter (\x -> runLim (getConst x)) id $ Const $ Lim ax 1524 | -- fpureRep a = fdistrib Proxy \_ -> a 1525 | {-# inline fpureRep #-} 1526 | 1527 | instance FFunctor (DFBind a b) where 1528 | ffmap = \f (DFBind fa afb) -> DFBind (f fa) (f . afb) 1529 | {-# inline ffmap #-} 1530 | 1531 | data DFBind a b f = DFBind (f a) (a ~> f % b) 1532 | 1533 | fbindRep :: FRepresentable f => f a -> (a ~> f % Coatkey b) -> f b 1534 | fbindRep = \fa f -> fdistrib (DFBind fa f) \(DFBind (F1 a) ab) -> runCoatkey $ runF1 (ab a) 1535 | {-# inline fbindRep #-} 1536 | 1537 | instance FRepresentable f => FBind (FDist f) where 1538 | fbind = \(FDist fa) f -> FDist $ fbindRep fa (runFDist #. f) 1539 | {-# inline fbind #-} 1540 | 1541 | faskRep :: FRepresentable f => f (FLog f) 1542 | faskRep = ftabulate id 1543 | {-# noinline[0] faskRep #-} 1544 | 1545 | ftraceRep :: FIndexable f => FLog f a -> f g -> g a 1546 | ftraceRep = \x y -> findex y x 1547 | 1548 | -- | We can convert a 'FLogarithm' of a 'FRepresentable' 'FFunctor' to any choice 1549 | -- of 'FLog', as the two forms are canonically isomorphic. 1550 | -- 1551 | -- @ 1552 | -- 'findex' f . 'flogFromLogarithm' ≡ 'findexLogarithm' f 1553 | -- 'ftabulate' (f . 'flogFromLogarithm') ≡ 'ftabulateLogarithm' f 1554 | -- 'flogFromLogarithm' '.' 'flogToLogarithm' ≡ 'id' 1555 | -- 'flogToLogarithm' '.' 'flogFromLogarithm' ≡ 'id' 1556 | -- @ 1557 | flogFromFLogarithm :: FRepresentable f => FLogarithm f ~> FLog f 1558 | flogFromFLogarithm = \(FLogarithm f) -> f faskRep 1559 | {-# inline flogFromFLogarithm #-} 1560 | 1561 | -- | We can convert any 'FLog' to a 'FLogarithm' as the two types are canonically isomorphic. 1562 | -- 1563 | -- @ 1564 | -- 'findexLogarithm' f . 'flogToLogarithm' ≡ 'findex' f 1565 | -- 'ftabulateLogarithm' (f . 'flogToLogarithm') ≡ 'ftabulate' f 1566 | -- 'flogFromLogarithm' '.' 'flogToLogarithm' ≡ 'id' 1567 | -- 'flogToLogarithm' '.' 'flogFromLogarithm' ≡ 'id' 1568 | -- @ 1569 | flogToFLogarithm :: FIndexable f => FLog f ~> FLogarithm f 1570 | flogToFLogarithm = \f -> FLogarithm (ftraceRep f) 1571 | {-# inline flogToFLogarithm #-} 1572 | 1573 | -- if HKD took x as its first parameter i could use FCompose 1574 | type role DHKD representational nominal nominal 1575 | newtype DHKD w x f = DHKD { runDHKD :: w (HKD f x) } 1576 | instance FFunctor w => FFunctor (DHKD w x) where 1577 | ffmap f = DHKD #. ffmap (mapHKD f) .# runDHKD 1578 | {-# inline ffmap #-} 1579 | 1580 | instance Indexable f => FIndexable (HKD f x) where 1581 | type FLog (HKD f x) = Atkey (Log f) x 1582 | findex = \(HKD fa) (Atkey lg) -> runF1 (index fa lg) 1583 | {-# inline findex #-} 1584 | 1585 | instance Representable f => FRepresentable (HKD f x) where 1586 | fscatter = \k g (ffmap g -> w) -> HKD $ distrib (DHKD w) $ F1 #. k . ffmap coerce .# runDHKD 1587 | {-# inline fscatter #-} 1588 | ftabulate = \f -> HKD $ tabulate (F1 #. f . Atkey) 1589 | {-# inline ftabulate #-} 1590 | 1591 | ------------------------------------------------------------------------------- 1592 | -- HKD 1593 | ------------------------------------------------------------------------------- 1594 | 1595 | lowerLogarithm :: FLogarithm f x -> Logarithm (LKD f) 1596 | lowerLogarithm = \(FLogarithm f) -> Logarithm $ getConst #. f .# runLKD 1597 | {-# inline lowerLogarithm #-} 1598 | 1599 | liftLogarithm :: FRepresentable f => Logarithm (LKD f) -> Some (FLogarithm f) 1600 | liftLogarithm = \(Logarithm f) -> f $ LKD $ ftabulateFLogarithm (Const #. Some) 1601 | {-# inline liftLogarithm #-} 1602 | 1603 | instance FIndexable f => Indexable (LKD f) where 1604 | type Log (LKD f) = Some (FLog f) 1605 | index = \fa (Some lg) -> getConst (findex (runLKD fa) lg) 1606 | {-# inline index #-} 1607 | 1608 | type role DLKD representational nominal 1609 | newtype DLKD w f = DLKD { runDLKD :: w (LKD f) } 1610 | 1611 | instance FFunctor w => FFunctor (DLKD w) where 1612 | ffmap = \f -> DLKD #. ffmap (LKD #. f .# runLKD) .# runDLKD 1613 | {-# inline ffmap #-} 1614 | 1615 | instance FRepresentable f => Representable (LKD f) where 1616 | scatter = \k g -> LKD . fscatter (Const #. k . ffmap coerce .# runDLKD) id . DLKD . ffmap g 1617 | {-# inline scatter #-} 1618 | tabulate = \f -> LKD $ ftabulate (Const #. f . Some) 1619 | {-# inline tabulate #-} 1620 | 1621 | 1622 | instance (FTraversable f, FRepresentable f) => Eq (FLogarithm f a) where 1623 | (==) = on (==) lowerLogarithm 1624 | {-# inline (==) #-} 1625 | 1626 | instance (FTraversable f, FRepresentable f) => Ord (FLogarithm f a) where 1627 | compare = on compare lowerLogarithm 1628 | {-# inline compare #-} 1629 | 1630 | -- safer than it looks 1631 | instance (FTraversable f, FRepresentable f) => GEq (FLogarithm f) where 1632 | geq = \x y -> 1633 | if lowerLogarithm x == lowerLogarithm y 1634 | then Just (unsafeCoerce Refl) 1635 | else Nothing 1636 | {-# inline geq #-} 1637 | 1638 | geqFLog :: forall f a b. (FRepresentable f, FTraversable f) => FLog f a -> FLog f b -> Maybe (a :~: b) 1639 | geqFLog x y = geq (flogFPath @f x) (flogFPath @f y) 1640 | {-# inline geqFLog #-} 1641 | 1642 | gcompareFLog :: forall f a b. (FRepresentable f, FTraversable f) => FLog f a -> FLog f b -> GOrdering a b 1643 | gcompareFLog x y = gcompare (flogFPath @f x) (flogFPath @f y) 1644 | {-# inline gcompareFLog #-} 1645 | 1646 | instance (FTraversable f, FRepresentable f) => TestEquality (FLogarithm f) where 1647 | testEquality = geq 1648 | {-# inline testEquality #-} 1649 | 1650 | instance (FTraversable f, FRepresentable f) => TestCoercion (FLogarithm f) where 1651 | testCoercion = \x y -> repr <$> geq x y 1652 | {-# inline testCoercion #-} 1653 | 1654 | instance (FTraversable f, FRepresentable f) => GCompare (FLogarithm f) where 1655 | gcompare = \x y -> case compare (lowerLogarithm x) (lowerLogarithm y) of 1656 | LT -> GLT 1657 | EQ -> unsafeCoerce GEQ 1658 | GT -> GGT 1659 | {-# inline gcompare #-} 1660 | 1661 | flogFPath :: forall f. (FRepresentable f, FTraversable f) => FLog f ~> FPath Proxy 1662 | flogFPath = findex $ runTrail (ftraverse fend $ fpureRep @f Proxy) id 1663 | {-# inline flogFPath #-} 1664 | 1665 | type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s 1666 | 1667 | type role FPath representational nominal 1668 | data FPath f a = FPath (f a) Path 1669 | 1670 | instance GEq (FPath f) where 1671 | geq = \(FPath _ x) (FPath _ y) -> 1672 | if x == y 1673 | then Just (unsafeCoerce Refl) 1674 | else Nothing 1675 | {-# inline geq #-} 1676 | 1677 | instance GCompare (FPath f) where 1678 | gcompare = \(FPath _ x) (FPath _ y) -> case compare x y of 1679 | LT -> GLT 1680 | EQ -> unsafeCoerce GEQ 1681 | GT -> GGT 1682 | {-# inline gcompare #-} 1683 | 1684 | fend :: f a -> Trail (FPath f a) 1685 | fend a = FPath a <$> end 1686 | 1687 | _flogarithm :: FTraversable t => FLogarithm t a -> Lens' (t f) (f a) 1688 | _flogarithm = \(FLogarithm f) a2ga tf -> 1689 | case f $ runTrail (ftraverse fend tf) id of 1690 | FPath a p -> a2ga a <&> \a' -> runEvil (ftraverse (\a'' -> Evil a'' (const (unsafeCoerce a'))) tf) p 1691 | {-# inline _flogarithm #-} 1692 | 1693 | _flog :: (FTraversable t, FRepresentable t) => FLog t a -> Lens' (t f) (f a) 1694 | _flog = \i a2ga tf -> 1695 | case findex (runTrail (ftraverse fend tf) id) i of 1696 | FPath a p -> a2ga a <&> \a' -> runEvil (ftraverse (\a'' -> Evil a'' (const (unsafeCoerce a'))) tf) p 1697 | {-# inline _flog #-} 1698 | 1699 | -- | Construct the lens for a logarithm using @'GEq' ('FLog' t)@ instead of with @'FTraversable' t@ 1700 | _flogGEq :: (FRepresentable t, GEq (FLog t)) => FLog t a -> Lens' (t f) (f a) 1701 | _flogGEq = \i a2ga fa -> a2ga (findex fa i) <&> \a' -> ifmapRep (\j a -> case geq i j of 1702 | Just Refl -> a' 1703 | Nothing -> a) fa 1704 | {-# inline _flogGEq #-} 1705 | 1706 | instance (FRepresentable f, FLog f ~ i) => FFunctorWithIndex i (FDist f) where 1707 | ifmap = ifmapRep 1708 | {-# inline ifmap #-} 1709 | 1710 | ifmapRep 1711 | :: forall f a b. FRepresentable f 1712 | => (forall x. FLog f x -> a x -> b x) -> f a -> f b 1713 | ifmapRep = \f -> fliftR2 f is 1714 | where is = faskRep :: f (FLog f) 1715 | {-# inline ifmapRep #-} 1716 | 1717 | instance (FRepresentable f, FFoldable f, FLog f ~ i) => FFoldableWithIndex i (FDist f) where 1718 | iffoldMap = iffoldMapRep 1719 | {-# inline iffoldMap #-} 1720 | 1721 | -- | A default definition for 'ifoldMap' from @FoldableWithIndex@ in terms of 'Representable' 1722 | iffoldMapRep 1723 | :: forall f m a. 1724 | (FRepresentable f, FFoldable f, Monoid m) 1725 | => (forall x. FLog f x -> a x -> m) -> f a -> m 1726 | iffoldMapRep = \f -> ffoldMap getConst . ifmapRep (\i -> Const #. f i) 1727 | {-# inline iffoldMapRep #-} 1728 | 1729 | instance (FRepresentable f, FTraversable f, FLog f ~ i) => FTraversableWithIndex i (FDist f) where 1730 | iftraverse = iftraverseRep 1731 | {-# inline iftraverse #-} 1732 | 1733 | iftraverseRep 1734 | :: forall f m a b. 1735 | (FRepresentable f, FTraversable f, Applicative m) 1736 | => (forall x. FLog f x -> a x -> m (b x)) -> f a -> m (f b) 1737 | iftraverseRep = \f -> ftraverse getCompose . ifmapRep (\i -> Compose #. f i) 1738 | {-# inline iftraverseRep #-} 1739 | 1740 | instance FIndexable (FConstrained p) where 1741 | type FLog (FConstrained p) = Dict1 p 1742 | findex = \(FConstrained x) Dict1 -> x 1743 | 1744 | instance FRepresentable (FConstrained p) where 1745 | fscatter = \k f (ffmap f -> w) -> FConstrained $ k $ ffmap (\(FConstrained x) -> F1 x) w 1746 | ftabulate = \f -> FConstrained $ f Dict1 1747 | 1748 | class FAll (p :: i -> Constraint) (f :: (i -> Type) -> Type) where 1749 | fall :: f (Dict1 p) 1750 | default fall :: (Generic1 f, FAll p (Rep1 f)) => f (Dict1 p) 1751 | fall = to1 fall 1752 | 1753 | instance (FAll p f, FAll p g) => FAll p (f :*: g) where 1754 | fall = fall :*: fall 1755 | 1756 | instance (Representable f, FAll p g) => FAll p (f :.: g) where 1757 | fall = Comp1 $ pureRep fall 1758 | 1759 | deriving newtype instance FAll p f => FAll p (M1 i c f) 1760 | deriving newtype instance FAll p f => FAll p (Rec1 f) 1761 | 1762 | instance FAll p U1 where fall = U1 1763 | 1764 | instance FAll p Proxy 1765 | 1766 | instance a ~ Dict1 p => FAll p ((:~:) a) where 1767 | fall = Refl 1768 | 1769 | instance p a => FAll p (F1 a) where 1770 | fall = F1 Dict1 1771 | 1772 | instance (p a, p b) => FAll p (F2 a b) where 1773 | fall = F2 Dict1 Dict1 1774 | 1775 | instance (p a, p b, p c) => FAll p (F3 a b c) where 1776 | fall = F3 Dict1 Dict1 Dict1 1777 | 1778 | instance (p a, p b, p c, p d) => FAll p (F4 a b c d) where 1779 | fall = F4 Dict1 Dict1 Dict1 Dict1 1780 | 1781 | instance (p a, p b, p c, p d, p e) => FAll p (F5 a b c d e) where 1782 | fall = F5 Dict1 Dict1 Dict1 Dict1 Dict1 1783 | 1784 | instance q (Dict1 p) => FAll p (Dict1 q) where 1785 | fall = Dict1 1786 | 1787 | instance (Representable f, FAll p g) => FAll p (Compose f g) 1788 | 1789 | instance (FAll p f, FAll p g) => FAll p (Product f g) 1790 | 1791 | -- this is arguably any existential constraint 1792 | instance (forall a. p a) => FAll p Some where fall = Some Dict1 1793 | instance (forall a. p a) => FAll p Lim where fall = Lim Dict1 1794 | instance (forall a. q a => p a) => FAll p (FConstrained q) where 1795 | fall = FConstrained Dict1 1796 | 1797 | fliftA2W :: (FRepresentable f, FFunctor w) => (forall x. a x -> w (F1 x) -> r x) -> f a -> w f -> f r 1798 | fliftA2W f fa w = fdistrib (F1 fa :*: w) \(F1 (F1 a) :*: w') -> f a w' 1799 | 1800 | cfdistrib 1801 | :: forall i (p :: i -> Constraint) (f :: (i -> Type) -> Type) (r :: i -> Type) w. 1802 | (FAll p f, FFunctor w, FRepresentable f) 1803 | => w f 1804 | -> (forall x. p x => w (F1 x) -> r x) 1805 | -> f r 1806 | cfdistrib w k = fliftA2W (\Dict1 -> k) (fall @i @p) w 1807 | 1808 | {- 1809 | type family EqC :: k -> Constraint where 1810 | EqC = Eq 1811 | EqC = FEq 1812 | 1813 | class DefaultFEq (w :: k -> Type) where 1814 | feqDefault :: EqC i => w i -> w i -> Bool 1815 | 1816 | instance (Representable w, Foldable w) => DefaultFEq (w :: Type -> Type) where 1817 | feqDefault = \x -> and . liftR2 (==) x 1818 | 1819 | instance (FRepresentable w, FFoldable w, FAll EqC w) => DefaultFEq (w :: (k -> Type) -> Type) where 1820 | feqDefault = \x y -> 1821 | Monoid.getAll $ 1822 | ffoldMap getConst $ 1823 | fliftR3 1824 | (\(Dict1 :: Dict1 EqC x) (i :: f x) (j :: f x) -> Const $ Monoid.All $ feq i j) 1825 | (fall @_ @EqC) 1826 | x 1827 | y 1828 | 1829 | class (forall i. EqC i => Eq (w i)) => FEq w 1830 | instance (forall i. EqC i => Eq (w i)) => FEq w 1831 | 1832 | feq :: (FEq w, EqC i) => w i -> w i -> Bool 1833 | feq = (==) 1834 | 1835 | -- type FEq w = forall i. EqC i => Eq (w i) :: Constraint 1836 | 1837 | {- 1838 | class FEq (w :: k -> Type) where 1839 | feq :: EqC i => w i -> w i -> Bool 1840 | default feq :: (DefaultFEq w, EqC i) => w i -> w i -> Bool 1841 | feq = feqDefault 1842 | {-# inline feq #-} 1843 | -} 1844 | 1845 | instance Eq (F0 x) 1846 | instance (EqC a, EqC b, DefaultFEq f) => Eq (F2 a b f) where 1847 | (==) = feqDefault 1848 | {- 1849 | --instance FEq V1 where feq = (==) 1850 | --instance FEq U1 where feq _ _ = True 1851 | --instance FEq F0 where feq _ _ = True 1852 | instance FEq Proxy where feq _ _ = True 1853 | 1854 | instance Eq a => FEq (Const a) where feq = (==) 1855 | instance Eq a => FEq (Constant a) where feq = (==) 1856 | instance EqC a => FEq (F1 a) 1857 | instance (EqC a, EqC b) => FEq (F2 a b) 1858 | instance (EqC a, EqC b, EqC c) => FEq (F3 a b c) 1859 | instance (EqC a, EqC b, EqC c, EqC d) => FEq (F4 a b c d) 1860 | instance (EqC a, EqC b, EqC c, EqC d, EqC e) => FEq (F5 a b c d e) 1861 | 1862 | instance (FEq f, FEq g) => FEq (f :*: g) where 1863 | feq (a :*: b) (a' :*: b') = feq a a' && feq b b' 1864 | 1865 | instance (FEq f, FEq g) => FEq (f :+: g) where 1866 | feq (L1 a) (L1 a') = feq a a' 1867 | feq (R1 b) (R1 b') = feq b b' 1868 | feq _ _ = False 1869 | 1870 | instance (Eq1 f, FEq g) => FEq (f :.: g) where 1871 | feq (Comp1 x) (Comp1 y) = liftEq feq x y 1872 | -} 1873 | -} 1874 | 1875 | -- * Internals 1876 | 1877 | -- Does @(Rep1 f)@ contain @'Rec1' f@, @K1@, @V1@, sums or a @Par1@? 1878 | -- In any of these cases 'tabulateGeneric/indexGeneric and defining 1879 | -- @Log f = Log (Rep1 f)@ will fail. In all of these cases 1880 | -- we'll default to using Logarithm. 1881 | -- In the other case we could try to use 'Index' or 1882 | type family GInvalid' (f :: j -> Type) (parValid :: Bool) (i :: Nat) :: Bool where 1883 | GInvalid' _ _ 0 = 'True 1884 | GInvalid' (K1 _ _) _ i = 'True 1885 | GInvalid' (M1 _ _ f) p i = GInvalid' f p i 1886 | GInvalid' U1 _ i = 'False 1887 | GInvalid' V1 _ i = 'True -- not 1888 | GInvalid' Par1 p _ = p 1889 | GInvalid' (f :*: g) p i = GInvalid' f p i || GInvalid' g p i 1890 | GInvalid' (f :+: g) _ i = 'True 1891 | GInvalid' (f :.: g) p i = GInvalid' (Rep1 f) 'True i || GInvalid' g p i 1892 | -- this clause is a hack. If pieces @f@ is built from are not 'Generic1', 1893 | -- this will get stuck. 1894 | -- 1895 | -- An alternative with non-linear match is suboptimal in other ways 1896 | GInvalid' (Rec1 f) p i = GInvalid' (Rep1 f) p (i - 1) 1897 | 1898 | -- Log (Rep1 f) is usable 1899 | type GInvalid (f :: j -> Type) = GInvalid' f 'False SearchDepth 1900 | 1901 | -- FLog (Rep1 f) is usable 1902 | type GFInvalid (f :: j -> Type) = GInvalid' f 'True SearchDepth 1903 | 1904 | type family IsJust (xs :: Maybe a) :: Bool where 1905 | IsJust ('Just x) = 'True 1906 | IsJust 'Nothing = 'False 1907 | 1908 | type family IsNothing (xs :: Maybe a) :: Bool where 1909 | IsNothing ('Just x) = 'False 1910 | IsNothing 'Nothing = 'True 1911 | 1912 | type family FromJust (xs :: Maybe a) :: a where 1913 | FromJust ('Just x) = x 1914 | 1915 | -- assumes we're not GInvalid 1916 | type family GUnknownSize (f :: j -> Type) :: Bool where 1917 | GUnknownSize (M1 _ _ f) = GUnknownSize f 1918 | GUnknownSize U1 = 'False 1919 | GUnknownSize Par1 = 'False 1920 | GUnknownSize (f :*: g) = GUnknownSize f || GUnknownSize g 1921 | GUnknownSize (f :.: g) = IsNothing (KnownSize f) || GUnknownSize g 1922 | GUnknownSize (Rec1 f) = IsNothing (KnownSize f) 1923 | 1924 | -- assumes we're not GInvalid and don't have GUnknownSize 1925 | type family GSize (f :: j -> Type) :: Nat where 1926 | GSize (M1 _ _ f) = GSize f 1927 | GSize U1 = 0 1928 | GSize Par1 = 1 1929 | GSize (f :*: g) = GSize f + GSize g 1930 | GSize (f :.: g) = Size f * GSize g 1931 | GSize (Rec1 f) = Size f 1932 | 1933 | type family (++) (f :: [i]) (g :: [i]) :: [i] where 1934 | '[] ++ ys = ys 1935 | (x ': xs) ++ ys = x ': (xs ++ ys) 1936 | 1937 | type family Repeat (n :: Nat) (as :: [i]) :: [i] where 1938 | Repeat 0 as = '[] 1939 | Repeat n as = as ++ Repeat (n - 1) as 1940 | 1941 | type family GUnknownIndices (f :: j -> Type) :: Bool where 1942 | GUnknownIndices (M1 _ _ f) = GUnknownIndices f 1943 | GUnknownIndices U1 = 'False 1944 | GUnknownIndices (f :*: g) = GUnknownIndices f || GUnknownIndices g 1945 | GUnknownIndices (f :.: g) = IsNothing (KnownSize f) || GUnknownIndices g 1946 | GUnknownIndices (Rec1 f) = IsNothing (KnownIndices f) 1947 | 1948 | type family GIndices' (f :: (k -> Type) -> Type) (acc :: [k]) :: [k] where 1949 | GIndices' (M1 _ _ f) as = GIndices' f as 1950 | GIndices' U1 as = as 1951 | GIndices' (f :*: g) as = GIndices' f (GIndices' g as) 1952 | GIndices' (f :.: g) as = Repeat (Size f) (GIndices g) ++ as 1953 | GIndices' (Rec1 f) as = Indices f ++ as 1954 | 1955 | type GIndices (f :: (k -> Type) -> Type) = GIndices' f '[] 1956 | 1957 | type GKnownSize (f :: j -> Type) = 1958 | If (GInvalid f || GUnknownSize f) 1959 | 'Nothing 1960 | ('Just (GSize f)) 1961 | 1962 | type GKnownIndices (f :: (j -> Type) -> Type) = 1963 | If (GFInvalid f || GUnknownIndices f) 1964 | 'Nothing 1965 | ('Just (GIndices f)) 1966 | 1967 | type DefaultKnownSize f = GKnownSize (Rep1 f) 1968 | type DefaultKnownIndices f = GKnownIndices (Rep1 f) 1969 | 1970 | type SearchDepth = 3 1971 | 1972 | type role AppDot representational nominal nominal 1973 | newtype AppDot w g f = AppDot { runAppDot :: w (f :.: g) } 1974 | instance FFunctor w => FFunctor (AppDot w g) where 1975 | ffmap f = AppDot #. ffmap (Comp1 #. f .# unComp1) .# runAppDot 1976 | {-# inline ffmap #-} 1977 | 1978 | 1979 | data Path = End | L Path | R Path deriving (Eq, Ord, Show, Read) 1980 | 1981 | -- This is not a legal 'Applicative', but it is used towards legal ends. 1982 | 1983 | type role Trail representational 1984 | newtype Trail a = Trail { runTrail :: (Path -> Path) -> a } 1985 | deriving Functor 1986 | 1987 | instance Applicative Trail where 1988 | pure = Trail . const 1989 | {-# inline pure #-} 1990 | 1991 | (<*>) = \fab fa -> Trail \k -> runTrail fab (k . L) $ runTrail fa (k . R) 1992 | {-# inline (<*>) #-} 1993 | 1994 | end :: Trail Path 1995 | end = Trail \k -> k End 1996 | {-# inline end #-} 1997 | 1998 | -- This is also not a legal 'Applicative', but it is used towards legal ends. 1999 | 2000 | type role Evil representational 2001 | data Evil a = Evil a (Path -> a) 2002 | deriving Functor 2003 | 2004 | instance Applicative Evil where 2005 | pure = \a -> Evil a \_ -> a 2006 | {-# inline pure #-} 2007 | (<*>) = \ ~(Evil mb mg) ~(Evil nb ng) -> Evil (mb nb) \case 2008 | L xs -> mg xs nb 2009 | R xs -> mb (ng xs) 2010 | End -> undefined 2011 | {-# inline (<*>) #-} 2012 | 2013 | runEvil :: Evil a -> Path -> a 2014 | runEvil = \(Evil _ mg) -> mg 2015 | {-# inline runEvil #-} 2016 | 2017 | -- for testing 2018 | data V2 a = V2 a a 2019 | deriving stock (Show, Read, Functor, Foldable, Traversable, Generic, Generic1, Data) 2020 | deriving anyclass (Indexable, Representable) 2021 | deriving (Eq1,Ord1,Applicative, Monad, MonadFix, MonadZip) via Dist V2 2022 | deriving (Eq,Ord,Num,Fractional,Floating,Semigroup,Monoid) via Dist V2 a 2023 | 2024 | instance Show1 V2 where 2025 | liftShowsPrec f _ d (V2 a b) = showParen (d > 10) $ showString "V2 " . f 11 a . showChar ' ' . f 11 b 2026 | 2027 | class 2028 | ( Traversable f 2029 | , Representable f 2030 | , IsJust (KnownSize f) ~ 'True 2031 | , KnownNat (Size f) 2032 | ) => FiniteRepresentable f 2033 | 2034 | instance 2035 | ( Traversable f 2036 | , Representable f 2037 | , IsJust (KnownSize f) ~ 'True 2038 | , KnownNat (Size f) 2039 | ) => FiniteRepresentable f 2040 | 2041 | type Size f = FromJust (KnownSize f) 2042 | type Indices f = FromJust (KnownIndices f) 2043 | 2044 | type LogFin f = Fin (Size f) 2045 | type FLogIndex f = Index (Indices f) 2046 | 2047 | type HasLogFin f = Log f == LogFin f 2048 | 2049 | lie :: a 2050 | lie = error "Data.Functor.Rep.Internal: logic error. index out of bounds or invalid Size f" 2051 | 2052 | class DefaultIndexFin' (b :: Bool) (f :: Type -> Type) where 2053 | indexFinDefault :: f a -> LogFin f -> a 2054 | 2055 | instance (Log f ~ LogFin f, Representable f) => DefaultIndexFin' 'True f where 2056 | indexFinDefault = index 2057 | {-# inline indexFinDefault #-} 2058 | 2059 | type f /~ g = (f == g) ~ 'False 2060 | 2061 | instance (Log f /~ LogFin f, FiniteRepresentable f) => DefaultIndexFin' 'False f where 2062 | indexFinDefault = \ f (Fin i) -> 2063 | fromMaybe lie $ 2064 | Monoid.getFirst $ 2065 | fold $ 2066 | liftR2 2067 | (\(Fin j) a -> Monoid.First $ if i == j then Just a else Nothing) 2068 | askFin 2069 | f 2070 | {-# inline indexFinDefault #-} 2071 | 2072 | type DefaultIndexFin f = DefaultIndexFin' (HasLogFin f) f 2073 | 2074 | indexFin :: forall f a. DefaultIndexFin f => f a -> LogFin f -> a 2075 | indexFin = indexFinDefault @(HasLogFin f) 2076 | {-# inline indexFin #-} 2077 | 2078 | -- assumes GSize f is defined and can be KnownNat 2079 | class GIndexFin f where 2080 | gunsafeIndexFin :: f a -> LogFin f -> a 2081 | 2082 | deriving newtype instance GIndexFin f => GIndexFin (M1 i c f) 2083 | 2084 | -- this would be better if it knew if f has an index that was Fin (Size f) and used index instead 2085 | instance DefaultIndexFin f => GIndexFin (Rec1 f) where 2086 | gunsafeIndexFin (Rec1 fa) (Fin i) = indexFin fa (UnsafeFin i) 2087 | {-# inline gunsafeIndexFin #-} 2088 | 2089 | instance GIndexFin U1 where 2090 | gunsafeIndexFin U1 (Fin _) = lie 2091 | 2092 | instance GIndexFin Par1 where 2093 | gunsafeIndexFin (Par1 x) (Fin 0) = x 2094 | gunsafeIndexFin _ _ = lie 2095 | {-# inline gunsafeIndexFin #-} 2096 | 2097 | instance (KnownNat (GSize f), GIndexFin f, GIndexFin g) => GIndexFin (f :*: g) where 2098 | gunsafeIndexFin (f :*: g) (Fin i) 2099 | | i < j = gunsafeIndexFin f (UnsafeFin i) 2100 | | otherwise = gunsafeIndexFin g (UnsafeFin $ i - j) 2101 | where j = int @(GSize f) 2102 | {-# inline gunsafeIndexFin #-} 2103 | 2104 | instance (DefaultIndexFin f, KnownNat (GSize g), GIndexFin g) => GIndexFin (f :.: g) where 2105 | gunsafeIndexFin (Comp1 fg) (Fin i) = case quotRem i $ int @(GSize g) of 2106 | (q, r) -> gunsafeIndexFin (indexFin fg (UnsafeFin q)) (UnsafeFin r) 2107 | {-# inline gunsafeIndexFin #-} 2108 | 2109 | gindexFin :: (Generic1 f, GIndexFin (Rep1 f), Log f ~ LogFin f, Size f ~ GSize (Rep1 f)) => f a -> LogFin f -> a 2110 | gindexFin fa (Fin i) = gunsafeIndexFin (from1 fa) (UnsafeFin i) 2111 | {-# inline gindexFin #-} 2112 | 2113 | askFin :: DefaultTabulateFin f => f (LogFin f) 2114 | askFin = tabulateFin id 2115 | {-# inline[0] askFin #-} 2116 | 2117 | class GTabulateFin f where 2118 | gunsafeTabulateFin :: (Fin (GSize f) -> a) -> f a 2119 | 2120 | instance GTabulateFin U1 where 2121 | gunsafeTabulateFin _ = U1 2122 | 2123 | instance DefaultTabulateFin f => GTabulateFin (Rec1 f) where 2124 | gunsafeTabulateFin f = Rec1 $ tabulateFin f 2125 | {-# inline gunsafeTabulateFin #-} 2126 | 2127 | deriving newtype instance GTabulateFin f => GTabulateFin (M1 i c f) 2128 | 2129 | instance GTabulateFin Par1 where 2130 | gunsafeTabulateFin f = Par1 $ f (UnsafeFin 0) 2131 | {-# inline gunsafeTabulateFin #-} 2132 | 2133 | instance (KnownNat (GSize f), GTabulateFin f, GTabulateFin g) => GTabulateFin (f :*: g) where 2134 | gunsafeTabulateFin f = 2135 | gunsafeTabulateFin (coerce f) 2136 | :*: gunsafeTabulateFin (\(Fin i) -> f (UnsafeFin (i + j))) 2137 | where j = int @(GSize f) 2138 | {-# inline gunsafeTabulateFin #-} 2139 | 2140 | instance (DefaultTabulateFin f, KnownNat (GSize g), GTabulateFin g) => GTabulateFin (f :.: g) where 2141 | gunsafeTabulateFin f = 2142 | Comp1 $ 2143 | tabulateFin \(Fin i) -> 2144 | gunsafeTabulateFin \(Fin j) -> 2145 | f $ UnsafeFin (i * k + j) 2146 | where k = int @(GSize g) 2147 | {-# inline gunsafeTabulateFin #-} 2148 | 2149 | class DefaultTabulateFin' (b :: Bool) (f :: Type -> Type) where 2150 | tabulateFinDefault :: (LogFin f -> a) -> f a 2151 | 2152 | instance (Log f ~ LogFin f, Representable f) => DefaultTabulateFin' 'True f where 2153 | tabulateFinDefault = tabulate 2154 | {-# inline tabulateFinDefault #-} 2155 | 2156 | instance (Log f /~ LogFin f, FiniteRepresentable f) => DefaultTabulateFin' 'False f where 2157 | tabulateFinDefault f = 2158 | case mapAccumL (\n () -> (n + 1, f $ UnsafeFin n)) 0 (pureRep ()) of 2159 | (n', xs) 2160 | | n' == int @(Size f) -> xs 2161 | | otherwise -> lie 2162 | {-# inline tabulateFinDefault #-} 2163 | 2164 | type DefaultTabulateFin f = DefaultTabulateFin' (HasLogFin f) f 2165 | 2166 | tabulateFin :: forall f a. DefaultTabulateFin f => (LogFin f -> a) -> f a 2167 | tabulateFin = tabulateFinDefault @(HasLogFin f) 2168 | {-# inline tabulateFin #-} 2169 | 2170 | gtabulateFin 2171 | :: (Generic1 f, GTabulateFin (Rep1 f)) 2172 | => (Fin (GSize (Rep1 f)) -> a) -> f a 2173 | gtabulateFin f = to1 $ gunsafeTabulateFin f 2174 | {-# inline gtabulateFin #-} 2175 | 2176 | #ifdef MIN_VERSION_profunctors 2177 | instance Indexable w => Indexable (Costar w a) where 2178 | type Log (Costar w a) = w a 2179 | index = runCostar 2180 | {-# inline index #-} 2181 | 2182 | instance Representable w => Representable (Costar w a) where 2183 | tabulate = Costar 2184 | {-# inline tabulate #-} 2185 | 2186 | instance Indexable w => Indexable (Star w a) where 2187 | type Log (Star w a) = (a, Log w) 2188 | index (Star f) (a,b) = index (f a) b 2189 | {-# inline index #-} 2190 | 2191 | instance Representable w => Representable (Star w a) where 2192 | tabulate f = Star \a -> tabulate \b -> f (a, b) 2193 | {-# inline tabulate #-} 2194 | #endif 2195 | 2196 | #ifdef MIN_VERSION_comonad 2197 | instance Indexable w => Indexable (TracedT m w) where 2198 | type Log (TracedT m w) = (Log w, m) 2199 | index = \(TracedT wma) (lw,m) -> index wma lw m 2200 | {-# inline index #-} 2201 | 2202 | instance Representable w => Representable (TracedT m w) where 2203 | 2204 | instance Indexable (Cokleisli w a) where 2205 | type Log (Cokleisli w a) = w a 2206 | index = runCokleisli 2207 | {-# inline index #-} 2208 | 2209 | instance Representable (Cokleisli w a) where 2210 | tabulate = Cokleisli 2211 | {-# inline tabulate #-} 2212 | #endif 2213 | 2214 | type Variant f = (,) (Log f) 2215 | type FVariant f = DSum (FLog f) 2216 | 2217 | zapWith :: Indexable f => (a -> b -> r) -> (Log f, a) -> f b -> r 2218 | zapWith k (i, f) g = k f (index g i) 2219 | {-# inline zapWith #-} 2220 | 2221 | fzapWith :: FIndexable f => (forall x. a x -> b x -> r) -> DSum (FLog f) a -> f b -> r 2222 | fzapWith k (i :=> f) g = k f (findex g i) 2223 | {-# inline fzapWith #-} 2224 | -------------------------------------------------------------------------------- /src/Data/Vec.hs: -------------------------------------------------------------------------------- 1 | {-# Language Trustworthy #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2021 Edward Kmett, 5 | -- License : BSD-2-Clause OR Apache-2.0 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : non-portable 9 | 10 | module Data.Vec 11 | ( Vec(Vec,toVector) 12 | , FromVector(..) 13 | , pattern V 14 | , withDim 15 | ) where 16 | 17 | import Data.Vec.Internal 18 | -------------------------------------------------------------------------------- /src/Data/Vec/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language DerivingVia #-} 3 | {-# Language GeneralizedNewtypeDeriving #-} 4 | {-# Language Unsafe #-} 5 | {-# options_haddock hide #-} 6 | 7 | module Data.Vec.Internal 8 | ( Vec(UnsafeVec,Vec,toVector) 9 | , pattern V 10 | , FromVector(..) 11 | , withDim 12 | ) where 13 | 14 | import Control.Monad 15 | import Control.Monad.Reader.Class 16 | import Control.Monad.Fix 17 | import Control.Monad.Zip 18 | import Data.Foldable.WithIndex 19 | import Data.Function.Coerce 20 | import Data.Functor.Classes 21 | import Data.Functor.Identity 22 | import Data.Functor.WithIndex 23 | import Data.HKD 24 | import Data.Proxy 25 | import Data.Rep 26 | import Data.Traversable.WithIndex 27 | import Data.Type.Equality 28 | import Data.Vector as V 29 | import GHC.Exts 30 | import GHC.TypeNats 31 | import Numeric.Fin.Internal 32 | import Text.Read 33 | import Unsafe.Coerce 34 | 35 | type role Vec nominal representational 36 | newtype Vec (n :: Nat) a = UnsafeVec (Vector a) 37 | deriving stock (Functor, Foldable, Traversable) 38 | deriving newtype (Eq, Eq1, Ord, Ord1, Show, Show1) 39 | 40 | pattern Vec :: Vector a -> Vec n a 41 | pattern Vec { toVector } <- UnsafeVec toVector 42 | 43 | {-# complete Vec :: Vec #-} 44 | 45 | instance Indexable (Vec n) where 46 | type Log (Vec n) = Fin n 47 | type KnownSize (Vec n) = 'Just n 48 | 49 | index :: forall a. Vec n a -> Fin n -> a 50 | index = coerce ((!) :: Vector a -> Int -> a) 51 | {-# inline index #-} 52 | 53 | instance KnownNat n => Representable (Vec n) where 54 | scatter = \(k :: w Identity -> r) f (ffmap f -> w) -> UnsafeVec $ 55 | generate (int @n) \i -> k $ ffmap (\v -> Identity $ index v $ UnsafeFin i) w 56 | {-# inlinable scatter #-} 57 | 58 | tabulate = \(f :: Fin n -> a) -> UnsafeVec $ generate (int @n) (f .# UnsafeFin) 59 | {-# inlinable tabulate #-} 60 | 61 | 62 | instance (KnownNat n, Read a) => Read (Vec n a) where 63 | readPrec = do 64 | l <- step readPrec 65 | let v = V.fromList l 66 | UnsafeVec v <$ guard (V.length v == int @n) 67 | 68 | instance KnownNat n => Read1 (Vec n) where 69 | liftReadPrec _ rl = do 70 | l <- rl 71 | let v = V.fromList l 72 | UnsafeVec v <$ guard (V.length v == int @n) 73 | {-# inline liftReadPrec #-} 74 | 75 | instance FunctorWithIndex (Fin n) (Vec n) where 76 | imap :: forall a b. (Fin n -> a -> b) -> Vec n a -> Vec n b 77 | imap = coerce (V.imap :: (Int -> a -> b) -> Vector a -> Vector b) 78 | {-# inline imap #-} 79 | 80 | instance FoldableWithIndex (Fin n) (Vec n) where 81 | ifoldMap f = V.ifoldr (\i a b -> f (UnsafeFin i) a `mappend` b) mempty .# toVector 82 | {-# inline ifoldMap #-} 83 | 84 | instance TraversableWithIndex (Fin n) (Vec n) where 85 | itraverse f (toVector -> as) = UnsafeVec #. V.fromListN (V.length as) <$> 86 | itraverse (f .# UnsafeFin) (V.toList as) 87 | {-# inline itraverse #-} 88 | 89 | data SomeVec a where 90 | SomeVec :: KnownNat n => Vec n a -> SomeVec a 91 | 92 | asVec :: FromVector t a => t -> SomeVec a 93 | asVec (UnsafeVec #. asVector -> v) = withDim v (SomeVec v) 94 | {-# inline asVec #-} 95 | 96 | withDim :: forall n a r. Vec n a -> (KnownNat n => r) -> r 97 | withDim v r = case someNatVal (fromIntegral $ V.length (toVector v)) of 98 | SomeNat (Proxy :: Proxy n') -> case unsafeCoerce Refl of 99 | (Refl :: n :~: n') -> r 100 | {-# inline withDim #-} 101 | 102 | class FromVector t a | t -> a where 103 | asVector :: t -> Vector a 104 | vectorAs :: Vector a -> t 105 | 106 | instance FromVector (Vector a) a where 107 | asVector = id 108 | vectorAs = id 109 | 110 | instance FromVector [a] a where 111 | asVector = V.fromList 112 | vectorAs = V.toList 113 | 114 | pattern V :: FromVector t a => KnownNat n => Vec n a -> t 115 | pattern V v <- (asVec -> SomeVec v) where 116 | V v = vectorAs (toVector v) 117 | 118 | {-# complete V :: Vector #-} 119 | {-# complete V :: [] #-} 120 | 121 | deriving via Dist (Vec n) instance KnownNat n => Applicative (Vec n) 122 | deriving via Dist (Vec n) instance KnownNat n => Monad (Vec n) 123 | deriving via Dist (Vec n) instance KnownNat n => MonadFix (Vec n) 124 | deriving via Dist (Vec n) instance KnownNat n => MonadZip (Vec n) 125 | deriving via Dist (Vec n) instance KnownNat n => MonadReader (Fin n) (Vec n) 126 | deriving via Dist (Vec n) a instance (KnownNat n, Num a) => Num (Vec n a) 127 | deriving via Dist (Vec n) a instance (KnownNat n, Fractional a) => Fractional (Vec n a) 128 | deriving via Dist (Vec n) a instance (KnownNat n, Floating a) => Floating (Vec n a) 129 | -------------------------------------------------------------------------------- /src/Trustworthy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | 3 | -- | 4 | -- Copyright : (c) Edward Kmett 2021 5 | -- License : BSD-2-Clause OR Apache-2.0 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- Safe Haskell has a pretty egregious design flaw. 11 | -- 12 | -- If you use @-Winferred-safe-imports@, which is really 13 | -- your only way to get visibility into upstream safety, 14 | -- there is generally no way to escape the warnings it 15 | -- gives except to expect upstream packages to fix their code. 16 | -- 17 | -- The "fix" is to import a module that isn't @Safe@ so 18 | -- I can forcibly downgrade myself to @Trustworthy@. 19 | -- 20 | -- Ideally, I'd just have @{-# LANGUAGE TrustworthyOrBetter #-}@ 21 | -- extension, but every time I've asked for it, I've been 22 | -- told this is against the spirit of the extension, which 23 | -- as far as I can tell exists solely to make my life hell. 24 | 25 | module Trustworthy () where 26 | -------------------------------------------------------------------------------- /tests/GenericsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE EmptyDataDecls #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | {-# LANGUAGE DeriveAnyClass #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : GenericSpec 16 | -- Copyright : (C) 2011-2021 Edward Kmett 17 | -- License : BSD-style (see the file LICENSE) 18 | -- 19 | -- Maintainer : Edward Kmett 20 | -- Stability : provisional 21 | -- 22 | -- Tests for generically derived 'Distributive' instances. 23 | ---------------------------------------------------------------------------- 24 | module GenericsSpec (main, spec) where 25 | 26 | import Test.Hspec 27 | 28 | import Data.Rep 29 | import Data.Type.Equality 30 | import GHC.Generics 31 | 32 | main :: IO () 33 | main = hspec spec 34 | 35 | spec :: Spec 36 | spec = do 37 | describe "Id" $ 38 | it "distribute idExample = idExample" $ 39 | distribute idExample `shouldBe` idExample 40 | describe "Stream" $ 41 | it "runId (shead (stail (distribute streamExample))) = 1" $ 42 | runId (shead (stail (distribute streamExample))) `shouldBe` 1 43 | describe "PolyRec" $ 44 | it "runId (plast (runId (pinit (distribute polyRecExample)))) = 1" $ 45 | runId (plast (runId (pinit (distribute polyRecExample)))) `shouldBe` 1 46 | 47 | newtype Id a = Id { runId :: a } 48 | deriving stock (Generic1, Functor, Show) 49 | deriving newtype Eq 50 | deriving anyclass (Indexable, Representable) 51 | 52 | idExample :: Id (Id Int) 53 | idExample = Id (Id 42) 54 | 55 | _logId :: Log Id :~: Fin 1 56 | _logId = Refl 57 | 58 | data Stream a = (:>) { shead :: a, stail :: Stream a } 59 | deriving stock (Generic1, Functor) 60 | deriving anyclass (Indexable, Representable) 61 | 62 | streamExample :: Id (Stream Int) 63 | streamExample = Id $ let s = 0 :> fmap (+1) s in s 64 | 65 | _logStream :: Log Stream :~: Logarithm Stream 66 | _logStream = Refl 67 | 68 | data PolyRec a = PolyRec { pinit :: Id (PolyRec a), plast :: a } 69 | deriving stock (Generic1, Functor) 70 | deriving anyclass (Indexable, Representable) 71 | 72 | polyRecExample :: Id (PolyRec Int) 73 | polyRecExample = Id $ let p = PolyRec (Id $ fmap (+1) p) 0 in p 74 | 75 | _logPolyRec :: Log PolyRec :~: Logarithm PolyRec 76 | _logPolyRec = Refl 77 | 78 | data Id2 a = Id2 (Id a) (Id a) 79 | deriving stock (Generic1, Functor) 80 | deriving anyclass (Indexable, Representable) 81 | 82 | _logId2 :: Log Id2 :~: Fin 2 83 | _logId2 = Refl 84 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------