├── .envrc ├── .git-blame-ignore-revs ├── .github └── workflows │ ├── flake-ci.yml │ └── haskell.yml ├── .gitignore ├── .hlint.yaml ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── functor-combinators.cabal ├── src ├── Control │ ├── Applicative │ │ ├── ListF.hs │ │ └── Step.hs │ ├── Monad │ │ └── Freer │ │ │ └── Church.hs │ └── Natural │ │ └── IsoF.hs └── Data │ ├── Functor │ ├── Apply │ │ └── Free.hs │ ├── Combinator.hs │ ├── Combinator │ │ └── Unsafe.hs │ ├── Contravariant │ │ ├── Conclude.hs │ │ ├── Decide.hs │ │ ├── Divise.hs │ │ ├── Divisible │ │ │ └── Free.hs │ │ └── Night.hs │ └── Invariant │ │ ├── Inplicative.hs │ │ ├── Inplicative │ │ └── Free.hs │ │ ├── Internative.hs │ │ ├── Internative │ │ └── Free.hs │ │ └── Night.hs │ ├── HBifunctor.hs │ ├── HBifunctor │ ├── Associative.hs │ ├── Tensor.hs │ └── Tensor │ │ └── Internal.hs │ ├── HFunctor.hs │ └── HFunctor │ ├── Chain.hs │ ├── Chain │ └── Internal.hs │ ├── Final.hs │ ├── HTraversable.hs │ ├── Internal.hs │ ├── Interpret.hs │ └── Route.hs └── test ├── Spec.hs └── Tests ├── HBifunctor.hs ├── HFunctor.hs └── Util.hs /.envrc: -------------------------------------------------------------------------------- 1 | nix_direnv_manual_reload 2 | watch_file ./*.cabal 3 | use flake 4 | -------------------------------------------------------------------------------- /.git-blame-ignore-revs: -------------------------------------------------------------------------------- 1 | # fourmolu 2 | 13a75ff81dde6d76ad7c61a860a62b71ff9cf63a 3 | -------------------------------------------------------------------------------- /.github/workflows/flake-ci.yml: -------------------------------------------------------------------------------- 1 | name: "Flake CI" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | checks: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - name: Free Disk Space 10 | uses: insightsengineering/free-disk-space@v1.1.0 11 | - uses: actions/checkout@v3 12 | - uses: webfactory/ssh-agent@v0.9.0 13 | with: 14 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 15 | - uses: cachix/install-nix-action@v22 16 | with: 17 | nix_path: nixpkgs=channel:nixos-unstable 18 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 19 | extra_nix_config: | 20 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 21 | allow-import-from-derivation = true 22 | auto-optimise-store = true 23 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 24 | - uses: cachix/cachix-action@v13 25 | with: 26 | name: mstksg 27 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 28 | - run: nix flake check --show-trace 29 | 30 | cache: 31 | runs-on: ubuntu-latest 32 | steps: 33 | - name: Free Disk Space 34 | uses: insightsengineering/free-disk-space@v1.1.0 35 | - uses: actions/checkout@v4.1.1 36 | - uses: webfactory/ssh-agent@v0.9.0 37 | with: 38 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 39 | - uses: cachix/install-nix-action@v22 40 | with: 41 | nix_path: nixpkgs=channel:nixos-unstable 42 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 43 | extra_nix_config: | 44 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 45 | allow-import-from-derivation = true 46 | auto-optimise-store = true 47 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 48 | - uses: cachix/cachix-action@v13 49 | with: 50 | name: mstksg 51 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 52 | - run: nix build --show-trace 53 | - run: nix develop --show-trace 54 | 55 | every-compiler: 56 | runs-on: ubuntu-latest 57 | steps: 58 | - name: Free Disk Space 59 | uses: insightsengineering/free-disk-space@v1.1.0 60 | - uses: actions/checkout@v3 61 | - uses: webfactory/ssh-agent@v0.9.0 62 | with: 63 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 64 | - uses: cachix/install-nix-action@v22 65 | with: 66 | nix_path: nixpkgs=channel:nixos-unstable 67 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 68 | extra_nix_config: | 69 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 70 | allow-import-from-derivation = true 71 | auto-optimise-store = true 72 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 73 | - uses: cachix/cachix-action@v13 74 | with: 75 | name: mstksg 76 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 77 | - run: nix build .#everyCompiler 78 | 79 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | # Haskell stack project Github Actions template 2 | # https://gist.github.com/mstksg/11f753d891cee5980326a8ea8c865233 3 | # 4 | # To use, mainly change the list in 'plans' and modify 'include' for 5 | # any OS package manager deps. 6 | # 7 | # Currently not working for cabal-install >= 3 8 | # 9 | # Based on https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/travis-complex.yml 10 | # 11 | # TODO: 12 | # * cache (https://github.com/actions/cache) 13 | # but this is too small. native cacheing will come soon 14 | # https://github.community/t5/GitHub-Actions/Caching-files-between-GitHub-Action-executions/m-p/30974/highlight/true#M630 15 | # so we can wait for then. 16 | # * support for cabal-install >= 3 17 | 18 | name: Haskell Stack Project CI 19 | 20 | on: 21 | push: 22 | schedule: 23 | - cron: "0 0 * * 1" 24 | 25 | jobs: 26 | build: 27 | strategy: 28 | matrix: 29 | os: [ubuntu-latest, macOS-latest] 30 | # use this to specify what resolvers and ghc to use 31 | plan: 32 | # - { build: stack, resolver: "--resolver lts-9" } # ghc-8.0.2 33 | # - { build: stack, resolver: "--resolver lts-11" } # ghc-8.2.2 34 | # - { build: stack, resolver: "--resolver lts-12" } # ghc-8.4.4 35 | # - { build: stack, resolver: "--resolver lts-13" } redundant because lts-14 checks ghc-8.6 already 36 | - { build: stack, resolver: "--resolver lts-14" } # ghc-8.6.5 37 | - { build: stack, resolver: "--resolver nightly" } 38 | - { build: stack, resolver: "" } 39 | # - { build: cabal, ghc: 8.0.2, cabal-install: "2.0" } 40 | # - { build: cabal, ghc: 8.2.2, cabal-install: "2.0" } 41 | # - { build: cabal, ghc: 8.4.4, cabal-install: "2.2" } 42 | - { build: cabal, ghc: 8.6.5, cabal-install: "2.4" } 43 | - { build: cabal, ghc: 8.8.1, cabal-install: "2.4" } # currently not working for >= 3.0 44 | # use this to include any dependencies from OS package managers 45 | include: 46 | # - os: macOS-latest 47 | # brew: anybrewdeps 48 | - os: ubuntu-latest 49 | apt-get: happy 50 | 51 | exclude: 52 | - os: macOS-latest 53 | plan: 54 | build: cabal 55 | 56 | runs-on: ${{ matrix.os }} 57 | steps: 58 | - name: Install OS Packages 59 | uses: mstksg/get-package@v1 60 | with: 61 | apt-get: ${{ matrix.apt-get }} 62 | brew: ${{ matrix.brew }} 63 | - uses: actions/checkout@v1 64 | 65 | - name: Setup stack 66 | uses: mstksg/setup-stack@v1 67 | 68 | - name: Setup cabal-install 69 | uses: actions/setup-haskell@v1 70 | with: 71 | ghc-version: ${{ matrix.plan.ghc }} 72 | cabal-version: ${{ matrix.plan.cabal-install }} 73 | if: matrix.plan.build == 'cabal' 74 | 75 | - name: Install dependencies 76 | run: | 77 | set -ex 78 | case "$BUILD" in 79 | stack) 80 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 81 | ;; 82 | cabal) 83 | cabal --version 84 | cabal update 85 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 86 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 87 | ;; 88 | esac 89 | set +ex 90 | env: 91 | ARGS: ${{ matrix.plan.resolver }} 92 | BUILD: ${{ matrix.plan.build }} 93 | 94 | - name: Build 95 | run: | 96 | set -ex 97 | case "$BUILD" in 98 | stack) 99 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 100 | ;; 101 | cabal) 102 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 103 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 104 | 105 | ORIGDIR=$(pwd) 106 | for dir in $PACKAGES 107 | do 108 | cd $dir 109 | cabal check || [ "$CABALVER" == "1.16" ] 110 | cabal sdist 111 | PKGVER=$(cabal info . | awk '{print $2;exit}') 112 | SRC_TGZ=$PKGVER.tar.gz 113 | cd dist 114 | tar zxfv "$SRC_TGZ" 115 | cd "$PKGVER" 116 | cabal configure --enable-tests --ghc-options -O0 117 | cabal build 118 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 119 | cabal test 120 | else 121 | cabal test --show-details=streaming --log=/dev/stdout 122 | fi 123 | cd $ORIGDIR 124 | done 125 | ;; 126 | esac 127 | set +ex 128 | env: 129 | ARGS: ${{ matrix.plan.resolver }} 130 | BUILD: ${{ matrix.plan.build }} 131 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | functor-combinators.cabal 3 | .log.log 4 | .stack.yaml.lock 5 | .ghc.environment.* 6 | dist-newstyle/ 7 | *.dump-hi 8 | *~ 9 | scratch 10 | tags 11 | .direnv 12 | /result 13 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: Eta reduce} 2 | - ignore: {name: Avoid lambda} 3 | - ignore: {name: Use const} 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | script: 2 | - | 3 | set -ex 4 | case "$BUILD" in 5 | stack) 6 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 7 | ;; 8 | cabal) 9 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 10 | 11 | ORIGDIR=$(pwd) 12 | for dir in $PACKAGES 13 | do 14 | cd $dir 15 | cabal check || [ "$CABALVER" == "1.16" ] 16 | cabal sdist 17 | PKGVER=$(cabal info . | awk '{print $2;exit}') 18 | SRC_TGZ=$PKGVER.tar.gz 19 | cd dist 20 | tar zxfv "$SRC_TGZ" 21 | cd "$PKGVER" 22 | cabal configure --enable-tests --ghc-options -O0 23 | cabal build 24 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 25 | cabal test 26 | else 27 | cabal test --show-details=streaming --log=/dev/stdout 28 | fi 29 | cd $ORIGDIR 30 | done 31 | ;; 32 | esac 33 | set +ex 34 | matrix: 35 | include: 36 | - env: BUILD=cabal GHCVER=8.6.5 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 37 | addons: 38 | apt: 39 | sources: 40 | - hvr-ghc 41 | packages: 42 | - cabal-install-2.4 43 | - ghc-8.6.5 44 | - happy-1.19.5 45 | - alex-3.1.7 46 | compiler: ': #GHC 8.6.5' 47 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 48 | addons: 49 | apt: 50 | sources: 51 | - hvr-ghc 52 | packages: 53 | - cabal-install-head 54 | - ghc-head 55 | - happy-1.19.5 56 | - alex-3.1.7 57 | compiler: ': #GHC HEAD' 58 | - env: BUILD=stack ARGS="" 59 | addons: 60 | apt: 61 | packages: 62 | - libgmp-dev 63 | compiler: ': #stack default' 64 | - env: BUILD=stack ARGS="--resolver lts-13" 65 | addons: 66 | apt: 67 | packages: 68 | - libgmp-dev 69 | compiler: ': #stack 8.6.5' 70 | - env: BUILD=stack ARGS="--resolver nightly" 71 | addons: 72 | apt: 73 | packages: 74 | - libgmp-dev 75 | compiler: ': #stack nightly' 76 | - env: BUILD=stack ARGS="" 77 | os: osx 78 | compiler: ': #stack default osx' 79 | - env: BUILD=stack ARGS="--resolver lts-13" 80 | os: osx 81 | compiler: ': #stack 8.6.5 osx' 82 | - env: BUILD=stack ARGS="--resolver nightly" 83 | os: osx 84 | compiler: ': #stack nightly osx' 85 | allow_failures: 86 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 87 | - env: BUILD=stack ARGS="--resolver nightly" 88 | install: 89 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo 90 | '?')]" 91 | - if [ -f configure.ac ]; then autoreconf -i; fi 92 | - | 93 | set -ex 94 | case "$BUILD" in 95 | stack) 96 | # Add in extra-deps for older snapshots, as necessary 97 | # 98 | # This is disabled by default, as relying on the solver like this can 99 | # make builds unreliable. Instead, if you have this situation, it's 100 | # recommended that you maintain multiple stack-lts-X.yaml files. 101 | 102 | #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 103 | # stack --no-terminal $ARGS build cabal-install && \ 104 | # stack --no-terminal $ARGS solver --update-config) 105 | 106 | # Build the dependencies 107 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 108 | ;; 109 | cabal) 110 | cabal --version 111 | travis_retry cabal update 112 | 113 | # Get the list of packages from the stack.yaml file. Note that 114 | # this will also implicitly run hpack as necessary to generate 115 | # the .cabal files needed by cabal-install. 116 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 117 | 118 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 119 | ;; 120 | esac 121 | set +ex 122 | cache: 123 | directories: 124 | - $HOME/.ghc 125 | - $HOME/.cabal 126 | - $HOME/.stack 127 | - $TRAVIS_BUILD_DIR/.stack-work 128 | before_install: 129 | - unset CC 130 | - CABALARGS="" 131 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 132 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 133 | - mkdir -p ~/.local/bin 134 | - | 135 | if [ `uname` = "Darwin" ] 136 | then 137 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 138 | else 139 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 140 | fi 141 | 142 | # Use the more reliable S3 mirror of Hackage 143 | mkdir -p $HOME/.cabal 144 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 145 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 146 | language: generic 147 | sudo: false 148 | 149 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changelog 2 | ========= 3 | 4 | Version 0.4.1.4 5 | --------------- 6 | 7 | *June 12, 2025* 8 | 9 | 10 | 11 | * Optimize `(.>)` for `Final` (#10) (@rhendric) 12 | 13 | Version 0.4.1.3 14 | --------------- 15 | 16 | *January 9, 2024* 17 | 18 | 19 | 20 | * Compatibility with transformers 0.6, and therefore ghc 9.6 (#7) 21 | 22 | Version 0.4.1.2 23 | --------------- 24 | 25 | *January 29, 2023* 26 | 27 | 28 | 29 | * Add Invariant instances to Freer.Church types 30 | 31 | Version 0.4.1.1 32 | --------------- 33 | 34 | *January 29, 2023* 35 | 36 | 37 | 38 | * Fix builds and warnings for GHC 9.2 and base 4.16 39 | 40 | Version 0.4.1.0 41 | --------------- 42 | 43 | *September 29, 2021* 44 | 45 | 46 | 47 | * All of the missing instances to the typeclasses added in 0.4 that I could 48 | remember. 49 | * Variations of `concatInply` / `concatInplicative` / `concatInalt` / 50 | `concatInplus` renamed to `gatheredN` / `swervedN` / `gatheredN1` / 51 | `swervedN1`. 52 | * `gatherN`, `gatherN1` added with typeclass-based multi-arity functions. 53 | * GHC 9.0 compatibility (@ocharles) 54 | 55 | Version 0.4.0.0 56 | --------------- 57 | 58 | *September 3, 2021* 59 | 60 | 61 | 62 | * Finally add *Data.Functor.Invariant.Inplicative* and 63 | *Data.Functor.Internative*, with the typlecasses `Inply`, `Inplicative`, 64 | `Inalt`, `Inplus`, and `Internative`, the invariant versions of 65 | `Apply`/`Divise`, `Applicative`/`Divisible`, `Alt`/`Decide`, 66 | `Plus`/`Choose`, and `Alternative`/`Decidable`. 67 | * Move *Data.Functor.Invariant.DivAp* and *Data.Functor.Invariant.DecAlt* to 68 | *Data.Functor.Invariant.Inplicative.Free* and 69 | *Data.Functor.Invariant.Internative.Free*, respectively. 70 | 71 | Their specialized `gather`/`knot`/`swerve`/`reject` are now a part of the 72 | typeclasses. 73 | * `concatDivAp` family and `concatDecAlt` family of functions generalized to 74 | work for all *Inplicative* and *Inplus*, respectively, and moved to the 75 | modules for their respective typeclasses as `concatInplicative`, 76 | `concatInply`, `concatInplus`, and `concatInalt`. 77 | * Changed the order of arguments on `gather` and `swerve` to be consistent 78 | with the arguments of `invmap`, `Day`, and `Night`. 79 | * Changed the order of arguments in the `Gather`, and `Swerve` patterns to 80 | be more consistent with the new order of arguments for `gather`/`swerve`. 81 | * Changed the order of arguments in the `DivAp1` and `DecAlt1` patterns to 82 | be more consistent with the order of arguments for `Day` and `Night`. 83 | * Add `runDay` and `runNight` for invariant `Day` and `Night`, using the 84 | `Inply` and `Inalt` typeclasses, respectively. `runDay` is found in 85 | *Data.Functor.Invariant.Inplicative*, even though it should belong in 86 | *Data.Functor.Invariant.Day*, but that's in a different package. 87 | * Add `dather`, `necide`, and `nerve` to invariant `Day`, contravariant 88 | `Night`, invariant `Night`, in parallel to `dap` for covariant `Day`. Uses 89 | the `Inply`, `Divise`, and `Inalt` typeclasses, respectively. `dather` is 90 | found in *Data.Functor.Invariant.Inplicative*, even though it should 91 | belong in *Data.Functor.Invariant.Day*, but that's in a different package. 92 | * Add `hfor` and `hfor1` to *Data.HFunctor.HTraversable*. 93 | 94 | Version 0.3.6.0 95 | --------------- 96 | 97 | *August 27, 2020* 98 | 99 | 100 | 101 | * *Data.HFunctor.HTraversable* added, providing `HTraversable` and 102 | `HTraversable1`. 103 | * *Control.Monad.Freer.Church*: Missing `Apply`, `Alt`, and `Plus` instances 104 | added for `Comp`. 105 | * *Data.HBifunctor*: `HFunctor` instances for `LeftF`, `RightF`, `Joker`, 106 | `Void3`, and `Comp` made more kind-polymorphic 107 | * *Data.HFunctor.Interpret*: `itraverse` added, mimicking `htraverse` for 108 | proper `Interpret` instances. 109 | * *Data.HFunctor.Chain*: `foldChainA` and `foldChain1A` added, for effectful 110 | folding of chains. 111 | 112 | Version 0.3.5.0 113 | --------------- 114 | 115 | *August 15, 2020* 116 | 117 | 118 | 119 | * `DayChain` and `NightChain` renamed to `DivAp` and `DecAlt`, to better 120 | reflect their abstracted nature ever since *0.3.4.0*. The modules are 121 | renamed to *Data.Functor.Invariant.DivAp* and 122 | *Data.Functor.Invariant.DecAlt*. 123 | 124 | * **v0.3.5.1**: Fixed infinite recursion bug for Tensor instances of 125 | invariant `Day`/`Night`. 126 | 127 | Version 0.3.4.0 128 | --------------- 129 | 130 | *August 14, 2020* 131 | 132 | 133 | 134 | * *Data.HFunctor.Route*: A new twist on getting invariant functor 135 | combinators. Instead of creating new ones, utilize existing functor 136 | combinators with `Pre`/`Post`. 137 | * *Data.Functor.Invariant.Day.Chain* and *Data.Functor.Invariant.Night.Chain* 138 | created, factoring out the `Chain` part of the invariant `Day`/`Night`. 139 | This was done to fix the fact that *Data.Functor.Invariant.Day* is a module 140 | that already existed in *kan-extensions*. Oops! 141 | * As a consequence, `DayChain` and `NightChain` are now newtype wrappers 142 | instead of plain type synonyms. 143 | 144 | * **v0.3.4.1**: Add in missing `Functor` and `Invariant` instances for 145 | `ProPre` and `ProPost`, as well as a bunch of instances for `ProPre`. 146 | * **v0.3.4.2**: Add in missing `HFunctor`, `Inject`, `Interpret` instances 147 | for `PostT`. 148 | 149 | Version 0.3.3.0 150 | --------------- 151 | 152 | *August 11, 2020* 153 | 154 | 155 | 156 | * *Control.Applicative.ListF*: Missing contravariant instances added for 157 | `MaybeF`. 158 | * *Data.HFunctor*: Add `injectMap` and `injectContramap`, two small utility 159 | functions that represent common patterns in injection and mapping. 160 | * *Data.Functor.Combinator*: Replace `divideN` and related functions with 161 | `dsum` and `dsum1`, which is an altogether cleaner interface that doesn't 162 | require heterogenous lists. A part of a larger project on cleaning up 163 | `Divisible` tools. 164 | * *Data.Functor.Contravariant.Divise*: Add useful utility functions `dsum` 165 | and `<:>`, which makes the type of `divise` closer to that of `<|>` and 166 | `asum`. 167 | * *Data.Functor.Contravariant.Divisible.Free*: Implement `Div` in terms of a 168 | list, instead of the mirrored `Ap`. Should make it much easier to use, 169 | although a less-than-ideal `Coyoneda` is required to keep it compatible 170 | with the contravariant `Day` in *kan-extensions*. Added patterns to 171 | recover the original interface. 172 | 173 | 174 | Version 0.3.2.0 175 | --------------- 176 | 177 | *August 9, 2020* 178 | 179 | 180 | 181 | * *Data.HFunctor.Interpret*: `icollect`, `icollect1` now are more 182 | constrained: they only work on things that have `Interpret` instances for 183 | *all* `Monoid m` or `Semigroup m` in `AltConst m`. While this doesn't 184 | affect how it works on any types in this library, it does make the type 185 | signature a little more clean (hiding the usage of `DList`) and prevents 186 | one from making an odd `Interpret` instance that does something weird with 187 | the `DList`. This also allows us to drop the direct *dlist >= 1.0* dependency. 188 | * *Data.HFunctor.Interpret*: `biapply`, `bifanout`, `bifanout1` added as 189 | contravariant consumer versions of `iget`, `icollect`, and `icollect1`. 190 | * *Data.HBifunctor.Associative*: `bicollect` `bicollect1` removed because 191 | they really don't make sense for associative tensors, which can only have 192 | at most one of each tensor. 193 | * *Data.HBifunctor.Associative*: `biapply` added as the contravariant 194 | consumer version of `biget`. 195 | * *Data.Functor.Invariant.Day*: Add conversion functions from chains to the 196 | covariant/invariant versions, `chainAp`, `chainAp1`, `chainDiv`, and 197 | `chainDiv1`. 198 | * *Data.Functor.Invariant.Night*: Add conversion functions from chains to the 199 | covariant/invariant versions, `chainDec`, `chainDec1`, `chainListF`, 200 | `chainNonEmptyF`. Also add "undescored" versions to the covariant 201 | versions, `toCoNight_`, `chainListF_`, `chainNonEmptyF_`, to more 202 | accurately represent the actual contravariant either-based day convolution. 203 | Also changed `Share` to `Swerve`. 204 | * *Data.Functor.Combinator*: `AltConst` re-exported. 205 | 206 | 207 | Version 0.3.1.0 208 | --------------- 209 | 210 | *August 7, 2020* 211 | 212 | 213 | 214 | * *Data.HFunctor.Interpret*: `getI` and `collectI` made more efficient, and 215 | renamed to `iget` and `icollect`, respectively, to mirror `biget` and 216 | `bicollect`. `getI` and `collectI` are left in with a deprecation warning. 217 | `icollect1` added to ensure a non-empty collection. `AltConst` added to 218 | aid in implementation. 219 | * *Data.HBifunctor.Associative*: `bicollect1` added to ensure a non-empty 220 | collection. *biget* and *bicollect* made more efficient. 221 | * *Data.Functor.Contravariant.Night*, *Data.Functor.Invariant.Night*: 222 | `refuted` added for a convenient `Not`. Missing `Invariant` instance for 223 | `Not` also added. 224 | * *Data.HFunctor.Chain*: `chainPair` and `chain1Pair` renamed to `toChain` 225 | and `toChain1`, respectively, to mirror `toListBy` and `toNonEmptyBy`. 226 | 227 | Version 0.3.0.0 228 | --------------- 229 | 230 | *August 5, 2020* 231 | 232 | 233 | 234 | * *Data.HBifunctor.Associative*, *Data.HBifunctor.Tensor*: Support for 235 | `Contravariant` and `Invariant` functor combinators. Main change to the 236 | infrastructure: add a `FunctorBy` associated constraint to `Associative` to 237 | signal what "sort of functor" the tensor supports: it should either be 238 | `Unconstrained`, `Functor`, `Contravariant`, or `Invariant`. 239 | * *Data.Functor.Contravariant.Divise*, *Data.Functor.Contravariant.Decide*, 240 | and *Data.Functor.Contravariant.Conclude*: Temporarily add in the 241 | semigroupoidal contravariant typeclasses. These should only be needed until 242 | they get merged into *semigroupoids*. 243 | * *Data.Functor.Contravariant.Divisible*: Add free structures for 244 | contravariant typeclass hierarchy. 245 | * Added in some new day convolutions: 246 | 247 | * *Data.Functor.Contravariant.Night*: `Night`, a contravariant day 248 | convolution using `Either`, which is the tensor that generates 249 | `Conclude` (and `Decidable` kinda). 250 | * *Data.Functor.Invariant.Day*: `Day`, an *invariant* day convolution 251 | using tuples. 252 | * *Data.Functor.Invariant.Night*: `Night`, an *invariant* day convolution 253 | using either. 254 | 255 | For the invariant day convolutions, we *could* write free monoids on them 256 | (like `Ap`/`Div`/`Dec`). But instead we just outsource our free structures 257 | to `Chain`, providing useful pattern synonyms and folding functions to 258 | pretend like we had an actual free structure. 259 | * *Data.Functor.Combinator*: Useful functions in for working with divisible 260 | and decidable contravariant functors: `divideN`, `diviseN`, `concludeN`, 261 | `decideN`, `divideNRec`, and `diviseNRec`. 262 | * `Contravariant` and `Invariant` instances for many types. 263 | * *Data.HFunctor.Final*: `FreeOf` adjusted to allow for contravariant free 264 | types. 265 | * *Data.Functor.Combinator.Unsafe*: Add `unsafeDivise` and `unsafeConclude`, 266 | to mirror the situation with `unsafeApply` and `unsafePlus`. 267 | 268 | Version 0.2.0.0 269 | --------------- 270 | 271 | *November 11, 2019* 272 | 273 | 274 | 275 | * Major restructuring of the hbifunctor-based classes. `Data.HBifunctor.Associative` 276 | and `Data.HBifunctor.Tensor` are more or less completely rewritten; the 277 | typeclasses are restructured in order to more properly reflect the math 278 | that motivates them. See the updated type classes to see what methods 279 | ended up where. 280 | 281 | However, much of the external API that is independent of the underlying 282 | abstraction is effectively unchanged (`biget`, etc.) 283 | 284 | For the most part, the migration would involve: 285 | 286 | * `SF`, `MF` are now `NonEmptyBy` and `ListBy`, respectively. 287 | * `-SF` and `-MF` as suffixes for function names now become `-NE` and 288 | `-LB`. 289 | 290 | * `upgradeC` no longer exists; use unsafe functions from 291 | *Data.Functor.Combinator.Unsafe* instead, on a per-tensor basis. 292 | 293 | * Restructuring of `Interpret`: It now takes an extra type parameter, the 294 | type to interpret into. This makes it more consistent with the new `MonoidIn` 295 | and `SemigroupIn`. Most of the external API should be effectively 296 | unchanged. 297 | 298 | For the most part, the migration would only affect people who *write* 299 | instances of `Interpret`. Instead of 300 | 301 | ```haskell 302 | instance Interpret MyType where 303 | type C MyType = Monad 304 | ``` 305 | 306 | you would write: 307 | 308 | ```haskell 309 | instance Monad f => Interpret MyType f where 310 | ``` 311 | 312 | 313 | Version 0.1.1.1 314 | --------------- 315 | 316 | *July 13, 2019* 317 | 318 | 319 | 320 | * Moved to *trivial-constraints-0.6.0.0* 321 | 322 | Version 0.1.1.0 323 | --------------- 324 | 325 | *June 19, 2019* 326 | 327 | 328 | 329 | * `appendChain` and `appendChain1` 330 | 331 | Version 0.1.0.1 332 | --------------- 333 | 334 | *June 19, 2019* 335 | 336 | 337 | 338 | * Small tweaks for haddock generation and dependency bounds. 339 | 340 | Version 0.1.0.0 341 | --------------- 342 | 343 | *June 19, 2019* 344 | 345 | 346 | 347 | * Initial release 348 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Justin Le (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Justin Le nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | functor-combinators 2 | =================== 3 | 4 | *[Introductory Blog Post][combinatorpedia]* / *[Hackage][hackage]* 5 | 6 | [combinatorpedia]: https://blog.jle.im/entry/functor-combinatorpedia.html 7 | [hackage]: https://hackage.haskell.org/package/functor-combinators 8 | 9 | Tools for working with *functor combinators*: types that take functors (or 10 | other indexed types) and returns a new functor that "enhances" or "mixes" them 11 | in some way. 12 | 13 | The main functionality is exported in *Data.Functor.Combinators*, but more 14 | fine-grained functionality and extra combinators (some of them 15 | re-implementations for compatibility) are available in other modules as well. 16 | 17 | The goal is to represent schemas, DSL's, and computations (things like parsers, 18 | things to execute, things to consume or produce data) by assembling 19 | "self-evident" basic primitives and subjecting them to many *different* 20 | successive transformations and combiners. The process of doing so: 21 | 22 | 1. Forces you to make explicit decisions about the structure of your 23 | computation type as an ADT. 24 | 2. Allows you to retain isolation of fundamental parts of your domain as 25 | separate types 26 | 3. Lets you manipulate the structure of your final computation type through 27 | *normal Haskell techniques* like pattern matching. The structure is 28 | available throughout the entire process, so you can replace individual 29 | components and values within your structure. 30 | 4. Allows you to fully *reflect* the structure of your final computation 31 | through pattern matching and folds, so you can inspect the structure and 32 | produce useful summaries. 33 | 34 | The main benefit of this library in specific is to allow you to be able to work 35 | with different functor combinators with a uniform and lawful interface, so the 36 | real functionality here is the wide variety of functor combinators from all 37 | around the Haskell ecosystem. This library does not provide the functor 38 | combinators, as much as it re-exports them with a unified interface. However, 39 | it does "fill in the matrix", in a sense, of functor combinators in specific 40 | roles that are missing from the haskell ecosystem. 41 | 42 | To jump into using it, import *Data.Functor.Combinator*. For a full 43 | introduction, check out the *[Functor Combinatorpedia][combinatorpedia]*, which 44 | goes in-depth into the motivation behind functor combinator-driven development, 45 | examples of the functor combinators in this library, and details about how to 46 | use these abstractions! 47 | 48 | Comparisons 49 | ----------- 50 | 51 | On the surface, *functor-combinators* look like it fills a similar space to 52 | effects systems and libraries like *[mtl][]*, *[polysemy][]*, 53 | *[freer-simple][]*, or *[fused-effects][]*. However, the functor combinator 54 | design pattern actually exists on a different level. 55 | 56 | [mtl]: https://hackage.haskell.org/package/mtl 57 | [polysemy]: https://hackage.haskell.org/package/polysemy 58 | [freer-simple]: https://hackage.haskell.org/package/freer-simple 59 | [fused-effects]: https://hackage.haskell.org/package/fused-effects 60 | 61 | Functor combinator design patterns can be used to help build the *structure* of 62 | the *data types* and schemas that define your program/DSL. Once you build 63 | these nice structures, you then *interpret* them into some target context. This 64 | "target context" is the realm that libraries like *mtl* and *polysemy* can 65 | fill; functor combinators serve to help you define a structure for your program 66 | *before* you interpret it into whatever Applicative or Monad or effects system 67 | you end up using. 68 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Basic Haskell Project Flake"; 3 | inputs = { 4 | haskellProjectFlake.url = "github:mstksg/haskell-project-flake"; 5 | nixpkgs.follows = "haskellProjectFlake/nixpkgs"; 6 | }; 7 | outputs = 8 | { self 9 | , nixpkgs 10 | , flake-utils 11 | , haskellProjectFlake 12 | }: 13 | flake-utils.lib.eachDefaultSystem (system: 14 | let 15 | name = "functor-combinators"; 16 | pkgs = import nixpkgs { 17 | inherit system; 18 | overlays = [ haskellProjectFlake.overlays."${system}".default ]; 19 | }; 20 | project-flake = pkgs.haskell-project-flake 21 | { 22 | inherit name; 23 | src = ./.; 24 | excludeCompilerMajors = [ "ghc94" "ghc913" ]; 25 | defaultCompiler = "ghc984"; 26 | }; 27 | in 28 | { 29 | packages = project-flake.packages; 30 | apps = project-flake.apps; 31 | checks = project-flake.checks; 32 | devShells = project-flake.devShells; 33 | legacyPackages."${name}" = project-flake; 34 | } 35 | ); 36 | } 37 | 38 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | column-limit: 100 2 | comma-style: leading 3 | fixities: [] 4 | function-arrows: trailing 5 | haddock-style: single-line 6 | haddock-style-module: null 7 | import-export-style: diff-friendly 8 | in-style: right-align 9 | indent-wheres: true 10 | indentation: 2 11 | let-style: inline 12 | newlines-between-decls: 1 13 | record-break-space: true 14 | reexports: [] 15 | respectful: true 16 | single-constraint-parens: never 17 | unicode: detect 18 | -------------------------------------------------------------------------------- /functor-combinators.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.24 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: c98f05061d45352f630dd964c7671a2a414e5708a12f8f4f8a39d61b986f6f5d 8 | 9 | name: functor-combinators 10 | version: 0.4.1.4 11 | synopsis: Tools for functor combinator-based program design 12 | description: 13 | Tools for working with /functor combinators/: types that take functors (or 14 | other indexed types) and returns a new functor that "enhances" or "mixes" 15 | them in some way. In the process, you can design featureful programs by 16 | composing smaller "primitives" using basic unversal combinators. 17 | . 18 | The main entry point is "Data.Functor.Combinators", but more fine-grained 19 | functionality and extra combinators (some of them re-implementations for 20 | compatibility) are available in other modules as well. 21 | . 22 | This library does not define new functor combinators for the most part, 23 | but rather re-exports them from different parts of the Haskell ecosystem 24 | and provides a uniform interface. 25 | . 26 | See the README for a quick overview, and also 27 | for an in-depth 28 | dive into the motivation behind functor combinator-driven development, 29 | examples of the functor combinators in this library, and details about how 30 | to use these abstractions! 31 | 32 | category: Data 33 | homepage: https://github.com/mstksg/functor-combinators#readme 34 | bug-reports: https://github.com/mstksg/functor-combinators/issues 35 | author: Justin Le 36 | maintainer: justin@jle.im 37 | copyright: (c) Justin Le 2025 38 | license: BSD3 39 | license-file: LICENSE 40 | tested-with: GHC >=8.6 41 | build-type: Simple 42 | extra-source-files: 43 | CHANGELOG.md 44 | README.md 45 | 46 | source-repository head 47 | type: git 48 | location: https://github.com/mstksg/functor-combinators 49 | 50 | library 51 | exposed-modules: 52 | Control.Applicative.ListF 53 | Control.Applicative.Step 54 | Control.Monad.Freer.Church 55 | Control.Natural.IsoF 56 | Data.Functor.Apply.Free 57 | Data.Functor.Combinator 58 | Data.Functor.Combinator.Unsafe 59 | Data.Functor.Contravariant.Conclude 60 | Data.Functor.Contravariant.Decide 61 | Data.Functor.Contravariant.Divise 62 | Data.Functor.Contravariant.Divisible.Free 63 | Data.Functor.Contravariant.Night 64 | Data.Functor.Invariant.Inplicative 65 | Data.Functor.Invariant.Inplicative.Free 66 | Data.Functor.Invariant.Internative 67 | Data.Functor.Invariant.Internative.Free 68 | Data.Functor.Invariant.Night 69 | Data.HBifunctor 70 | Data.HBifunctor.Associative 71 | Data.HBifunctor.Tensor 72 | Data.HFunctor 73 | Data.HFunctor.Chain 74 | Data.HFunctor.Final 75 | Data.HFunctor.HTraversable 76 | Data.HFunctor.Interpret 77 | Data.HFunctor.Route 78 | 79 | other-modules: 80 | Data.HBifunctor.Tensor.Internal 81 | Data.HFunctor.Chain.Internal 82 | Data.HFunctor.Internal 83 | 84 | hs-source-dirs: src 85 | default-extensions: 86 | AllowAmbiguousTypes 87 | ConstraintKinds 88 | DataKinds 89 | DefaultSignatures 90 | DeriveDataTypeable 91 | DeriveFoldable 92 | DeriveFunctor 93 | DeriveGeneric 94 | DeriveTraversable 95 | DerivingStrategies 96 | EmptyCase 97 | ExistentialQuantification 98 | ExplicitNamespaces 99 | FlexibleContexts 100 | FlexibleInstances 101 | FunctionalDependencies 102 | GADTs 103 | GeneralizedNewtypeDeriving 104 | InstanceSigs 105 | KindSignatures 106 | LambdaCase 107 | MultiParamTypeClasses 108 | OverloadedStrings 109 | PatternSynonyms 110 | PolyKinds 111 | QuantifiedConstraints 112 | RankNTypes 113 | ScopedTypeVariables 114 | StandaloneDeriving 115 | TemplateHaskell 116 | TupleSections 117 | TypeApplications 118 | TypeFamilies 119 | TypeOperators 120 | UndecidableInstances 121 | UndecidableSuperClasses 122 | ViewPatterns 123 | 124 | ghc-options: 125 | -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns 126 | -Wunused-packages 127 | 128 | build-depends: 129 | assoc 130 | , base >=4.12 && <5 131 | , bifunctors 132 | , comonad 133 | , constraints 134 | , containers 135 | , contravariant 136 | , deriving-compat 137 | , free 138 | , hashable 139 | , invariant 140 | , kan-extensions 141 | , mmorph 142 | , mtl 143 | , natural-transformation 144 | , nonempty-containers >=0.3.4.4 145 | , pointed 146 | , profunctors 147 | , semigroupoids 148 | , sop-core 149 | , StateVar 150 | , tagged 151 | , these 152 | , transformers 153 | , trivial-constraint >=0.5 154 | , unordered-containers 155 | , vinyl 156 | 157 | default-language: Haskell2010 158 | 159 | test-suite functor-combinators-test 160 | type: exitcode-stdio-1.0 161 | main-is: Spec.hs 162 | other-modules: 163 | Paths_functor_combinators 164 | Tests.HBifunctor 165 | Tests.HFunctor 166 | Tests.Util 167 | 168 | hs-source-dirs: test 169 | default-extensions: 170 | AllowAmbiguousTypes 171 | ConstraintKinds 172 | DataKinds 173 | DefaultSignatures 174 | DeriveDataTypeable 175 | DeriveFoldable 176 | DeriveFunctor 177 | DeriveGeneric 178 | DeriveTraversable 179 | DerivingStrategies 180 | EmptyCase 181 | ExistentialQuantification 182 | ExplicitNamespaces 183 | FlexibleContexts 184 | FlexibleInstances 185 | FunctionalDependencies 186 | GADTs 187 | GeneralizedNewtypeDeriving 188 | InstanceSigs 189 | KindSignatures 190 | LambdaCase 191 | MultiParamTypeClasses 192 | OverloadedStrings 193 | PatternSynonyms 194 | PolyKinds 195 | QuantifiedConstraints 196 | RankNTypes 197 | ScopedTypeVariables 198 | StandaloneDeriving 199 | TemplateHaskell 200 | TupleSections 201 | TypeApplications 202 | TypeFamilies 203 | TypeOperators 204 | UndecidableInstances 205 | UndecidableSuperClasses 206 | ViewPatterns 207 | 208 | ghc-options: 209 | -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns 210 | -threaded -rtsopts -with-rtsopts=-N -Wunused-packages 211 | 212 | build-depends: 213 | base >=4.12 && <5 214 | , bifunctors 215 | , dependent-sum 216 | , free 217 | , functor-combinators 218 | , hedgehog >=0.6 219 | , nonempty-containers >=0.3.4.4 220 | , semigroupoids 221 | , tasty 222 | , tasty-hedgehog 223 | , transformers 224 | , trivial-constraint >=0.5 225 | 226 | default-language: Haskell2010 227 | -------------------------------------------------------------------------------- /src/Control/Applicative/ListF.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Applicative.ListF 3 | -- Copyright : (c) Justin Le 2025 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : justin@jle.im 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- This module provides functor combinators that are wrappers over lists or 11 | -- maybes of @f a@s, especially for their 12 | -- 'Data.HFunctor.Interpret.Interpret' instances. 13 | -- 14 | -- Each one transforms a functor into some product of itself. For example, 15 | -- @'NonEmptyF' f@ represents @f ':*:' f@, or @f :*: f :*: f@, or @f :*: 16 | -- f :*: f :*: f@, etc. 17 | module Control.Applicative.ListF ( 18 | -- * 'ListF' 19 | ListF (..), 20 | mapListF, 21 | 22 | -- * 'NonEmptyF' 23 | NonEmptyF (.., ProdNonEmpty, nonEmptyProd), 24 | mapNonEmptyF, 25 | toListF, 26 | fromListF, 27 | 28 | -- * 'MaybeF' 29 | MaybeF (..), 30 | mapMaybeF, 31 | listToMaybeF, 32 | maybeToListF, 33 | 34 | -- * 'MapF' 35 | MapF (..), 36 | NEMapF (..), 37 | ) where 38 | 39 | import Control.Applicative 40 | import Control.Natural 41 | import Data.Coerce 42 | import Data.Data 43 | import Data.Deriving 44 | import Data.Foldable 45 | import Data.Functor.Bind 46 | import Data.Functor.Classes 47 | import Data.Functor.Contravariant 48 | import Data.Functor.Contravariant.Conclude 49 | import Data.Functor.Contravariant.Decide 50 | import Data.Functor.Contravariant.Divise 51 | import Data.Functor.Contravariant.Divisible 52 | import Data.Functor.Invariant 53 | import Data.Functor.Plus 54 | import Data.List.NonEmpty (NonEmpty (..)) 55 | import qualified Data.Map as M 56 | import qualified Data.Map.NonEmpty as NEM 57 | import Data.Maybe 58 | import Data.Pointed 59 | import Data.Semigroup.Foldable 60 | import Data.Semigroup.Traversable 61 | import GHC.Generics 62 | 63 | -- | A list of @f a@s. Can be used to describe a product of many different 64 | -- values of type @f a@. 65 | -- 66 | -- This is the Free 'Plus'. 67 | -- 68 | -- Incidentally, if used with a 'Contravariant' @f@, this is instead the 69 | -- free 'Divisible'. 70 | newtype ListF f a = ListF {runListF :: [f a]} 71 | deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) 72 | 73 | deriveShow1 ''ListF 74 | deriveRead1 ''ListF 75 | deriveEq1 ''ListF 76 | deriveOrd1 ''ListF 77 | 78 | instance Apply f => Apply (ListF f) where 79 | ListF fs <.> ListF xs = ListF $ liftF2 (<.>) fs xs 80 | instance Applicative f => Applicative (ListF f) where 81 | pure = ListF . (: []) . pure 82 | ListF fs <*> ListF xs = ListF $ liftA2 (<*>) fs xs 83 | 84 | instance Functor f => Alt (ListF f) where 85 | () = (<>) 86 | 87 | instance Functor f => Plus (ListF f) where 88 | zero = mempty 89 | 90 | instance Applicative f => Alternative (ListF f) where 91 | empty = zero 92 | (<|>) = () 93 | 94 | instance Semigroup (ListF f a) where 95 | ListF xs <> ListF ys = ListF (xs ++ ys) 96 | 97 | instance Monoid (ListF f a) where 98 | mempty = ListF [] 99 | 100 | instance Pointed f => Pointed (ListF f) where 101 | point = ListF . (: []) . point 102 | 103 | -- | @since 0.3.0.0 104 | instance Contravariant f => Contravariant (ListF f) where 105 | contramap f (ListF xs) = ListF ((map . contramap) f xs) 106 | 107 | -- | @since 0.3.0.0 108 | instance Invariant f => Invariant (ListF f) where 109 | invmap f g (ListF xs) = ListF (map (invmap f g) xs) 110 | 111 | -- | @since 0.3.0.0 112 | instance Contravariant f => Divise (ListF f) where 113 | divise f (ListF xs) (ListF ys) = 114 | ListF $ 115 | (map . contramap) (fst . f) xs 116 | <> (map . contramap) (snd . f) ys 117 | 118 | -- | @since 0.3.0.0 119 | instance Contravariant f => Divisible (ListF f) where 120 | divide = divise 121 | conquer = ListF [] 122 | 123 | -- | @since 0.3.0.0 124 | instance Decide f => Decide (ListF f) where 125 | decide f (ListF xs) (ListF ys) = 126 | ListF $ 127 | liftA2 (decide f) xs ys 128 | 129 | -- | @since 0.3.0.0 130 | instance Conclude f => Conclude (ListF f) where 131 | conclude f = ListF [conclude f] 132 | 133 | -- | @since 0.3.0.0 134 | instance Decidable f => Decidable (ListF f) where 135 | lose f = ListF [lose f] 136 | choose f (ListF xs) (ListF ys) = 137 | ListF $ 138 | liftA2 (choose f) xs ys 139 | 140 | -- | Map a function over the inside of a 'ListF'. 141 | mapListF :: 142 | ([f a] -> [g b]) -> 143 | ListF f a -> 144 | ListF g b 145 | mapListF = coerce 146 | 147 | -- | A non-empty list of @f a@s. Can be used to describe a product between 148 | -- many different possible values of type @f a@. 149 | -- 150 | -- Essentially: 151 | -- 152 | -- @ 153 | -- 'NonEmptyF' f 154 | -- ~ f -- one f 155 | -- ':+:' (f ':*:' f) -- two f's 156 | -- :+: (f :*: f :*: f) -- three f's 157 | -- :+: (f :*: f :*: f :*: f) -- four f's 158 | -- :+: ... -- etc. 159 | -- @ 160 | -- 161 | -- This is the Free 'Plus' on any 'Functor' @f@. 162 | -- 163 | -- Incidentally, if used with a 'Contravariant' @f@, this is instead the 164 | -- free 'Divise'. 165 | newtype NonEmptyF f a = NonEmptyF {runNonEmptyF :: NonEmpty (f a)} 166 | deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) 167 | 168 | deriveShow1 ''NonEmptyF 169 | deriveRead1 ''NonEmptyF 170 | deriveEq1 ''NonEmptyF 171 | deriveOrd1 ''NonEmptyF 172 | 173 | instance Applicative f => Applicative (NonEmptyF f) where 174 | pure = NonEmptyF . (:| []) . pure 175 | NonEmptyF fs <*> NonEmptyF xs = NonEmptyF $ liftA2 (<*>) fs xs 176 | 177 | instance Functor f => Alt (NonEmptyF f) where 178 | () = (<>) 179 | 180 | -- | @since 0.3.0.0 181 | instance Contravariant f => Contravariant (NonEmptyF f) where 182 | contramap f (NonEmptyF xs) = NonEmptyF (fmap (contramap f) xs) 183 | 184 | -- | @since 0.3.0.0 185 | instance Invariant f => Invariant (NonEmptyF f) where 186 | invmap f g (NonEmptyF xs) = NonEmptyF (fmap (invmap f g) xs) 187 | 188 | -- | @since 0.3.0.0 189 | instance Contravariant f => Divise (NonEmptyF f) where 190 | divise f (NonEmptyF xs) (NonEmptyF ys) = 191 | NonEmptyF $ 192 | (fmap . contramap) (fst . f) xs 193 | <> (fmap . contramap) (snd . f) ys 194 | 195 | -- | @since 0.3.0.0 196 | instance Decide f => Decide (NonEmptyF f) where 197 | decide f (NonEmptyF xs) (NonEmptyF ys) = 198 | NonEmptyF $ 199 | decide f <$> xs <*> ys 200 | 201 | instance Semigroup (NonEmptyF f a) where 202 | NonEmptyF xs <> NonEmptyF ys = NonEmptyF (xs <> ys) 203 | 204 | instance Pointed f => Pointed (NonEmptyF f) where 205 | point = NonEmptyF . (:| []) . point 206 | 207 | -- | Map a function over the inside of a 'NonEmptyF'. 208 | mapNonEmptyF :: 209 | (NonEmpty (f a) -> NonEmpty (g b)) -> 210 | NonEmptyF f a -> 211 | NonEmptyF g b 212 | mapNonEmptyF = coerce 213 | 214 | -- | Convert a 'NonEmptyF' into a 'ListF' with at least one item. 215 | toListF :: NonEmptyF f ~> ListF f 216 | toListF (NonEmptyF xs) = ListF (toList xs) 217 | 218 | -- | Convert a 'ListF' either a 'NonEmptyF', or a 'Proxy' in the case that 219 | -- the list was empty. 220 | fromListF :: ListF f ~> (Proxy :+: NonEmptyF f) 221 | fromListF (ListF xs) = case xs of 222 | [] -> L1 Proxy 223 | y : ys -> R1 $ NonEmptyF (y :| ys) 224 | 225 | -- | Treat a @'NonEmptyF' f@ as a product between an @f@ and a @'ListF' f@. 226 | -- 227 | -- 'nonEmptyProd' is the record accessor. 228 | pattern ProdNonEmpty :: (f :*: ListF f) a -> NonEmptyF f a 229 | pattern ProdNonEmpty{nonEmptyProd} <- 230 | (\case NonEmptyF (x :| xs) -> x :*: ListF xs -> nonEmptyProd) 231 | where 232 | ProdNonEmpty (x :*: ListF xs) = NonEmptyF (x :| xs) 233 | 234 | {-# COMPLETE ProdNonEmpty #-} 235 | 236 | -- | A maybe @f a@. 237 | -- 238 | -- Can be useful for describing a "an @f a@ that may or may not be there". 239 | -- 240 | -- This is the free structure for a "fail"-like typeclass that would only 241 | -- have @zero :: f a@. 242 | newtype MaybeF f a = MaybeF {runMaybeF :: Maybe (f a)} 243 | deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) 244 | 245 | deriveShow1 ''MaybeF 246 | deriveRead1 ''MaybeF 247 | deriveEq1 ''MaybeF 248 | deriveOrd1 ''MaybeF 249 | 250 | instance Applicative f => Applicative (MaybeF f) where 251 | pure = MaybeF . Just . pure 252 | MaybeF f <*> MaybeF x = MaybeF $ liftA2 (<*>) f x 253 | 254 | instance Functor f => Alt (MaybeF f) where 255 | () = (<>) 256 | 257 | instance Functor f => Plus (MaybeF f) where 258 | zero = mempty 259 | 260 | instance Applicative f => Alternative (MaybeF f) where 261 | empty = zero 262 | (<|>) = () 263 | 264 | -- | @since 0.3.3.0 265 | instance Contravariant f => Contravariant (MaybeF f) where 266 | contramap f (MaybeF x) = MaybeF $ (fmap . contramap) f x 267 | 268 | -- | @since 0.3.3.0 269 | instance Invariant f => Invariant (MaybeF f) where 270 | invmap f g (MaybeF x) = MaybeF $ fmap (invmap f g) x 271 | 272 | -- | @since 0.3.3.0 273 | instance Contravariant f => Divise (MaybeF f) where 274 | divise f (MaybeF x) (MaybeF y) = 275 | MaybeF $ 276 | (fmap . contramap) (fst . f) x 277 | <|> (fmap . contramap) (snd . f) y 278 | 279 | -- | @since 0.3.3.0 280 | instance Contravariant f => Divisible (MaybeF f) where 281 | divide = divise 282 | conquer = MaybeF Nothing 283 | 284 | -- | @since 0.3.3.0 285 | instance Decide f => Decide (MaybeF f) where 286 | decide f (MaybeF x) (MaybeF y) = 287 | MaybeF $ 288 | liftA2 (decide f) x y 289 | 290 | -- | @since 0.3.3.0 291 | instance Conclude f => Conclude (MaybeF f) where 292 | conclude f = MaybeF (Just (conclude f)) 293 | 294 | -- | @since 0.3.3.0 295 | instance Decidable f => Decidable (MaybeF f) where 296 | choose f (MaybeF x) (MaybeF y) = 297 | MaybeF $ 298 | liftA2 (choose f) x y 299 | lose f = MaybeF (Just (lose f)) 300 | 301 | -- | Picks the first 'Just'. 302 | instance Semigroup (MaybeF f a) where 303 | MaybeF xs <> MaybeF ys = MaybeF (xs ys) 304 | 305 | instance Monoid (MaybeF f a) where 306 | mempty = MaybeF Nothing 307 | 308 | instance Pointed f => Pointed (MaybeF f) where 309 | point = MaybeF . Just . point 310 | 311 | -- | Map a function over the inside of a 'MaybeF'. 312 | mapMaybeF :: 313 | (Maybe (f a) -> Maybe (g b)) -> 314 | MaybeF f a -> 315 | MaybeF g b 316 | mapMaybeF = coerce 317 | 318 | -- | Convert a 'MaybeF' into a 'ListF' with zero or one items. 319 | maybeToListF :: MaybeF f ~> ListF f 320 | maybeToListF (MaybeF x) = ListF (maybeToList x) 321 | 322 | -- | Convert a 'ListF' into a 'MaybeF' containing the first @f a@ in the 323 | -- list, if it exists. 324 | listToMaybeF :: ListF f ~> MaybeF f 325 | listToMaybeF (ListF xs) = MaybeF (listToMaybe xs) 326 | 327 | -- | A map of @f a@s, indexed by keys of type @k@. It can be useful for 328 | -- represeting a product of many different values of type @f a@, each "at" 329 | -- a different @k@ location. 330 | -- 331 | -- Can be considered a combination of 'Control.Comonad.Trans.Env.EnvT' and 332 | -- 'ListF', in a way --- a @'MapF' k f a@ is like a @'ListF' 333 | -- ('Control.Comonad.Trans.Env.EnvT' k f) a@ with unique (and ordered) 334 | -- keys. 335 | -- 336 | -- One use case might be to extend a schema with many "options", indexed by 337 | -- some string. 338 | -- 339 | -- For example, if you had a command line argument parser for a single 340 | -- command 341 | -- 342 | -- @ 343 | -- data Command a 344 | -- @ 345 | -- 346 | -- Then you can represent a command line argument parser for /multiple/ 347 | -- named commands with 348 | -- 349 | -- @ 350 | -- type Commands = 'MapF' 'String' Command 351 | -- @ 352 | -- 353 | -- See 'NEMapF' for a non-empty variant, if you want to enforce that your 354 | -- bag has at least one @f a@. 355 | newtype MapF k f a = MapF {runMapF :: M.Map k (f a)} 356 | deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) 357 | 358 | deriveShow1 ''MapF 359 | deriveEq1 ''MapF 360 | deriveOrd1 ''MapF 361 | 362 | instance (Ord k, Read k, Read1 f) => Read1 (MapF k f) where 363 | liftReadsPrec = $(makeLiftReadsPrec ''MapF) 364 | 365 | -- | A union, combining matching keys with ''. 366 | instance (Ord k, Alt f) => Semigroup (MapF k f a) where 367 | MapF xs <> MapF ys = MapF $ M.unionWith () xs ys 368 | 369 | instance (Ord k, Alt f) => Monoid (MapF k f a) where 370 | mempty = MapF M.empty 371 | 372 | -- | Left-biased union 373 | instance (Functor f, Ord k) => Alt (MapF k f) where 374 | MapF xs MapF ys = MapF $ M.union xs ys 375 | 376 | instance (Functor f, Ord k) => Plus (MapF k f) where 377 | zero = MapF M.empty 378 | 379 | instance (Monoid k, Pointed f) => Pointed (MapF k f) where 380 | point = MapF . M.singleton mempty . point 381 | 382 | -- | A non-empty map of @f a@s, indexed by keys of type @k@. It can be 383 | -- useful for represeting a product of many different values of type @f a@, 384 | -- each "at" a different @k@ location, where you need to have at least one 385 | -- @f a@ at all times. 386 | -- 387 | -- Can be considered a combination of 'Control.Comonad.Trans.Env.EnvT' and 388 | -- 'NonEmptyF', in a way --- an @'NEMapF' k f a@ is like a @'NonEmptyF' 389 | -- ('Control.Comonad.Trans.Env.EnvT' k f) a@ with unique (and ordered) 390 | -- keys. 391 | -- 392 | -- See 'MapF' for some use cases. 393 | newtype NEMapF k f a = NEMapF {runNEMapF :: NEM.NEMap k (f a)} 394 | deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) 395 | 396 | deriveShow1 ''NEMapF 397 | deriveEq1 ''NEMapF 398 | deriveOrd1 ''NEMapF 399 | 400 | instance (Ord k, Read k, Read1 f) => Read1 (NEMapF k f) where 401 | liftReadsPrec = $(makeLiftReadsPrec ''NEMapF) 402 | 403 | instance Foldable1 f => Foldable1 (NEMapF k f) where 404 | fold1 = foldMap1 fold1 . runNEMapF 405 | foldMap1 f = (foldMap1 . foldMap1) f . runNEMapF 406 | toNonEmpty = foldMap1 toNonEmpty . runNEMapF 407 | 408 | instance Traversable1 f => Traversable1 (NEMapF k f) where 409 | traverse1 f = fmap NEMapF . (traverse1 . traverse1) f . runNEMapF 410 | sequence1 = fmap NEMapF . traverse1 sequence1 . runNEMapF 411 | 412 | -- | A union, combining matching keys with ''. 413 | instance (Ord k, Alt f) => Semigroup (NEMapF k f a) where 414 | NEMapF xs <> NEMapF ys = NEMapF $ NEM.unionWith () xs ys 415 | 416 | -- | Left-biased union 417 | instance (Functor f, Ord k) => Alt (NEMapF k f) where 418 | NEMapF xs NEMapF ys = NEMapF $ NEM.union xs ys 419 | 420 | instance (Monoid k, Pointed f) => Pointed (NEMapF k f) where 421 | point = NEMapF . NEM.singleton mempty . point 422 | -------------------------------------------------------------------------------- /src/Control/Natural/IsoF.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Natural.IsoF 3 | -- Copyright : (c) Justin Le 2025 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : justin@jle.im 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- Types describing isomorphisms between two functors, and functions to 11 | -- manipulate them. 12 | module Control.Natural.IsoF ( 13 | type (~>), 14 | type (<~>), 15 | isoF, 16 | coercedF, 17 | viewF, 18 | reviewF, 19 | overF, 20 | fromF, 21 | ) where 22 | 23 | import Control.Natural 24 | import Data.Coerce 25 | import Data.Kind 26 | import Data.Profunctor 27 | import Data.Tagged 28 | 29 | -- | The type of an isomorphism between two functors. @f '<~>' g@ means that 30 | -- @f@ and @g@ are isomorphic to each other. 31 | -- 32 | -- We can effectively /use/ an @f \<~\> g@ with: 33 | -- 34 | -- @ 35 | -- 'viewF' :: (f \<~\> g) -> f a -> g a 36 | -- 'reviewF' :: (f \<~\> g) -> g a -> a a 37 | -- @ 38 | -- 39 | -- Use 'viewF' to extract the "@f@ to @g@" function, and 'reviewF' to 40 | -- extract the "@g@ to @f@" function. Reviewing and viewing the same value 41 | -- (or vice versa) leaves the value unchanged. 42 | -- 43 | -- One nice thing is that we can compose isomorphisms using '.' from 44 | -- "Prelude": 45 | -- 46 | -- @ 47 | -- ('.') :: f \<~\> g 48 | -- -> g \<~\> h 49 | -- -> f \<~\> h 50 | -- @ 51 | -- 52 | -- Another nice thing about this representation is that we have the 53 | -- "identity" isomorphism by using 'id' from "Prelude". 54 | -- 55 | -- @ 56 | -- 'id' :: f '<~>' g 57 | -- @ 58 | -- 59 | -- As a convention, most isomorphisms have form "X-ing", where the 60 | -- forwards function is "ing". For example, we have: 61 | -- 62 | -- @ 63 | -- 'Data.HBifunctor.Tensor.splittingSF' :: 'Data.HBifunctor.Tensor.Monoidal' t => 'Data.HBifunctor.Associative.SF' t a '<~>' t f ('Data.HBifunctor.Tensor.MF' t f) 64 | -- 'Data.HBifunctor.Tensor.splitSF' :: Monoidal t => SF t a '~>' t f (MF t f) 65 | -- @ 66 | type f <~> g = forall p a. Profunctor p => p (g a) (g a) -> p (f a) (f a) 67 | 68 | infixr 0 <~> 69 | 70 | -- | Create an @f '<~>' g@ by providing both legs of the isomorphism (the 71 | -- @f a -> g a@ and the @g a -> f a@. 72 | isoF :: 73 | f ~> g -> 74 | g ~> f -> 75 | f <~> g 76 | isoF f g a = dimap f g a 77 | 78 | -- | An isomorphism between two functors that are coercible/have the same 79 | -- internal representation. Useful for newtype wrappers. 80 | coercedF :: 81 | forall f g. (forall x. Coercible (f x) (g x), forall x. Coercible (g x) (f x)) => f <~> g 82 | coercedF = isoF coerce coerce 83 | 84 | -- | Use a '<~>' by retrieving the "forward" function: 85 | -- 86 | -- @ 87 | -- 'viewF' :: (f <~> g) -> f a -> g a 88 | -- @ 89 | viewF :: f <~> g -> f ~> g 90 | viewF i = runForget (i (Forget id)) 91 | 92 | -- | Use a '<~>' by retrieving the "backwards" function: 93 | -- 94 | -- @ 95 | -- 'viewF' :: (f <~> g) -> f a -> g a 96 | -- @ 97 | reviewF :: f <~> g -> g ~> f 98 | reviewF i x = unTagged (i (Tagged x)) 99 | 100 | -- | Lift a function @g a ~> g a@ to be a function @f a -> f a@, given an 101 | -- isomorphism between the two. 102 | -- 103 | -- One neat thing is that @'overF' i id == id@. 104 | overF :: f <~> g -> g ~> g -> f ~> f 105 | overF i f = i f 106 | 107 | -- | Reverse an isomorphism. 108 | -- 109 | -- @ 110 | -- 'viewF' ('fromF' i) == 'reviewF' i 111 | -- 'reviewF' ('fromF' i) == 'viewF' i 112 | -- @ 113 | fromF :: 114 | forall (f :: Type -> Type) (g :: Type -> Type). 115 | () => 116 | f <~> g -> 117 | g <~> f 118 | fromF i = isoF (reviewF i) (viewF i) 119 | -------------------------------------------------------------------------------- /src/Data/Functor/Apply/Free.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Functor.Apply.Free 3 | -- Copyright : (c) Justin Le 2025 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : justin@jle.im 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- The free 'Apply'. Provides 'Ap1' and various utility methods. See 11 | -- 'Ap1' for more details. 12 | -- 13 | -- Ideally 'Ap1' would be in the /free/ package. However, it is defined 14 | -- here for now. 15 | module Data.Functor.Apply.Free ( 16 | Ap1 (.., DayAp1, ap1Day), 17 | toAp, 18 | fromAp, 19 | liftAp1, 20 | retractAp1, 21 | runAp1, 22 | ) where 23 | 24 | import Control.Applicative.Free 25 | import Control.Natural 26 | import Data.Function 27 | import Data.Functor.Apply 28 | import Data.Functor.Day 29 | import Data.Functor.Identity 30 | import Data.Functor.Invariant 31 | import Data.HFunctor 32 | import Data.HFunctor.HTraversable 33 | import Data.HFunctor.Interpret 34 | import Data.Kind 35 | import GHC.Generics 36 | 37 | -- | One or more @f@s convolved with itself. 38 | -- 39 | -- Essentially: 40 | -- 41 | -- @ 42 | -- 'Ap1' f 43 | -- ~ f -- one f 44 | -- ':+:' (f \`'Day'` f) -- two f's 45 | -- :+: (f \`Day\` f \`Day\` f) -- three f's 46 | -- :+: (f \`Day\` f \`Day\` f \`Day\` f) -- four f's 47 | -- :+: ... -- etc. 48 | -- @ 49 | -- 50 | -- Useful if you want to promote an @f@ to a situation with "at least one 51 | -- @f@ sequenced with itself". 52 | -- 53 | -- Mostly useful for its 'HFunctor' and 'Interpret' instance, along with 54 | -- its relationship with 'Ap' and 'Day'. 55 | -- 56 | -- This is the free 'Apply' --- Basically a "non-empty" 'Ap'. 57 | -- 58 | -- The construction here is based on 'Ap', similar to now 59 | -- 'Data.List.NonEmpty.NonEmpty' is built on list. 60 | data Ap1 :: (Type -> Type) -> Type -> Type where 61 | Ap1 :: f a -> Ap f (a -> b) -> Ap1 f b 62 | 63 | -- | An 'Ap1' is a "non-empty" 'Ap'; this function "forgets" the non-empty 64 | -- property and turns it back into a normal 'Ap'. 65 | toAp :: Ap1 f ~> Ap f 66 | toAp (Ap1 x xs) = Ap x xs 67 | 68 | -- | Convert an 'Ap' into an 'Ap1' if possible. If the 'Ap' was "empty", 69 | -- return the 'Pure' value instead. 70 | fromAp :: Ap f ~> (Identity :+: Ap1 f) 71 | fromAp = \case 72 | Pure x -> L1 $ Identity x 73 | Ap x xs -> R1 $ Ap1 x xs 74 | 75 | -- | @since 0.3.0.0 76 | instance Invariant (Ap1 f) where 77 | invmap f _ = fmap f 78 | 79 | -- | An @'Ap1' f@ is just a @'Day' f ('Ap' f)@. This bidirectional pattern 80 | -- synonym lets you treat it as such. 81 | pattern DayAp1 :: Day f (Ap f) a -> Ap1 f a 82 | pattern DayAp1{ap1Day} <- (\case Ap1 x y -> Day x y (&) -> ap1Day) 83 | where 84 | DayAp1 (Day x y f) = Ap1 x (flip f <$> y) 85 | 86 | {-# COMPLETE DayAp1 #-} 87 | 88 | deriving instance Functor (Ap1 f) 89 | 90 | instance Apply (Ap1 f) where 91 | Ap1 x xs <.> ys = Ap1 x (flip <$> xs <*> toAp ys) 92 | 93 | -- | Embed an @f@ into 'Ap1'. 94 | liftAp1 :: f ~> Ap1 f 95 | liftAp1 x = Ap1 x (Pure id) 96 | 97 | -- | Extract the @f@ out of the 'Ap1'. 98 | -- 99 | -- @ 100 | -- 'retractAp1' . 'liftAp1' == id 101 | -- @ 102 | retractAp1 :: Apply f => Ap1 f ~> f 103 | retractAp1 (Ap1 x xs) = retractAp1_ x xs 104 | 105 | -- | Interpret an @'Ap' f@ into some 'Apply' context @g@. 106 | runAp1 :: 107 | Apply g => 108 | (f ~> g) -> 109 | Ap1 f ~> g 110 | runAp1 f (Ap1 x xs) = runAp1_ f x xs 111 | 112 | instance HFunctor Ap1 where 113 | hmap f (Ap1 x xs) = Ap1 (f x) (hmap f xs) 114 | 115 | instance Inject Ap1 where 116 | inject = liftAp1 117 | 118 | instance HBind Ap1 where 119 | hbind = runAp1 120 | 121 | instance HTraversable Ap1 where 122 | htraverse f (Ap1 x xs) = Ap1 <$> f x <*> htraverse f xs 123 | 124 | instance HTraversable1 Ap1 where 125 | htraverse1 f (Ap1 x xs) = traverseAp1_ f x xs 126 | 127 | traverseAp1_ :: 128 | forall f g h a b. 129 | Apply h => 130 | (forall x. f x -> h (g x)) -> 131 | f a -> 132 | Ap f (a -> b) -> 133 | h (Ap1 g b) 134 | traverseAp1_ f = go 135 | where 136 | go :: f x -> Ap f (x -> y) -> h (Ap1 g y) 137 | go x = \case 138 | Pure y -> (`Ap1` Pure y) <$> f x 139 | Ap y ys -> Ap1 <$> f x <.> (toAp <$> go y ys) 140 | 141 | instance Apply f => Interpret Ap1 f where 142 | retract = retractAp1 143 | interpret = runAp1 144 | 145 | retractAp1_ :: Apply f => f a -> Ap f (a -> b) -> f b 146 | retractAp1_ x = \case 147 | Pure y -> y <$> x 148 | Ap y ys -> (&) <$> x <.> retractAp1_ y ys 149 | 150 | runAp1_ :: 151 | forall f g a b. 152 | Apply g => 153 | (f ~> g) -> 154 | f a -> 155 | Ap f (a -> b) -> 156 | g b 157 | runAp1_ f = go 158 | where 159 | go :: f x -> Ap f (x -> y) -> g y 160 | go x = \case 161 | Pure y -> y <$> f x 162 | Ap y ys -> (&) <$> f x <.> go y ys 163 | -------------------------------------------------------------------------------- /src/Data/Functor/Combinator.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Functor.Combinator 3 | -- Copyright : (c) Justin Le 2025 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : justin@jle.im 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- Functor combinators and tools (typeclasses and utiility functions) to 11 | -- manipulate them. This is the main "entrypoint" of the library. 12 | -- 13 | -- Classes include: 14 | -- 15 | -- * 'HFunctor' and 'HBifunctor', used to swap out the functors that the 16 | -- combinators modify 17 | -- * 'Interpret', 'Associative', 'Tensor', used to inject and interpret 18 | -- functor values with respect to their combinators. 19 | -- 20 | -- We have some helpful utility functions, as well, built on top of these 21 | -- typeclasses. 22 | -- 23 | -- The second half of this module exports the various useful functor 24 | -- combinators that can modify functors to add extra functionality, or join 25 | -- two functors together and mix them in different ways. Use them to build 26 | -- your final structure by combining simpler ones in composable ways! 27 | -- 28 | -- See and the 29 | -- README for a tutorial and a rundown on each different functor 30 | -- combinator. 31 | module Data.Functor.Combinator ( 32 | -- * Classes 33 | 34 | -- | A lot of type signatures are stated in terms of '~>'. '~>' 35 | -- represents a "natural transformation" between two functors: a value of 36 | -- type @f '~>' g@ is a value of type 'f a -> g a@ that works for /any/ 37 | -- @a@. 38 | type (~>), 39 | type (<~>), 40 | 41 | -- ** Single Functors 42 | 43 | -- | Classes that deal with single-functor combinators, that enhance 44 | -- a single functor. 45 | HFunctor (..), 46 | Inject (..), 47 | Interpret (..), 48 | forI, 49 | iget, 50 | icollect, 51 | icollect1, 52 | iapply, 53 | ifanout, 54 | ifanout1, 55 | getI, 56 | collectI, 57 | injectMap, 58 | injectContramap, 59 | AltConst (..), 60 | 61 | -- ** 'HTraversable' 62 | HTraversable (..), 63 | hsequence, 64 | hfoldMap, 65 | htoList, 66 | HTraversable1 (..), 67 | hsequence1, 68 | hfoldMap1, 69 | htoNonEmpty, 70 | 71 | -- ** Multi-Functors 72 | 73 | -- | Classes that deal with two-functor combinators, that "mix" two 74 | -- functors together in some way. 75 | HBifunctor (..), 76 | 77 | -- *** Associative 78 | Associative (..), 79 | SemigroupIn (..), 80 | biget, 81 | biapply, 82 | -- , biget, bicollect, bicollect1 83 | (!*!), 84 | (!+!), 85 | (!$!), 86 | 87 | -- *** Tensor 88 | Tensor (..), 89 | MonoidIn (..), 90 | nilLB, 91 | consLB, 92 | inL, 93 | inR, 94 | outL, 95 | outR, 96 | 97 | -- * Combinators 98 | 99 | -- | Functor combinators 100 | -- ** Single 101 | Coyoneda (..), 102 | ListF (..), 103 | NonEmptyF (..), 104 | MaybeF (..), 105 | MapF (..), 106 | NEMapF (..), 107 | Ap, 108 | Ap1 (..), 109 | Alt, 110 | Free, 111 | Free1, 112 | Lift, 113 | Step (..), 114 | Steps (..), 115 | ProxyF (..), 116 | ConstF (..), 117 | EnvT (..), 118 | ReaderT (..), 119 | Flagged (..), 120 | IdentityT (..), 121 | Void2, 122 | Final (..), 123 | FreeOf (..), 124 | ComposeT (..), 125 | 126 | -- ** Multi 127 | Day (..), 128 | (:*:) (..), 129 | prodOutL, 130 | prodOutR, 131 | (:+:) (..), 132 | V1, 133 | These1 (..), 134 | Night (..), 135 | Not (..), 136 | refuted, 137 | Comp (Comp, unComp), 138 | LeftF (..), 139 | RightF (..), 140 | 141 | -- ** Combinator Combinators 142 | HLift (..), 143 | HFree (..), 144 | 145 | -- * Util 146 | 147 | -- ** Natural Transformations 148 | generalize, 149 | absorb, 150 | 151 | -- ** Divisible 152 | dsum, 153 | dsum1, 154 | concludeN, 155 | decideN, 156 | ) where 157 | 158 | import Control.Alternative.Free 159 | import Control.Applicative.Free 160 | import Control.Applicative.Lift 161 | import Control.Applicative.ListF 162 | import Control.Applicative.Step 163 | import Control.Comonad.Trans.Env 164 | import Control.Monad.Freer.Church 165 | import Control.Monad.Trans.Compose 166 | import Control.Monad.Trans.Identity 167 | import Control.Monad.Trans.Reader 168 | import Control.Natural 169 | import Control.Natural.IsoF 170 | import Data.Functor.Apply.Free 171 | import Data.Functor.Contravariant 172 | import Data.Functor.Contravariant.Conclude 173 | import Data.Functor.Contravariant.Decide 174 | import Data.Functor.Contravariant.Divise 175 | import Data.Functor.Contravariant.Divisible 176 | import Data.Functor.Coyoneda 177 | import Data.Functor.Day 178 | import Data.Functor.Invariant.Night 179 | import Data.Functor.These 180 | import Data.HBifunctor 181 | import Data.HBifunctor.Associative 182 | import Data.HBifunctor.Tensor 183 | import Data.HFunctor 184 | import Data.HFunctor.Final 185 | import Data.HFunctor.HTraversable 186 | import Data.HFunctor.Internal 187 | import Data.HFunctor.Interpret 188 | import qualified Data.SOP as SOP 189 | import GHC.Generics 190 | 191 | -- | Convenient helper function to build up a 'Divisible' by splitting 192 | -- input across many different @f a@s. Most useful when used alongside 193 | -- 'contramap': 194 | -- 195 | -- @ 196 | -- dsum [ 197 | -- contramap get1 x 198 | -- , contramap get2 y 199 | -- , contramap get3 z 200 | -- ] 201 | -- @ 202 | -- 203 | -- @since 0.3.3.0 204 | dsum :: 205 | (Foldable t, Divisible f) => 206 | t (f a) -> 207 | f a 208 | dsum = foldr (divide (\x -> (x, x))) conquer 209 | 210 | -- | Convenient helper function to build up a 'Conclude' by providing 211 | -- each component of it. This makes it much easier to build up longer 212 | -- chains as opposed to nested calls to 'decide' and manually peeling off 213 | -- eithers one-by-one. 214 | -- 215 | -- For example, if you had a data type 216 | -- 217 | -- @ 218 | -- data MyType = MTI Int | MTB Bool | MTS String 219 | -- @ 220 | -- 221 | -- and a contravariant consumer @Builder@ (representing, say, a way to 222 | -- serialize an item, where @intBuilder :: Builder Int@ is a serializer of 223 | -- 'Int's), then you could assemble a serializer a @MyType@ using: 224 | -- 225 | -- @ 226 | -- contramap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z)))) $ 227 | -- concludeN $ intBuilder 228 | -- :* boolBuilder 229 | -- :* stringBuilder 230 | -- :* Nil 231 | -- @ 232 | -- 233 | -- Some notes on usefulness depending on how many components you have: 234 | -- 235 | -- * If you have 0 components, use 'conclude'. 236 | -- * If you have 1 component, use 'inject' directly. 237 | -- * If you have 2 components, use 'decide' directly. 238 | -- * If you have 3 or more components, these combinators may be useful; 239 | -- otherwise you'd need to manually peel off eithers one-by-one. 240 | -- 241 | -- @since 0.3.0.0 242 | concludeN :: 243 | Conclude f => 244 | SOP.NP f as -> 245 | f (SOP.NS SOP.I as) 246 | concludeN = \case 247 | SOP.Nil -> conclude (\case {}) 248 | x SOP.:* xs -> 249 | decide 250 | (\case SOP.Z y -> Left (SOP.unI y); SOP.S ys -> Right ys) 251 | x 252 | (concludeN xs) 253 | 254 | -- | A version of 'concludeN' that works for non-empty 'SOP.NP'/'SOP.NS', 255 | -- and so only requires a 'Decide' constraint. 256 | -- 257 | -- @since 0.3.0.0 258 | decideN :: 259 | Decide f => 260 | SOP.NP f (a ': as) -> 261 | f (SOP.NS SOP.I (a ': as)) 262 | decideN = \case 263 | x SOP.:* xs -> case xs of 264 | SOP.Nil -> contramap (SOP.unI . SOP.unZ) x 265 | _ SOP.:* _ -> 266 | decide 267 | (\case SOP.Z z -> Left (SOP.unI z); SOP.S zs -> Right zs) 268 | x 269 | (decideN xs) 270 | -------------------------------------------------------------------------------- /src/Data/Functor/Combinator/Unsafe.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Functor.Combinator.Unsafe 3 | -- Copyright : (c) Justin Le 2025 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : justin@jle.im 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- Working with non-standard typeclasses like 'Plus', 'Apply', 'Bind', and 11 | -- 'Pointed' will sometimes cause problems when using with libraries that 12 | -- do not provide instances, even though their types already are instances 13 | -- of 'Alternative' or 'Applicative' or 'Monad'. 14 | -- 15 | -- This module provides unsafe methods to "promote" 'Applicative' instances 16 | -- to 'Apply', 'Alternative' to 'Plus', etc. 17 | -- 18 | -- They are unsafe in the sense that if those types /already/ have those 19 | -- instances, this will cause overlapping instances errors or problems with 20 | -- coherence. Because of this, you should always use these with /specific/ 21 | -- @f@s, and never in a polymorphic way over @f@. 22 | module Data.Functor.Combinator.Unsafe ( 23 | unsafePlus, 24 | unsafeApply, 25 | unsafeBind, 26 | unsafePointed, 27 | unsafeConclude, 28 | unsafeDivise, 29 | unsafeInvariantCo, 30 | unsafeInvariantContra, 31 | unsafeInplyCo, 32 | unsafeInplyContra, 33 | unsafeInplicativeCo, 34 | unsafeInplicativeContra, 35 | ) where 36 | 37 | import Control.Applicative 38 | import Data.Constraint 39 | import Data.Constraint.Unsafe 40 | import Data.Functor.Bind 41 | import Data.Functor.Contravariant 42 | import Data.Functor.Contravariant.Conclude 43 | import Data.Functor.Contravariant.Divise 44 | import Data.Functor.Contravariant.Divisible 45 | import Data.Functor.Invariant 46 | import Data.Functor.Invariant.Inplicative 47 | import Data.Functor.Plus 48 | import Data.Pointed 49 | 50 | -- | For any @'Alternative' f@, produce a value that would require @'Plus' 51 | -- f@. 52 | -- 53 | -- Always use with concrete and specific @f@ only, and never use with any 54 | -- @f@ that already has a 'Plus' instance. 55 | -- 56 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 57 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 58 | -- \@MyFunctor@. 59 | unsafePlus :: forall f proxy r. Alternative f => proxy f -> (Plus f => r) -> r 60 | unsafePlus _ x = case unsafeCoerceConstraint @(Plus (WrappedApplicative f)) @(Plus f) of 61 | Sub Dict -> x 62 | 63 | -- | For any @'Applicative' f@, produce a value that would require @'Apply' 64 | -- f@. 65 | -- 66 | -- Always use with concrete and specific @f@ only, and never use with any 67 | -- @f@ that already has a 'Apply' instance. 68 | -- 69 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 70 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 71 | -- \@MyFunctor@. 72 | unsafeApply :: forall f proxy r. Applicative f => proxy f -> (Apply f => r) -> r 73 | unsafeApply _ x = case unsafeCoerceConstraint @(Apply (WrappedApplicative f)) @(Apply f) of 74 | Sub Dict -> x 75 | 76 | -- | For any @'Monad' f@, produce a value that would require @'Bind' 77 | -- f@. 78 | -- 79 | -- Always use with concrete and specific @f@ only, and never use with any 80 | -- @f@ that already has a 'Bind' instance. 81 | -- 82 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 83 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 84 | -- \@MyFunctor@. 85 | unsafeBind :: forall f proxy r. Monad f => proxy f -> (Bind f => r) -> r 86 | unsafeBind _ x = case unsafeCoerceConstraint @(Bind (WrappedMonad f)) @(Bind f) of 87 | Sub Dict -> x 88 | 89 | newtype PointMe f a = PointMe (f a) 90 | 91 | instance Applicative f => Pointed (PointMe f) where 92 | point = PointMe . pure 93 | 94 | -- | For any @'Applicative' f@, produce a value that would require 95 | -- @'Pointed' f@. 96 | -- 97 | -- Always use with concrete and specific @f@ only, and never use with any 98 | -- @f@ that already has a 'Pointed' instance. 99 | -- 100 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 101 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 102 | -- \@MyFunctor@. 103 | unsafePointed :: forall f proxy r. Applicative f => proxy f -> (Pointed f => r) -> r 104 | unsafePointed _ x = case unsafeCoerceConstraint @(Pointed (PointMe f)) @(Pointed f) of 105 | Sub Dict -> x 106 | 107 | -- | For any @'Decidable' f@, produce a value that would require @'Conclude' 108 | -- f@. 109 | -- 110 | -- Always use with concrete and specific @f@ only, and never use with any 111 | -- @f@ that already has a 'Conclude' instance. 112 | -- 113 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 114 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 115 | -- \@MyFunctor@. 116 | -- 117 | -- @since 0.3.0.0 118 | unsafeConclude :: forall f proxy r. Decidable f => proxy f -> (Conclude f => r) -> r 119 | unsafeConclude _ x = case unsafeCoerceConstraint @(Conclude (WrappedDivisible f)) @(Conclude f) of 120 | Sub Dict -> x 121 | 122 | -- | For any @'Divisible' f@, produce a value that would require @'Divise' 123 | -- f@. 124 | -- 125 | -- Always use with concrete and specific @f@ only, and never use with any 126 | -- @f@ that already has a 'Divise' instance. 127 | -- 128 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 129 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 130 | -- \@MyFunctor@. 131 | -- 132 | -- @since 0.3.0.0 133 | unsafeDivise :: forall f proxy r. Divisible f => proxy f -> (Divise f => r) -> r 134 | unsafeDivise _ x = case unsafeCoerceConstraint @(Divise (WrappedDivisible f)) @(Divise f) of 135 | Sub Dict -> x 136 | 137 | -- | For any @'Functor' f@, produce a value that would require @'Invariant' 138 | -- f@. 139 | -- 140 | -- Always use with concrete and specific @f@ only, and never use with any 141 | -- @f@ that already has an 'Invariant' instance. 142 | -- 143 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 144 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 145 | -- \@MyFunctor@. 146 | -- 147 | -- @since 0.4.1.0 148 | unsafeInvariantCo :: forall f proxy r. Functor f => proxy f -> (Invariant f => r) -> r 149 | unsafeInvariantCo _ x = case unsafeCoerceConstraint @(Invariant (WrappedFunctor f)) @(Invariant f) of 150 | Sub Dict -> x 151 | 152 | -- | For any @'Contravariant' f@, produce a value that would require @'Invariant' 153 | -- f@. 154 | -- 155 | -- Always use with concrete and specific @f@ only, and never use with any 156 | -- @f@ that already has an 'Invariant' instance. 157 | -- 158 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 159 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 160 | -- \@MyFunctor@. 161 | -- 162 | -- @since 0.4.1.0 163 | unsafeInvariantContra :: forall f proxy r. Contravariant f => proxy f -> (Invariant f => r) -> r 164 | unsafeInvariantContra _ x = case unsafeCoerceConstraint @(Invariant (WrappedContravariant f)) @(Invariant f) of 165 | Sub Dict -> x 166 | 167 | -- | For any @'Apply' f@, produce a value that would require @'Inply' 168 | -- f@. 169 | -- 170 | -- Always use with concrete and specific @f@ only, and never use with any 171 | -- @f@ that already has an 'Inply' instance. 172 | -- 173 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 174 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 175 | -- \@MyFunctor@. 176 | -- 177 | -- @since 0.4.1.0 178 | unsafeInplyCo :: forall f proxy r. Apply f => proxy f -> (Inply f => r) -> r 179 | unsafeInplyCo _ x = case unsafeCoerceConstraint @(Inply (WrappedFunctor f)) @(Inply f) of 180 | Sub Dict -> x 181 | 182 | -- | For any @'Divise' f@, produce a value that would require @'Inply' 183 | -- f@. 184 | -- 185 | -- Always use with concrete and specific @f@ only, and never use with any 186 | -- @f@ that already has an 'Inply' instance. 187 | -- 188 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 189 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 190 | -- \@MyFunctor@. 191 | -- 192 | -- @since 0.4.1.0 193 | unsafeInplyContra :: forall f proxy r. Divise f => proxy f -> (Inply f => r) -> r 194 | unsafeInplyContra _ x = case unsafeCoerceConstraint @(Inply (WrappedContravariant f)) @(Inply f) of 195 | Sub Dict -> x 196 | 197 | -- | For any @'Applicative' f@, produce a value that would require 198 | -- @'Inplicative' f@. 199 | -- 200 | -- Always use with concrete and specific @f@ only, and never use with any 201 | -- @f@ that already has an 'Inplicative' instance. 202 | -- 203 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 204 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 205 | -- \@MyFunctor@. 206 | -- 207 | -- @since 0.4.1.0 208 | unsafeInplicativeCo :: 209 | forall f proxy r. (Applicative f, Invariant f) => proxy f -> (Inplicative f => r) -> r 210 | unsafeInplicativeCo _ x = case unsafeCoerceConstraint @(Inply (WrappedApplicativeOnly f)) @(Inplicative f) of 211 | Sub Dict -> x 212 | 213 | -- | For any @'Divisibl3' f@, produce a value that would require 214 | -- @'Inplicative' f@. 215 | -- 216 | -- Always use with concrete and specific @f@ only, and never use with any 217 | -- @f@ that already has an 'Inplicative' instance. 218 | -- 219 | -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ 220 | -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' 221 | -- \@MyFunctor@. 222 | -- 223 | -- @since 0.4.1.0 224 | unsafeInplicativeContra :: 225 | forall f proxy r. (Divisible f, Invariant f) => proxy f -> (Inplicative f => r) -> r 226 | unsafeInplicativeContra _ x = case unsafeCoerceConstraint @(Inply (WrappedDivisibleOnly f)) @(Inplicative f) of 227 | Sub Dict -> x 228 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Conclude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-deprecations #-} 4 | 5 | -- | 6 | -- Module : Data.Functor.Contravariant.Conclude 7 | -- Copyright : (c) Justin Le 2025 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : justin@jle.im 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | -- The contravariant counterpart of 'Data.Functor.Plus': like 'Decidable', 15 | -- but without needing a 'Divisible' constraint. This is only a part of 16 | -- this library currently for compatibility, until it is (hopefully) merged 17 | -- into /semigroupoids/. 18 | -- 19 | -- @since 0.3.0.0 20 | module Data.Functor.Contravariant.Conclude ( 21 | Conclude (..), 22 | concluded, 23 | ) where 24 | 25 | import Control.Applicative.Backwards 26 | import Control.Monad.Trans.Identity 27 | import Control.Monad.Trans.Maybe 28 | import qualified Control.Monad.Trans.RWS.Lazy as Lazy 29 | import qualified Control.Monad.Trans.RWS.Strict as Strict 30 | import Control.Monad.Trans.Reader 31 | import qualified Control.Monad.Trans.State.Lazy as Lazy 32 | import qualified Control.Monad.Trans.State.Strict as Strict 33 | import qualified Control.Monad.Trans.Writer.Lazy as Lazy 34 | import qualified Control.Monad.Trans.Writer.Strict as Strict 35 | 36 | import Data.Functor.Apply 37 | import Data.Functor.Compose 38 | import Data.Functor.Contravariant 39 | import Data.Functor.Contravariant.Decide 40 | import Data.Functor.Contravariant.Divise 41 | import Data.Functor.Contravariant.Divisible 42 | import Data.Functor.Product 43 | import Data.Functor.Reverse 44 | import Data.Void 45 | 46 | #if !MIN_VERSION_base(4,8,0) 47 | import Control.Applicative 48 | #endif 49 | 50 | #if MIN_VERSION_base(4,8,0) 51 | import Data.Monoid (Alt(..)) 52 | #else 53 | import Data.Monoid (Monoid(..)) 54 | #endif 55 | 56 | #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 57 | import Data.Proxy 58 | #endif 59 | 60 | #ifdef MIN_VERSION_StateVar 61 | import Data.StateVar 62 | #endif 63 | 64 | #if __GLASGOW_HASKELL__ >= 702 65 | #define GHC_GENERICS 66 | import GHC.Generics 67 | #endif 68 | 69 | #if !MIN_VERSION_transformers(0,6,0) 70 | import Control.Monad.Trans.List 71 | #endif 72 | 73 | -- | The contravariant analogue of 'Data.Functor.Plus.Plus'. Adds on to 74 | -- 'Decide' the ability to express a combinator that rejects all input, to 75 | -- act as the dead-end. Essentially 'Decidable' without a superclass 76 | -- constraint on 'Divisible'. 77 | -- 78 | -- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines 79 | -- a consumer that cannot ever receive /any/ input. 80 | -- 81 | -- Conclude acts as an identity with 'decide', because any decision that 82 | -- involves 'conclude' must necessarily /always/ pick the other option. 83 | -- 84 | -- That is, for, say, 85 | -- 86 | -- @ 87 | -- 'decide' f x 'concluded' 88 | -- @ 89 | -- 90 | -- @f@ is the deciding function that picks which of the inputs of @decide@ 91 | -- to direct input to; in the situation above, @f@ must /always/ direct all 92 | -- input to @x@, and never 'concluded'. 93 | -- 94 | -- Mathematically, a functor being an instance of 'Decide' means that it is 95 | -- "monoidal" with respect to the contravariant "either-based" Day 96 | -- convolution described in the documentation of 'Decide'. On top of 97 | -- 'Decide', it adds a way to construct an "identity" @conclude@ where 98 | -- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@. 99 | class Decide f => Conclude f where 100 | -- | The consumer that cannot ever receive /any/ input. 101 | conclude :: (a -> Void) -> f a 102 | 103 | -- | A potentially more meaningful form of 'conclude', the consumer that cannot 104 | -- ever receive /any/ input. That is because it expects only input of type 105 | -- 'Void', but such a type has no values. 106 | -- 107 | -- @ 108 | -- 'concluded' = 'conclude' 'id' 109 | -- @ 110 | concluded :: Conclude f => f Void 111 | concluded = conclude id 112 | 113 | instance Decidable f => Conclude (WrappedDivisible f) where 114 | conclude f = WrapDivisible (lose f) 115 | 116 | instance Conclude Comparison where conclude = lose 117 | instance Conclude Equivalence where conclude = lose 118 | instance Conclude Predicate where conclude = lose 119 | instance Conclude (Op r) where 120 | conclude f = Op $ absurd . f 121 | 122 | #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 123 | instance Conclude Proxy where conclude = lose 124 | #endif 125 | 126 | #ifdef MIN_VERSION_StateVar 127 | instance Conclude SettableStateVar where conclude = lose 128 | #endif 129 | 130 | #if MIN_VERSION_base(4,8,0) 131 | instance Conclude f => Conclude (Alt f) where 132 | conclude = Alt . conclude 133 | #endif 134 | 135 | #ifdef GHC_GENERICS 136 | instance Conclude U1 where conclude = lose 137 | 138 | instance Conclude f => Conclude (Rec1 f) where 139 | conclude = Rec1 . conclude 140 | 141 | instance Conclude f => Conclude (M1 i c f) where 142 | conclude = M1 . conclude 143 | 144 | instance (Conclude f, Conclude g) => Conclude (f :*: g) where 145 | conclude f = conclude f :*: conclude f 146 | 147 | instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where 148 | conclude = Comp1 . pure . conclude 149 | #endif 150 | 151 | instance Conclude f => Conclude (Backwards f) where 152 | conclude = Backwards . conclude 153 | 154 | instance Conclude f => Conclude (IdentityT f) where 155 | conclude = IdentityT . conclude 156 | 157 | instance Conclude m => Conclude (ReaderT r m) where 158 | conclude f = ReaderT $ \_ -> conclude f 159 | 160 | instance Conclude m => Conclude (Lazy.RWST r w s m) where 161 | conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f) 162 | 163 | instance Conclude m => Conclude (Strict.RWST r w s m) where 164 | conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f) 165 | 166 | #if !MIN_VERSION_transformers(0,6,0) 167 | instance (Divisible m, Divise m) => Conclude (ListT m) where 168 | conclude _ = ListT conquer 169 | #endif 170 | 171 | instance (Divisible m, Divise m) => Conclude (MaybeT m) where 172 | conclude _ = MaybeT conquer 173 | 174 | instance Conclude m => Conclude (Lazy.StateT s m) where 175 | conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f) 176 | 177 | instance Conclude m => Conclude (Strict.StateT s m) where 178 | conclude f = Strict.StateT $ \_ -> contramap fst (conclude f) 179 | 180 | instance Conclude m => Conclude (Lazy.WriterT w m) where 181 | conclude f = Lazy.WriterT $ contramap lazyFst (conclude f) 182 | 183 | instance Conclude m => Conclude (Strict.WriterT w m) where 184 | conclude f = Strict.WriterT $ contramap fst (conclude f) 185 | 186 | instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where 187 | conclude = Compose . pure . conclude 188 | 189 | instance (Conclude f, Conclude g) => Conclude (Product f g) where 190 | conclude f = Pair (conclude f) (conclude f) 191 | 192 | instance Conclude f => Conclude (Reverse f) where 193 | conclude = Reverse . conclude 194 | 195 | lazyFst :: (a, b) -> a 196 | lazyFst ~(a, _) = a 197 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Decide.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-deprecations #-} 4 | 5 | -- | 6 | -- Module : Data.Functor.Contravariant.Decide 7 | -- Copyright : (c) Justin Le 2025 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : justin@jle.im 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | -- The contravariant counterpart of 'Alt': like 'Decidable', but without 15 | -- 'Data.Functor.Contravariant.Divisible.loss' or a superclass constraint 16 | -- on 'Divisible'. This is only a part of this library currently for 17 | -- compatibility, until it is (hopefully) merged into /semigroupoids/. 18 | -- 19 | -- @since 0.3.0.0 20 | module Data.Functor.Contravariant.Decide ( 21 | Decide (..), 22 | decided, 23 | ) where 24 | 25 | import Control.Applicative.Backwards 26 | import Control.Monad.Trans.Identity 27 | import Control.Monad.Trans.Maybe 28 | import qualified Control.Monad.Trans.RWS.Lazy as Lazy 29 | import qualified Control.Monad.Trans.RWS.Strict as Strict 30 | import Control.Monad.Trans.Reader 31 | import qualified Control.Monad.Trans.State.Lazy as Lazy 32 | import qualified Control.Monad.Trans.State.Strict as Strict 33 | import qualified Control.Monad.Trans.Writer.Lazy as Lazy 34 | import qualified Control.Monad.Trans.Writer.Strict as Strict 35 | import Data.Functor.Apply 36 | import Data.Functor.Compose 37 | import Data.Functor.Contravariant 38 | import Data.Functor.Contravariant.Divise 39 | import Data.Functor.Contravariant.Divisible 40 | import Data.Functor.Product 41 | import Data.Functor.Reverse 42 | 43 | #if MIN_VERSION_base(4,8,0) 44 | import Data.Monoid (Alt(..)) 45 | #else 46 | import Data.Monoid (Monoid(..)) 47 | #endif 48 | 49 | #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 50 | import Data.Proxy 51 | #endif 52 | 53 | #ifdef MIN_VERSION_StateVar 54 | import Data.StateVar 55 | #endif 56 | 57 | #if __GLASGOW_HASKELL__ >= 702 58 | #define GHC_GENERICS 59 | import GHC.Generics 60 | #endif 61 | 62 | #if !MIN_VERSION_transformers(0,6,0) 63 | import Control.Monad.Trans.List 64 | import Control.Arrow 65 | import Data.Either 66 | #endif 67 | 68 | -- | The contravariant analogue of 'Alt'. 69 | -- 70 | -- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one 71 | -- to handle the consumption of a value by choosing to handle it via 72 | -- exactly one of two independent consumers. It redirects the input 73 | -- completely into one of two consumers. 74 | -- 75 | -- 'decide' takes the "decision" method and the two potential consumers, 76 | -- and returns the wrapped/combined consumer. 77 | -- 78 | -- Mathematically, a functor being an instance of 'Decide' means that it is 79 | -- "semgroupoidal" with respect to the contravariant "either-based" Day 80 | -- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@). 81 | -- That is, it is possible to define a function @(f `EitherDay` f) a -> 82 | -- f a@ in a way that is associative. 83 | class Contravariant f => Decide f where 84 | -- | Takes the "decision" method and the two potential consumers, and 85 | -- returns the wrapped/combined consumer. 86 | decide :: (a -> Either b c) -> f b -> f c -> f a 87 | 88 | -- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct 89 | -- 'Left's to be consumed by @x@, and 'Right's to be consumed by y. 90 | decided :: Decide f => f b -> f c -> f (Either b c) 91 | decided = decide id 92 | 93 | instance Decidable f => Decide (WrappedDivisible f) where 94 | decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y) 95 | 96 | instance Decide Comparison where decide = choose 97 | instance Decide Equivalence where decide = choose 98 | instance Decide Predicate where decide = choose 99 | 100 | -- | Unlike 'Decidable', requires no constraint on @r@ 101 | instance Decide (Op r) where 102 | decide f (Op g) (Op h) = Op $ either g h . f 103 | 104 | #if MIN_VERSION_base(4,8,0) 105 | instance Decide f => Decide (Alt f) where 106 | decide f (Alt l) (Alt r) = Alt $ decide f l r 107 | #endif 108 | 109 | #ifdef GHC_GENERICS 110 | instance Decide U1 where decide = choose 111 | instance Decide V1 where decide _ = \case {} 112 | 113 | instance Decide f => Decide (Rec1 f) where 114 | decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r 115 | 116 | instance Decide f => Decide (M1 i c f) where 117 | decide f (M1 l) (M1 r) = M1 $ decide f l r 118 | 119 | instance (Decide f, Decide g) => Decide (f :*: g) where 120 | decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2 121 | 122 | -- | Unlike 'Decidable', requires only 'Apply' on @f@. 123 | instance (Apply f, Decide g) => Decide (f :.: g) where 124 | decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r) 125 | #endif 126 | 127 | instance Decide f => Decide (Backwards f) where 128 | decide f (Backwards l) (Backwards r) = Backwards $ decide f l r 129 | 130 | instance Decide f => Decide (IdentityT f) where 131 | decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r 132 | 133 | instance Decide m => Decide (ReaderT r m) where 134 | decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r) 135 | 136 | instance Decide m => Decide (Lazy.RWST r w s m) where 137 | decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> 138 | decide 139 | ( \ ~(a, s', w) -> 140 | either 141 | (Left . betuple3 s' w) 142 | (Right . betuple3 s' w) 143 | (abc a) 144 | ) 145 | (rsmb r s) 146 | (rsmc r s) 147 | 148 | instance Decide m => Decide (Strict.RWST r w s m) where 149 | decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> 150 | decide 151 | ( \(a, s', w) -> 152 | either 153 | (Left . betuple3 s' w) 154 | (Right . betuple3 s' w) 155 | (abc a) 156 | ) 157 | (rsmb r s) 158 | (rsmc r s) 159 | 160 | #if !MIN_VERSION_transformers(0,6,0) 161 | instance Divise m => Decide (ListT m) where 162 | decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r 163 | #endif 164 | 165 | instance Divise m => Decide (MaybeT m) where 166 | decide f (MaybeT l) (MaybeT r) = 167 | MaybeT $ 168 | divise 169 | ( maybe 170 | (Nothing, Nothing) 171 | ( either 172 | (\b -> (Just b, Nothing)) 173 | (\c -> (Nothing, Just c)) 174 | . f 175 | ) 176 | ) 177 | l 178 | r 179 | 180 | instance Decide m => Decide (Lazy.StateT s m) where 181 | decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> 182 | decide 183 | (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) 184 | (l s) 185 | (r s) 186 | 187 | instance Decide m => Decide (Strict.StateT s m) where 188 | decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> 189 | decide 190 | (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) 191 | (l s) 192 | (r s) 193 | 194 | instance Decide m => Decide (Lazy.WriterT w m) where 195 | decide f (Lazy.WriterT l) (Lazy.WriterT r) = 196 | Lazy.WriterT $ 197 | decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r 198 | 199 | instance Decide m => Decide (Strict.WriterT w m) where 200 | decide f (Strict.WriterT l) (Strict.WriterT r) = 201 | Strict.WriterT $ 202 | decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r 203 | 204 | -- | Unlike 'Decidable', requires only 'Apply' on @f@. 205 | instance (Apply f, Decide g) => Decide (Compose f g) where 206 | decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r) 207 | 208 | instance (Decide f, Decide g) => Decide (Product f g) where 209 | decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2) 210 | 211 | instance Decide f => Decide (Reverse f) where 212 | decide f (Reverse l) (Reverse r) = Reverse $ decide f l r 213 | 214 | betuple :: s -> a -> (a, s) 215 | betuple s a = (a, s) 216 | 217 | betuple3 :: s -> w -> a -> (a, s, w) 218 | betuple3 s w a = (a, s, w) 219 | 220 | #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 221 | instance Decide Proxy where 222 | decide _ Proxy Proxy = Proxy 223 | #endif 224 | 225 | #ifdef MIN_VERSION_StateVar 226 | instance Decide SettableStateVar where 227 | decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of 228 | Left b -> l b 229 | Right c -> r c 230 | #endif 231 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Divise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-deprecations #-} 4 | 5 | -- | 6 | -- Module : Data.Functor.Contravariant.Divise 7 | -- Copyright : (c) Justin Le 2025 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : justin@jle.im 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | -- The contravariant counterpart of 'Apply': like 'Divisible', but without 15 | -- 'conquer'. This is only a part of this library currently for 16 | -- compatibility, until it is (hopefully) merged into /semigroupoids/. 17 | -- 18 | -- @since 0.3.0.0 19 | module Data.Functor.Contravariant.Divise ( 20 | Divise (..), 21 | (<:>), 22 | dsum1, 23 | WrappedDivisible (..), 24 | ) where 25 | 26 | import Control.Applicative 27 | import Control.Applicative.Backwards 28 | import Control.Arrow 29 | import Control.Monad.Trans.Except 30 | import Control.Monad.Trans.Identity 31 | import Control.Monad.Trans.Maybe 32 | import qualified Control.Monad.Trans.RWS.Lazy as Lazy 33 | import qualified Control.Monad.Trans.RWS.Strict as Strict 34 | import Control.Monad.Trans.Reader 35 | import qualified Control.Monad.Trans.State.Lazy as Lazy 36 | import qualified Control.Monad.Trans.State.Strict as Strict 37 | import qualified Control.Monad.Trans.Writer.Lazy as Lazy 38 | import qualified Control.Monad.Trans.Writer.Strict as Strict 39 | import Data.Deriving 40 | import Data.Functor.Apply 41 | import Data.Functor.Compose 42 | import Data.Functor.Constant 43 | import Data.Functor.Contravariant 44 | import Data.Functor.Contravariant.Divisible 45 | import Data.Functor.Invariant 46 | import Data.Functor.Product 47 | import Data.Functor.Reverse 48 | import qualified Data.Semigroup.Foldable as F1 49 | 50 | #if MIN_VERSION_base(4,8,0) 51 | import Data.Monoid (Alt(..)) 52 | #else 53 | import Data.Monoid (Monoid(..)) 54 | #endif 55 | 56 | #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,12,0) 57 | import Data.Semigroup (Semigroup(..)) 58 | #endif 59 | 60 | #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 61 | import Data.Proxy 62 | #endif 63 | 64 | #ifdef MIN_VERSION_StateVar 65 | import Data.StateVar 66 | #endif 67 | 68 | #if __GLASGOW_HASKELL__ >= 702 69 | #define GHC_GENERICS 70 | import GHC.Generics 71 | #endif 72 | 73 | #if !MIN_VERSION_transformers(0,6,0) 74 | import Control.Monad.Trans.Error 75 | import Control.Monad.Trans.List 76 | #endif 77 | 78 | -- | The contravariant analogue of 'Apply'; it is 79 | -- 'Divisible' without 'conquer'. 80 | -- 81 | -- If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one 82 | -- to handle the consumption of a value by splitting it between two 83 | -- consumers that consume separate parts of @a@. 84 | -- 85 | -- 'divise' takes the "splitting" method and the two sub-consumers, and 86 | -- returns the wrapped/combined consumer. 87 | -- 88 | -- All instances of 'Divisible' should be instances of 'Divise' with 89 | -- @'divise' = 'divide'@. 90 | -- 91 | -- The guarantee that a function polymorphic over of @'Divise' f@ provides 92 | -- that @'Divisible' f@ doesn't that any input consumed will be passed to at 93 | -- least one sub-consumer; it won't potentially disappear into the void, as 94 | -- is possible if 'conquer' is available. 95 | -- 96 | -- Mathematically, a functor being an instance of 'Divise' means that it is 97 | -- "semgroupoidal" with respect to the contravariant (tupling) Day 98 | -- convolution. That is, it is possible to define a function @(f `Day` f) 99 | -- a -> f a@ in a way that is associative. 100 | class Contravariant f => Divise f where 101 | -- | Takes a "splitting" method and the two sub-consumers, and 102 | -- returns the wrapped/combined consumer. 103 | divise :: (a -> (b, c)) -> f b -> f c -> f a 104 | divise f x y = contramap f (divised x y) 105 | 106 | -- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer 107 | -- of @(a, b)@. 108 | divised :: f a -> f b -> f (a, b) 109 | divised = divise id 110 | 111 | {-# MINIMAL divise | divised #-} 112 | 113 | -- | The Contravariant version of '<|>': split the same input over two 114 | -- different consumers. 115 | (<:>) :: Divise f => f a -> f a -> f a 116 | x <:> y = divise (\r -> (r, r)) x y 117 | 118 | -- | Convenient helper function to build up a 'Divise' by splitting 119 | -- input across many different @f a@s. Most useful when used alongside 120 | -- 'contramap': 121 | -- 122 | -- @ 123 | -- dsum1 $ contramap get1 x 124 | -- :| [ contramap get2 y 125 | -- , contramap get3 z 126 | -- ] 127 | -- @ 128 | -- 129 | -- @since 0.3.3.0 130 | dsum1 :: (F1.Foldable1 t, Divise f) => t (f a) -> f a 131 | dsum1 = foldr1 (<:>) . F1.toNonEmpty 132 | 133 | -- | Wrap a 'Divisible' to be used as a member of 'Divise' 134 | newtype WrappedDivisible f a = WrapDivisible {unwrapDivisible :: f a} 135 | deriving (Generic, Eq, Show, Ord, Read, Functor, Foldable, Traversable) 136 | deriving newtype (Divisible, Contravariant) 137 | 138 | deriveShow1 ''WrappedDivisible 139 | deriveRead1 ''WrappedDivisible 140 | deriveEq1 ''WrappedDivisible 141 | deriveOrd1 ''WrappedDivisible 142 | 143 | instance Contravariant f => Invariant (WrappedDivisible f) where 144 | invmap _ g (WrapDivisible x) = WrapDivisible (contramap g x) 145 | 146 | instance Divisible f => Divise (WrappedDivisible f) where 147 | divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y) 148 | 149 | #if MIN_VERSION_base(4,9,0) 150 | -- | Unlike 'Divisible', requires only 'Semigroup' on @r@. 151 | instance Semigroup r => Divise (Op r) where 152 | divise f (Op g) (Op h) = Op $ \a -> case f a of 153 | (b, c) -> g b <> h c 154 | 155 | -- | Unlike 'Divisible', requires only 'Semigroup' on @m@. 156 | instance Semigroup m => Divise (Const m) where 157 | divise _ (Const a) (Const b) = Const (a <> b) 158 | 159 | -- | Unlike 'Divisible', requires only 'Semigroup' on @m@. 160 | instance Semigroup m => Divise (Constant m) where 161 | divise _ (Constant a) (Constant b) = Constant (a <> b) 162 | #else 163 | instance Monoid r => Divise (Op r) where divise = divide 164 | instance Monoid m => Divise (Const m) where divise = divide 165 | instance Monoid m => Divise (Constant m) where divise = divide 166 | #endif 167 | 168 | instance Divise Comparison where divise = divide 169 | instance Divise Equivalence where divise = divide 170 | instance Divise Predicate where divise = divide 171 | 172 | #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 173 | instance Divise Proxy where divise = divide 174 | #endif 175 | 176 | #ifdef MIN_VERSION_StateVar 177 | instance Divise SettableStateVar where divise = divide 178 | #endif 179 | 180 | #if MIN_VERSION_base(4,8,0) 181 | instance Divise f => Divise (Alt f) where 182 | divise f (Alt l) (Alt r) = Alt $ divise f l r 183 | #endif 184 | 185 | #ifdef GHC_GENERICS 186 | instance Divise U1 where divise = divide 187 | instance Divise V1 where divise _ = \case {} 188 | 189 | instance Divise f => Divise (Rec1 f) where 190 | divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r 191 | 192 | instance Divise f => Divise (M1 i c f) where 193 | divise f (M1 l) (M1 r) = M1 $ divise f l r 194 | 195 | instance (Divise f, Divise g) => Divise (f :*: g) where 196 | divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2 197 | 198 | -- | Unlike 'Divisible', requires only 'Apply' on @f@. 199 | instance (Apply f, Divise g) => Divise (f :.: g) where 200 | divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r) 201 | #endif 202 | 203 | instance Divise f => Divise (Backwards f) where 204 | divise f (Backwards l) (Backwards r) = Backwards $ divise f l r 205 | 206 | instance Divise m => Divise (ExceptT e m) where 207 | divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r 208 | 209 | instance Divise f => Divise (IdentityT f) where 210 | divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r 211 | 212 | #if !MIN_VERSION_transformers(0,6,0) 213 | instance Divise m => Divise (ErrorT e m) where 214 | divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r 215 | 216 | instance Divise m => Divise (ListT m) where 217 | divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r 218 | #endif 219 | 220 | instance Divise m => Divise (MaybeT m) where 221 | divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r 222 | 223 | instance Divise m => Divise (ReaderT r m) where 224 | divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r) 225 | 226 | instance Divise m => Divise (Lazy.RWST r w s m) where 227 | divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> 228 | divise 229 | ( \ ~(a, s', w) -> case abc a of 230 | ~(b, c) -> ((b, s', w), (c, s', w)) 231 | ) 232 | (rsmb r s) 233 | (rsmc r s) 234 | 235 | instance Divise m => Divise (Strict.RWST r w s m) where 236 | divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> 237 | divise 238 | ( \(a, s', w) -> case abc a of 239 | (b, c) -> ((b, s', w), (c, s', w)) 240 | ) 241 | (rsmb r s) 242 | (rsmc r s) 243 | 244 | instance Divise m => Divise (Lazy.StateT s m) where 245 | divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> 246 | divise (lazyFanout f) (l s) (r s) 247 | 248 | instance Divise m => Divise (Strict.StateT s m) where 249 | divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> 250 | divise (strictFanout f) (l s) (r s) 251 | 252 | instance Divise m => Divise (Lazy.WriterT w m) where 253 | divise f (Lazy.WriterT l) (Lazy.WriterT r) = 254 | Lazy.WriterT $ 255 | divise (lazyFanout f) l r 256 | 257 | instance Divise m => Divise (Strict.WriterT w m) where 258 | divise f (Strict.WriterT l) (Strict.WriterT r) = 259 | Strict.WriterT $ 260 | divise (strictFanout f) l r 261 | 262 | -- | Unlike 'Divisible', requires only 'Apply' on @f@. 263 | instance (Apply f, Divise g) => Divise (Compose f g) where 264 | divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r) 265 | 266 | instance (Divise f, Divise g) => Divise (Product f g) where 267 | divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2) 268 | 269 | instance Divise f => Divise (Reverse f) where 270 | divise f (Reverse l) (Reverse r) = Reverse $ divise f l r 271 | 272 | lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) 273 | lazyFanout f ~(a, s) = case f a of 274 | ~(b, c) -> ((b, s), (c, s)) 275 | 276 | strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) 277 | strictFanout f (a, s) = case f a of 278 | (b, c) -> ((b, s), (c, s)) 279 | 280 | funzip :: Functor f => f (a, b) -> (f a, f b) 281 | funzip = fmap fst &&& fmap snd 282 | 283 | -- TODO: WrappedContravariant 284 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Divisible/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | -- | 4 | -- Module : Data.Functor.Contravariant.Divisible.Free 5 | -- Copyright : (c) Justin Le 2025 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : justin@jle.im 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | -- Provides free structures for the various typeclasses of the 'Divisible' 13 | -- hierarchy. 14 | -- 15 | -- @since 0.3.0.0 16 | module Data.Functor.Contravariant.Divisible.Free ( 17 | Div (.., Conquer, Divide), 18 | hoistDiv, 19 | liftDiv, 20 | runDiv, 21 | divListF, 22 | listFDiv, 23 | Div1 (.., Div1_), 24 | hoistDiv1, 25 | liftDiv1, 26 | toDiv, 27 | runDiv1, 28 | div1NonEmptyF, 29 | nonEmptyFDiv1, 30 | Dec (..), 31 | hoistDec, 32 | liftDec, 33 | runDec, 34 | Dec1 (..), 35 | hoistDec1, 36 | liftDec1, 37 | toDec, 38 | runDec1, 39 | ) where 40 | 41 | import Control.Applicative.ListF 42 | import qualified Control.Monad.Trans.Compose as CT 43 | import Control.Natural 44 | import Data.Bifunctor 45 | import Data.Bifunctor.Assoc 46 | import Data.Foldable 47 | import Data.Functor.Apply 48 | import Data.Functor.Contravariant 49 | import Data.Functor.Contravariant.Conclude 50 | import Data.Functor.Contravariant.Coyoneda 51 | import qualified Data.Functor.Contravariant.Day as CD 52 | import Data.Functor.Contravariant.Decide 53 | import Data.Functor.Contravariant.Divise 54 | import Data.Functor.Contravariant.Divisible 55 | import Data.Functor.Invariant 56 | import Data.Functor.Invariant.Inplicative 57 | import Data.Functor.Invariant.Internative 58 | import Data.HFunctor 59 | import Data.HFunctor.HTraversable 60 | import Data.HFunctor.Interpret 61 | import Data.Kind 62 | import Data.List.NonEmpty (NonEmpty (..)) 63 | import Data.Semigroup.Traversable 64 | import Data.Void 65 | 66 | -- | The free 'Divisible'. Used to sequence multiple contravariant 67 | -- consumers, splitting out the input across all consumers. 68 | -- 69 | -- This type is essentially 'ListF'; the only reason why it has to exist 70 | -- separately outside of 'ListF' is because the current typeclass hierarchy 71 | -- isn't compatible with both the covariant 'Interpret' instance (requiring 72 | -- 'Plus') and the contravariant 'Interpret' instance (requiring 73 | -- 'Divisible'). 74 | -- 75 | -- The wrapping in 'Coyoneda' is also to provide a usable 76 | -- 'Data.HBifunctor.Associative.Associative' instance for the contravariant 77 | -- 'CD.Day'. 78 | newtype Div f a = Div {unDiv :: [Coyoneda f a]} 79 | deriving (Contravariant, Divise, Divisible) via (ListF (Coyoneda f)) 80 | deriving (HFunctor, Inject) via (CT.ComposeT ListF Coyoneda) 81 | 82 | instance HTraversable Div where 83 | htraverse f (Div xs) = Div <$> traverse (htraverse f) xs 84 | 85 | instance Invariant (Div f) where 86 | invmap _ = contramap 87 | 88 | deriving via WrappedDivisible (Div f) instance Inply (Div f) 89 | deriving via WrappedDivisible (Div f) instance Inplicative (Div f) 90 | 91 | -- | Pattern matching on an empty 'Div'. 92 | -- 93 | -- Before v0.3.3.0, this used to be the concrete constructor of 'Div'. 94 | -- After, it is now an abstract pattern. 95 | pattern Conquer :: Div f a 96 | pattern Conquer = Div [] 97 | 98 | -- | Pattern matching on a non-empty 'Div', exposing the raw @f@ instead of 99 | -- having it wrapped in a 'Coyoneda'. This is the analogue of 100 | -- 'Control.Applicative.Free.Pure' and essentially treats the "cons" of the 101 | -- 'Div' as a contravariant day convolution. 102 | -- 103 | -- Before v0.3.3.0, this used to be the concrete constructor of 'Div'. 104 | -- After, it is now an abstract pattern. 105 | pattern Divide :: (a -> (b, c)) -> f b -> Div f c -> Div f a 106 | pattern Divide f x xs <- (divDay_ -> Just (CD.Day x xs f)) 107 | where 108 | Divide f x (Div xs) = Div $ Coyoneda (fst . f) x : (map . contramap) (snd . f) xs 109 | 110 | {-# COMPLETE Conquer, Divide #-} 111 | 112 | divDay_ :: Div f a -> Maybe (CD.Day f (Div f) a) 113 | divDay_ (Div []) = Nothing 114 | divDay_ (Div (Coyoneda f x : xs)) = Just $ CD.Day x (Div xs) (\y -> (f y, y)) 115 | 116 | -- | 'Div' is isomorphic to 'ListF' for contravariant @f@. This witnesses 117 | -- one way of that isomorphism. 118 | divListF :: forall f. Contravariant f => Div f ~> ListF f 119 | divListF = ListF . map lowerCoyoneda . unDiv 120 | 121 | -- | 'Div' is isomorphic to 'ListF' for contravariant @f@. This witnesses 122 | -- one way of that isomorphism. 123 | listFDiv :: ListF f ~> Div f 124 | listFDiv = Div . map liftCoyoneda . runListF 125 | 126 | -- | Map over the undering context in a 'Div'. 127 | hoistDiv :: forall f g. (f ~> g) -> Div f ~> Div g 128 | hoistDiv = hmap 129 | 130 | -- | Inject a single action in @f@ into a @'Div' f@. 131 | liftDiv :: f ~> Div f 132 | liftDiv = inject 133 | 134 | -- | Interpret a 'Div' into a context @g@, provided @g@ is 'Divisible'. 135 | runDiv :: forall f g. Divisible g => (f ~> g) -> Div f ~> g 136 | runDiv f = foldr go conquer . unDiv 137 | where 138 | go (Coyoneda g x) = divide (\y -> (y, y)) (contramap g (f x)) 139 | 140 | instance Divisible f => Interpret Div f where 141 | interpret = runDiv 142 | 143 | -- | The free 'Divise': a non-empty version of 'Div'. 144 | -- 145 | -- This type is essentially 'NonEmptyF'; the only reason why it has to exist 146 | -- separately outside of 'NonEmptyF' is because the current typeclass 147 | -- hierarchy isn't compatible with both the covariant 'Interpret' instance 148 | -- (requiring 'Plus') and the contravariant 'Interpret' instance (requiring 149 | -- 'Divisible'). 150 | -- 151 | -- The wrapping in 'Coyoneda' is also to provide a usable 152 | -- 'Data.HBifunctor.Associative.Associative' instance for the contravariant 153 | -- 'CD.Day'. 154 | newtype Div1 f a = Div1 {unDiv1 :: NonEmpty (Coyoneda f a)} 155 | deriving (Contravariant, Divise) via (NonEmptyF (Coyoneda f)) 156 | deriving (HFunctor, Inject) via (CT.ComposeT NonEmptyF Coyoneda) 157 | 158 | instance HTraversable Div1 where 159 | htraverse f (Div1 xs) = Div1 <$> traverse (htraverse f) xs 160 | 161 | instance HTraversable1 Div1 where 162 | htraverse1 f (Div1 xs) = Div1 <$> traverse1 (htraverse1 f) xs 163 | 164 | instance Invariant (Div1 f) where 165 | invmap _ = contramap 166 | 167 | deriving via WrappedDivisible (Div1 f) instance Inply (Div1 f) 168 | 169 | instance Divise f => Interpret Div1 f where 170 | interpret = runDiv1 171 | 172 | -- | Pattern matching on a 'Div1', exposing the raw @f@ instead of 173 | -- having it wrapped in a 'Coyoneda'. This is the analogue of 174 | -- 'Data.Functor.Apply.Ap1' and essentially treats the "cons" of the 175 | -- 'Div1' as a contravariant day convolution. 176 | -- 177 | -- Before v0.3.3.0, this used to be the concrete constructor of 'Div1'. 178 | -- After, it is now an abstract pattern. 179 | -- 180 | -- @since 0.3.3.0 181 | pattern Div1_ :: (a -> (b, c)) -> f b -> Div f c -> Div1 f a 182 | pattern Div1_ f x xs <- (div1_ -> CD.Day x xs f) 183 | where 184 | Div1_ f x (Div xs) = Div1 $ Coyoneda (fst . f) x :| (map . contramap) (snd . f) xs 185 | 186 | {-# COMPLETE Div1_ #-} 187 | 188 | div1_ :: Div1 f ~> CD.Day f (Div f) 189 | div1_ (Div1 (Coyoneda g x :| xs)) = CD.Day x (Div xs) (\y -> (g y, y)) 190 | 191 | -- | A 'Div1' is a "non-empty" 'Div'; this function "forgets" the non-empty 192 | -- property and turns it back into a normal 'Div'. 193 | toDiv :: Div1 f ~> Div f 194 | toDiv = Div . toList . unDiv1 195 | 196 | -- | Map over the underlying context in a 'Div1'. 197 | hoistDiv1 :: (f ~> g) -> Div1 f ~> Div1 g 198 | hoistDiv1 = hmap 199 | 200 | -- | Inject a single action in @f@ into a @'Div' f@. 201 | liftDiv1 :: f ~> Div1 f 202 | liftDiv1 = inject 203 | 204 | -- | Interpret a 'Div1' into a context @g@, provided @g@ is 'Divise'. 205 | runDiv1 :: Divise g => (f ~> g) -> Div1 f ~> g 206 | runDiv1 f = foldr1 (divise (\y -> (y, y))) . fmap go . unDiv1 207 | where 208 | go (Coyoneda g x) = contramap g (f x) 209 | 210 | -- | 'Div1' is isomorphic to 'NonEmptyF' for contravariant @f@. This 211 | -- witnesses one way of that isomorphism. 212 | div1NonEmptyF :: Contravariant f => Div1 f ~> NonEmptyF f 213 | div1NonEmptyF = NonEmptyF . fmap lowerCoyoneda . unDiv1 214 | 215 | -- | 'Div1' is isomorphic to 'NonEmptyF' for contravariant @f@. This 216 | -- witnesses one way of that isomorphism. 217 | nonEmptyFDiv1 :: NonEmptyF f ~> Div1 f 218 | nonEmptyFDiv1 = Div1 . fmap liftCoyoneda . runNonEmptyF 219 | 220 | -- | The free 'Decide'. Used to aggregate multiple possible consumers, 221 | -- directing the input into an appropriate consumer. 222 | data Dec :: (Type -> Type) -> Type -> Type where 223 | Lose :: (a -> Void) -> Dec f a 224 | Choose :: (a -> Either b c) -> f b -> Dec f c -> Dec f a 225 | 226 | instance Contravariant (Dec f) where 227 | contramap f = \case 228 | Lose g -> Lose (g . f) 229 | Choose g x xs -> Choose (g . f) x xs 230 | instance Invariant (Dec f) where 231 | invmap _ = contramap 232 | deriving via WrappedDivisible (Dec f) instance Inalt (Dec f) 233 | deriving via WrappedDivisible (Dec f) instance Inplus (Dec f) 234 | instance Decide (Dec f) where 235 | decide f = \case 236 | Lose g -> contramap (either (absurd . g) id . f) 237 | Choose g x xs -> 238 | Choose (assoc . first g . f) x 239 | . decide id xs 240 | instance Conclude (Dec f) where 241 | conclude = Lose 242 | instance HFunctor Dec where 243 | hmap = hoistDec 244 | instance Inject Dec where 245 | inject = liftDec 246 | instance Conclude f => Interpret Dec f where 247 | interpret = runDec 248 | 249 | instance HTraversable Dec where 250 | htraverse :: forall f g h a. Applicative h => (forall x. f x -> h (g x)) -> Dec f a -> h (Dec g a) 251 | htraverse f = go 252 | where 253 | go :: Dec f b -> h (Dec g b) 254 | go = \case 255 | Lose v -> pure (Lose v) 256 | Choose g x xs -> Choose g <$> f x <*> go xs 257 | 258 | -- | Map over the underlying context in a 'Dec'. 259 | hoistDec :: forall f g. (f ~> g) -> Dec f ~> Dec g 260 | hoistDec f = go 261 | where 262 | go :: Dec f ~> Dec g 263 | go = \case 264 | Lose g -> Lose g 265 | Choose g x xs -> Choose g (f x) (go xs) 266 | 267 | -- | Inject a single action in @f@ into a @'Dec' f@. 268 | liftDec :: f ~> Dec f 269 | liftDec x = Choose Left x (Lose id) 270 | 271 | -- | Interpret a 'Dec' into a context @g@, provided @g@ is 'Conclude'. 272 | runDec :: forall f g. Conclude g => (f ~> g) -> Dec f ~> g 273 | runDec f = go 274 | where 275 | go :: Dec f ~> g 276 | go = \case 277 | Lose g -> conclude g 278 | Choose g x xs -> decide g (f x) (go xs) 279 | 280 | -- | The free 'Decide': a non-empty version of 'Dec'. 281 | data Dec1 :: (Type -> Type) -> Type -> Type where 282 | Dec1 :: (a -> Either b c) -> f b -> Dec f c -> Dec1 f a 283 | 284 | -- | A 'Dec1' is a "non-empty" 'Dec'; this function "forgets" the non-empty 285 | -- property and turns it back into a normal 'Dec'. 286 | toDec :: Dec1 f a -> Dec f a 287 | toDec (Dec1 f x xs) = Choose f x xs 288 | 289 | instance Contravariant (Dec1 f) where 290 | contramap f (Dec1 g x xs) = Dec1 (g . f) x xs 291 | instance Invariant (Dec1 f) where 292 | invmap _ = contramap 293 | deriving via WrappedDivisible (Dec1 f) instance Inalt (Dec1 f) 294 | instance Decide (Dec1 f) where 295 | decide f (Dec1 g x xs) = 296 | Dec1 (assoc . first g . f) x 297 | . decide id xs 298 | . toDec 299 | instance HFunctor Dec1 where 300 | hmap = hoistDec1 301 | instance Inject Dec1 where 302 | inject = liftDec1 303 | instance Decide f => Interpret Dec1 f where 304 | interpret = runDec1 305 | 306 | instance HTraversable Dec1 where 307 | htraverse f (Dec1 g x xs) = Dec1 g <$> f x <*> htraverse f xs 308 | 309 | instance HTraversable1 Dec1 where 310 | htraverse1 f (Dec1 g x xs) = traverseDec1_ f g x xs 311 | 312 | -- | Map over the undering context in a 'Dec1'. 313 | hoistDec1 :: forall f g. (f ~> g) -> Dec1 f ~> Dec1 g 314 | hoistDec1 f (Dec1 g x xs) = Dec1 g (f x) (hoistDec f xs) 315 | 316 | -- | Inject a single action in @f@ into a @'Dec1' f@. 317 | liftDec1 :: f ~> Dec1 f 318 | liftDec1 x = Dec1 Left x (Lose id) 319 | 320 | -- | Interpret a 'Dec1' into a context @g@, provided @g@ is 'Decide'. 321 | runDec1 :: Decide g => (f ~> g) -> Dec1 f ~> g 322 | runDec1 f (Dec1 g x xs) = runDec1_ f g x xs 323 | 324 | runDec1_ :: 325 | forall f g a b c. 326 | Decide g => 327 | (f ~> g) -> 328 | (a -> Either b c) -> 329 | f b -> 330 | Dec f c -> 331 | g a 332 | runDec1_ f = go 333 | where 334 | go :: (x -> Either y z) -> f y -> Dec f z -> g x 335 | go g x = \case 336 | Lose h -> contramap (either id (absurd . h) . g) (f x) 337 | Choose h y ys -> decide g (f x) (go h y ys) 338 | 339 | traverseDec1_ :: 340 | forall f g h a b c. 341 | Apply h => 342 | (forall x. f x -> h (g x)) -> 343 | (a -> Either b c) -> 344 | f b -> 345 | Dec f c -> 346 | h (Dec1 g a) 347 | traverseDec1_ f = go 348 | where 349 | go :: (x -> Either y z) -> f y -> Dec f z -> h (Dec1 g x) 350 | go g x = \case 351 | Lose h -> (\x' -> Dec1 g x' (Lose h)) <$> f x 352 | Choose h y ys -> Dec1 g <$> f x <.> (toDec <$> go h y ys) 353 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Night.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Functor.Contravariant.Night 3 | -- Copyright : (c) Justin Le 2025 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : justin@jle.im 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- Provides 'Night', a form of the day convolution that is contravariant 11 | -- and splits on 'Either'. 12 | -- 13 | -- @since 0.3.0.0 14 | module Data.Functor.Contravariant.Night ( 15 | Night (..), 16 | night, 17 | runNight, 18 | necide, 19 | assoc, 20 | unassoc, 21 | swapped, 22 | trans1, 23 | trans2, 24 | intro1, 25 | intro2, 26 | elim1, 27 | elim2, 28 | Not (..), 29 | refuted, 30 | ) where 31 | 32 | import Control.Natural 33 | import Data.Bifunctor 34 | import qualified Data.Bifunctor.Assoc as B 35 | import qualified Data.Bifunctor.Swap as B 36 | import Data.Functor.Contravariant 37 | import Data.Functor.Contravariant.Decide 38 | import Data.Functor.Invariant 39 | import Data.Kind 40 | import Data.Void 41 | 42 | -- | A pairing of contravariant functors to create a new contravariant 43 | -- functor that represents the "choice" between the two. 44 | -- 45 | -- A @'Night' f g a@ is a contravariant "consumer" of @a@, and it does this 46 | -- by either feeding the @a@ to @f@, or feeding the @a@ to @g@. Which one 47 | -- it gives it to happens at runtime depending /what/ @a@ is actually 48 | -- given. 49 | -- 50 | -- For example, if we have @x :: f a@ (a consumer of @a@s) and @y :: g b@ 51 | -- (a consumer of @b@s), then @'night' x y :: 'Night' f g ('Either' a b)@. 52 | -- This is a consumer of @'Either' a b@s, and it consumes 'Left' branches 53 | -- by feeding it to @x@, and 'Right' branches by feeding it to @y@. 54 | -- 55 | -- Mathematically, this is a contravariant day convolution, except with 56 | -- a different choice of bifunctor ('Either') than the typical one we talk 57 | -- about in Haskell (which uses @(,)@). Therefore, it is an alternative to 58 | -- the typical 'Data.Functor.Day' convolution --- hence, the name 'Night'. 59 | data Night :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) where 60 | Night :: 61 | f b -> 62 | g c -> 63 | (a -> Either b c) -> 64 | Night f g a 65 | 66 | instance Contravariant (Night f g) where 67 | contramap f (Night x y g) = Night x y (g . f) 68 | 69 | instance Invariant (Night f g) where 70 | invmap _ f (Night x y g) = Night x y (g . f) 71 | 72 | -- | Inject into a 'Night'. 73 | -- 74 | -- @'night' x y@ is a consumer of @'Either' a b@; 'Left' will be passed 75 | -- to @x@, and 'Right' will be passed to @y@. 76 | night :: 77 | f a -> 78 | g b -> 79 | Night f g (Either a b) 80 | night x y = Night x y id 81 | 82 | -- | Interpret out of a 'Night' into any instance of 'Decide' by providing 83 | -- two interpreting functions. 84 | runNight :: 85 | Decide h => 86 | (f ~> h) -> 87 | (g ~> h) -> 88 | Night f g ~> h 89 | runNight f g (Night x y z) = decide z (f x) (g y) 90 | 91 | -- | Squash the two items in a 'Night' using their natural 'Decide' 92 | -- instances. 93 | -- 94 | -- @since 0.4.0.0 95 | necide :: 96 | Decide f => 97 | Night f f ~> f 98 | necide (Night x y z) = decide z x y 99 | 100 | -- | 'Night' is associative. 101 | assoc :: Night f (Night g h) ~> Night (Night f g) h 102 | assoc (Night x (Night y z f) g) = Night (Night x y id) z (B.unassoc . second f . g) 103 | 104 | -- | 'Night' is associative. 105 | unassoc :: Night (Night f g) h ~> Night f (Night g h) 106 | unassoc (Night (Night x y f) z g) = Night x (Night y z id) (B.assoc . first f . g) 107 | 108 | -- | The two sides of a 'Night' can be swapped. 109 | swapped :: Night f g ~> Night g f 110 | swapped (Night x y f) = Night y x (B.swap . f) 111 | 112 | -- | Hoist a function over the left side of a 'Night'. 113 | trans1 :: f ~> h -> Night f g ~> Night h g 114 | trans1 f (Night x y z) = Night (f x) y z 115 | 116 | -- | Hoist a function over the right side of a 'Night'. 117 | trans2 :: g ~> h -> Night f g ~> Night f h 118 | trans2 f (Night x y z) = Night x (f y) z 119 | 120 | -- | A value of type @'Not' a@ is "proof" that @a@ is uninhabited. 121 | newtype Not a = Not {refute :: a -> Void} 122 | 123 | -- | A useful shortcut for a common usage: 'Void' is always not so. 124 | -- 125 | -- @since 0.3.1.0 126 | refuted :: Not Void 127 | refuted = Not id 128 | 129 | instance Contravariant Not where 130 | contramap f (Not g) = Not (g . f) 131 | 132 | -- | @since 0.3.1.0 133 | instance Invariant Not where 134 | invmap _ = contramap 135 | 136 | instance Semigroup (Not a) where 137 | Not f <> Not g = Not (f <> g) 138 | 139 | -- | The left identity of 'Night' is 'Not'; this is one side of that 140 | -- isomorphism. 141 | intro1 :: g ~> Night Not g 142 | intro1 x = Night refuted x Right 143 | 144 | -- | The right identity of 'Night' is 'Not'; this is one side of that 145 | -- isomorphism. 146 | intro2 :: f ~> Night f Not 147 | intro2 x = Night x refuted Left 148 | 149 | -- | The left identity of 'Night' is 'Not'; this is one side of that 150 | -- isomorphism. 151 | elim1 :: Contravariant g => Night Not g ~> g 152 | elim1 (Night x y z) = contramap (either (absurd . refute x) id . z) y 153 | 154 | -- | The right identity of 'Night' is 'Not'; this is one side of that 155 | -- isomorphism. 156 | elim2 :: Contravariant f => Night f Not ~> f 157 | elim2 (Night x y z) = contramap (either id (absurd . refute y) . z) x 158 | -------------------------------------------------------------------------------- /src/Data/Functor/Invariant/Inplicative/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | -- | 5 | -- Module : Data.Functor.Invariant.Inplicative.Free 6 | -- Copyright : (c) Justin Le 2025 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : justin@jle.im 10 | -- Stability : experimental 11 | -- Portability : non-portable 12 | -- 13 | -- Provide an invariant functor combinator sequencer, like a combination of 14 | -- 'Ap' and 'Div'. 15 | -- 16 | -- This module was named 'Data.Functor.Invariant.DecAlt' before v0.4.0.0 17 | -- 18 | -- @since 0.4.0.0 19 | module Data.Functor.Invariant.Inplicative.Free ( 20 | -- * Chain 21 | DivAp (.., Gather, Knot), 22 | runCoDivAp, 23 | runContraDivAp, 24 | divApAp, 25 | divApDiv, 26 | foldDivAp, 27 | assembleDivAp, 28 | assembleDivApRec, 29 | 30 | -- * Nonempty Chain 31 | DivAp1 (.., DivAp1), 32 | runCoDivAp1, 33 | runContraDivAp1, 34 | divApAp1, 35 | divApDiv1, 36 | foldDivAp1, 37 | assembleDivAp1, 38 | assembleDivAp1Rec, 39 | ) where 40 | 41 | #if !MIN_VERSION_base(4,17,0) 42 | import Control.Applicative (liftA2) 43 | #endif 44 | import Control.Applicative.Free (Ap (..)) 45 | import Control.Applicative.ListF (MaybeF (..)) 46 | import Control.Natural 47 | import Data.Coerce 48 | import Data.Functor.Apply 49 | import Data.Functor.Apply.Free (Ap1 (..)) 50 | import Data.Functor.Contravariant.Divise 51 | import Data.Functor.Contravariant.Divisible 52 | import Data.Functor.Contravariant.Divisible.Free (Div (..), Div1) 53 | import Data.Functor.Identity 54 | import Data.Functor.Invariant 55 | import Data.Functor.Invariant.Day 56 | import Data.Functor.Invariant.Inplicative 57 | import Data.HBifunctor.Tensor hiding (elim1, elim2, intro1, intro2) 58 | import Data.HFunctor 59 | import Data.HFunctor.Chain 60 | import Data.HFunctor.Chain.Internal 61 | import Data.HFunctor.Interpret 62 | import Data.SOP hiding (hmap) 63 | import qualified Data.Vinyl as V 64 | import qualified Data.Vinyl.Functor as V 65 | 66 | -- | In the covariant direction, we can interpret into any 'Apply'. 67 | -- 68 | -- In theory, this shouldn't never be necessary, because you should just be 69 | -- able to use 'interpret', since any instance of 'Apply' is also an instance 70 | -- of 'Inply'. However, this can be handy if you are using an instance of 71 | -- 'Apply' that has no 'Inply' instance. Consider also 'unsafeInplyCo' if 72 | -- you are using a specific, concrete type for @g@. 73 | runCoDivAp1 :: 74 | forall f g. 75 | Apply g => 76 | f ~> g -> 77 | DivAp1 f ~> g 78 | runCoDivAp1 f = foldDivAp1 f (runDayApply f id) 79 | 80 | -- | In the contravariant direction, we can interpret into any 'Divise'. 81 | -- 82 | -- In theory, this shouldn't never be necessary, because you should just be 83 | -- able to use 'interpret', since any instance of 'Divise' is also an instance 84 | -- of 'Inply'. However, this can be handy if you are using an instance of 85 | -- 'Divise' that has no 'Inply' instance. Consider also 86 | -- 'unsafeInplyContra' if you are using a specific, concrete type for @g@. 87 | runContraDivAp1 :: 88 | forall f g. 89 | Divise g => 90 | f ~> g -> 91 | DivAp1 f ~> g 92 | runContraDivAp1 f = foldDivAp1 f (runDayDivise f id) 93 | 94 | -- | In the covariant direction, we can interpret into any 'Applicative'. 95 | -- 96 | -- In theory, this shouldn't never be necessary, because you should just be 97 | -- able to use 'interpret', since any instance of 'Applicative' is also an 98 | -- instance of 'Inplicative'. However, this can be handy if you are using 99 | -- an instance of 'Applicative' that has no 'Inplicative' instance. 100 | -- Consider also 'unsafeInplicativeCo' if you are using a specific, 101 | -- concrete type for @g@. 102 | runCoDivAp :: 103 | forall f g. 104 | Applicative g => 105 | f ~> g -> 106 | DivAp f ~> g 107 | runCoDivAp f = foldDivAp pure (\case Day x y h _ -> liftA2 h (f x) y) 108 | 109 | -- | In the covariant direction, we can interpret into any 'Divisible'. 110 | -- 111 | -- In theory, this shouldn't never be necessary, because you should just be 112 | -- able to use 'interpret', since any instance of 'Divisible' is also an 113 | -- instance of 'Inplicative'. However, this can be handy if you are using 114 | -- an instance of 'Divisible' that has no 'Inplicative' instance. Consider 115 | -- also 'unsafeInplicativeContra' if you are using a specific, concrete 116 | -- type for @g@. 117 | runContraDivAp :: 118 | forall f g. 119 | Divisible g => 120 | f ~> g -> 121 | DivAp f ~> g 122 | runContraDivAp f = foldDivAp (const conquer) (\case Day x y _ g -> divide g (f x) y) 123 | 124 | -- | General-purpose folder of 'DivAp'. Provide a way to handle the 125 | -- identity ('pure'/'conquer'/'Knot') and a way to handle a cons 126 | -- ('liftA2'/'divide'/'Gather'). 127 | -- 128 | -- @since 0.3.5.0 129 | foldDivAp :: 130 | (forall x. x -> g x) -> 131 | (Day f g ~> g) -> 132 | DivAp f ~> g 133 | foldDivAp f g = foldChain (f . runIdentity) g . unDivAp 134 | 135 | -- | General-purpose folder of 'DivAp1'. Provide a way to handle the 136 | -- individual leaves and a way to handle a cons ('liftF2/'divise'/'Gather'). 137 | -- 138 | -- @since 0.3.5.0 139 | foldDivAp1 :: 140 | (f ~> g) -> 141 | (Day f g ~> g) -> 142 | DivAp1 f ~> g 143 | foldDivAp1 f g = foldChain1 f g . unDivAp1 144 | 145 | -- | Extract the 'Ap' part out of a 'DivAp', shedding the 146 | -- contravariant bits. 147 | -- 148 | -- @since 0.3.2.0 149 | divApAp :: DivAp f ~> Ap f 150 | divApAp = runCoDivAp inject 151 | 152 | -- | Extract the 'Ap1' part out of a 'DivAp1', shedding the 153 | -- contravariant bits. 154 | -- 155 | -- @since 0.3.2.0 156 | divApAp1 :: DivAp1 f ~> Ap1 f 157 | divApAp1 = runCoDivAp1 inject 158 | 159 | -- | Extract the 'Div' part out of a 'DivAp', shedding the 160 | -- covariant bits. 161 | -- 162 | -- @since 0.3.2.0 163 | divApDiv :: DivAp f ~> Div f 164 | divApDiv = runContraDivAp inject 165 | 166 | -- | Extract the 'Div1' part out of a 'DivAp1', shedding the 167 | -- covariant bits. 168 | -- 169 | -- @since 0.3.2.0 170 | divApDiv1 :: DivAp1 f ~> Div1 f 171 | divApDiv1 = runContraDivAp1 inject 172 | 173 | -- | Match on a non-empty 'DivAp'; contains no @f@s, but only the 174 | -- terminal value. Analogous to the 'Control.Applicative.Free.Ap' 175 | -- constructor. 176 | -- 177 | -- Note that the order of the first two arguments has swapped as of 178 | -- v0.4.0.0 179 | pattern Gather :: (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp f a 180 | pattern Gather f g x xs <- (unGather_ -> MaybeF (Just (Day x xs f g))) 181 | where 182 | Gather f g x xs = DivAp $ More $ Day x (unDivAp xs) f g 183 | 184 | unGather_ :: DivAp f ~> MaybeF (Day f (DivAp f)) 185 | unGather_ = \case 186 | DivAp (More (Day x xs g f)) -> MaybeF . Just $ Day x (DivAp xs) g f 187 | DivAp (Done _) -> MaybeF Nothing 188 | 189 | -- | Match on an "empty" 'DivAp'; contains no @f@s, but only the 190 | -- terminal value. Analogous to 'Control.Applicative.Free.Pure'. 191 | pattern Knot :: a -> DivAp f a 192 | pattern Knot x = DivAp (Done (Identity x)) 193 | 194 | {-# COMPLETE Gather, Knot #-} 195 | 196 | instance Inply (DivAp f) where 197 | gather = coerce (gather @(Chain Day Identity _)) 198 | 199 | -- | The free 'Inplicative' 200 | instance Inplicative (DivAp f) where 201 | knot = coerce (knot @(Chain Day Identity _)) 202 | 203 | -- | Match on a 'DivAp1' to get the head and the rest of the items. 204 | -- Analogous to the 'Data.Functor.Apply.Free.Ap1' constructor. 205 | -- 206 | -- Note that the order of the first two arguments has swapped as of 207 | -- v0.4.0.0 208 | pattern DivAp1 :: Invariant f => (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp1 f a 209 | pattern DivAp1 f g x xs <- (coerce splitChain1 -> Day x xs f g) 210 | where 211 | DivAp1 f g x xs = unsplitNE $ Day x xs f g 212 | 213 | {-# COMPLETE DivAp1 #-} 214 | 215 | -- | The free 'Inplicative' 216 | instance Invariant f => Inply (DivAp1 f) where 217 | gather = coerce (gather @(Chain1 Day _)) 218 | 219 | -- | Convenient wrapper to build up a 'DivAp' by providing each 220 | -- component of it. This makes it much easier to build up longer chains 221 | -- because you would only need to write the splitting/joining functions in 222 | -- one place. 223 | -- 224 | -- For example, if you had a data type 225 | -- 226 | -- @ 227 | -- data MyType = MT Int Bool String 228 | -- @ 229 | -- 230 | -- and an invariant functor @Prim@ (representing, say, a bidirectional 231 | -- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@), 232 | -- then you could assemble a bidirectional parser for a @MyType@ using: 233 | -- 234 | -- @ 235 | -- invmap (\(MyType x y z) -> I x :* I y :* I z :* Nil) 236 | -- (\(I x :* I y :* I z :* Nil) -> MyType x y z) $ 237 | -- assembleDivAp $ intPrim 238 | -- :* boolPrim 239 | -- :* stringPrim 240 | -- :* Nil 241 | -- @ 242 | -- 243 | -- Some notes on usefulness depending on how many components you have: 244 | -- 245 | -- * If you have 0 components, use 'Knot' directly. 246 | -- * If you have 1 component, use 'inject' or 'injectChain' directly. 247 | -- * If you have 2 components, use 'toListBy' or 'toChain'. 248 | -- * If you have 3 or more components, these combinators may be useful; 249 | -- otherwise you'd need to manually peel off tuples one-by-one. 250 | -- 251 | -- If each component is itself a @'DivAp' f@ (instead of @f@), you can use 252 | -- 'concatInplicative'. 253 | assembleDivAp :: 254 | NP f as -> 255 | DivAp f (NP I as) 256 | assembleDivAp = \case 257 | Nil -> DivAp $ Done $ Identity Nil 258 | x :* xs -> 259 | DivAp $ 260 | More $ 261 | Day 262 | x 263 | (unDivAp (assembleDivAp xs)) 264 | (\y ys -> I y :* ys) 265 | (\case I y :* ys -> (y, ys)) 266 | 267 | -- | A version of 'assembleDivAp' but for 'DivAp1' instead. Can be 268 | -- useful if you intend on interpreting it into something with only 269 | -- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'. 270 | -- 271 | -- If each component is itself a @'DivAp1' f@ (instead of @f@), you can use 272 | -- 'concatInply'. 273 | assembleDivAp1 :: 274 | Invariant f => 275 | NP f (a ': as) -> 276 | DivAp1 f (NP I (a ': as)) 277 | assembleDivAp1 (x :* xs) = DivAp1_ $ case xs of 278 | Nil -> Done1 $ invmap ((:* Nil) . I) (unI . hd) x 279 | _ :* _ -> 280 | More1 $ 281 | Day 282 | x 283 | (unDivAp1 (assembleDivAp1 xs)) 284 | (\y ys -> I y :* ys) 285 | (\case I y :* ys -> (y, ys)) 286 | 287 | -- | A version of 'assembleDivAp' using 'V.XRec' from /vinyl/ instead of 288 | -- 'NP' from /sop-core/. This can be more convenient because it doesn't 289 | -- require manual unwrapping/wrapping of components. 290 | -- 291 | -- @ 292 | -- data MyType = MT Int Bool String 293 | -- 294 | -- invmap (\(MyType x y z) -> x ::& y ::& z ::& RNil) 295 | -- (\(x ::& y ::& z ::& RNil) -> MyType x y z) $ 296 | -- assembleDivApRec $ intPrim 297 | -- :& boolPrim 298 | -- :& stringPrim 299 | -- :& Nil 300 | -- @ 301 | -- 302 | -- If each component is itself a @'DivAp' f@ (instead of @f@), you can use 303 | -- 'concatDivApRec'. 304 | assembleDivApRec :: 305 | V.Rec f as -> 306 | DivAp f (V.XRec V.Identity as) 307 | assembleDivApRec = \case 308 | V.RNil -> DivAp $ Done $ Identity V.RNil 309 | x V.:& xs -> 310 | DivAp $ 311 | More $ 312 | Day 313 | x 314 | (unDivAp (assembleDivApRec xs)) 315 | (V.::&) 316 | unconsRec 317 | 318 | -- | A version of 'assembleDivAp1' using 'V.XRec' from /vinyl/ instead of 319 | -- 'NP' from /sop-core/. This can be more convenient because it doesn't 320 | -- require manual unwrapping/wrapping of components. 321 | -- 322 | -- If each component is itself a @'DivAp1' f@ (instead of @f@), you can use 323 | -- 'concatDivAp1Rec'. 324 | assembleDivAp1Rec :: 325 | Invariant f => 326 | V.Rec f (a ': as) -> 327 | DivAp1 f (V.XRec V.Identity (a ': as)) 328 | assembleDivAp1Rec (x V.:& xs) = case xs of 329 | V.RNil -> DivAp1_ $ Done1 $ invmap (V.::& V.RNil) (\case z V.::& _ -> z) x 330 | _ V.:& _ -> 331 | DivAp1_ $ 332 | More1 $ 333 | Day 334 | x 335 | (unDivAp1 (assembleDivAp1Rec xs)) 336 | (V.::&) 337 | unconsRec 338 | 339 | unconsRec :: V.XRec V.Identity (a ': as) -> (a, V.XRec V.Identity as) 340 | unconsRec (y V.::& ys) = (y, ys) 341 | 342 | -- | A free 'Inply' 343 | instance Inply f => Interpret DivAp1 f where 344 | interpret f (DivAp1_ x) = foldChain1 f (runDay f id) x 345 | 346 | -- | A free 'Inplicative' 347 | instance Inplicative f => Interpret DivAp f where 348 | interpret f (DivAp x) = foldChain (knot . runIdentity) (runDay f id) x 349 | -------------------------------------------------------------------------------- /src/Data/Functor/Invariant/Internative/Free.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | -- | 4 | -- Module : Data.Functor.Invariant.Internative.Free 5 | -- Copyright : (c) Justin Le 2025 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : justin@jle.im 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | -- Provide an invariant functor combinator choice-collector, like 13 | -- a combination of 'ListF' and 'Dec'. 14 | -- 15 | -- This module was named 'Data.Functor.Invariant.DecAlt' before v0.4.0.0 16 | -- 17 | -- @since 0.4.0.0 18 | module Data.Functor.Invariant.Internative.Free ( 19 | -- * Chain 20 | DecAlt (.., Swerve, Reject), 21 | runCoDecAlt, 22 | runContraDecAlt, 23 | decAltListF, 24 | decAltListF_, 25 | decAltDec, 26 | foldDecAlt, 27 | assembleDecAlt, 28 | 29 | -- * Nonempty Chain 30 | DecAlt1 (.., DecAlt1), 31 | runCoDecAlt1, 32 | runContraDecAlt1, 33 | decAltNonEmptyF, 34 | decAltNonEmptyF_, 35 | decAltDec1, 36 | foldDecAlt1, 37 | assembleDecAlt1, 38 | ) where 39 | 40 | import Control.Applicative.ListF 41 | import qualified Control.Monad.Trans.Compose as CT 42 | import Control.Natural 43 | import Data.Coerce 44 | import Data.Functor.Alt 45 | import Data.Functor.Contravariant.Conclude 46 | import Data.Functor.Contravariant.Decide 47 | import Data.Functor.Contravariant.Divisible.Free 48 | import qualified Data.Functor.Coyoneda as CY 49 | import Data.Functor.Invariant 50 | import Data.Functor.Invariant.Internative 51 | import Data.Functor.Invariant.Night 52 | import Data.Functor.Plus 53 | import Data.HBifunctor.Tensor hiding (elim1, elim2, intro1, intro2) 54 | import Data.HFunctor 55 | import Data.HFunctor.Chain 56 | import Data.HFunctor.Chain.Internal 57 | import qualified Data.List.NonEmpty as NE 58 | import Data.SOP hiding (hmap) 59 | import Data.Void 60 | 61 | -- | In the covariant direction, we can interpret into any 'Alt'. 62 | -- 63 | -- In theory, this shouldn't never be necessary, because you should just be 64 | -- able to use 'interpret', since any instance of 'Alt' is also an instance 65 | -- of 'Inalt'. However, this can be handy if you are using an instance of 66 | -- 'Alt' that has no 'Inalt' instance. Consider also 'unsafeInaltCo' if 67 | -- you are using a specific, concrete type for @g@. 68 | runCoDecAlt1 :: 69 | forall f g. 70 | Alt g => 71 | f ~> g -> 72 | DecAlt1 f ~> g 73 | runCoDecAlt1 f = foldDecAlt1 f (runNightAlt f id) 74 | 75 | -- | In the contravariant direction, we can interpret into any 'Decide'. 76 | -- 77 | -- In theory, this shouldn't never be necessary, because you should just be 78 | -- able to use 'interpret', since any instance of 'Decide' is also an instance 79 | -- of 'Inalt'. However, this can be handy if you are using an instance of 80 | -- 'Decide' that has no 'Inalt' instance. Consider also 81 | -- 'unsafeInaltContra' if you are using a specific, concrete type for @g@. 82 | runContraDecAlt1 :: 83 | forall f g. 84 | Decide g => 85 | f ~> g -> 86 | DecAlt1 f ~> g 87 | runContraDecAlt1 f = foldDecAlt1 f (runNightDecide f id) 88 | 89 | -- | Extract the 'Dec' part out of a 'DecAlt', shedding the 90 | -- covariant bits. 91 | decAltDec :: DecAlt f ~> Dec f 92 | decAltDec = runContraDecAlt inject 93 | 94 | -- | Extract the 'Dec1' part out of a 'DecAlt1', shedding the 95 | -- covariant bits. 96 | decAltDec1 :: DecAlt1 f ~> Dec1 f 97 | decAltDec1 = runContraDecAlt1 inject 98 | 99 | -- | In the covariant direction, we can interpret into any 'Plus'. 100 | -- 101 | -- In theory, this shouldn't never be necessary, because you should just be 102 | -- able to use 'interpret', since any instance of 'Plus' is also an instance 103 | -- of 'Inplus'. However, this can be handy if you are using an instance of 104 | -- 'Plus' that has no 'Inplus' instance. Consider also 'unsafeInplusCo' if 105 | -- you are using a specific, concrete type for @g@. 106 | runCoDecAlt :: 107 | forall f g. 108 | Plus g => 109 | f ~> g -> 110 | DecAlt f ~> g 111 | runCoDecAlt f = foldDecAlt (const zero) (runNightAlt f id) 112 | 113 | -- | In the contravariant direction, we can interpret into any 'Decide'. 114 | -- 115 | -- In theory, this shouldn't never be necessary, because you should just be 116 | -- able to use 'interpret', since any instance of 'Conclude' is also an 117 | -- instance of 'Inplus'. However, this can be handy if you are using an 118 | -- instance of 'Conclude' that has no 'Inplus' instance. Consider also 119 | -- 'unsafeInplusContra' if you are using a specific, concrete type for @g@. 120 | runContraDecAlt :: 121 | forall f g. 122 | Conclude g => 123 | f ~> g -> 124 | DecAlt f ~> g 125 | runContraDecAlt f = foldDecAlt conclude (runNightDecide f id) 126 | 127 | -- | Extract the 'ListF' part out of a 'DecAlt', shedding the 128 | -- contravariant bits. 129 | -- 130 | -- @since 0.3.2.0 131 | decAltListF :: Functor f => DecAlt f ~> ListF f 132 | decAltListF = runCoDecAlt inject 133 | 134 | -- | Extract the 'ListF' part out of a 'DecAlt', shedding the 135 | -- contravariant bits. 136 | -- 137 | -- This version does not require a 'Functor' constraint because it converts 138 | -- to the coyoneda-wrapped product, which is more accurately the true 139 | -- conversion to a covariant chain. 140 | -- 141 | -- @since 0.3.2.0 142 | decAltListF_ :: DecAlt f ~> CT.ComposeT ListF CY.Coyoneda f 143 | decAltListF_ = foldDecAlt (const (CT.ComposeT (ListF []))) $ \case 144 | Night x (CT.ComposeT (ListF xs)) f g _ -> 145 | CT.ComposeT . ListF $ 146 | CY.Coyoneda f x : (map . fmap) g xs 147 | 148 | -- | Extract the 'NonEmptyF' part out of a 'DecAlt1', shedding the 149 | -- contravariant bits. 150 | -- 151 | -- @since 0.3.2.0 152 | decAltNonEmptyF :: Functor f => DecAlt1 f ~> NonEmptyF f 153 | decAltNonEmptyF = runCoDecAlt1 inject 154 | 155 | -- | Extract the 'NonEmptyF' part out of a 'DecAlt1', shedding the 156 | -- contravariant bits. 157 | -- 158 | -- This version does not require a 'Functor' constraint because it converts 159 | -- to the coyoneda-wrapped product, which is more accurately the true 160 | -- conversion to a covariant chain. 161 | -- 162 | -- @since 0.3.2.0 163 | decAltNonEmptyF_ :: DecAlt1 f ~> CT.ComposeT NonEmptyF CY.Coyoneda f 164 | decAltNonEmptyF_ = foldDecAlt1 inject $ \case 165 | Night x (CT.ComposeT (NonEmptyF xs)) f g _ -> 166 | CT.ComposeT . NonEmptyF $ 167 | CY.Coyoneda f x NE.<| (fmap . fmap) g xs 168 | 169 | -- | General-purpose folder of 'DecAlt'. Provide a way to handle the 170 | -- identity ('empty'/'conclude'/'Reject') and a way to handle a cons 171 | -- (''/'decide'/'swerve'). 172 | -- 173 | -- @since 0.3.5.0 174 | foldDecAlt :: 175 | (forall x. (x -> Void) -> g x) -> 176 | (Night f g ~> g) -> 177 | DecAlt f ~> g 178 | foldDecAlt f g = foldChain (f . refute) g . unDecAlt 179 | 180 | -- | General-purpose folder of 'DecAlt1'. Provide a way to handle the 181 | -- individual leaves and a way to handle a cons (''/'decide'/'swerve'). 182 | -- 183 | -- @since 0.3.5.0 184 | foldDecAlt1 :: 185 | (f ~> g) -> 186 | (Night f g ~> g) -> 187 | DecAlt1 f ~> g 188 | foldDecAlt1 f g = foldChain1 f g . unDecAlt1 189 | 190 | -- | Match on a non-empty 'DecAlt'; contains the splitting function, 191 | -- the two rejoining functions, the first @f@, and the rest of the chain. 192 | -- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Choose' 193 | -- constructor. 194 | pattern Swerve :: (b -> a) -> (c -> a) -> (a -> Either b c) -> f b -> DecAlt f c -> DecAlt f a 195 | pattern Swerve f g h x xs <- (unSwerve_ -> MaybeF (Just (Night x xs f g h))) 196 | where 197 | Swerve f g h x xs = DecAlt $ More $ Night x (unDecAlt xs) f g h 198 | 199 | unSwerve_ :: DecAlt f ~> MaybeF (Night f (DecAlt f)) 200 | unSwerve_ = \case 201 | DecAlt (More (Night x xs g f h)) -> MaybeF . Just $ Night x (DecAlt xs) g f h 202 | DecAlt (Done _) -> MaybeF Nothing 203 | 204 | -- | Match on an "empty" 'DecAlt'; contains no @f@s, but only the 205 | -- terminal value. Analogous to the 206 | -- 'Data.Functor.Contravariant.Divisible.Free.Lose' constructor. 207 | pattern Reject :: (a -> Void) -> DecAlt f a 208 | pattern Reject x = DecAlt (Done (Not x)) 209 | 210 | {-# COMPLETE Swerve, Reject #-} 211 | 212 | instance Inalt (DecAlt f) where 213 | swerve = coerce (swerve @(Chain Night Not _)) 214 | 215 | instance Inplus (DecAlt f) where 216 | reject = coerce (reject @(Chain Night Not _)) 217 | 218 | -- | Match on a 'DecAlt1' to get the head and the rest of the items. 219 | -- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Dec1' 220 | -- constructor. 221 | pattern DecAlt1 :: 222 | Invariant f => (b -> a) -> (c -> a) -> (a -> Either b c) -> f b -> DecAlt f c -> DecAlt1 f a 223 | pattern DecAlt1 f g h x xs <- (coerce splitChain1 -> Night x xs f g h) 224 | where 225 | DecAlt1 f g h x xs = unsplitNE $ Night x xs f g h 226 | 227 | {-# COMPLETE DecAlt1 #-} 228 | 229 | instance Invariant f => Inalt (DecAlt1 f) where 230 | swerve = coerce (swerve @(Chain1 Night _)) 231 | 232 | -- | Convenient wrapper to build up a 'DecAlt' on by providing each 233 | -- branch of it. This makes it much easier to build up longer chains 234 | -- because you would only need to write the splitting/joining functions in 235 | -- one place. 236 | -- 237 | -- For example, if you had a data type 238 | -- 239 | -- @ 240 | -- data MyType = MTI Int | MTB Bool | MTS String 241 | -- @ 242 | -- 243 | -- and an invariant functor @Prim@ (representing, say, a bidirectional 244 | -- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@), 245 | -- then you could assemble a bidirectional parser for a @MyType@ using: 246 | -- 247 | -- @ 248 | -- invmap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z)))) 249 | -- (\case Z (I x) -> MTI x; S (Z (I y)) -> MTB y; S (S (Z (I z))) -> MTS z) $ 250 | -- assembleDecAlt $ intPrim 251 | -- :* boolPrim 252 | -- :* stringPrim 253 | -- :* Nil 254 | -- @ 255 | -- 256 | -- Some notes on usefulness depending on how many components you have: 257 | -- 258 | -- * If you have 0 components, use 'Reject' directly. 259 | -- * If you have 1 component, use 'inject' or 'injectChain' directly. 260 | -- * If you have 2 components, use 'toListBy' or 'toChain'. 261 | -- * If you have 3 or more components, these combinators may be useful; 262 | -- otherwise you'd need to manually peel off eithers one-by-one. 263 | -- 264 | -- If each component is itself a @'DecAlt' f@ (instead of @f@), you can use 265 | -- 'concatInplus'. 266 | assembleDecAlt :: 267 | NP f as -> 268 | DecAlt f (NS I as) 269 | assembleDecAlt = \case 270 | Nil -> DecAlt $ Done $ Not (\case {}) 271 | x :* xs -> 272 | DecAlt $ 273 | More $ 274 | Night 275 | x 276 | (unDecAlt $ assembleDecAlt xs) 277 | (Z . I) 278 | S 279 | (\case Z (I y) -> Left y; S ys -> Right ys) 280 | 281 | -- | A version of 'assembleDecAlt' but for 'DecAlt1' instead. Can 282 | -- be useful if you intend on interpreting it into something with only 283 | -- a 'Decide' or 'Alt' instance, but no 284 | -- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or 285 | -- 'Control.Applicative.Alternative'. 286 | -- 287 | -- If each component is itself a @'DecAlt1' f@ (instead of @f@), you can 288 | -- use 'concatInalt'. 289 | assembleDecAlt1 :: 290 | Invariant f => 291 | NP f (a ': as) -> 292 | DecAlt1 f (NS I (a ': as)) 293 | assembleDecAlt1 (x :* xs) = DecAlt1_ $ case xs of 294 | Nil -> Done1 $ invmap (Z . I) (unI . unZ) x 295 | _ :* _ -> 296 | More1 $ 297 | Night 298 | x 299 | (unDecAlt1 $ assembleDecAlt1 xs) 300 | (Z . I) 301 | S 302 | (\case Z (I y) -> Left y; S ys -> Right ys) 303 | -------------------------------------------------------------------------------- /src/Data/Functor/Invariant/Night.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Functor.Invariant.Night 3 | -- Copyright : (c) Justin Le 2025 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : justin@jle.im 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- Provides an 'Invariant' version of a Day convolution over 'Either'. 11 | -- 12 | -- @since 0.3.0.0 13 | module Data.Functor.Invariant.Night ( 14 | Night (..), 15 | Not (..), 16 | refuted, 17 | night, 18 | runNight, 19 | nerve, 20 | runNightAlt, 21 | runNightDecide, 22 | toCoNight, 23 | toCoNight_, 24 | toContraNight, 25 | assoc, 26 | unassoc, 27 | intro1, 28 | intro2, 29 | elim1, 30 | elim2, 31 | swapped, 32 | trans1, 33 | trans2, 34 | ) where 35 | 36 | import Control.Natural 37 | import Data.Bifunctor 38 | import qualified Data.Bifunctor.Assoc as B 39 | import qualified Data.Bifunctor.Swap as B 40 | import Data.Functor.Alt 41 | import Data.Functor.Contravariant.Decide 42 | import Data.Functor.Contravariant.Night (Not (..), refuted) 43 | import qualified Data.Functor.Contravariant.Night as CN 44 | import qualified Data.Functor.Coyoneda as CY 45 | import Data.Functor.Invariant 46 | import Data.Functor.Invariant.Internative 47 | import Data.Kind 48 | import Data.Void 49 | import GHC.Generics 50 | 51 | -- | A pairing of invariant functors to create a new invariant functor that 52 | -- represents the "choice" between the two. 53 | -- 54 | -- A @'Night' f g a@ is a invariant "consumer" and "producer" of @a@, and 55 | -- it does this by either feeding the @a@ to @f@, or feeding the @a@ to 56 | -- @g@, and then collecting the result from whichever one it was fed to. 57 | -- Which decision of which path to takes happens at runtime depending 58 | -- /what/ @a@ is actually given. 59 | -- 60 | -- For example, if we have @x :: f a@ and @y :: g b@, then @'night' x y :: 61 | -- 'Night' f g ('Either' a b)@. This is a consumer/producer of @'Either' a b@s, and 62 | -- it consumes 'Left' branches by feeding it to @x@, and 'Right' branches 63 | -- by feeding it to @y@. It then passes back the single result from the one of 64 | -- the two that was chosen. 65 | -- 66 | -- Mathematically, this is a invariant day convolution, except with 67 | -- a different choice of bifunctor ('Either') than the typical one we talk 68 | -- about in Haskell (which uses @(,)@). Therefore, it is an alternative to 69 | -- the typical 'Data.Functor.Day' convolution --- hence, the name 'Night'. 70 | data Night :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) where 71 | Night :: 72 | f b -> 73 | g c -> 74 | (b -> a) -> 75 | (c -> a) -> 76 | (a -> Either b c) -> 77 | Night f g a 78 | 79 | instance Invariant (Night f g) where 80 | invmap f g (Night x y h j k) = Night x y (f . h) (f . j) (k . g) 81 | 82 | -- | Pair two invariant actions together into a 'Night'; assigns the first 83 | -- one to 'Left' inputs and outputs and the second one to 'Right' inputs 84 | -- and outputs. 85 | night :: f a -> g b -> Night f g (Either a b) 86 | night x y = Night x y Left Right id 87 | 88 | -- | Interpret the covariant part of a 'Night' into a target context @h@, 89 | -- as long as the context is an instance of 'Alt'. The 'Alt' is used to 90 | -- combine results back together, chosen by ''. 91 | runNightAlt :: 92 | forall f g h. 93 | Alt h => 94 | f ~> h -> 95 | g ~> h -> 96 | Night f g ~> h 97 | runNightAlt f g (Night x y h j _) = fmap h (f x) fmap j (g y) 98 | 99 | -- | Interpret the contravariant part of a 'Night' into a target context 100 | -- @h@, as long as the context is an instance of 'Decide'. The 'Decide' is 101 | -- used to pick which part to feed the input to. 102 | runNightDecide :: 103 | forall f g h. 104 | Decide h => 105 | f ~> h -> 106 | g ~> h -> 107 | Night f g ~> h 108 | runNightDecide f g (Night x y _ _ k) = decide k (f x) (g y) 109 | 110 | -- | Convert an invariant 'Night' into the covariant version, dropping the 111 | -- contravariant part. 112 | -- 113 | -- Note that there is no covariant version of 'Night' defined in any common 114 | -- library, so we use an equivalent type (if @f@ and @g@ are 'Functor's) @f 115 | -- ':*:' g@. 116 | toCoNight :: (Functor f, Functor g) => Night f g ~> f :*: g 117 | toCoNight (Night x y f g _) = fmap f x :*: fmap g y 118 | 119 | -- | Convert an invariant 'Night' into the covariant version, dropping the 120 | -- contravariant part. 121 | -- 122 | -- This version does not require a 'Functor' constraint because it converts 123 | -- to the coyoneda-wrapped product, which is more accurately the covariant 124 | -- 'Night' convolution. 125 | -- 126 | -- @since 0.3.2.0 127 | toCoNight_ :: Night f g ~> CY.Coyoneda f :*: CY.Coyoneda g 128 | toCoNight_ (Night x y f g _) = CY.Coyoneda f x :*: CY.Coyoneda g y 129 | 130 | -- | Convert an invariant 'Night' into the contravariant version, dropping 131 | -- the covariant part. 132 | toContraNight :: Night f g ~> CN.Night f g 133 | toContraNight (Night x y _ _ h) = CN.Night x y h 134 | 135 | -- | Interpret out of a 'Night' into any instance of 'Inalt' by providing 136 | -- two interpreting functions. 137 | -- 138 | -- @since 0.4.0.0 139 | runNight :: 140 | Inalt h => 141 | (f ~> h) -> 142 | (g ~> h) -> 143 | Night f g ~> h 144 | runNight f g (Night x y a b c) = swerve a b c (f x) (g y) 145 | 146 | -- | Squash the two items in a 'Night' using their natural 'Inalt' 147 | -- instances. 148 | -- 149 | -- @since 0.4.0.0 150 | nerve :: 151 | Inalt f => 152 | Night f f ~> f 153 | nerve (Night x y a b c) = swerve a b c x y 154 | 155 | -- | 'Night' is associative. 156 | assoc :: Night f (Night g h) ~> Night (Night f g) h 157 | assoc (Night x (Night y z f g h) j k l) = 158 | Night 159 | (Night x y Left Right id) 160 | z 161 | (either j (k . f)) 162 | (k . g) 163 | (B.unassoc . second h . l) 164 | 165 | -- | 'Night' is associative. 166 | unassoc :: Night (Night f g) h ~> Night f (Night g h) 167 | unassoc (Night (Night x y f g h) z j k l) = 168 | Night 169 | x 170 | (Night y z Left Right id) 171 | (j . f) 172 | (either (j . g) k) 173 | (B.assoc . first h . l) 174 | 175 | -- (k . g) 176 | -- (either (k . h) l) 177 | 178 | -- | The left identity of 'Night' is 'Not'; this is one side of that 179 | -- isomorphism. 180 | intro1 :: g ~> Night Not g 181 | intro1 y = Night refuted y absurd id Right 182 | 183 | -- | The right identity of 'Night' is 'Not'; this is one side of that 184 | -- isomorphism. 185 | intro2 :: f ~> Night f Not 186 | intro2 x = Night x refuted id absurd Left 187 | 188 | -- | The left identity of 'Night' is 'Not'; this is one side of that 189 | -- isomorphism. 190 | elim1 :: Invariant g => Night Not g ~> g 191 | elim1 (Night x y _ g h) = invmap g (either (absurd . refute x) id . h) y 192 | 193 | -- | The right identity of 'Night' is 'Not'; this is one side of that 194 | -- isomorphism. 195 | elim2 :: Invariant f => Night f Not ~> f 196 | elim2 (Night x y f _ h) = invmap f (either id (absurd . refute y) . h) x 197 | 198 | -- | The two sides of a 'Night' can be swapped. 199 | swapped :: Night f g ~> Night g f 200 | swapped (Night x y f g h) = Night y x g f (B.swap . h) 201 | 202 | -- | Hoist a function over the left side of a 'Night'. 203 | trans1 :: f ~> h -> Night f g ~> Night h g 204 | trans1 f (Night x y g h j) = Night (f x) y g h j 205 | 206 | -- | Hoist a function over the right side of a 'Night'. 207 | trans2 :: g ~> h -> Night f g ~> Night f h 208 | trans2 f (Night x y g h j) = Night x (f y) g h j 209 | -------------------------------------------------------------------------------- /src/Data/HBifunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | -- | 4 | -- Module : Data.HBifunctor 5 | -- Copyright : (c) Justin Le 2025 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : justin@jle.im 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | -- This module provides an abstraction for "two-argument functor 13 | -- combinators", 'HBifunctor', as well as some useful combinators. 14 | module Data.HBifunctor ( 15 | HBifunctor (..), 16 | WrappedHBifunctor (..), 17 | overHBifunctor, 18 | 19 | -- * Simple Instances 20 | LeftF (..), 21 | RightF (..), 22 | ) where 23 | 24 | import Control.Natural.IsoF 25 | import Data.Biapplicative 26 | import Data.Bifunctor.TH 27 | import Data.Coerce 28 | import Data.Data 29 | import Data.Deriving 30 | import Data.HFunctor 31 | import Data.HFunctor.HTraversable 32 | import Data.HFunctor.Internal 33 | import Data.HFunctor.Interpret 34 | import GHC.Generics 35 | 36 | -- | Lift two isomorphisms on each side of a bifunctor to become an 37 | -- isomorphism between the two bifunctor applications. 38 | -- 39 | -- Basically, if @f@ and @f'@ are isomorphic, and @g@ and @g'@ are 40 | -- isomorphic, then @t f g@ is isomorphic to @t f' g'@. 41 | overHBifunctor :: 42 | HBifunctor t => 43 | (f <~> f') -> 44 | (g <~> g') -> 45 | t f g <~> t f' g' 46 | overHBifunctor f g = 47 | isoF 48 | (hbimap (viewF f) (viewF g)) 49 | (hbimap (reviewF f) (reviewF g)) 50 | 51 | -- | An 'HBifunctor' that ignores its second input. Like 52 | -- a 'GHC.Generics.:+:' with no 'GHC.Generics.R1'/right branch. 53 | -- 54 | -- This is 'Data.Bifunctors.Joker.Joker' from "Data.Bifunctors.Joker", but 55 | -- given a more sensible name for its purpose. 56 | newtype LeftF f g a = LeftF {runLeftF :: f a} 57 | deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) 58 | 59 | deriveShow1 ''LeftF 60 | deriveRead1 ''LeftF 61 | deriveEq1 ''LeftF 62 | deriveOrd1 ''LeftF 63 | deriveBifunctor ''LeftF 64 | deriveBifoldable ''LeftF 65 | deriveBitraversable ''LeftF 66 | 67 | instance Applicative f => Biapplicative (LeftF f) where 68 | bipure _ y = LeftF (pure y) 69 | LeftF x <<*>> LeftF y = LeftF (x <*> y) 70 | 71 | instance HBifunctor LeftF where 72 | hbimap f _ (LeftF x) = LeftF (f x) 73 | 74 | instance HFunctor (LeftF f) where 75 | hmap _ = coerce 76 | 77 | instance HTraversable (LeftF f) where 78 | htraverse _ = pure . coerce 79 | 80 | -- | An 'HBifunctor' that ignores its first input. Like 81 | -- a 'GHC.Generics.:+:' with no 'GHC.Generics.L1'/left branch. 82 | -- 83 | -- In its polykinded form (on @f@), it is essentially a higher-order 84 | -- version of 'Data.Tagged.Tagged'. 85 | newtype RightF f g a = RightF {runRightF :: g a} 86 | deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) 87 | 88 | deriveShow1 ''RightF 89 | deriveRead1 ''RightF 90 | deriveEq1 ''RightF 91 | deriveOrd1 ''RightF 92 | 93 | instance HBifunctor RightF where 94 | hbimap _ g (RightF x) = RightF (g x) 95 | 96 | instance HFunctor (RightF g) where 97 | hmap f (RightF x) = RightF (f x) 98 | 99 | instance Inject (RightF g) where 100 | inject = RightF 101 | 102 | instance HTraversable (RightF g) where 103 | htraverse f (RightF x) = RightF <$> f x 104 | 105 | instance HBind (RightF g) where 106 | hbind f (RightF x) = f x 107 | 108 | instance Interpret (RightF g) f where 109 | retract (RightF x) = x 110 | interpret f (RightF x) = f x 111 | -------------------------------------------------------------------------------- /src/Data/HBifunctor/Tensor/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide, not-home #-} 2 | 3 | module Data.HBifunctor.Tensor.Internal ( 4 | Tensor (..), 5 | unconsLB, 6 | nilLB, 7 | consLB, 8 | appendChain, 9 | unroll, 10 | reroll, 11 | rerollNE, 12 | splitChain1, 13 | ) where 14 | 15 | import Control.Natural 16 | import Control.Natural.IsoF 17 | import Data.HBifunctor 18 | import Data.HBifunctor.Associative 19 | import Data.HFunctor 20 | import Data.HFunctor.Chain.Internal 21 | import Data.Kind 22 | import GHC.Generics 23 | 24 | -- | An 'Associative' 'HBifunctor' can be a 'Tensor' if there is some 25 | -- identity @i@ where @t i f@ and @t f i@ are equivalent to just @f@. 26 | -- 27 | -- That is, "enhancing" @f@ with @t i@ does nothing. 28 | -- 29 | -- The methods in this class provide us useful ways of navigating 30 | -- a @'Tensor' t@ with respect to this property. 31 | -- 32 | -- The 'Tensor' is essentially the 'HBifunctor' equivalent of 'Inject', 33 | -- with 'intro1' and 'intro2' taking the place of 'inject'. 34 | -- 35 | -- Formally, we can say that @t@ enriches a the category of 36 | -- endofunctors with monoid strcture: it turns our endofunctor category 37 | -- into a "monoidal category". 38 | -- 39 | -- Different instances of @t@ each enrich the endofunctor category in 40 | -- different ways, giving a different monoidal category. 41 | class (Associative t, Inject (ListBy t)) => Tensor t i | t -> i where 42 | -- | The "monoidal functor combinator" induced by @t@. 43 | -- 44 | -- A value of type @ListBy t f a@ is /equivalent/ to one of: 45 | -- 46 | -- * @I a@ -- zero fs 47 | -- * @f a@ -- one f 48 | -- * @t f f a@ -- two fs 49 | -- * @t f (t f f) a@ -- three fs 50 | -- * @t f (t f (t f f)) a@ 51 | -- * @t f (t f (t f (t f f))) a@ 52 | -- * .. etc 53 | -- 54 | -- For example, for ':*:', we have 'ListF'. This is because: 55 | -- 56 | -- @ 57 | -- 'Proxy' ~ 'ListF' [] ~ 'nilLB' \@(':*:') 58 | -- x ~ ListF [x] ~ 'inject' x 59 | -- x :*: y ~ ListF [x,y] ~ 'toListBy' (x :*: y) 60 | -- x :*: y :*: z ~ ListF [x,y,z] 61 | -- -- etc. 62 | -- @ 63 | -- 64 | -- You can create an "empty" one with 'nilLB', a "singleton" one with 65 | -- 'inject', or else one from a single @t f f@ with 'toListBy'. 66 | -- 67 | -- See 'Data.HBifunctor.Associative.NonEmptyBy' for a "non-empty" 68 | -- version of this type. 69 | type ListBy t :: (Type -> Type) -> Type -> Type 70 | 71 | -- | Because @t f (I t)@ is equivalent to @f@, we can always "insert" 72 | -- @f@ into @t f (I t)@. 73 | -- 74 | -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's. 75 | intro1 :: f ~> t f i 76 | 77 | -- | Because @t (I t) g@ is equivalent to @f@, we can always "insert" 78 | -- @g@ into @t (I t) g@. 79 | -- 80 | -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's. 81 | intro2 :: g ~> t i g 82 | 83 | -- | Witnesses the property that @i@ is the identity of @t@: @t 84 | -- f i@ always leaves @f@ unchanged, so we can always just drop the 85 | -- @i@. 86 | elim1 :: FunctorBy t f => t f i ~> f 87 | 88 | -- | Witnesses the property that @i@ is the identity of @t@: @t i g@ 89 | -- always leaves @g@ unchanged, so we can always just drop the @i t@. 90 | elim2 :: FunctorBy t g => t i g ~> g 91 | 92 | -- | If a @'ListBy' t f@ represents multiple applications of @t f@ to 93 | -- itself, then we can also "append" two @'ListBy' t f@s applied to 94 | -- themselves into one giant @'ListBy' t f@ containing all of the @t f@s. 95 | -- 96 | -- Note that this essentially gives an instance for @'SemigroupIn' 97 | -- t (ListBy t f)@, for any functor @f@; this is witnessed by 98 | -- 'WrapLB'. 99 | appendLB :: t (ListBy t f) (ListBy t f) ~> ListBy t f 100 | 101 | -- | Lets you convert an @'NonEmptyBy' t f@ into a single application of @f@ to 102 | -- @'ListBy' t f@. 103 | -- 104 | -- Analogous to a function @'Data.List.NonEmpty.NonEmpty' a -> (a, 105 | -- [a])@ 106 | -- 107 | -- Note that this is not reversible in general unless we have 108 | -- @'Matchable' t@. 109 | splitNE :: NonEmptyBy t f ~> t f (ListBy t f) 110 | 111 | -- | An @'ListBy' t f@ is either empty, or a single application of @t@ to @f@ 112 | -- and @ListBy t f@ (the "head" and "tail"). This witnesses that 113 | -- isomorphism. 114 | -- 115 | -- To /use/ this property, see 'nilLB', 'consLB', and 'unconsLB'. 116 | splittingLB :: ListBy t f <~> i :+: t f (ListBy t f) 117 | 118 | -- | Embed a direct application of @f@ to itself into a @'ListBy' t f@. 119 | toListBy :: t f f ~> ListBy t f 120 | toListBy = 121 | reviewF (splittingLB @t) 122 | . R1 123 | . hright (inject @(ListBy t)) 124 | 125 | -- | @'NonEmptyBy' t f@ is "one or more @f@s", and @'ListBy t f@ is "zero or more 126 | -- @f@s". This function lets us convert from one to the other. 127 | -- 128 | -- This is analogous to a function @'Data.List.NonEmpty.NonEmpty' a -> 129 | -- [a]@. 130 | -- 131 | -- Note that because @t@ is not inferrable from the input or output 132 | -- type, you should call this using /-XTypeApplications/: 133 | -- 134 | -- @ 135 | -- 'fromNE' \@(':*:') :: 'NonEmptyF' f a -> 'ListF' f a 136 | -- fromNE \@'Comp' :: 'Free1' f a -> 'Free' f a 137 | -- @ 138 | fromNE :: NonEmptyBy t f ~> ListBy t f 139 | fromNE = reviewF (splittingLB @t) . R1 . splitNE @t 140 | 141 | {-# MINIMAL intro1, intro2, elim1, elim2, appendLB, splitNE, splittingLB #-} 142 | 143 | -- | Create the "empty 'ListBy'". 144 | -- 145 | -- If @'ListBy' t f@ represents multiple applications of @t f@ with 146 | -- itself, then @nilLB@ gives us "zero applications of @f@". 147 | -- 148 | -- Note that @t@ cannot be inferred from the input or output type of 149 | -- 'nilLB', so this function must always be called with -XTypeApplications: 150 | -- 151 | -- @ 152 | -- 'nilLB' \@'Day' :: 'Identity' '~>' 'Ap' f 153 | -- nilLB \@'Comp' :: Identity ~> 'Free' f 154 | -- nilLB \@(':*:') :: 'Proxy' ~> 'ListF' f 155 | -- @ 156 | -- 157 | -- Note that this essentially gives an instance for @'MonoidIn' t i (ListBy 158 | -- t f)@, for any functor @f@; this is witnessed by 'WrapLB'. 159 | nilLB :: forall t i f. Tensor t i => i ~> ListBy t f 160 | nilLB = reviewF (splittingLB @t) . L1 161 | 162 | -- | Lets us "cons" an application of @f@ to the front of an @'ListBy' t f@. 163 | consLB :: Tensor t i => t f (ListBy t f) ~> ListBy t f 164 | consLB = reviewF splittingLB . R1 165 | 166 | -- | "Pattern match" on an @'ListBy' t@ 167 | -- 168 | -- An @'ListBy' t f@ is either empty, or a single application of @t@ to @f@ 169 | -- and @ListBy t f@ (the "head" and "tail") 170 | -- 171 | -- This is analogous to the function @'Data.List.uncons' :: [a] -> Maybe 172 | -- (a, [a])@. 173 | unconsLB :: Tensor t i => ListBy t f ~> i :+: t f (ListBy t f) 174 | unconsLB = viewF splittingLB 175 | 176 | -- | 'Chain' is a monoid with respect to @t@: we can "combine" them in 177 | -- an associative way. The identity here is anything made with the 'Done' 178 | -- constructor. 179 | -- 180 | -- This is essentially 'biretract', but only requiring @'Tensor' t i@: it 181 | -- comes from the fact that @'Chain1' t i@ is the "free @'MonoidIn' t i@". 182 | -- 'pureT' is 'Done'. 183 | -- 184 | -- @since 0.1.1.0 185 | appendChain :: 186 | forall t i f. 187 | Tensor t i => 188 | t (Chain t i f) (Chain t i f) ~> Chain t i f 189 | appendChain = 190 | unroll 191 | . appendLB 192 | . hbimap reroll reroll 193 | 194 | -- | A type @'ListBy' t@ is supposed to represent the successive application of 195 | -- @t@s to itself. 'unroll' makes that successive application explicit, 196 | -- buy converting it to a literal 'Chain' of applications of @t@ to 197 | -- itself. 198 | -- 199 | -- @ 200 | -- 'unroll' = 'unfoldChain' 'unconsLB' 201 | -- @ 202 | unroll :: 203 | Tensor t i => 204 | ListBy t f ~> Chain t i f 205 | unroll = unfoldChain unconsLB 206 | 207 | -- | A type @'ListBy' t@ is supposed to represent the successive application of 208 | -- @t@s to itself. 'rerollNE' takes an explicit 'Chain' of applications of 209 | -- @t@ to itself and rolls it back up into an @'ListBy' t@. 210 | -- 211 | -- @ 212 | -- 'reroll' = 'foldChain' 'nilLB' 'consLB' 213 | -- @ 214 | -- 215 | -- Because @t@ cannot be inferred from the input or output, you should call 216 | -- this with /-XTypeApplications/: 217 | -- 218 | -- @ 219 | -- 'reroll' \@'Control.Monad.Freer.Church.Comp' 220 | -- :: 'Chain' Comp 'Data.Functor.Identity.Identity' f a -> 'Control.Monad.Freer.Church.Free' f a 221 | -- @ 222 | reroll :: 223 | forall t i f. 224 | Tensor t i => 225 | Chain t i f ~> ListBy t f 226 | reroll = foldChain (nilLB @t) consLB 227 | 228 | -- | A type @'NonEmptyBy' t@ is supposed to represent the successive application of 229 | -- @t@s to itself. 'rerollNE' takes an explicit 'Chain1' of applications 230 | -- of @t@ to itself and rolls it back up into an @'NonEmptyBy' t@. 231 | -- 232 | -- @ 233 | -- 'rerollNE' = 'foldChain1' 'inject' 'consNE' 234 | -- @ 235 | rerollNE :: Associative t => Chain1 t f ~> NonEmptyBy t f 236 | rerollNE = foldChain1 inject consNE 237 | 238 | -- | The "forward" function representing 'splittingChain1'. Provided here 239 | -- as a separate function because it does not require @'Functor' f@. 240 | splitChain1 :: 241 | forall t i f. 242 | Tensor t i => 243 | Chain1 t f ~> t f (Chain t i f) 244 | splitChain1 = hright (unroll @t) . splitNE @t . rerollNE 245 | -------------------------------------------------------------------------------- /src/Data/HFunctor/Chain.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | 4 | -- Module : Data.HFunctor.Chain 5 | -- Copyright : (c) Justin Le 2025 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : justin@jle.im 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | -- This module provides an 'Interpret'able data type of "linked list of 13 | -- tensor applications". 14 | -- 15 | -- The type @'Chain' t@, for any @'Tensor' t@, is meant to be the same as 16 | -- @'ListBy' t@ (the monoidal functor combinator for @t@), and represents 17 | -- "zero or more" applications of @f@ to @t@. 18 | -- 19 | -- The type @'Chain1' t@, for any @'Associative' t@, is meant to be the 20 | -- same as @'NonEmptyBy' t@ (the semigroupoidal functor combinator for @t@) and 21 | -- represents "one or more" applications of @f@ to @t@. 22 | -- 23 | -- The advantage of using 'Chain' and 'Chain1' over 'ListBy' or 'NonEmptyBy' is that 24 | -- they provide a universal interface for pattern matching and constructing 25 | -- such values, which may simplify working with new such functor 26 | -- combinators you might encounter. 27 | module Data.HFunctor.Chain ( 28 | -- * 'Chain' 29 | Chain (..), 30 | foldChain, 31 | foldChainA, 32 | unfoldChain, 33 | unroll, 34 | reroll, 35 | unrolling, 36 | appendChain, 37 | splittingChain, 38 | toChain, 39 | injectChain, 40 | unconsChain, 41 | 42 | -- * 'Chain1' 43 | Chain1 (..), 44 | foldChain1, 45 | foldChain1A, 46 | unfoldChain1, 47 | unrollingNE, 48 | unrollNE, 49 | rerollNE, 50 | appendChain1, 51 | fromChain1, 52 | matchChain1, 53 | toChain1, 54 | injectChain1, 55 | 56 | -- ** Matchable 57 | 58 | -- | The following conversions between 'Chain' and 'Chain1' are only 59 | -- possible if @t@ is 'Matchable' 60 | splittingChain1, 61 | splitChain1, 62 | matchingChain, 63 | unmatchChain, 64 | ) where 65 | 66 | import Control.Monad.Freer.Church 67 | import Control.Natural 68 | import Control.Natural.IsoF 69 | import Data.Functor.Bind 70 | import Data.Functor.Contravariant 71 | import Data.Functor.Contravariant.Conclude 72 | import qualified Data.Functor.Contravariant.Day as CD 73 | import Data.Functor.Contravariant.Decide 74 | import Data.Functor.Contravariant.Divise 75 | import Data.Functor.Contravariant.Divisible 76 | import qualified Data.Functor.Contravariant.Night as N 77 | import Data.Functor.Day hiding (elim1, elim2, intro1, intro2) 78 | import Data.Functor.Identity 79 | import Data.Functor.Invariant 80 | import qualified Data.Functor.Invariant.Day as ID 81 | import Data.Functor.Invariant.Inplicative 82 | import Data.Functor.Invariant.Internative 83 | import qualified Data.Functor.Invariant.Night as IN 84 | import Data.Functor.Plus 85 | import Data.Functor.Product 86 | import Data.HBifunctor 87 | import Data.HBifunctor.Associative 88 | import Data.HBifunctor.Tensor 89 | import Data.HBifunctor.Tensor.Internal 90 | import Data.HFunctor 91 | import Data.HFunctor.Chain.Internal 92 | import Data.HFunctor.Interpret 93 | import Data.Typeable 94 | import GHC.Generics 95 | 96 | instance SemigroupIn t f => Interpret (Chain1 t) f where 97 | retract = \case 98 | Done1 x -> x 99 | More1 xs -> binterpret id retract xs 100 | interpret :: forall g. g ~> f -> Chain1 t g ~> f 101 | interpret f = go 102 | where 103 | go :: Chain1 t g ~> f 104 | go = \case 105 | Done1 x -> f x 106 | More1 xs -> binterpret f go xs 107 | 108 | -- | A type @'NonEmptyBy' t@ is supposed to represent the successive application of 109 | -- @t@s to itself. The type @'Chain1' t f@ is an actual concrete ADT that contains 110 | -- successive applications of @t@ to itself, and you can pattern match on 111 | -- each layer. 112 | -- 113 | -- 'unrollingNE' states that the two types are isormorphic. Use 'unrollNE' 114 | -- and 'rerollNE' to convert between the two. 115 | unrollingNE :: forall t f. (Associative t, FunctorBy t f) => NonEmptyBy t f <~> Chain1 t f 116 | unrollingNE = isoF unrollNE rerollNE 117 | 118 | -- | A type @'NonEmptyBy' t@ is supposed to represent the successive application of 119 | -- @t@s to itself. 'unrollNE' makes that successive application explicit, 120 | -- buy converting it to a literal 'Chain1' of applications of @t@ to 121 | -- itself. 122 | -- 123 | -- @ 124 | -- 'unrollNE' = 'unfoldChain1' 'matchNE' 125 | -- @ 126 | unrollNE :: (Associative t, FunctorBy t f) => NonEmptyBy t f ~> Chain1 t f 127 | unrollNE = unfoldChain1 matchNE 128 | 129 | -- | 'Chain1' is a semigroup with respect to @t@: we can "combine" them in 130 | -- an associative way. 131 | -- 132 | -- This is essentially 'biretract', but only requiring @'Associative' t@: 133 | -- it comes from the fact that @'Chain1' t@ is the "free @'SemigroupIn' 134 | -- t@". 135 | -- 136 | -- @since 0.1.1.0 137 | appendChain1 :: 138 | forall t f. 139 | (Associative t, FunctorBy t f) => 140 | t (Chain1 t f) (Chain1 t f) ~> Chain1 t f 141 | appendChain1 = 142 | unrollNE 143 | . appendNE 144 | . hbimap rerollNE rerollNE 145 | 146 | -- | @'Chain1' t@ is the "free @'SemigroupIn' t@". However, we have to 147 | -- wrap @t@ in 'WrapHBF' to prevent overlapping instances. 148 | instance (Associative t, FunctorBy t f, FunctorBy t (Chain1 t f)) => SemigroupIn (WrapHBF t) (Chain1 t f) where 149 | biretract = appendChain1 . unwrapHBF 150 | binterpret f g = biretract . hbimap f g 151 | 152 | -- | @'Chain1' 'Day'@ is the free "semigroup in the semigroupoidal category 153 | -- of endofunctors enriched by 'Day'" --- aka, the free 'Apply'. 154 | instance Functor f => Apply (Chain1 Day f) where 155 | f <.> x = appendChain1 $ Day f x ($) 156 | 157 | instance Functor f => Apply (Chain1 Comp f) where 158 | (<.>) = apDefault 159 | 160 | -- | @'Chain1' 'Comp'@ is the free "semigroup in the semigroupoidal 161 | -- category of endofunctors enriched by 'Comp'" --- aka, the free 'Bind'. 162 | instance Functor f => Bind (Chain1 Comp f) where 163 | x >>- f = appendChain1 (x :>>= f) 164 | 165 | -- | @'Chain1' (':*:')@ is the free "semigroup in the semigroupoidal 166 | -- category of endofunctors enriched by ':*:'" --- aka, the free 'Alt'. 167 | instance Functor f => Alt (Chain1 (:*:) f) where 168 | x y = appendChain1 (x :*: y) 169 | 170 | -- | @'Chain1' 'Product'@ is the free "semigroup in the semigroupoidal 171 | -- category of endofunctors enriched by 'Product'" --- aka, the free 'Alt'. 172 | instance Functor f => Alt (Chain1 Product f) where 173 | x y = appendChain1 (Pair x y) 174 | 175 | -- | @'Chain1' 'CD.Day'@ is the free "semigroup in the semigroupoidal 176 | -- category of endofunctors enriched by 'CD.Day'" --- aka, the free 'Divise'. 177 | -- 178 | -- @since 0.3.0.0 179 | instance Contravariant f => Divise (Chain1 CD.Day f) where 180 | divise f x y = appendChain1 $ CD.Day x y f 181 | 182 | -- | @'Chain1' 'N.Night'@ is the free "semigroup in the semigroupoidal 183 | -- category of endofunctors enriched by 'N.Night'" --- aka, the free 184 | -- 'Decide'. 185 | -- 186 | -- @since 0.3.0.0 187 | instance Contravariant f => Decide (Chain1 N.Night f) where 188 | decide f x y = appendChain1 $ N.Night x y f 189 | 190 | -- | @since 0.4.0.0 191 | instance Invariant f => Inply (Chain1 ID.Day f) where 192 | gather f g x y = appendChain1 (ID.Day x y f g) 193 | 194 | instance Tensor t i => Inject (Chain t i) where 195 | inject = injectChain 196 | 197 | -- | @since 0.4.0.0 198 | instance Invariant f => Inalt (Chain1 IN.Night f) where 199 | swerve f g h x y = appendChain1 (IN.Night x y f g h) 200 | 201 | -- | We can collapse and interpret an @'Chain' t i@ if we have @'Tensor' t@. 202 | instance MonoidIn t i f => Interpret (Chain t i) f where 203 | interpret :: 204 | forall g. 205 | () => 206 | g ~> f -> 207 | Chain t i g ~> f 208 | interpret f = go 209 | where 210 | go :: Chain t i g ~> f 211 | go = \case 212 | Done x -> pureT @t x 213 | More xs -> binterpret f go xs 214 | 215 | -- | Convert a tensor value pairing two @f@s into a two-item 'Chain'. An 216 | -- analogue of 'toListBy'. 217 | -- 218 | -- @since 0.3.1.0 219 | toChain :: Tensor t i => t f f ~> Chain t i f 220 | toChain = More . hright inject 221 | 222 | -- | Create a singleton chain. 223 | -- 224 | -- @since 0.3.0.0 225 | injectChain :: Tensor t i => f ~> Chain t i f 226 | injectChain = More . hright Done . intro1 227 | 228 | -- | A 'Chain1' is "one or more linked @f@s", and a 'Chain' is "zero or 229 | -- more linked @f@s". So, we can convert from a 'Chain1' to a 'Chain' that 230 | -- always has at least one @f@. 231 | -- 232 | -- The result of this function always is made with 'More' at the top level. 233 | fromChain1 :: 234 | Tensor t i => 235 | Chain1 t f ~> Chain t i f 236 | fromChain1 = foldChain1 (More . hright Done . intro1) More 237 | 238 | -- | A type @'ListBy' t@ is supposed to represent the successive application of 239 | -- @t@s to itself. The type @'Chain' t i f@ is an actual concrete 240 | -- ADT that contains successive applications of @t@ to itself, and you can 241 | -- pattern match on each layer. 242 | -- 243 | -- 'unrolling' states that the two types are isormorphic. Use 'unroll' 244 | -- and 'reroll' to convert between the two. 245 | unrolling :: 246 | Tensor t i => 247 | ListBy t f <~> Chain t i f 248 | unrolling = isoF unroll reroll 249 | 250 | -- | A @'Chain1' t f@ is like a non-empty linked list of @f@s, and 251 | -- a @'Chain' t i f@ is a possibly-empty linked list of @f@s. This 252 | -- witnesses the fact that the former is isomorphic to @f@ consed to the 253 | -- latter. 254 | splittingChain1 :: 255 | forall t i f. 256 | (Matchable t i, FunctorBy t f) => 257 | Chain1 t f <~> t f (Chain t i f) 258 | splittingChain1 = 259 | fromF unrollingNE 260 | . splittingNE @t 261 | . overHBifunctor id unrolling 262 | 263 | -- | A @'Chain' t i f@ is a linked list of @f@s, and a @'Chain1' t f@ is 264 | -- a non-empty linked list of @f@s. This witnesses the fact that 265 | -- a @'Chain' t i f@ is either empty (@i@) or non-empty (@'Chain1' t f@). 266 | matchingChain :: 267 | forall t i f. 268 | (Matchable t i, FunctorBy t f) => 269 | Chain t i f <~> i :+: Chain1 t f 270 | matchingChain = 271 | fromF unrolling 272 | . matchingLB @t 273 | . overHBifunctor id unrollingNE 274 | 275 | -- | The "reverse" function representing 'matchingChain'. Provided here 276 | -- as a separate function because it does not require @'Functor' f@. 277 | unmatchChain :: 278 | forall t i f. 279 | Tensor t i => 280 | i :+: Chain1 t f ~> Chain t i f 281 | unmatchChain = unroll . (nilLB @t !*! fromNE @t) . hright rerollNE 282 | 283 | -- | We have to wrap @t@ in 'WrapHBF' to prevent overlapping instances. 284 | instance (Tensor t i, FunctorBy t (Chain t i f)) => SemigroupIn (WrapHBF t) (Chain t i f) where 285 | biretract = appendChain . unwrapHBF 286 | binterpret f g = biretract . hbimap f g 287 | 288 | -- | @'Chain' t i@ is the "free @'MonoidIn' t i@". However, we have to 289 | -- wrap @t@ in 'WrapHBF' and @i@ in 'WrapF' to prevent overlapping instances. 290 | instance (Tensor t i, FunctorBy t (Chain t i f)) => MonoidIn (WrapHBF t) (WrapF i) (Chain t i f) where 291 | pureT = Done . unwrapF 292 | 293 | instance Apply (Chain Day Identity f) where 294 | f <.> x = appendChain $ Day f x ($) 295 | 296 | -- | @'Chain' 'Day' 'Identity'@ is the free "monoid in the monoidal 297 | -- category of endofunctors enriched by 'Day'" --- aka, the free 298 | -- 'Applicative'. 299 | instance Applicative (Chain Day Identity f) where 300 | pure = Done . Identity 301 | (<*>) = (<.>) 302 | 303 | -- | @since 0.3.0.0 304 | instance Divise (Chain CD.Day Proxy f) where 305 | divise f x y = appendChain $ CD.Day x y f 306 | 307 | -- | @'Chain' 'CD.Day' 'Proxy'@ is the free "monoid in the monoidal 308 | -- category of endofunctors enriched by contravariant 'CD.Day'" --- aka, 309 | -- the free 'Divisible'. 310 | -- 311 | -- @since 0.3.0.0 312 | instance Divisible (Chain CD.Day Proxy f) where 313 | divide f x y = appendChain $ CD.Day x y f 314 | conquer = Done Proxy 315 | 316 | -- | @since 0.4.0.0 317 | instance Inply (Chain ID.Day Identity f) where 318 | gather f g x y = appendChain (ID.Day x y f g) 319 | 320 | -- | @since 0.4.0.0 321 | instance Inplicative (Chain ID.Day Identity f) where 322 | knot = Done . Identity 323 | 324 | -- | @since 0.4.0.0 325 | instance Inalt (Chain IN.Night IN.Not f) where 326 | swerve f g h x y = appendChain (IN.Night x y f g h) 327 | 328 | -- | @since 0.4.0.0 329 | instance Inplus (Chain IN.Night IN.Not f) where 330 | reject = Done . IN.Not 331 | 332 | -- | @since 0.3.0.0 333 | instance Decide (Chain N.Night N.Not f) where 334 | decide f x y = appendChain $ N.Night x y f 335 | 336 | -- | @'Chain' 'N.Night' 'N.Refutec'@ is the free "monoid in the monoidal 337 | -- category of endofunctors enriched by 'N.Night'" --- aka, the free 338 | -- 'Conclude'. 339 | -- 340 | -- @since 0.3.0.0 341 | instance Conclude (Chain N.Night N.Not f) where 342 | conclude = Done . N.Not 343 | 344 | instance Apply (Chain Comp Identity f) where 345 | (<.>) = apDefault 346 | 347 | instance Applicative (Chain Comp Identity f) where 348 | pure = Done . Identity 349 | (<*>) = (<.>) 350 | 351 | instance Bind (Chain Comp Identity f) where 352 | x >>- f = appendChain (x :>>= f) 353 | 354 | -- | @'Chain' 'Comp' 'Identity'@ is the free "monoid in the monoidal 355 | -- category of endofunctors enriched by 'Comp'" --- aka, the free 356 | -- 'Monad'. 357 | instance Monad (Chain Comp Identity f) where 358 | (>>=) = (>>-) 359 | 360 | instance Functor f => Alt (Chain (:*:) Proxy f) where 361 | x y = appendChain (x :*: y) 362 | 363 | -- | @'Chain' (':*:') 'Proxy'@ is the free "monoid in the monoidal 364 | -- category of endofunctors enriched by ':*:'" --- aka, the free 365 | -- 'Plus'. 366 | instance Functor f => Plus (Chain (:*:) Proxy f) where 367 | zero = Done Proxy 368 | 369 | instance Functor f => Alt (Chain Product Proxy f) where 370 | x y = appendChain (Pair x y) 371 | 372 | -- | @'Chain' (':*:') 'Proxy'@ is the free "monoid in the monoidal 373 | -- category of endofunctors enriched by ':*:'" --- aka, the free 374 | -- 'Plus'. 375 | instance Functor f => Plus (Chain Product Proxy f) where 376 | zero = Done Proxy 377 | -------------------------------------------------------------------------------- /src/Data/HFunctor/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# OPTIONS_HADDOCK hide, not-home #-} 3 | 4 | module Data.HFunctor.Internal ( 5 | HFunctor (..), 6 | HBifunctor (..), 7 | WrappedHBifunctor (..), 8 | sumSum, 9 | prodProd, 10 | generalize, 11 | absorb, 12 | NDL, 13 | ndlSingleton, 14 | fromNDL, 15 | ) where 16 | 17 | import qualified Control.Alternative.Free as Alt 18 | import Control.Applicative.Backwards 19 | import Control.Applicative.Free 20 | import qualified Control.Applicative.Free.Fast as FAF 21 | import qualified Control.Applicative.Free.Final as FA 22 | import Control.Applicative.Lift 23 | import Control.Applicative.ListF 24 | import Control.Applicative.Step 25 | import Control.Comonad.Trans.Env 26 | import qualified Control.Monad.Free.Church as MC 27 | import Control.Monad.Freer.Church 28 | import Control.Monad.Trans.Compose 29 | import Control.Monad.Trans.Identity 30 | import Control.Monad.Trans.Maybe 31 | import Control.Monad.Trans.Reader 32 | import Control.Natural 33 | import Control.Natural.IsoF 34 | import Data.Bifunctor 35 | import Data.Bifunctor.Joker 36 | import Data.Coerce 37 | import Data.Foldable 38 | import Data.Functor.Bind 39 | import qualified Data.Functor.Contravariant.Coyoneda as CCY 40 | import qualified Data.Functor.Contravariant.Day as CD 41 | import Data.Functor.Contravariant.Night (Night (..)) 42 | import qualified Data.Functor.Contravariant.Night as N 43 | import Data.Functor.Coyoneda 44 | import Data.Functor.Day (Day (..)) 45 | import qualified Data.Functor.Day as D 46 | import Data.Functor.Identity 47 | import qualified Data.Functor.Invariant.Day as ID 48 | import qualified Data.Functor.Invariant.Night as IN 49 | import Data.Functor.Product 50 | import Data.Functor.Reverse 51 | import Data.Functor.Sum 52 | import Data.Functor.These 53 | import Data.Functor.Yoneda 54 | import Data.Kind 55 | import Data.List.NonEmpty (NonEmpty (..)) 56 | import Data.Proxy 57 | import qualified Data.SOP as SOP 58 | import qualified Data.SOP.NP as SOP 59 | import qualified Data.SOP.NS as SOP 60 | import Data.Tagged 61 | import Data.Vinyl.CoRec 62 | import Data.Vinyl.Core (Rec) 63 | import Data.Vinyl.Recursive 64 | import GHC.Generics 65 | 66 | -- | An 'HFunctor' can be thought of a unary "functor transformer" --- 67 | -- a basic functor combinator. It takes a functor as input and returns 68 | -- a functor as output. 69 | -- 70 | -- It "enhances" a functor with extra structure (sort of like how a monad 71 | -- transformer enhances a 'Monad' with extra structure). 72 | -- 73 | -- As a uniform inteface, we can "swap the underlying functor" (also 74 | -- sometimes called "hoisting"). This is what 'hmap' does: it lets us swap 75 | -- out the @f@ in a @t f@ for a @t g@. 76 | -- 77 | -- For example, the free monad 'Free' takes a 'Functor' and returns a new 78 | -- 'Functor'. In the process, it provides a monadic structure over @f@. 79 | -- 'hmap' lets us turn a @'Free' f@ into a @'Free' g@: a monad built over 80 | -- @f@ can be turned into a monad built over @g@. 81 | -- 82 | -- For the ability to move in and out of the enhanced functor, see 83 | -- 'Data.HFunctor.Inject' and 'Data.HFunctor.Interpret.Interpret'. 84 | -- 85 | -- This class is similar to 'Control.Monad.Morph.MFunctor' from 86 | -- "Control.Monad.Morph", but instances must work without a 'Monad' constraint. 87 | -- 88 | -- This class is also found in the /hschema/ library with the same name. 89 | class HFunctor t where 90 | -- | If we can turn an @f@ into a @g@, then we can turn a @t f@ into 91 | -- a @t g@. 92 | -- 93 | -- It must be the case that 94 | -- 95 | -- @ 96 | -- 'hmap' 'id' == id 97 | -- @ 98 | -- 99 | -- Essentially, @t f@ adds some "extra structure" to @f@. 'hmap' 100 | -- must swap out the functor, /without affecting the added structure/. 101 | -- 102 | -- For example, @'ListF' f a@ is essentially a list of @f a@s. If we 103 | -- 'hmap' to swap out the @f a@s for @g a@s, then we must ensure that 104 | -- the "added structure" (here, the number of items in the list, and 105 | -- the ordering of those items) remains the same. So, 'hmap' must 106 | -- preserve the number of items in the list, and must maintain the 107 | -- ordering. 108 | -- 109 | -- The law @'hmap' 'id' == id@ is a way of formalizing this property. 110 | hmap :: f ~> g -> t f ~> t g 111 | 112 | {-# MINIMAL hmap #-} 113 | 114 | -- | A 'HBifunctor' is like an 'HFunctor', but it enhances /two/ different 115 | -- functors instead of just one. 116 | -- 117 | -- Usually, it enhaces them "together" in some sort of combining way. 118 | -- 119 | -- This typeclass provides a uniform instance for "swapping out" or 120 | -- "hoisting" the enhanced functors. We can hoist the first one with 121 | -- 'hleft', the second one with 'hright', or both at the same time with 122 | -- 'hbimap'. 123 | -- 124 | -- For example, the @f :*: g@ type gives us "both @f@ and @g@": 125 | -- 126 | -- @ 127 | -- data (f ':*:' g) a = f a :*: g a 128 | -- @ 129 | -- 130 | -- It combines both @f@ and @g@ into a unified structure --- here, it does 131 | -- it by providing both @f@ and @g@. 132 | -- 133 | -- The single law is: 134 | -- 135 | -- @ 136 | -- 'hbimap' 'id' id == id 137 | -- @ 138 | -- 139 | -- This ensures that 'hleft', 'hright', and 'hbimap' do not affect the 140 | -- structure that @t@ adds on top of the underlying functors. 141 | class HBifunctor (t :: (k -> Type) -> (k -> Type) -> k -> Type) where 142 | -- | Swap out the first transformed functor. 143 | hleft :: f ~> j -> t f g ~> t j g 144 | hleft f x = hbimap f id x 145 | 146 | -- | Swap out the second transformed functor. 147 | hright :: g ~> l -> t f g ~> t f l 148 | hright f x = hbimap id f x 149 | 150 | -- | Swap out both transformed functors at the same time. 151 | hbimap :: f ~> j -> g ~> l -> t f g ~> t j l 152 | hbimap f g = hleft f . hright g 153 | 154 | {-# MINIMAL hleft, hright | hbimap #-} 155 | 156 | -- | Useful newtype to allow us to derive an 'HFunctor' instance from any 157 | -- instance of 'HBifunctor', using -XDerivingVia. 158 | -- 159 | -- For example, because we have @instance 'HBifunctor' 'Day'@, we can 160 | -- write: 161 | -- 162 | -- @ 163 | -- deriving via ('WrappedHBifunctor' 'Day' f) instance 'HFunctor' ('Day' f) 164 | -- @ 165 | -- 166 | -- to give us an automatic 'HFunctor' instance and save us some work. 167 | newtype WrappedHBifunctor t (f :: k -> Type) (g :: k -> Type) (a :: k) = WrapHBifunctor {unwrapHBifunctor :: t f g a} 168 | deriving (Functor) 169 | 170 | -- | Isomorphism between different varieities of ':+:'. 171 | sumSum :: (f :+: g) <~> Sum f g 172 | sumSum = isoF to_ from_ 173 | where 174 | to_ (L1 x) = InL x 175 | to_ (R1 y) = InR y 176 | from_ (InL x) = L1 x 177 | from_ (InR y) = R1 y 178 | 179 | -- | Isomorphism between different varieities of ':*:'. 180 | prodProd :: (f :*: g) <~> Product f g 181 | prodProd = isoF to_ from_ 182 | where 183 | to_ (x :*: y) = Pair x y 184 | from_ (Pair x y) = x :*: y 185 | 186 | -- | Turn 'Identity' into any @'Applicative' f@. Can be useful as an 187 | -- argument to 'hmap', 'hbimap', or 'Data.HFunctor.Interpret.interpret'. 188 | -- 189 | -- It is a more general form of 'Control.Monad.Morph.generalize' from 190 | -- /mmorph/. 191 | generalize :: Applicative f => Identity ~> f 192 | generalize (Identity x) = pure x 193 | 194 | -- | Natural transformation from any functor @f@ into 'Proxy'. Can be 195 | -- useful for "zeroing out" a functor with 'hmap' or 'hbimap' or 196 | -- 'Data.HFunctor.Interpret.interpret'. 197 | absorb :: f ~> Proxy 198 | absorb _ = Proxy 199 | 200 | -- | Internal type, used to not require dlist-1.0 201 | newtype NDL a = NDL ([a] -> NonEmpty a) 202 | 203 | ndlSingleton :: a -> NDL a 204 | ndlSingleton x = NDL (x :|) 205 | 206 | fromNDL :: NDL a -> NonEmpty a 207 | fromNDL (NDL f) = f [] 208 | 209 | instance Semigroup (NDL a) where 210 | NDL x <> NDL y = NDL (x . toList . y) 211 | 212 | instance HFunctor Coyoneda where 213 | hmap f x = hoistCoyoneda f x 214 | 215 | -- | @since 0.3.0.0 216 | instance HFunctor CCY.Coyoneda where 217 | hmap f (CCY.Coyoneda g x) = CCY.Coyoneda g (f x) 218 | 219 | instance HFunctor Ap where 220 | hmap f x = hoistAp f x 221 | 222 | instance HFunctor ListF where 223 | hmap f (ListF xs) = ListF (map f xs) 224 | 225 | instance HFunctor NonEmptyF where 226 | hmap f (NonEmptyF xs) = NonEmptyF (fmap f xs) 227 | 228 | instance HFunctor MaybeF where 229 | hmap f (MaybeF xs) = MaybeF (fmap f xs) 230 | 231 | instance HFunctor (MapF k) where 232 | hmap f (MapF xs) = MapF (fmap f xs) 233 | 234 | instance HFunctor (NEMapF k) where 235 | hmap f (NEMapF xs) = NEMapF (fmap f xs) 236 | 237 | instance HFunctor Alt.Alt where 238 | hmap f x = Alt.hoistAlt f x 239 | 240 | -- | @since 0.3.6.0 241 | instance HFunctor Alt.AltF where 242 | hmap f = \case 243 | Alt.Ap x xs -> Alt.Ap (f x) (hmap f xs) 244 | Alt.Pure x -> Alt.Pure x 245 | 246 | instance HFunctor Step where 247 | hmap f (Step n x) = Step n (f x) 248 | 249 | instance HFunctor Steps where 250 | hmap f (Steps xs) = Steps (f <$> xs) 251 | 252 | instance HFunctor Flagged where 253 | hmap f (Flagged b x) = Flagged b (f x) 254 | 255 | instance HFunctor Free where 256 | hmap f x = hoistFree f x 257 | 258 | instance HFunctor Free1 where 259 | hmap f x = hoistFree1 f x 260 | 261 | -- | Note that there is no 'Data.HFunctor.Interpret.Interpret' or 262 | -- 'Data.HFunctor.Bind' instance, because 'Data.HFunctor.inject' requires 263 | -- @'Functor' f@. 264 | instance HFunctor MC.F where 265 | hmap f x = MC.hoistF f x 266 | 267 | -- | Note that there is no 'Data.HFunctor.Interpret.Interpret' or 268 | -- 'Data.HFunctor.Bind' instance, because 'Data.HFunctor.inject' requires 269 | -- @'Functor' f@. 270 | instance HFunctor MaybeT where 271 | hmap f x = mapMaybeT f x 272 | 273 | instance HFunctor Yoneda where 274 | hmap f x = Yoneda $ f . runYoneda x 275 | 276 | instance HFunctor FA.Ap where 277 | hmap f x = FA.hoistAp f x 278 | 279 | instance HFunctor FAF.Ap where 280 | hmap f x = FAF.hoistAp f x 281 | 282 | instance HFunctor IdentityT where 283 | hmap f x = mapIdentityT f x 284 | 285 | instance HFunctor Lift where 286 | hmap f x = mapLift f x 287 | 288 | instance HFunctor MaybeApply where 289 | hmap f (MaybeApply x) = MaybeApply (first f x) 290 | 291 | instance HFunctor Backwards where 292 | hmap f (Backwards x) = Backwards (f x) 293 | 294 | instance HFunctor WrappedApplicative where 295 | hmap f (WrapApplicative x) = WrapApplicative (f x) 296 | 297 | instance HFunctor (ReaderT r) where 298 | hmap f x = mapReaderT f x 299 | 300 | instance HFunctor Tagged where 301 | hmap _ x = coerce x 302 | 303 | instance HFunctor Reverse where 304 | hmap f (Reverse x) = Reverse (f x) 305 | 306 | instance (HFunctor s, HFunctor t) => HFunctor (ComposeT s t) where 307 | hmap f (ComposeT x) = ComposeT $ hmap (hmap f) x 308 | 309 | instance Functor f => HFunctor ((:.:) f) where 310 | hmap f (Comp1 x) = Comp1 (f <$> x) 311 | 312 | instance HFunctor (M1 i c) where 313 | hmap f (M1 x) = M1 (f x) 314 | 315 | instance HFunctor Void2 where 316 | hmap _ x = coerce x 317 | 318 | instance HFunctor (EnvT e) where 319 | hmap f (EnvT e x) = EnvT e (f x) 320 | 321 | instance HFunctor Rec where 322 | hmap f x = rmap f x 323 | 324 | instance HFunctor CoRec where 325 | hmap f (CoRec x) = CoRec (f x) 326 | 327 | -- | @since 0.3.0.0 328 | instance HFunctor SOP.NP where 329 | hmap f = SOP.cata_NP SOP.Nil ((SOP.:*) . f) 330 | 331 | -- | @since 0.3.0.0 332 | instance HFunctor SOP.NS where 333 | hmap f = SOP.cata_NS (SOP.Z . f) SOP.S 334 | 335 | instance HFunctor (Joker f) where 336 | hmap _ x = coerce x 337 | 338 | instance HFunctor (Void3 f) where 339 | hmap _ = \case {} 340 | 341 | instance HFunctor (Comp f) where 342 | hmap f (x :>>= h) = x :>>= (f . h) 343 | 344 | instance HBifunctor (:*:) where 345 | hleft f (x :*: y) = f x :*: y 346 | hright g (x :*: y) = x :*: g y 347 | hbimap f g (x :*: y) = f x :*: g y 348 | 349 | instance HBifunctor Product where 350 | hleft f (Pair x y) = Pair (f x) y 351 | hright g (Pair x y) = Pair x (g y) 352 | hbimap f g (Pair x y) = Pair (f x) (g y) 353 | 354 | instance HBifunctor Day where 355 | hleft f x = D.trans1 f x 356 | hright f x = D.trans2 f x 357 | hbimap f g (Day x y z) = Day (f x) (g y) z 358 | 359 | -- | @since 0.3.0.0 360 | instance HBifunctor CD.Day where 361 | hleft f x = CD.trans1 f x 362 | hright f x = CD.trans2 f x 363 | hbimap f g (CD.Day x y z) = CD.Day (f x) (g y) z 364 | 365 | -- | @since 0.3.4.0 366 | instance HBifunctor ID.Day where 367 | hbimap f g (ID.Day x y h j) = ID.Day (f x) (g y) h j 368 | 369 | instance HBifunctor IN.Night where 370 | hbimap f g (IN.Night x y h j k) = IN.Night (f x) (g y) h j k 371 | 372 | -- | @since 0.3.0.0 373 | instance HBifunctor Night where 374 | hleft f x = N.trans1 f x 375 | hright f x = N.trans2 f x 376 | hbimap f g (Night x y z) = Night (f x) (g y) z 377 | 378 | instance HBifunctor (:+:) where 379 | hleft f = \case 380 | L1 x -> L1 (f x) 381 | R1 y -> R1 y 382 | 383 | hright g = \case 384 | L1 x -> L1 x 385 | R1 y -> R1 (g y) 386 | 387 | hbimap f g = \case 388 | L1 x -> L1 (f x) 389 | R1 y -> R1 (g y) 390 | 391 | instance HBifunctor Sum where 392 | hleft f = \case 393 | InL x -> InL (f x) 394 | InR y -> InR y 395 | 396 | hright g = \case 397 | InL x -> InL x 398 | InR y -> InR (g y) 399 | 400 | hbimap f g = \case 401 | InL x -> InL (f x) 402 | InR y -> InR (g y) 403 | 404 | instance HBifunctor These1 where 405 | hbimap f g = \case 406 | This1 x -> This1 (f x) 407 | That1 y -> That1 (g y) 408 | These1 x y -> These1 (f x) (g y) 409 | 410 | instance HBifunctor Joker where 411 | hleft f (Joker x) = Joker (f x) 412 | hright _ = coerce 413 | hbimap f _ (Joker x) = Joker (f x) 414 | 415 | instance HBifunctor Void3 where 416 | hleft _ = coerce 417 | hright _ = coerce 418 | hbimap _ _ = coerce 419 | 420 | instance HBifunctor Comp where 421 | hleft f (x :>>= h) = f x :>>= h 422 | hright g (x :>>= h) = x :>>= (g . h) 423 | hbimap f g (x :>>= h) = f x :>>= (g . h) 424 | 425 | instance HBifunctor t => HFunctor (WrappedHBifunctor t f) where 426 | hmap f = WrapHBifunctor . hright f . unwrapHBifunctor 427 | 428 | deriving via (WrappedHBifunctor Day f) instance HFunctor (Day f) 429 | deriving via (WrappedHBifunctor ID.Day f) instance HFunctor (ID.Day f) 430 | deriving via (WrappedHBifunctor IN.Night f) instance HFunctor (IN.Night f) 431 | deriving via (WrappedHBifunctor (:*:) f) instance HFunctor ((:*:) f) 432 | deriving via (WrappedHBifunctor (:+:) f) instance HFunctor ((:+:) f) 433 | deriving via (WrappedHBifunctor Product f) instance HFunctor (Product f) 434 | deriving via (WrappedHBifunctor Sum f) instance HFunctor (Sum f) 435 | deriving via (WrappedHBifunctor These1 f) instance HFunctor (These1 f) 436 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | import Tests.HBifunctor 3 | import Tests.HFunctor 4 | 5 | main :: IO () 6 | main = 7 | defaultMain $ 8 | testGroup 9 | "Tests" 10 | [ hfunctorTests 11 | , hbifunctorTests 12 | ] 13 | -------------------------------------------------------------------------------- /test/Tests/HFunctor.hs: -------------------------------------------------------------------------------- 1 | module Tests.HFunctor ( 2 | hfunctorTests, 3 | ) where 4 | 5 | import Control.Applicative 6 | import Control.Applicative.Backwards 7 | import qualified Control.Applicative.Free.Fast as FAF 8 | import qualified Control.Applicative.Free.Final as FA 9 | import Data.Bifunctor 10 | import Data.Functor.Bind 11 | import Data.Functor.Combinator 12 | import Data.Functor.Product 13 | import Data.Functor.Reverse 14 | import Data.Functor.Sum 15 | import Data.HFunctor 16 | import qualified Data.Semigroup as S 17 | import Data.Void 18 | import GHC.Generics (M1 (..), Meta (..)) 19 | import Hedgehog 20 | import qualified Hedgehog.Gen as Gen 21 | import qualified Hedgehog.Range as Range 22 | import Test.Tasty 23 | import Test.Tasty.Hedgehog 24 | import Tests.Util 25 | 26 | hmapProp :: 27 | forall t f m a. 28 | ( HFunctor t 29 | , Monad m 30 | , Show (t f a) 31 | , Eq (t f a) 32 | ) => 33 | Gen (t f a) -> 34 | PropertyT m () 35 | hmapProp gx = do 36 | x <- forAll gx 37 | hmap id x === x 38 | 39 | retractingProp :: 40 | forall t f m a. 41 | ( Interpret t f 42 | , Monad m 43 | , Show (f a) 44 | , Show (t f a) 45 | , Eq (f a) 46 | ) => 47 | Gen (f a) -> 48 | PropertyT m () 49 | retractingProp gx = do 50 | x <- forAll gx 51 | tripping x (inject @t) (Just . retract) 52 | 53 | interpretProp :: 54 | forall t f m a. 55 | ( Interpret t f 56 | , Monad m 57 | , Show (f a) 58 | , Show (t f a) 59 | , Eq (f a) 60 | ) => 61 | Gen (t f a) -> 62 | PropertyT m () 63 | interpretProp gx = do 64 | x <- forAll gx 65 | retract x === interpret id x 66 | 67 | hbindInjectProp :: 68 | forall t f m a. 69 | ( HBind t 70 | , Monad m 71 | , Show (t f a) 72 | , Eq (t f a) 73 | ) => 74 | Gen (t f a) -> 75 | PropertyT m () 76 | hbindInjectProp gx = do 77 | x <- forAll gx 78 | hbind inject x === x 79 | 80 | hbindhjoinProp :: 81 | forall t f m a. 82 | ( HBind t 83 | , Monad m 84 | , Show (t (t f) a) 85 | , Show (t f a) 86 | , Eq (t f a) 87 | ) => 88 | Gen (t (t f) a) -> 89 | PropertyT m () 90 | hbindhjoinProp gx = do 91 | x <- forAll gx 92 | hbind id x === hjoin x 93 | 94 | hjoinAssocProp :: 95 | forall t f m a. 96 | ( HBind t 97 | , Monad m 98 | , Show (t (t (t f)) a) 99 | , Show (t f a) 100 | , Eq (t f a) 101 | ) => 102 | Gen (t (t (t f)) a) -> 103 | PropertyT m () 104 | hjoinAssocProp gx = do 105 | x <- forAll gx 106 | hjoin (hjoin x) === hjoin (hmap hjoin x) 107 | 108 | hfunctorProps :: 109 | forall t f a. 110 | ( TestHFunctor t 111 | , Show (t f a) 112 | , Eq (t f a) 113 | , TestHFunctorBy t f 114 | ) => 115 | Gen (f a) -> 116 | TestTree 117 | hfunctorProps gx = 118 | testGroup 119 | "HFunctor" 120 | [testProperty "hmap" . property $ hmapProp @t (genHF gx)] 121 | 122 | hbindProps :: 123 | forall t f a. 124 | ( HBind t 125 | , TestHFunctor t 126 | , Show (t f a) 127 | , Eq (t f a) 128 | , Show (t (t f) a) 129 | , Show (t (t (t f)) a) 130 | , TestHFunctorBy t (t (t f)) 131 | , TestHFunctorBy t (t f) 132 | , TestHFunctorBy t f 133 | ) => 134 | Gen (f a) -> 135 | TestTree 136 | hbindProps gx = 137 | testGroup "HBind" 138 | . map (uncurry testProperty . second property) 139 | $ [ ("hbindInject", hbindInjectProp @t (genHF gx)) 140 | , ("hbindhjoin", hbindhjoinProp @t (genHF (genHF gx))) 141 | , ("hjoinAssoc", hjoinAssocProp @t (genHF (genHF (genHF gx)))) 142 | ] 143 | 144 | interpretProps :: 145 | forall t f a. 146 | ( Interpret t f 147 | , TestHFunctor t 148 | , Show (f a) 149 | , Eq (f a) 150 | , Show (t f a) 151 | , TestHFunctorBy t f 152 | ) => 153 | Gen (f a) -> 154 | TestTree 155 | interpretProps gx = 156 | testGroup "Interpret" 157 | . map (uncurry testProperty . second property) 158 | $ [ ("retracting", retractingProp @t gx) 159 | , ("interpret", interpretProp @t (genHF gx)) 160 | ] 161 | 162 | hbindProps_ :: 163 | forall t f a. 164 | ( HBind t 165 | , TestHFunctor t 166 | , Show (t f a) 167 | , Eq (t f a) 168 | , Show (t (t f) a) 169 | , Show (t (t (t f)) a) 170 | , TestHFunctorBy t f 171 | , TestHFunctorBy t (t f) 172 | , TestHFunctorBy t (t (t f)) 173 | ) => 174 | Gen (f a) -> 175 | [TestTree] 176 | hbindProps_ gx = 177 | [ hfunctorProps @t gx 178 | , hbindProps @t gx 179 | ] 180 | 181 | interpretProps_ :: 182 | forall t f a. 183 | ( Interpret t f 184 | , TestHFunctor t 185 | , Show (f a) 186 | , Eq (f a) 187 | , Show (t f a) 188 | , Eq (t f a) 189 | , TestHFunctorBy t f 190 | ) => 191 | Gen (f a) -> 192 | [TestTree] 193 | interpretProps_ gx = 194 | [ hfunctorProps @t gx 195 | , interpretProps @t gx 196 | ] 197 | 198 | bindInterpProps_ :: 199 | forall t f a. 200 | ( HBind t 201 | , Interpret t f 202 | , TestHFunctor t 203 | , Show (f a) 204 | , Eq (f a) 205 | , Show (t f a) 206 | , Eq (t f a) 207 | , Show (t (t f) a) 208 | , Show (t (t (t f)) a) 209 | , TestHFunctorBy t (t (t f)) 210 | , TestHFunctorBy t (t f) 211 | , TestHFunctorBy t f 212 | ) => 213 | Gen (f a) -> 214 | [TestTree] 215 | bindInterpProps_ gx = 216 | [ hfunctorProps @t gx 217 | , hbindProps @t gx 218 | , interpretProps @t gx 219 | ] 220 | 221 | hfunctorTests :: TestTree 222 | hfunctorTests = 223 | testGroup 224 | "HFunctors" 225 | [ testGroup "Ap" $ bindInterpProps_ @Ap @_ @Void (Const . S.Sum <$> intGen) 226 | , testGroup "Ap'" $ bindInterpProps_ @FA.Ap (Const . S.Sum <$> intGen) 227 | , testGroup "Ap''" $ bindInterpProps_ @FAF.Ap (Const . S.Sum <$> intGen) 228 | , -- , testGroup "Alt" $ bindInterpProps_ @Alt (Const . S.Sum <$> intGen) -- TODO 229 | testGroup "Coyoneda" $ bindInterpProps_ @Coyoneda listGen 230 | , testGroup "WrappedApplicative" $ bindInterpProps_ @WrappedApplicative listGen 231 | , testGroup "MaybeApply" $ bindInterpProps_ @MaybeApply listGen 232 | , testGroup "Lift" $ bindInterpProps_ @Lift listGen 233 | , testGroup "ListF" $ bindInterpProps_ @ListF (Gen.list (Range.linear 0 3) intGen) 234 | , testGroup "NonEmptyF" $ bindInterpProps_ @NonEmptyF (Gen.list (Range.linear 0 3) intGen) 235 | , testGroup "MaybeF" $ bindInterpProps_ @MaybeF listGen 236 | , testGroup "MapF" $ interpretProps_ @(MapF Ordering) (Gen.list (Range.linear 0 3) intGen) 237 | , testGroup "NEMapF" $ interpretProps_ @(NEMapF Ordering) (Gen.list (Range.linear 0 3) intGen) 238 | , testGroup "Free1" $ bindInterpProps_ @Free1 (Gen.list (Range.linear 0 3) intGen) 239 | , testGroup "Free" $ bindInterpProps_ @Free (Gen.list (Range.linear 0 3) intGen) 240 | , testGroup "Ap1" $ bindInterpProps_ @Ap1 (Const . S.Sum <$> intGen) 241 | , testGroup "EnvT" $ bindInterpProps_ @(EnvT Ordering) listGen 242 | , testGroup "IdentityT" $ bindInterpProps_ @IdentityT listGen 243 | , -- , testGroup "ReaderT" [ hfunctorProps @(ReaderT Int) listGen ] -- no Show 244 | testGroup "These1" $ bindInterpProps_ @(These1 []) listGen 245 | , testGroup "Reverse" $ bindInterpProps_ @Reverse listGen 246 | , testGroup "Backwards" $ bindInterpProps_ @Backwards listGen 247 | , testGroup "Comp" [hfunctorProps @(Comp []) (Gen.list (Range.linear 0 3) intGen)] 248 | , testGroup "Comp'" [hfunctorProps @((:*:) []) (Gen.list (Range.linear 0 3) intGen)] 249 | , testGroup "Step" $ bindInterpProps_ @Step listGen 250 | , testGroup "Steps" $ interpretProps_ @Steps listGen 251 | , testGroup "Flagged" $ bindInterpProps_ @Flagged listGen 252 | , testGroup "M1" $ bindInterpProps_ @(M1 () ('MetaData "" "" "" 'True)) listGen 253 | , testGroup "Product" $ bindInterpProps_ @((:*:) []) listGen 254 | , testGroup "Product'" $ bindInterpProps_ @(Product []) listGen 255 | , testGroup "Sum" $ bindInterpProps_ @((:+:) []) listGen 256 | , testGroup "Sum'" $ bindInterpProps_ @(Sum []) listGen 257 | , testGroup "ProxyF" $ hbindProps_ @ProxyF listGen 258 | , testGroup "RightF" $ hbindProps_ @(RightF []) listGen 259 | ] 260 | -------------------------------------------------------------------------------- /test/Tests/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Tests.Util ( 5 | isoProp, 6 | sumGen, 7 | intGen, 8 | listGen, 9 | TestHFunctor (..), 10 | TestHBifunctor (..), 11 | ) where 12 | 13 | import Control.Applicative 14 | import Control.Applicative.Backwards 15 | import qualified Control.Applicative.Free as Ap 16 | import qualified Control.Applicative.Free.Fast as FAF 17 | import qualified Control.Applicative.Free.Final as FA 18 | import Control.Applicative.Lift 19 | import Control.Monad.Freer.Church 20 | import Control.Natural.IsoF 21 | import Data.Bifunctor.Joker 22 | import Data.Constraint.Trivial 23 | import Data.Function 24 | import Data.Functor 25 | import Data.Functor.Bind 26 | import Data.Functor.Classes 27 | import Data.Functor.Combinator 28 | import Data.Functor.Identity 29 | import Data.Functor.Plus 30 | import Data.Functor.Product 31 | import Data.Functor.Reverse 32 | import Data.Functor.Sum 33 | import Data.GADT.Show 34 | import Data.HBifunctor.Tensor 35 | import Data.HFunctor.Chain 36 | import Data.HFunctor.Interpret 37 | import Data.Kind 38 | import qualified Data.List.NonEmpty as NE 39 | import qualified Data.Map.NonEmpty as NEM 40 | import Data.Semigroup (Any (..)) 41 | import Data.Semigroup.Traversable 42 | import GHC.Generics (M1 (..)) 43 | import Hedgehog hiding (HTraversable (..)) 44 | import qualified Hedgehog.Gen as Gen 45 | import qualified Hedgehog.Range as Range 46 | 47 | isoProp :: 48 | (Show (f a), Show (g a), Eq (f a), Eq (g a), Monad m) => 49 | (f <~> g) -> 50 | Gen (f a) -> 51 | Gen (g a) -> 52 | PropertyT m () 53 | isoProp i gx gy = do 54 | x <- forAll gx 55 | tripping x (viewF i) (Just . reviewF i) 56 | y <- forAll gy 57 | tripping y (reviewF i) (Just . viewF i) 58 | 59 | sumGen :: MonadGen m => m (f a) -> m (g a) -> m ((f :+: g) a) 60 | sumGen gx gy = 61 | Gen.bool >>= \case 62 | False -> L1 <$> gx 63 | True -> R1 <$> gy 64 | 65 | intGen :: MonadGen m => m Int 66 | intGen = Gen.integral (Range.linear 0 100) 67 | 68 | listGen :: MonadGen m => m [Int] 69 | listGen = Gen.list (Range.linear 0 100) intGen 70 | 71 | instance (GShow f, GShow g) => Eq (Day f g a) where 72 | (==) = (==) `on` show 73 | 74 | instance Show c => GShow (Const c) where 75 | gshowsPrec = showsPrec 76 | 77 | instance (GShow f, GShow g) => GShow (Day f g) where 78 | gshowsPrec d (Day x y _) = 79 | showsBinaryWith gshowsPrec gshowsPrec "Day" d x y 80 | 81 | instance (GShow f, GShow (t f (Chain1 t f))) => GShow (Chain1 t f) where 82 | gshowsPrec d = \case 83 | Done1 x -> gshowsPrec d x 84 | More1 xs -> gshowsPrec d xs 85 | 86 | instance GShow Identity where 87 | gshowsPrec _ _ = showString "" 88 | 89 | instance (GShow i, GShow (t f (Chain t i f))) => GShow (Chain t i f) where 90 | gshowsPrec d = \case 91 | Done x -> gshowsPrec d x 92 | More xs -> gshowsPrec d xs 93 | 94 | instance (GShow f, GShow g) => Show (Day f g a) where 95 | showsPrec = gshowsPrec 96 | 97 | instance (GShow f, Functor f) => GShow (Ap1 f) where 98 | gshowsPrec d (Ap1 x y) = case matchLB @Day y of 99 | L1 _ -> showsUnaryWith gshowsPrec "inject" d x 100 | R1 ys -> showsBinaryWith gshowsPrec gshowsPrec "Ap1" d x ys 101 | 102 | instance (GShow f, Functor f) => Eq (Ap1 f a) where 103 | (==) = (==) `on` show 104 | 105 | instance (GShow f, Functor f) => Show (Ap1 f a) where 106 | showsPrec = gshowsPrec 107 | 108 | instance GShow f => GShow (Ap f) where 109 | gshowsPrec d = \case 110 | Ap.Pure _ -> showString "" 111 | Ap.Ap x xs -> showsBinaryWith gshowsPrec gshowsPrec "Ap" d x xs 112 | 113 | instance GShow f => GShow (FA.Ap f) where 114 | gshowsPrec d = gshowsPrec d . FA.runAp Ap.liftAp 115 | 116 | instance GShow f => GShow (FAF.Ap f) where 117 | gshowsPrec d = gshowsPrec d . FAF.runAp Ap.liftAp 118 | 119 | instance GShow f => Show (Ap f a) where 120 | showsPrec = gshowsPrec 121 | 122 | instance GShow f => Show (FA.Ap f a) where 123 | showsPrec = gshowsPrec 124 | 125 | instance GShow f => Show (FAF.Ap f a) where 126 | showsPrec = gshowsPrec 127 | 128 | #if !MIN_VERSION_free(5,2,0) 129 | instance GShow f => Eq (Ap f a) where 130 | (==) = (==) `on` show 131 | #endif 132 | 133 | instance GShow f => Eq (FA.Ap f a) where 134 | (==) = (==) `on` show 135 | 136 | instance GShow f => Eq (FAF.Ap f a) where 137 | (==) = (==) `on` show 138 | 139 | deriving instance (Show e, Show (f a)) => Show (EnvT e f a) 140 | deriving instance (Eq e, Eq (f a)) => Eq (EnvT e f a) 141 | 142 | instance (Show e, Show1 f) => Show1 (EnvT e f) where 143 | liftShowsPrec sp sl d (EnvT e x) = 144 | showsBinaryWith showsPrec (liftShowsPrec sp sl) "EnvT" d e x 145 | 146 | instance (Eq e, Eq1 f) => Eq1 (EnvT e f) where 147 | liftEq eq (EnvT e x) (EnvT d y) = e == d && liftEq eq x y 148 | 149 | instance Show1 (s (t f)) => Show1 (ComposeT s t f) where 150 | liftShowsPrec sp sl d (ComposeT x) = 151 | showsUnaryWith (liftShowsPrec sp sl) "ComposeT" d x 152 | 153 | instance Eq1 (s (t f)) => Eq1 (ComposeT s t f) where 154 | liftEq eq (ComposeT x) (ComposeT y) = liftEq eq x y 155 | 156 | instance Enum Any where 157 | toEnum = Any . toEnum 158 | fromEnum = fromEnum . getAny 159 | 160 | #if !MIN_VERSION_base(0,9,2) 161 | instance Show1 V1 where 162 | liftShowsPrec _ _ _ = \case {} 163 | 164 | instance Eq1 V1 where 165 | liftEq _ = \case {} 166 | #endif 167 | 168 | class HFunctor t => TestHFunctor t where 169 | type TestHFunctorBy t :: (Type -> Type) -> Constraint 170 | type TestHFunctorBy t = Unconstrained 171 | genHF :: 172 | (MonadGen m, TestHFunctorBy t f) => 173 | m (f a) -> 174 | m (t f a) 175 | default genHF :: (Inject t, MonadGen m) => m (f a) -> m (t f a) 176 | genHF = fmap inject 177 | 178 | instance TestHFunctor Step where 179 | genHF gx = Step <$> Gen.integral (Range.linear 0 25) <*> gx 180 | 181 | instance TestHFunctor ListF where 182 | genHF gx = ListF <$> Gen.list (Range.linear 0 25) gx 183 | 184 | instance TestHFunctor NonEmptyF where 185 | genHF gx = NonEmptyF <$> Gen.nonEmpty (Range.linear 1 25) gx 186 | 187 | instance (Enum k, Bounded k, Ord k) => TestHFunctor (MapF k) where 188 | genHF gx = MapF <$> Gen.map (Range.linear 0 10) kv 189 | where 190 | kv = 191 | (,) 192 | <$> Gen.enumBounded 193 | <*> gx 194 | 195 | instance (Enum k, Bounded k, Ord k) => TestHFunctor (NEMapF k) where 196 | genHF gx = do 197 | mp <- Gen.map (Range.linear 0 10) kv 198 | (k, v) <- kv 199 | pure . NEMapF $ NEM.insertMap k v mp 200 | where 201 | kv = 202 | (,) 203 | <$> Gen.enumBounded 204 | <*> gx 205 | 206 | instance TestHFunctor Steps where 207 | genHF gx = do 208 | mp <- Gen.map (Range.linear 0 10) kv 209 | (k, v) <- kv 210 | pure . Steps $ NEM.insertMap k v mp 211 | where 212 | kv = 213 | (,) 214 | <$> Gen.integral (Range.linear 0 25) 215 | <*> gx 216 | 217 | instance TestHFunctor Ap where 218 | genHF gx = 219 | fmap NE.last 220 | . sequence1 221 | . fmap inject 222 | <$> Gen.nonEmpty (Range.linear 0 3) gx 223 | 224 | instance TestHFunctor FA.Ap where 225 | genHF gx = 226 | fmap NE.last 227 | . sequence1 228 | . fmap inject 229 | <$> Gen.nonEmpty (Range.linear 0 3) gx 230 | 231 | instance TestHFunctor FAF.Ap where 232 | genHF gx = 233 | fmap NE.last 234 | . sequence1 235 | . fmap inject 236 | <$> Gen.nonEmpty (Range.linear 0 3) gx 237 | 238 | instance TestHFunctor Ap1 where 239 | genHF gx = 240 | fmap NE.last 241 | . sequence1 242 | . fmap inject 243 | <$> Gen.nonEmpty (Range.linear 1 3) gx 244 | 245 | instance TestHFunctor Free where 246 | genHF gx = 247 | fmap NE.last 248 | . traverse inject 249 | <$> Gen.nonEmpty (Range.linear 0 3) gx 250 | 251 | instance TestHFunctor Free1 where 252 | genHF gx = 253 | fmap NE.last 254 | . sequence1 255 | . fmap inject 256 | <$> Gen.nonEmpty (Range.linear 1 3) gx 257 | 258 | instance TestHFunctor t => TestHFunctor (HLift t) where 259 | type TestHFunctorBy (HLift t) = TestHFunctorBy t 260 | genHF gx = 261 | Gen.bool >>= \case 262 | False -> HPure <$> gx 263 | True -> HOther <$> genHF gx 264 | 265 | instance (Enum e, Bounded e) => TestHFunctor (EnvT e) where 266 | genHF gx = EnvT <$> Gen.enumBounded <*> gx 267 | 268 | instance (TestHFunctor s, HTraversable s, TestHFunctor t) => TestHFunctor (ComposeT s t) where 269 | type TestHFunctorBy (ComposeT s t) = AndC (TestHFunctorBy s) (TestHFunctorBy t) 270 | genHF gx = 271 | fmap ComposeT 272 | . htraverse (genHF @t . pure) 273 | =<< genHF @s gx 274 | 275 | instance TestHFunctor Flagged where 276 | genHF gx = Flagged <$> Gen.bool <*> gx 277 | 278 | class HBifunctor t => TestHBifunctor t where 279 | genHB :: 280 | MonadGen m => 281 | m (f a) -> 282 | m (g a) -> 283 | m (t f g a) 284 | 285 | instance TestHBifunctor (:+:) where 286 | genHB = sumGen 287 | 288 | instance TestHBifunctor Sum where 289 | genHB gx gy = 290 | sumGen gx gy <&> \case 291 | L1 x -> InL x 292 | R1 y -> InR y 293 | 294 | instance TestHBifunctor (:*:) where 295 | genHB gx gy = (:*:) <$> gx <*> gy 296 | 297 | instance TestHBifunctor Product where 298 | genHB gx gy = Pair <$> gx <*> gy 299 | 300 | instance TestHBifunctor Day where 301 | genHB gx gy = do 302 | f <- 303 | Gen.bool <&> \case 304 | False -> const 305 | True -> const id 306 | Day <$> gx <*> gy <*> pure f 307 | 308 | instance TestHBifunctor These1 where 309 | genHB gx gy = 310 | Gen.enumBounded >>= \case 311 | LT -> This1 <$> gx 312 | EQ -> That1 <$> gy 313 | GT -> These1 <$> gx <*> gy 314 | 315 | instance TestHBifunctor Comp where 316 | genHB gx gy = (:>>=) <$> gx <*> fmap const gy 317 | 318 | instance TestHBifunctor LeftF where 319 | genHB gx _ = LeftF <$> gx 320 | 321 | instance TestHBifunctor Joker where 322 | genHB gx _ = Joker <$> gx 323 | 324 | instance TestHBifunctor RightF where 325 | genHB _ gy = RightF <$> gy 326 | 327 | instance TestHBifunctor t => TestHFunctor (Chain1 t) where 328 | genHF x = go 329 | where 330 | go = 331 | Gen.bool >>= \case 332 | False -> Done1 <$> x 333 | True -> More1 <$> genHB x go 334 | 335 | deriving instance Eq (f a) => Eq (WrappedApplicative f a) 336 | deriving instance Show (f a) => Show (WrappedApplicative f a) 337 | 338 | -- | We cannot test the pure case, huhu 339 | instance TestHFunctor MaybeApply 340 | 341 | deriving instance (Eq a, Eq (f a)) => Eq (MaybeApply f a) 342 | deriving instance (Show a, Show (f a)) => Show (MaybeApply f a) 343 | 344 | -- | We cannot test the pure case, huhu 345 | instance TestHFunctor Lift 346 | 347 | -- | We cannot test the pure case, huhu 348 | instance TestHFunctor (These1 f) 349 | 350 | instance TestHFunctor MaybeF where 351 | genHF gx = 352 | Gen.bool >>= \case 353 | False -> pure $ MaybeF Nothing 354 | True -> MaybeF . Just <$> gx 355 | 356 | instance TestHFunctor IdentityT 357 | instance TestHFunctor Coyoneda 358 | instance TestHFunctor WrappedApplicative 359 | instance TestHFunctor Reverse 360 | instance TestHFunctor Backwards 361 | instance Applicative f => TestHFunctor (Comp f :: (Type -> Type) -> Type -> Type) 362 | instance TestHFunctor (M1 i c) 363 | instance Plus f => TestHFunctor ((:*:) f) 364 | instance Plus f => TestHFunctor (Product f) 365 | instance TestHFunctor ((:+:) f) 366 | instance TestHFunctor (Sum f) 367 | instance TestHFunctor ProxyF 368 | instance TestHFunctor (RightF f) 369 | --------------------------------------------------------------------------------