├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CONTRIBUTING.md ├── README.md ├── cabal.haskell-ci ├── cabal.project ├── monad-chronicle ├── CHANGELOG.md ├── LICENSE ├── cabal.project ├── monad-chronicle.cabal └── src │ └── Control │ └── Monad │ ├── Chronicle.hs │ ├── Chronicle │ └── Class.hs │ └── Trans │ └── Chronicle.hs ├── semialign ├── CHANGELOG.md ├── LICENSE ├── cabal.project ├── semialign.cabal └── src │ └── Data │ ├── Align.hs │ ├── Crosswalk.hs │ ├── Semialign.hs │ ├── Semialign │ ├── Indexed.hs │ └── Internal.hs │ └── Zip.hs ├── stack.yaml ├── these-lens ├── CHANGELOG.md ├── LICENSE ├── cabal.project ├── src │ └── Data │ │ └── These │ │ └── Lens.hs └── these-lens.cabal ├── these-optics ├── CHANGELOG.md ├── LICENSE ├── cabal.project ├── src │ └── Data │ │ └── These │ │ └── Optics.hs └── these-optics.cabal ├── these-tests ├── LICENSE ├── src │ └── Dummy.hs ├── test │ ├── Tests.hs │ └── Tests │ │ ├── AlignWrong.hs │ │ ├── Crosswalk.hs │ │ ├── Orphans.hs │ │ ├── Semialign.hs │ │ ├── SemialignWithIndex.hs │ │ └── These.hs └── these-tests.cabal └── these ├── CHANGELOG.md ├── LICENSE ├── cabal.project ├── src └── Data │ ├── Functor │ └── These.hs │ ├── These.hs │ └── These │ └── Combinators.hs └── these.cabal /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250104 12 | # 13 | # REGENDATA ("0.19.20250104",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-20.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.1 36 | compilerKind: ghc 37 | compilerVersion: 9.12.1 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.1 41 | compilerKind: ghc 42 | compilerVersion: 9.10.1 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.6 51 | compilerKind: ghc 52 | compilerVersion: 9.6.6 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | fail-fast: false 86 | steps: 87 | - name: apt-get install 88 | run: | 89 | apt-get update 90 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 91 | - name: Install GHCup 92 | run: | 93 | mkdir -p "$HOME/.ghcup/bin" 94 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 95 | chmod a+x "$HOME/.ghcup/bin/ghcup" 96 | - name: Install cabal-install 97 | run: | 98 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1 || (cat "$HOME"/.ghcup/logs/*.* && false) 99 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1 -vnormal+nowrap" >> "$GITHUB_ENV" 100 | - name: Install GHC (GHCup) 101 | if: matrix.setup-method == 'ghcup' 102 | run: | 103 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 104 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 105 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 106 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 107 | echo "HC=$HC" >> "$GITHUB_ENV" 108 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 109 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 110 | env: 111 | HCKIND: ${{ matrix.compilerKind }} 112 | HCNAME: ${{ matrix.compiler }} 113 | HCVER: ${{ matrix.compilerVersion }} 114 | - name: Set PATH and environment variables 115 | run: | 116 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 117 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 118 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 119 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 120 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 121 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 122 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 123 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 124 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 125 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 126 | env: 127 | HCKIND: ${{ matrix.compilerKind }} 128 | HCNAME: ${{ matrix.compiler }} 129 | HCVER: ${{ matrix.compilerVersion }} 130 | - name: env 131 | run: | 132 | env 133 | - name: write cabal config 134 | run: | 135 | mkdir -p $CABAL_DIR 136 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 169 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 170 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 171 | rm -f cabal-plan.xz 172 | chmod a+x $HOME/.cabal/bin/cabal-plan 173 | cabal-plan --version 174 | - name: checkout 175 | uses: actions/checkout@v4 176 | with: 177 | path: source 178 | - name: initial cabal.project for sdist 179 | run: | 180 | touch cabal.project 181 | echo "packages: $GITHUB_WORKSPACE/source/these" >> cabal.project 182 | echo "packages: $GITHUB_WORKSPACE/source/these-lens" >> cabal.project 183 | echo "packages: $GITHUB_WORKSPACE/source/these-optics" >> cabal.project 184 | echo "packages: $GITHUB_WORKSPACE/source/semialign" >> cabal.project 185 | echo "packages: $GITHUB_WORKSPACE/source/monad-chronicle" >> cabal.project 186 | echo "packages: $GITHUB_WORKSPACE/source/these-tests" >> cabal.project 187 | cat cabal.project 188 | - name: sdist 189 | run: | 190 | mkdir -p sdist 191 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 192 | - name: unpack 193 | run: | 194 | mkdir -p unpacked 195 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 196 | - name: generate cabal.project 197 | run: | 198 | PKGDIR_these="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/these-[0-9.]*')" 199 | echo "PKGDIR_these=${PKGDIR_these}" >> "$GITHUB_ENV" 200 | PKGDIR_these_lens="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/these-lens-[0-9.]*')" 201 | echo "PKGDIR_these_lens=${PKGDIR_these_lens}" >> "$GITHUB_ENV" 202 | PKGDIR_these_optics="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/these-optics-[0-9.]*')" 203 | echo "PKGDIR_these_optics=${PKGDIR_these_optics}" >> "$GITHUB_ENV" 204 | PKGDIR_semialign="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/semialign-[0-9.]*')" 205 | echo "PKGDIR_semialign=${PKGDIR_semialign}" >> "$GITHUB_ENV" 206 | PKGDIR_monad_chronicle="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/monad-chronicle-[0-9.]*')" 207 | echo "PKGDIR_monad_chronicle=${PKGDIR_monad_chronicle}" >> "$GITHUB_ENV" 208 | PKGDIR_these_tests="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/these-tests-[0-9.]*')" 209 | echo "PKGDIR_these_tests=${PKGDIR_these_tests}" >> "$GITHUB_ENV" 210 | rm -f cabal.project cabal.project.local 211 | touch cabal.project 212 | touch cabal.project.local 213 | echo "packages: ${PKGDIR_these}" >> cabal.project 214 | echo "packages: ${PKGDIR_these_lens}" >> cabal.project 215 | echo "packages: ${PKGDIR_these_optics}" >> cabal.project 216 | echo "packages: ${PKGDIR_semialign}" >> cabal.project 217 | echo "packages: ${PKGDIR_monad_chronicle}" >> cabal.project 218 | echo "packages: ${PKGDIR_these_tests}" >> cabal.project 219 | echo "package these" >> cabal.project 220 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 221 | echo "package these-lens" >> cabal.project 222 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 223 | echo "package these-optics" >> cabal.project 224 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 225 | echo "package semialign" >> cabal.project 226 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 227 | echo "package monad-chronicle" >> cabal.project 228 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 229 | echo "package these-tests" >> cabal.project 230 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 231 | cat >> cabal.project <> cabal.project.local 234 | cat cabal.project 235 | cat cabal.project.local 236 | - name: dump install plan 237 | run: | 238 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 239 | cabal-plan 240 | - name: restore cache 241 | uses: actions/cache/restore@v4 242 | with: 243 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 244 | path: ~/.cabal/store 245 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 246 | - name: build w/o tests 247 | run: | 248 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 249 | - name: build 250 | run: | 251 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 252 | - name: tests 253 | run: | 254 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 255 | - name: cabal check 256 | run: | 257 | cd ${PKGDIR_these} || false 258 | ${CABAL} -vnormal check 259 | cd ${PKGDIR_these_lens} || false 260 | ${CABAL} -vnormal check 261 | cd ${PKGDIR_these_optics} || false 262 | ${CABAL} -vnormal check 263 | cd ${PKGDIR_semialign} || false 264 | ${CABAL} -vnormal check 265 | cd ${PKGDIR_monad_chronicle} || false 266 | ${CABAL} -vnormal check 267 | cd ${PKGDIR_these_tests} || false 268 | ${CABAL} -vnormal check 269 | - name: haddock 270 | run: | 271 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 272 | - name: unconstrained build 273 | run: | 274 | rm -f cabal.project.local 275 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 276 | - name: prepare for constraint sets 277 | run: | 278 | rm -f cabal.project.local 279 | - name: constraint set mtl-2.3 280 | run: | 281 | if [ $((HCNUMVER < 90600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='mtl ^>=2.3' --constraint='transformers <0.6' all --dry-run ; fi 282 | if [ $((HCNUMVER < 90600)) -ne 0 ] ; then cabal-plan topo | sort ; fi 283 | if [ $((HCNUMVER < 90600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='mtl ^>=2.3' --constraint='transformers <0.6' all ; fi 284 | - name: constraint set transformers-0.6 285 | run: | 286 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='transformers ^>=0.6' all --dry-run 287 | cabal-plan topo | sort 288 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='transformers ^>=0.6' all 289 | - name: constraint set light 290 | run: | 291 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='monad-chronicle -semigroupoids' --constraint='semialign -semigroupoids' all --dry-run 292 | cabal-plan topo | sort 293 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='monad-chronicle -semigroupoids' --constraint='semialign -semigroupoids' all 294 | - name: save cache 295 | if: always() 296 | uses: actions/cache/save@v4 297 | with: 298 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 299 | path: ~/.cabal/store 300 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.p_o 2 | *.o 3 | *.hi 4 | *.prof 5 | dist 6 | .cabal-sandbox 7 | cabal.sandbox.config 8 | dist-newstyle/ 9 | .ghc.environment.* 10 | .stack-work/ 11 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: group 4 | list_align: after_alias 5 | long_list_align: new_line 6 | empty_list_align: right_after 7 | list_padding: module_name 8 | - language_pragmas: 9 | style: vertical 10 | remove_redundant: true 11 | - trailing_whitespace: {} 12 | columns: 80 13 | language_extensions: 14 | - DataKinds 15 | - EmptyCase 16 | - ExplicitForAll 17 | - FlexibleContexts 18 | - MultiParamTypeClasses 19 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Patches welcome! 2 | 3 | - If you are only going to bump bounds: 4 | - If it's really **only bounds**, please simply open an issue (so you'll have a URL to refer to). I have a semi-automated process to make revisions, pull requests only disturb it. 5 | - If patch includes **source code change** (i.e. I'll need to make a release), and it's a patch to support **newer base/GHC version**: 6 | - Amend `tested-with` to include that GHC 7 | - Regenerate `.github/workflows/haskell-ci.yml` with `haskell-ci regenerate` (get the latest from [GitHub haskell-ci/haskell-ci](https://github.com/haskell-ci/haskell-ci)) 8 | 9 | - Don't edit `CHANGELOG.md`, rather include a copyable entry in your pull request description. I often process pull requests in bulk, and everyone editing the `CHANGELOG.md` causes unnecessary conflicts. 10 | - For the same reason, do not edit `version` or `x-revision` 11 | 12 | - I use [`stylish-haskell`](https://github.com/jaspervdj/stylish-haskell) to format imports. I encourage you to use it too, when contributing. 13 | - General code style is 4 spaces, just look around how it looks, it's not so strict. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | These — an either-or-both data type 2 | ==================================== 3 | 4 | [![Build Status](https://secure.travis-ci.org/isomorphism/these.svg)](http://travis-ci.org/isomorphism/these) 5 | 6 | 7 | The type `These a b` represents having either a value of type `a`, a value of type `b`, or values of both `a` and `b`: 8 | 9 | ```haskell 10 | data These a b = This a | That b | These a b 11 | ``` 12 | 13 | This is equivalent to `Either (a, b) (Either a b)`. Or equivalent to `Either a (b, Maybe a)`. Or various other equally equivalent types. In terms of "sum" and "product" types, `These a b` is `a + b + ab` which can't be factored cleanly to get a type that mentions `a` and `b` only once each. 14 | 15 | The fact that there's no single obvious way to express it as a combination of existing types is one primary motivation for this package. 16 | 17 | A variety of functions are provided in `Data.These` akin to those in `Data.Either`, except somewhat more numerous on account of having more cases to consider. Most should be self-explanatory if you're already familiar with the similarly-named functions in `Data.Either` and `Data.Maybe`. 18 | 19 | `here` and `there` are traversals over elements of the same type, suitable for use with `Control.Lens`. This has the dramatic benefit that if you're using `lens` you can ignore the dreadfully bland `mapThis` and `mapThat` functions in favor of saying `over here` and `over there`. 20 | 21 | 22 | Align — structural unions 23 | ========================== 24 | 25 | There is a notion of "zippy" `Applicative`s where `liftA2 (,)` behaves like `zip` in the sense that if the `Functor` is regarded as a container with distinct locations, each element of the result is a pair of the values that occupied the same location in the two inputs. For this to be possible, the result can only contain values at locations where both inputs also contained values. In a sense, this is the intersection of the "shapes" of the two inputs. 26 | 27 | In the case of the `zip` function itself, this means the length of the result is equal to the length of the shorter of the two inputs. 28 | 29 | On many occasions it would be more useful to have a "zip with padding", where the length of the result is that of the *longer* input, with the other input extended by some means. The best way to do this is a recurring question, having been asked [at](http://stackoverflow.com/q/21349408/157360) [least](http://stackoverflow.com/q/22403029/157360) [four](http://stackoverflow.com/q/3015962/157360) [times](http://stackoverflow.com/q/9198410/157360) on Stack Overflow. 30 | 31 | Probably the most obvious general-purpose solution is use `Maybe` so that the result is of type `[(Maybe a, Maybe b)]`, but this forces any code using that result to consider the possibility of the list containing the value `(Nothing, Nothing)`, which we don't want. 32 | 33 | The type class `Align` is here because `f (These a b)` is the natural result type of a generic "zip with padding" operation--i.e. a structural union rather than intersection. 34 | 35 | I believe the name "Align" was borrowed from [a blog post by Paul Chiusano](http://pchiusano.blogspot.com/2010/06/alignable-functors-typeclass-for-zippy.html), though he used `Alignable` instead. 36 | 37 | 38 | Unalign 39 | ------- 40 | 41 | `unalign` is to `align` as `unzip` is to `zip`. 42 | 43 | Crosswalk 44 | --------- 45 | 46 | `Crosswalk` is to `Align` as `Traversable` is to `Applicative`. That's really all there is to say on the matter. 47 | 48 | 49 | Bicrosswalk 50 | ----------- 51 | 52 | ``` 53 | elliott, you should think of some more instances for Bicrosswalk one of these days 54 | cmccann: Does it have any instances? 55 | cmccann: unfortunately it is too perfect an abstraction to be useful. 56 | ``` 57 | 58 | ChronicleT — a.k.a. These as a monad 59 | ===================================== 60 | 61 | `These a` has an obvious `Monad` instance, provided here in monad transformer form. 62 | 63 | The expected use case is for computations with a notion of fatal vs. non-fatal errors, like a hybrid writer/exception monad. While running successfully a computation carries a "record" of type `c`, which accumulates using a `Monoid` instance (as with the writer monad); if a computation fails completely, the result is its record up to the point where it ended. 64 | 65 | A more specific example would be something like parsing ill-formed input with the goal of extracting as much as you can and throwing out anything you can't interpret. 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | -- doctest: <9 3 | -- docspec: True 4 | jobs-selection: any 5 | ghcjs-tests: True 6 | head-hackage: False 7 | 8 | -- quickcheck-instances makes a loop 9 | install-dependencies: False 10 | 11 | constraint-set light 12 | constraints: monad-chronicle -semigroupoids 13 | constraints: semialign -semigroupoids 14 | 15 | constraint-set transformers-0.6 16 | ghc: >=8.6 17 | constraints: transformers ^>=0.6 18 | 19 | -- No 9.6 cause lens fails top build 20 | constraint-set mtl-2.3 21 | ghc: >=8.6 && <9.6 22 | constraints: mtl ^>=2.3, transformers <0.6 23 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: these 2 | packages: these-lens 3 | packages: these-optics 4 | packages: semialign 5 | packages: monad-chronicle 6 | packages: these-tests 7 | 8 | tests: true 9 | -------------------------------------------------------------------------------- /monad-chronicle/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.1 2 | 3 | - Remove `disclose`. Use `dictate c >> return def` if you need it. 4 | No more dependency of `data-default` or `data-default-class`. 5 | This change is a consequence of change in `data-default-0.8.0.0` 6 | 7 | # 1.0.2 8 | 9 | - Support GHC-8.6.5...GHC-9.10.1 10 | 11 | # 1.0.1 12 | 13 | - Support `transformers-0.6` and `mtl-2.3` 14 | 15 | # 1 16 | 17 | - Split out of `these` package. 18 | -------------------------------------------------------------------------------- /monad-chronicle/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus 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 C. McCann 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 | -------------------------------------------------------------------------------- /monad-chronicle/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | packages: ../these 3 | tests: False 4 | benchmarks: False 5 | -------------------------------------------------------------------------------- /monad-chronicle/monad-chronicle.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: monad-chronicle 3 | version: 1.1 4 | synopsis: These as a transformer, ChronicleT 5 | homepage: https://github.com/haskellari/these 6 | license: BSD3 7 | license-file: LICENSE 8 | author: C. McCann, Oleg Grenrus 9 | maintainer: Oleg Grenrus 10 | category: Control, These 11 | build-type: Simple 12 | extra-source-files: CHANGELOG.md 13 | description: 14 | This packages provides @ChronicleT@, a monad transformer based on 15 | the @Monad@ instance for @These a@, along with the usual monad 16 | transformer bells and whistles. 17 | 18 | tested-with: 19 | GHC ==8.6.5 20 | || ==8.8.4 21 | || ==8.10.7 22 | || ==9.0.2 23 | || ==9.2.8 24 | || ==9.4.8 25 | || ==9.6.6 26 | || ==9.8.4 27 | || ==9.10.1 28 | || ==9.12.1 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/haskellari/these.git 33 | 34 | flag semigroupoids 35 | description: Build with semigroupoids dependency 36 | manual: True 37 | default: True 38 | 39 | library 40 | default-language: Haskell2010 41 | ghc-options: -Wall -Wno-trustworthy-safe 42 | hs-source-dirs: src 43 | exposed-modules: 44 | Control.Monad.Chronicle 45 | Control.Monad.Chronicle.Class 46 | Control.Monad.Trans.Chronicle 47 | 48 | -- ghc boot libs 49 | build-depends: 50 | base >=4.12.0.0 && <4.22 51 | , mtl >=2.2.2 && <2.4 52 | , transformers >=0.5.6.2 && <0.7 53 | 54 | build-depends: these >=1.2.1 && <1.3 55 | 56 | -- other dependencies 57 | build-depends: transformers-compat >=0.6.5 && <0.8 58 | 59 | if flag(semigroupoids) 60 | build-depends: semigroupoids >=6.0.1 && <6.1 61 | -------------------------------------------------------------------------------- /monad-chronicle/src/Control/Monad/Chronicle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | ----------------------------------------------------------------------------- 3 | -- | Module : Control.Monad.Trans.Chronicle 4 | -- 5 | -- The 'ChronicleT' monad, a hybrid error/writer monad that allows 6 | -- both accumulating outputs and aborting computation with a final 7 | -- output. 8 | ----------------------------------------------------------------------------- 9 | module Control.Monad.Chronicle ( 10 | -- * Type class for Chronicle-style monads 11 | MonadChronicle(..) 12 | -- * The ChronicleT monad transformer 13 | , Chronicle, runChronicle, ChronicleT(..) 14 | ) where 15 | 16 | import Control.Monad.Chronicle.Class 17 | import Control.Monad.Trans.Chronicle (Chronicle, ChronicleT (..), runChronicle) 18 | -------------------------------------------------------------------------------- /monad-chronicle/src/Control/Monad/Chronicle/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- for the ErrorT instances 7 | ----------------------------------------------------------------------------- 8 | -- | Module : Control.Monad.Chronicle.Class 9 | -- 10 | -- Hybrid error/writer monad class that allows both accumulating outputs and 11 | -- aborting computation with a final output. 12 | -- 13 | -- The expected use case is for computations with a notion of fatal vs. 14 | -- non-fatal errors. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | module Control.Monad.Chronicle.Class ( 18 | MonadChronicle(..), 19 | ) where 20 | 21 | import Control.Applicative 22 | import Control.Monad.Trans.Chronicle (ChronicleT) 23 | import qualified Control.Monad.Trans.Chronicle as Ch 24 | import Data.These 25 | import Data.These.Combinators 26 | 27 | import Control.Monad.Trans.Except as Except 28 | import Control.Monad.Trans.Identity as Identity 29 | import Control.Monad.Trans.Maybe as Maybe 30 | import Control.Monad.Trans.RWS.Lazy as LazyRWS 31 | import Control.Monad.Trans.RWS.Strict as StrictRWS 32 | import Control.Monad.Trans.Reader as Reader 33 | import Control.Monad.Trans.State.Lazy as LazyState 34 | import Control.Monad.Trans.State.Strict as StrictState 35 | import Control.Monad.Trans.Writer.Lazy as LazyWriter 36 | import Control.Monad.Trans.Writer.Strict as StrictWriter 37 | 38 | #if !(MIN_VERSION_transformers(0,6,0)) 39 | import Control.Monad.Trans.Error as Error 40 | #endif 41 | 42 | import Control.Monad (liftM) 43 | import Control.Monad.Trans.Class (lift) 44 | import Data.Semigroup 45 | import Prelude 46 | 47 | class (Monad m) => MonadChronicle c m | m -> c where 48 | -- | @'dictate' c@ is an action that records the output @c@. 49 | -- 50 | -- Equivalent to 'tell' for the 'Writer' monad. 51 | dictate :: c -> m () 52 | 53 | -- | @'confess' c@ is an action that ends with a final record @c@. 54 | -- 55 | -- Equivalent to 'throwError' for the 'Error' monad. 56 | confess :: c -> m a 57 | 58 | -- | @'memento' m@ is an action that executes the action @m@, returning either 59 | -- its record if it ended with 'confess', or its final value otherwise, with 60 | -- any record added to the current record. 61 | -- 62 | -- Similar to 'catchError' in the 'Error' monad, but with a notion of 63 | -- non-fatal errors (which are accumulated) vs. fatal errors (which are caught 64 | -- without accumulating). 65 | memento :: m a -> m (Either c a) 66 | 67 | -- | @'absolve' x m@ is an action that executes the action @m@ and discards any 68 | -- record it had. The default value @x@ will be used if @m@ ended via 69 | -- 'confess'. 70 | absolve :: a -> m a -> m a 71 | 72 | -- | @'condemn' m@ is an action that executes the action @m@ and keeps its value 73 | -- only if it had no record. Otherwise, the value (if any) will be discarded 74 | -- and only the record kept. 75 | -- 76 | -- This can be seen as converting non-fatal errors into fatal ones. 77 | condemn :: m a -> m a 78 | 79 | -- | @'retcon' f m@ is an action that executes the action @m@ and applies the 80 | -- function @f@ to its output, leaving the return value unchanged. 81 | -- 82 | -- Equivalent to 'censor' for the 'Writer' monad. 83 | retcon :: (c -> c) -> m a -> m a 84 | 85 | -- | @'chronicle' m@ lifts a plain @'These' c a@ value into a 'MonadChronicle' instance. 86 | chronicle :: These c a -> m a 87 | 88 | 89 | instance (Semigroup c) => MonadChronicle c (These c) where 90 | dictate c = These c () 91 | confess c = This c 92 | memento (This c) = That (Left c) 93 | memento m = mapThere Right m 94 | absolve x (This _) = That x 95 | absolve _ (That x) = That x 96 | absolve _ (These _ x) = That x 97 | condemn (These c _) = This c 98 | condemn m = m 99 | retcon = mapHere 100 | chronicle = id 101 | 102 | instance (Semigroup c, Monad m) => MonadChronicle c (ChronicleT c m) where 103 | dictate = Ch.dictate 104 | confess = Ch.confess 105 | memento = Ch.memento 106 | absolve = Ch.absolve 107 | condemn = Ch.condemn 108 | retcon = Ch.retcon 109 | chronicle = Ch.ChronicleT . return 110 | 111 | instance (MonadChronicle c m) => MonadChronicle c (IdentityT m) where 112 | dictate = lift . dictate 113 | confess = lift . confess 114 | memento (IdentityT m) = lift $ memento m 115 | absolve x (IdentityT m) = lift $ absolve x m 116 | condemn (IdentityT m) = lift $ condemn m 117 | retcon f (IdentityT m) = lift $ retcon f m 118 | chronicle = lift . chronicle 119 | 120 | instance (MonadChronicle c m) => MonadChronicle c (MaybeT m) where 121 | dictate = lift . dictate 122 | confess = lift . confess 123 | memento (MaybeT m) = MaybeT $ either (Just . Left) (Right <$>) `liftM` memento m 124 | absolve x (MaybeT m) = MaybeT $ absolve (Just x) m 125 | condemn (MaybeT m) = MaybeT $ condemn m 126 | retcon f (MaybeT m) = MaybeT $ retcon f m 127 | chronicle = lift . chronicle 128 | 129 | #if !(MIN_VERSION_transformers(0,6,0)) 130 | instance (Error e, MonadChronicle c m) => MonadChronicle c (ErrorT e m) where 131 | dictate = lift . dictate 132 | confess = lift . confess 133 | memento (ErrorT m) = ErrorT $ either (Right . Left) (Right <$>) `liftM` memento m 134 | absolve x (ErrorT m) = ErrorT $ absolve (Right x) m 135 | condemn (ErrorT m) = ErrorT $ condemn m 136 | retcon f (ErrorT m) = ErrorT $ retcon f m 137 | chronicle = lift . chronicle 138 | #endif 139 | 140 | instance (MonadChronicle c m) => MonadChronicle c (ExceptT e m) where 141 | dictate = lift . dictate 142 | confess = lift . confess 143 | memento (ExceptT m) = ExceptT $ either (Right . Left) (Right <$>) `liftM` memento m 144 | absolve x (ExceptT m) = ExceptT $ absolve (Right x) m 145 | condemn (ExceptT m) = ExceptT $ condemn m 146 | retcon f (ExceptT m) = ExceptT $ retcon f m 147 | chronicle = lift . chronicle 148 | 149 | instance (MonadChronicle c m) => MonadChronicle c (ReaderT r m) where 150 | dictate = lift . dictate 151 | confess = lift . confess 152 | memento (ReaderT m) = ReaderT $ memento . m 153 | absolve x (ReaderT m) = ReaderT $ absolve x . m 154 | condemn (ReaderT m) = ReaderT $ condemn . m 155 | retcon f (ReaderT m) = ReaderT $ retcon f . m 156 | chronicle = lift . chronicle 157 | 158 | instance (MonadChronicle c m) => MonadChronicle c (LazyState.StateT s m) where 159 | dictate = lift . dictate 160 | confess = lift . confess 161 | memento (LazyState.StateT m) = LazyState.StateT $ \s -> do 162 | either (\c -> (Left c, s)) (\(a, s') -> (Right a, s')) `liftM` memento (m s) 163 | absolve x (LazyState.StateT m) = LazyState.StateT $ \s -> absolve (x, s) $ m s 164 | condemn (LazyState.StateT m) = LazyState.StateT $ condemn . m 165 | retcon f (LazyState.StateT m) = LazyState.StateT $ retcon f . m 166 | chronicle = lift . chronicle 167 | 168 | instance (MonadChronicle c m) => MonadChronicle c (StrictState.StateT s m) where 169 | dictate = lift . dictate 170 | confess = lift . confess 171 | memento (StrictState.StateT m) = StrictState.StateT $ \s -> do 172 | either (\c -> (Left c, s)) (\(a, s') -> (Right a, s')) `liftM` memento (m s) 173 | absolve x (StrictState.StateT m) = StrictState.StateT $ \s -> absolve (x, s) $ m s 174 | condemn (StrictState.StateT m) = StrictState.StateT $ condemn . m 175 | retcon f (StrictState.StateT m) = StrictState.StateT $ retcon f . m 176 | chronicle = lift . chronicle 177 | 178 | instance (Monoid w, MonadChronicle c m) => MonadChronicle c (LazyWriter.WriterT w m) where 179 | dictate = lift . dictate 180 | confess = lift . confess 181 | memento (LazyWriter.WriterT m) = LazyWriter.WriterT $ 182 | either (\c -> (Left c, mempty)) (\(a, w) -> (Right a, w)) `liftM` memento m 183 | absolve x (LazyWriter.WriterT m) = LazyWriter.WriterT $ absolve (x, mempty) m 184 | condemn (LazyWriter.WriterT m) = LazyWriter.WriterT $ condemn m 185 | retcon f (LazyWriter.WriterT m) = LazyWriter.WriterT $ retcon f m 186 | chronicle = lift . chronicle 187 | 188 | instance (Monoid w, MonadChronicle c m) => MonadChronicle c (StrictWriter.WriterT w m) where 189 | dictate = lift . dictate 190 | confess = lift . confess 191 | memento (StrictWriter.WriterT m) = StrictWriter.WriterT $ 192 | either (\c -> (Left c, mempty)) (\(a, w) -> (Right a, w)) `liftM` memento m 193 | absolve x (StrictWriter.WriterT m) = StrictWriter.WriterT $ absolve (x, mempty) m 194 | condemn (StrictWriter.WriterT m) = StrictWriter.WriterT $ condemn m 195 | retcon f (StrictWriter.WriterT m) = StrictWriter.WriterT $ retcon f m 196 | chronicle = lift . chronicle 197 | 198 | instance (Monoid w, MonadChronicle c m) => MonadChronicle c (LazyRWS.RWST r w s m) where 199 | dictate = lift . dictate 200 | confess = lift . confess 201 | memento (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> 202 | either (\c -> (Left c, s, mempty)) (\(a, s', w) -> (Right a, s', w)) `liftM` memento (m r s) 203 | absolve x (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> absolve (x, s, mempty) $ m r s 204 | condemn (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> condemn $ m r s 205 | retcon f (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> retcon f $ m r s 206 | chronicle = lift . chronicle 207 | 208 | instance (Monoid w, MonadChronicle c m) => MonadChronicle c (StrictRWS.RWST r w s m) where 209 | dictate = lift . dictate 210 | confess = lift . confess 211 | memento (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> 212 | either (\c -> (Left c, s, mempty)) (\(a, s', w) -> (Right a, s', w)) `liftM` memento (m r s) 213 | absolve x (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> absolve (x, s, mempty) $ m r s 214 | condemn (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> condemn $ m r s 215 | retcon f (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> retcon f $ m r s 216 | chronicle = lift . chronicle 217 | 218 | 219 | 220 | -------------------------------------------------------------------------------- /monad-chronicle/src/Control/Monad/Trans/Chronicle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | ----------------------------------------------------------------------------- 7 | -- | Module : Control.Monad.Chronicle 8 | -- 9 | -- Hybrid error/writer monad class that allows both accumulating outputs and 10 | -- aborting computation with a final output. 11 | -- 12 | -- The expected use case is for computations with a notion of fatal vs. 13 | -- non-fatal errors. 14 | 15 | ----------------------------------------------------------------------------- 16 | module Control.Monad.Trans.Chronicle ( 17 | -- * The Chronicle monad 18 | Chronicle, chronicle, runChronicle, 19 | -- * The ChronicleT monad transformer 20 | ChronicleT(..), 21 | -- * Chronicle operations 22 | dictate, confess, 23 | memento, absolve, condemn, 24 | retcon, 25 | ) where 26 | 27 | import Control.Applicative 28 | import Control.Monad 29 | import Control.Monad.Fix 30 | import Control.Monad.Trans 31 | import Data.Functor.Identity 32 | import Data.Semigroup 33 | 34 | import Control.Monad.Error.Class 35 | import Control.Monad.Reader.Class 36 | import Control.Monad.RWS.Class 37 | import Data.These 38 | import Data.These.Combinators (mapHere) 39 | import Prelude 40 | 41 | #ifdef MIN_VERSION_semigroupoids 42 | import Data.Functor.Apply (Apply (..)) 43 | import Data.Functor.Bind (Bind (..)) 44 | #endif 45 | 46 | -- -------------------------------------------------------------------------- 47 | -- | A chronicle monad parameterized by the output type @c@. 48 | -- 49 | -- The 'return' function produces a computation with no output, and '>>=' 50 | -- combines multiple outputs with '<>'. 51 | type Chronicle c = ChronicleT c Identity 52 | 53 | chronicle :: Monad m => These c a -> ChronicleT c m a 54 | chronicle = ChronicleT . return 55 | 56 | runChronicle :: Chronicle c a -> These c a 57 | runChronicle = runIdentity . runChronicleT 58 | 59 | -- -------------------------------------------------------------------------- 60 | -- | The `ChronicleT` monad transformer. 61 | -- 62 | -- The 'return' function produces a computation with no output, and '>>=' 63 | -- combines multiple outputs with '<>'. 64 | newtype ChronicleT c m a = ChronicleT { runChronicleT :: m (These c a) } 65 | 66 | instance (Functor m) => Functor (ChronicleT c m) where 67 | fmap f (ChronicleT c) = ChronicleT (fmap f <$> c) 68 | 69 | #ifdef MIN_VERSION_semigroupoids 70 | instance (Semigroup c, Apply m) => Apply (ChronicleT c m) where 71 | ChronicleT f <.> ChronicleT x = ChronicleT ((<*>) <$> f <.> x) 72 | 73 | instance (Semigroup c, Apply m, Monad m) => Bind (ChronicleT c m) where 74 | (>>-) = (>>=) 75 | #endif 76 | 77 | instance (Semigroup c, Applicative m) => Applicative (ChronicleT c m) where 78 | pure = ChronicleT . pure . pure 79 | ChronicleT f <*> ChronicleT x = ChronicleT (liftA2 (<*>) f x) 80 | 81 | instance (Semigroup c, Monad m) => Monad (ChronicleT c m) where 82 | return = ChronicleT . return . return 83 | m >>= k = ChronicleT $ 84 | do cx <- runChronicleT m 85 | case cx of 86 | This a -> return (This a) 87 | That x -> runChronicleT (k x) 88 | These a x -> do cy <- runChronicleT (k x) 89 | return $ case cy of 90 | This b -> This (a <> b) 91 | That y -> These a y 92 | These b y -> These (a <> b) y 93 | 94 | instance (Semigroup c) => MonadTrans (ChronicleT c) where 95 | lift m = ChronicleT (That `liftM` m) 96 | 97 | instance (Semigroup c, MonadIO m) => MonadIO (ChronicleT c m) where 98 | liftIO = lift . liftIO 99 | 100 | 101 | instance (Semigroup c, Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where 102 | empty = mzero 103 | (<|>) = mplus 104 | 105 | instance (Semigroup c, Monoid c, Monad m) => MonadPlus (ChronicleT c m) where 106 | mzero = confess mempty 107 | mplus x y = do x' <- memento x 108 | case x' of 109 | Left _ -> y 110 | Right r -> return r 111 | 112 | 113 | instance (Semigroup c, MonadError e m) => MonadError e (ChronicleT c m) where 114 | throwError = lift . throwError 115 | catchError (ChronicleT m) c = ChronicleT $ catchError m (runChronicleT . c) 116 | 117 | 118 | instance (Semigroup c, MonadReader r m) => MonadReader r (ChronicleT c m) where 119 | ask = lift ask 120 | local f (ChronicleT m) = ChronicleT $ local f m 121 | reader = lift . reader 122 | 123 | instance (Semigroup c, MonadRWS r w s m) => MonadRWS r w s (ChronicleT c m) where 124 | 125 | instance (Semigroup c, MonadState s m) => MonadState s (ChronicleT c m) where 126 | get = lift get 127 | put = lift . put 128 | state = lift . state 129 | 130 | instance (Semigroup c, MonadWriter w m) => MonadWriter w (ChronicleT c m) where 131 | tell = lift . tell 132 | listen (ChronicleT m) = ChronicleT $ do 133 | (m', w) <- listen m 134 | return $ case m' of 135 | This c -> This c 136 | That x -> That (x, w) 137 | These c x -> These c (x, w) 138 | pass (ChronicleT m) = ChronicleT $ do 139 | pass $ these (\c -> (This c, id)) 140 | (\(x, f) -> (That x, f)) 141 | (\c (x, f) -> (These c x, f)) `liftM` m 142 | writer = lift . writer 143 | 144 | -- this is basically copied from the instance for Either in transformers 145 | -- need to test this to make sure it's actually sensible...? 146 | instance (Semigroup c, MonadFix m) => MonadFix (ChronicleT c m) where 147 | mfix f = ChronicleT (mfix (runChronicleT . f . these (const bomb) id (flip const))) 148 | where bomb = error "mfix (ChronicleT): inner compuation returned This value" 149 | 150 | 151 | -- | @'dictate' c@ is an action that records the output @c@. 152 | -- 153 | -- Equivalent to 'tell' for the 'Writer' monad. 154 | dictate :: (Semigroup c, Monad m) => c -> ChronicleT c m () 155 | dictate c = ChronicleT $ return (These c ()) 156 | 157 | -- | @'confess' c@ is an action that ends with a final output @c@. 158 | -- 159 | -- Equivalent to 'throwError' for the 'Error' monad. 160 | confess :: (Semigroup c, Monad m) => c -> ChronicleT c m a 161 | confess c = ChronicleT $ return (This c) 162 | 163 | -- | @'memento' m@ is an action that executes the action @m@, returning either 164 | -- its record if it ended with 'confess', or its final value otherwise, with 165 | -- any record added to the current record. 166 | -- 167 | -- Similar to 'catchError' in the 'Error' monad, but with a notion of 168 | -- non-fatal errors (which are accumulated) vs. fatal errors (which are caught 169 | -- without accumulating). 170 | memento :: (Semigroup c, Monad m) => ChronicleT c m a -> ChronicleT c m (Either c a) 171 | memento m = ChronicleT $ 172 | do cx <- runChronicleT m 173 | return $ case cx of 174 | This a -> That (Left a) 175 | That x -> That (Right x) 176 | These a x -> These a (Right x) 177 | 178 | -- | @'absolve' x m@ is an action that executes the action @m@ and discards any 179 | -- record it had. The default value @x@ will be used if @m@ ended via 180 | -- 'confess'. 181 | absolve :: (Semigroup c, Monad m) => a -> ChronicleT c m a -> ChronicleT c m a 182 | absolve x m = ChronicleT $ 183 | do cy <- runChronicleT m 184 | return $ case cy of 185 | This _ -> That x 186 | That y -> That y 187 | These _ y -> That y 188 | 189 | 190 | -- | @'condemn' m@ is an action that executes the action @m@ and keeps its value 191 | -- only if it had no record. Otherwise, the value (if any) will be discarded 192 | -- and only the record kept. 193 | -- 194 | -- This can be seen as converting non-fatal errors into fatal ones. 195 | condemn :: (Semigroup c, Monad m) => ChronicleT c m a -> ChronicleT c m a 196 | condemn (ChronicleT m) = ChronicleT $ do 197 | m' <- m 198 | return $ case m' of 199 | This x -> This x 200 | That y -> That y 201 | These x _ -> This x 202 | 203 | 204 | -- | @'retcon' f m@ is an action that executes the action @m@ and applies the 205 | -- function @f@ to its output, leaving the return value unchanged. 206 | -- 207 | -- Equivalent to 'censor' for the 'Writer' monad. 208 | retcon :: (Semigroup c, Monad m) => (c -> c) -> ChronicleT c m a -> ChronicleT c m a 209 | retcon f m = ChronicleT $ mapHere f `liftM` runChronicleT m 210 | 211 | -------------------------------------------------------------------------------- /semialign/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.3.1 2 | 3 | - Support GHC-8.6.5...GHC-9.10.1 4 | 5 | # 1.3 6 | 7 | - Depend on `bifunctor-classes-compat` instead of `bifunctors` 8 | See changelog note in `bifunctors-5.6`: https://hackage.haskell.org/package/bifunctors-5.6/changelog 9 | This is breaking change, but affects only GHC-8.0 and older users. 10 | In that case you should check various combinations of newer/older 11 | `bifunctors`, `these`, and `semialign` packages. 12 | 13 | # 1.2.0.1 14 | 15 | - GHC-9.2 support 16 | 17 | # 1.2 18 | 19 | - Migrate `SemialignWithIndex` and `ZipWithIndex` to this package, 20 | using `FunctorWithIndex` from `indexed-traversable`. 21 | - Add `RepeatWithIndex` type-class. 22 | - Poly-kinded instances (notably `Tagged`) 23 | 24 | # 1.1.0.1 25 | 26 | - Drop `base-compat` dependency 27 | 28 | # 1.1 29 | 30 | - Split `Semialign` into `Semialign` and `Zip`. 31 | - Rename old `Zip` into `Repeat` 32 | - i.e. current main hierarchy is 33 | - Remove `malign`, use `salign` or `alignWith mappend` where `Monoid` is necessary. 34 | - Add `Option` instances 35 | 36 | ```haskell 37 | instance Functor f => Semialign f where 38 | alignWith :: (These a b -> c) -> f a -> f b -> f c 39 | 40 | instance Semialign f => Align f where 41 | nil :: f a 42 | 43 | instance Semialign f => Zip f where 44 | zipWith :: (a -> b -> c) -> f a -> f b -> f c 45 | 46 | instance Zip f => Repeat f where 47 | repeat :: a -> f a 48 | ``` 49 | 50 | This biased choice, that `Semialign` is a super-class of `Zip` is motivated by the fact that 51 | - There's no `Semialign`-like class anywhere else, yet 52 | - `Zip` and `Repeat` are `Apply` (from `semigroupoids`) and `Applicative` with slightly more laws. I 53 | If you need only `Repeat` class, and your type isn't `Aling`able, maybe using `Applicative` is enough? 54 | 55 | # 1 56 | 57 | Split out of `these` package. 58 | -------------------------------------------------------------------------------- /semialign/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus 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 C. McCann 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 | -------------------------------------------------------------------------------- /semialign/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | packages: ../these 3 | tests: False 4 | benchmarks: False 5 | -------------------------------------------------------------------------------- /semialign/semialign.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: semialign 3 | version: 1.3.1 4 | x-revision: 1 5 | synopsis: 6 | Align and Zip type-classes from the common Semialign ancestor. 7 | 8 | homepage: https://github.com/haskellari/these 9 | license: BSD3 10 | license-file: LICENSE 11 | author: C. McCann, Oleg Grenrus 12 | maintainer: Oleg Grenrus 13 | category: Data, These 14 | build-type: Simple 15 | extra-source-files: CHANGELOG.md 16 | description: 17 | The major use of @These@ of this is provided by the @align@ member of 18 | @Semialign@ class, representing a generalized notion of "zipping with padding" 19 | that combines structures without truncating to the size of the smaller input. 20 | . 21 | It turns out that @zip@ operation fits well the @Semialign@ class, 22 | forming lattice-like structure. 23 | 24 | tested-with: 25 | GHC ==8.6.5 26 | || ==8.8.4 27 | || ==8.10.7 28 | || ==9.0.2 29 | || ==9.2.8 30 | || ==9.4.8 31 | || ==9.6.6 32 | || ==9.8.4 33 | || ==9.10.1 34 | || ==9.12.1 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/haskellari/these.git 39 | subdir: semialign 40 | 41 | flag semigroupoids 42 | description: Build with semigroupoids dependency 43 | manual: True 44 | default: True 45 | 46 | library 47 | default-language: Haskell2010 48 | ghc-options: -Wall -Wno-trustworthy-safe 49 | 50 | if impl(ghc >=9.2) 51 | ghc-options: -Wno-noncanonical-monoid-instances 52 | 53 | hs-source-dirs: src 54 | exposed-modules: 55 | Data.Align 56 | Data.Crosswalk 57 | Data.Semialign 58 | Data.Semialign.Indexed 59 | Data.Zip 60 | 61 | other-modules: Data.Semialign.Internal 62 | 63 | -- ghc boot libs 64 | build-depends: 65 | base >=4.12.0.0 && <4.22 66 | , containers >=0.6.0.1 && <0.8 67 | , transformers >=0.5.6.2 && <0.7 68 | 69 | -- These 70 | build-depends: these >=1.2.1 && <1.3 71 | 72 | -- other dependencies 73 | build-depends: 74 | hashable >=1.4.4.0 && <1.6 75 | , indexed-traversable >=0.1.4 && <0.2 76 | , indexed-traversable-instances >=0.1.2 && <0.2 77 | , tagged >=0.8.8 && <0.9 78 | , unordered-containers >=0.2.8.0 && <0.3 79 | , vector >=0.13.0.0 && <0.14 80 | 81 | if flag(semigroupoids) 82 | build-depends: semigroupoids >=6.0.1 && <6.1 83 | -------------------------------------------------------------------------------- /semialign/src/Data/Align.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 'These'-based aligning and unaligning of functors with non-uniform 3 | -- shapes. 4 | -- 5 | -- For a traversals traversal of (bi)foldable (bi)functors through said 6 | -- functors see "Data.Crosswalk". 7 | module Data.Align ( 8 | Semialign (..), 9 | Align (..), 10 | Unalign (..), 11 | -- * Specialized aligns 12 | salign, padZip, padZipWith, 13 | lpadZip, lpadZipWith, 14 | rpadZip, rpadZipWith, 15 | alignVectorWith, 16 | ) where 17 | 18 | import Data.Semialign.Internal 19 | -------------------------------------------------------------------------------- /semialign/src/Data/Crosswalk.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | module Data.Crosswalk ( 3 | -- * Crosswalk 4 | Crosswalk (..), 5 | -- * Bicrosswalk 6 | Bicrosswalk (..), 7 | ) where 8 | 9 | import Control.Applicative (pure, (<$>)) 10 | import Data.Bifoldable (Bifoldable (..)) 11 | import Data.Bifunctor (Bifunctor (..)) 12 | import Data.Foldable (Foldable (..)) 13 | import Data.Functor.Compose (Compose (..)) 14 | import Data.Functor.Identity (Identity (..)) 15 | import Data.Vector.Generic (Vector) 16 | import Prelude (Either (..), Functor (fmap), Maybe (..), id, (.)) 17 | 18 | import qualified Data.Sequence as Seq 19 | import qualified Data.Vector as V 20 | import qualified Data.Vector.Generic as VG 21 | 22 | import Data.Align 23 | import Data.These 24 | 25 | -- -------------------------------------------------------------------------- 26 | -- | Foldable functors supporting traversal through an alignable 27 | -- functor. 28 | -- 29 | -- Minimal definition: @crosswalk@ or @sequenceL@. 30 | -- 31 | -- Laws: 32 | -- 33 | -- @ 34 | -- crosswalk (const nil) = const nil 35 | -- crosswalk f = sequenceL . fmap f 36 | -- @ 37 | class (Functor t, Foldable t) => Crosswalk t where 38 | crosswalk :: (Align f) => (a -> f b) -> t a -> f (t b) 39 | crosswalk f = sequenceL . fmap f 40 | 41 | sequenceL :: (Align f) => t (f a) -> f (t a) 42 | sequenceL = crosswalk id 43 | 44 | {-# MINIMAL crosswalk | sequenceL #-} 45 | 46 | instance Crosswalk Identity where 47 | crosswalk f (Identity a) = fmap Identity (f a) 48 | 49 | instance Crosswalk Maybe where 50 | crosswalk _ Nothing = nil 51 | crosswalk f (Just a) = Just <$> f a 52 | 53 | instance Crosswalk [] where 54 | crosswalk _ [] = nil 55 | crosswalk f (x:xs) = alignWith cons (f x) (crosswalk f xs) 56 | where cons = these pure id (:) 57 | 58 | instance Crosswalk Seq.Seq where 59 | crosswalk f = foldr (alignWith cons . f) nil where 60 | cons = these Seq.singleton id (Seq.<|) 61 | 62 | instance Crosswalk (These a) where 63 | crosswalk _ (This _) = nil 64 | crosswalk f (That x) = That <$> f x 65 | crosswalk f (These a x) = These a <$> f x 66 | 67 | crosswalkVector :: (Vector v a, Vector v b, Align f) 68 | => (a -> f b) -> v a -> f (v b) 69 | crosswalkVector f = fmap VG.fromList . VG.foldr (alignWith cons . f) nil where 70 | cons = these pure id (:) 71 | 72 | instance Crosswalk V.Vector where 73 | crosswalk = crosswalkVector 74 | 75 | instance Crosswalk ((,) a) where 76 | crosswalk fun (a, x) = fmap ((,) a) (fun x) 77 | 78 | -- can't (shouldn't) do longer tuples until there are Functor and Foldable 79 | -- instances for them 80 | 81 | instance (Crosswalk f, Crosswalk g) => Crosswalk (Compose f g) where 82 | crosswalk f 83 | = fmap Compose -- can't coerce: maybe the Align-able thing has role nominal 84 | . crosswalk (crosswalk f) 85 | . getCompose 86 | 87 | -- -------------------------------------------------------------------------- 88 | -- | Bifoldable bifunctors supporting traversal through an alignable 89 | -- functor. 90 | -- 91 | -- Minimal definition: @bicrosswalk@ or @bisequenceL@. 92 | -- 93 | -- Laws: 94 | -- 95 | -- @ 96 | -- bicrosswalk (const empty) (const empty) = const empty 97 | -- bicrosswalk f g = bisequenceL . bimap f g 98 | -- @ 99 | class (Bifunctor t, Bifoldable t) => Bicrosswalk t where 100 | bicrosswalk :: (Align f) => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) 101 | bicrosswalk f g = bisequenceL . bimap f g 102 | 103 | bisequenceL :: (Align f) => t (f a) (f b) -> f (t a b) 104 | bisequenceL = bicrosswalk id id 105 | 106 | {-# MINIMAL bicrosswalk | bisequenceL #-} 107 | 108 | instance Bicrosswalk Either where 109 | bicrosswalk f _ (Left x) = Left <$> f x 110 | bicrosswalk _ g (Right x) = Right <$> g x 111 | 112 | instance Bicrosswalk These where 113 | bicrosswalk f _ (This x) = This <$> f x 114 | bicrosswalk _ g (That x) = That <$> g x 115 | bicrosswalk f g (These x y) = align (f x) (g y) 116 | -------------------------------------------------------------------------------- /semialign/src/Data/Semialign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | Zipping and aligning of functors with non-uniform shapes. 3 | -- 4 | -- 5 | module Data.Semialign ( 6 | -- * Classes 7 | Semialign (..), 8 | Align (..), 9 | Unalign (..), 10 | Zip (..), 11 | Repeat (..), 12 | Unzip (..), 13 | unzipDefault, 14 | -- * Specialized aligns 15 | salign, padZip, padZipWith, 16 | lpadZip, lpadZipWith, 17 | rpadZip, rpadZipWith, 18 | alignVectorWith, 19 | ) where 20 | 21 | import Data.Semialign.Internal 22 | -------------------------------------------------------------------------------- /semialign/src/Data/Semialign/Indexed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | -- | Zipping and aligning of indexed functors. 3 | module Data.Semialign.Indexed ( 4 | SemialignWithIndex (..), 5 | ZipWithIndex (..), 6 | RepeatWithIndex (..), 7 | ) where 8 | 9 | import Data.Semialign.Internal 10 | -------------------------------------------------------------------------------- /semialign/src/Data/Semialign/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE Trustworthy #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | module Data.Semialign.Internal where 10 | 11 | import Prelude 12 | (Bool (..), Either (..), Eq (..), Functor (fmap), Int, Maybe (..), 13 | Monad (..), Ord (..), Ordering (..), String, error, flip, fst, id, maybe, 14 | snd, uncurry, ($), (++), (.)) 15 | 16 | import qualified Prelude as Prelude 17 | 18 | import Control.Applicative (ZipList (..), pure, (<$>)) 19 | import Data.Bifunctor (Bifunctor (..)) 20 | import Data.Functor.Compose (Compose (..)) 21 | import Data.Functor.Identity (Identity (..)) 22 | import Data.Functor.Product (Product (..)) 23 | import Data.Hashable (Hashable (..)) 24 | import Data.HashMap.Strict (HashMap) 25 | import Data.List.NonEmpty (NonEmpty (..)) 26 | import Data.Maybe (catMaybes) 27 | import Data.Monoid (Monoid (..)) 28 | import Data.Proxy (Proxy (..)) 29 | import Data.Semigroup (Semigroup (..)) 30 | import Data.Sequence (Seq) 31 | import Data.Tagged (Tagged (..)) 32 | import Data.Vector.Fusion.Stream.Monadic (Step (..), Stream (..)) 33 | import Data.Vector.Generic (Vector, empty, stream, unstream) 34 | import Data.Void (Void) 35 | 36 | import Data.Functor.WithIndex (FunctorWithIndex (imap)) 37 | import Data.Functor.WithIndex.Instances () 38 | 39 | import qualified Data.HashMap.Strict as HM 40 | import qualified Data.List.NonEmpty as NE 41 | import qualified Data.Sequence as Seq 42 | import qualified Data.Tree as T 43 | import qualified Data.Vector as V 44 | import qualified Data.Vector.Fusion.Stream.Monadic as Stream 45 | 46 | import Data.Vector.Fusion.Bundle.Monadic (Bundle (..)) 47 | import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle 48 | import qualified Data.Vector.Fusion.Bundle.Size as Bundle 49 | 50 | import Data.Map.Lazy (Map) 51 | import qualified Data.Map.Lazy as Map 52 | 53 | import Data.IntMap.Lazy (IntMap) 54 | import qualified Data.IntMap.Lazy as IntMap 55 | 56 | import qualified Data.IntMap.Merge.Lazy as IntMap 57 | import qualified Data.Map.Merge.Lazy as Map 58 | 59 | #if !(MIN_VERSION_base(4,16,0)) 60 | import Data.Semigroup (Option (..)) 61 | #endif 62 | 63 | import Data.These 64 | import Data.These.Combinators 65 | 66 | oops :: String -> a 67 | oops = error . ("Data.Align: internal error: " ++) 68 | 69 | -- -------------------------------------------------------------------------- 70 | -- | Functors supporting an 'align' operation that takes the union of 71 | -- non-uniform shapes. 72 | -- 73 | -- Minimal definition: either 'align' or 'alignWith'. 74 | -- 75 | -- == Laws 76 | -- 77 | -- The laws of 'align' and 'zip' resemble lattice laws. 78 | -- There is a plenty of laws, but they are simply satisfied. 79 | -- 80 | -- And an additional property if @f@ is 'Foldable', 81 | -- which tries to enforce 'align'-feel: 82 | -- neither values are duplicated nor lost. 83 | -- 84 | -- 85 | -- /Note:/ @'join' f x = f x x@ 86 | -- 87 | -- /Idempotency/ 88 | -- 89 | -- @ 90 | -- join align ≡ fmap (join These) 91 | -- @ 92 | -- 93 | -- /Commutativity/ 94 | -- 95 | -- @ 96 | -- align x y ≡ swap \<$> align y x 97 | -- @ 98 | -- 99 | -- /Associativity/ 100 | -- 101 | -- @ 102 | -- align x (align y z) ≡ assoc \<$> align (align x y) z 103 | -- @ 104 | -- 105 | -- /With/ 106 | -- 107 | -- @ 108 | -- alignWith f a b ≡ f \<$> align a b 109 | -- @ 110 | -- 111 | -- /Functoriality/ 112 | -- 113 | -- @ 114 | -- align (f \<$> x) (g \<$> y) ≡ bimap f g \<$> align x y 115 | -- @ 116 | -- 117 | -- /Alignedness/, if @f@ is 'Foldable' 118 | -- 119 | -- @ 120 | -- toList x ≡ toListOf (folded . here) (align x y) 121 | -- ≡ mapMaybe justHere (toList (align x y)) 122 | -- @ 123 | -- 124 | class Functor f => Semialign f where 125 | -- | Analogous to @'zip'@, combines two structures by taking the union of 126 | -- their shapes and using @'These'@ to hold the elements. 127 | align :: f a -> f b -> f (These a b) 128 | align = alignWith id 129 | 130 | -- | Analogous to @'zipWith'@, combines two structures by taking the union of 131 | -- their shapes and combining the elements with the given function. 132 | alignWith :: (These a b -> c) -> f a -> f b -> f c 133 | alignWith f a b = f <$> align a b 134 | 135 | {-# MINIMAL (align | alignWith) #-} 136 | 137 | -- | A unit of 'align'. 138 | -- 139 | -- == Laws 140 | -- 141 | -- @ 142 | -- (\`align` nil) ≡ fmap This 143 | -- (nil \`align`) ≡ fmap That 144 | -- @ 145 | -- 146 | class Semialign f => Align f where 147 | -- | An empty structure. @'align'@ing with @'nil'@ will produce a structure with 148 | -- the same shape and elements as the other input, modulo @'This'@ or @'That'@. 149 | nil :: f a 150 | 151 | -- | 152 | -- 153 | -- Alignable functors supporting an \"inverse\" to 'align': splitting 154 | -- a union shape into its component parts. 155 | -- 156 | -- == Laws 157 | -- 158 | -- @ 159 | -- uncurry align (unalign xs) ≡ xs 160 | -- unalign (align xs ys) ≡ (xs, ys) 161 | -- @ 162 | -- 163 | -- == Compatibility note 164 | -- 165 | -- In version 1 'unalign' was changed to return @(f a, f b)@ pair, 166 | -- instead of @(f (Just a), f (Just b))@. Old behaviour can be achieved with 167 | -- if ever needed. 168 | -- 169 | -- >>> unzipWith (unalign . Just) [This 'a', That 'b', These 'c' 'd'] 170 | -- ([Just 'a',Nothing,Just 'c'],[Nothing,Just 'b',Just 'd']) 171 | -- 172 | class Semialign f => Unalign f where 173 | unalign :: f (These a b) -> (f a, f b) 174 | unalign = unalignWith id 175 | 176 | unalignWith :: (c -> These a b) -> f c -> (f a, f b) 177 | unalignWith f fx = unalign (fmap f fx) 178 | 179 | {-# MINIMAL unalignWith | unalign #-} 180 | 181 | -- | Functors supporting a 'zip' operation that takes the intersection of 182 | -- non-uniform shapes. 183 | -- 184 | -- Minimal definition: either 'zip' or 'zipWith'. 185 | -- 186 | -- /Idempotency/ 187 | -- 188 | -- @ 189 | -- join zip ≡ fmap (join (,)) 190 | -- @ 191 | -- 192 | -- /Commutativity/ 193 | -- 194 | -- @ 195 | -- zip x y ≡ swap \<$> zip y x 196 | -- @ 197 | -- 198 | -- /Associativity/ 199 | -- 200 | -- @ 201 | -- zip x (zip y z) ≡ assoc \<$> zip (zip x y) z 202 | -- @ 203 | -- 204 | -- /Absorption/ 205 | -- 206 | -- @ 207 | -- fst \<$> zip xs (align xs ys) ≡ xs 208 | -- toThis \<$> align xs (zip xs ys) ≡ This \<$> xs 209 | -- where 210 | -- toThis (This a) = This a 211 | -- toThis (These a _) = This a 212 | -- toThis (That b) = That b 213 | -- @ 214 | -- 215 | -- /With/ 216 | -- 217 | -- @ 218 | -- zipWith f a b ≡ f \<$> zip a b 219 | -- @ 220 | -- 221 | -- /Functoriality/ 222 | -- 223 | -- @ 224 | -- zip (f \<$> x) (g \<$> y) ≡ bimap f g \<$> zip x y 225 | -- @ 226 | -- 227 | -- /Zippyness/ 228 | -- 229 | -- @ 230 | -- fmap fst (zip x x) ≡ x 231 | -- fmap snd (zip x x) ≡ x 232 | -- zip (fmap fst x) (fmap snd x) ≡ x 233 | -- @ 234 | -- 235 | -- /Distributivity/ 236 | -- 237 | -- @ 238 | -- align (zip xs ys) zs ≡ undistrThesePair \<$> zip (align xs zs) (align ys zs) 239 | -- distrPairThese \<$> zip (align xs ys) zs ≡ align (zip xs zs) (zip ys zs) 240 | -- zip (align xs ys) zs ≡ undistrPairThese \<$> align (zip xs zs) (zip ys zs) 241 | -- @ 242 | -- 243 | -- /Note/, the following doesn't hold: 244 | -- 245 | -- @ 246 | -- distrThesePair \<$> align (zip xs ys) zs ≢ zip (align xs zs) (align ys zs) 247 | -- @ 248 | -- 249 | -- when @xs = []@ and @ys = zs = [0]@, then 250 | -- the left hand side is "only" @[('That' 0, 'That' 0)]@, 251 | -- but the right hand side is @[('That' 0, 'These' 0 0)]@. 252 | -- 253 | class Semialign f => Zip f where 254 | -- | Combines two structures by taking the intersection of their shapes 255 | -- and using pair to hold the elements. 256 | zip :: f a -> f b -> f (a, b) 257 | zip = zipWith (,) 258 | -- 259 | -- | Combines two structures by taking the intersection of their shapes 260 | -- and combining the elements with the given function. 261 | zipWith :: (a -> b -> c) -> f a -> f b -> f c 262 | zipWith f a b = uncurry f <$> zip a b 263 | 264 | {-# MINIMAL (zip | zipWith) #-} 265 | 266 | -- | Zippable functors supporting left and right units 267 | -- 268 | -- /Unit/ 269 | -- 270 | -- @ 271 | -- fst \<$> zip xs (repeat y) ≡ xs 272 | -- snd \<$> zip (repeat x) ys ≡ ys 273 | -- @ 274 | -- 275 | class Zip f => Repeat f where 276 | -- | A /repeat/ structure. 277 | repeat :: a -> f a 278 | 279 | -- | Right inverse of 'zip'. 280 | -- 281 | -- This class is definable for every 'Functor'. See 'unzipDefault'. 282 | -- 283 | -- == Laws 284 | -- 285 | -- @ 286 | -- uncurry zip (unzip xs) ≡ xs 287 | -- unzip (zip xs xs) ≡ (xs, xs) 288 | -- @ 289 | -- 290 | -- Note: 291 | -- 292 | -- @ 293 | -- unzip (zip xs ys) ≢ (xs, _) or (_, ys) 294 | -- @ 295 | -- 296 | -- For sequence-like types this holds, but for Map-like it doesn't. 297 | -- 298 | class Zip f => Unzip f where 299 | unzipWith :: (c -> (a, b)) -> f c -> (f a, f b) 300 | unzipWith f = unzip . fmap f 301 | 302 | unzip :: f (a, b) -> (f a, f b) 303 | unzip = unzipWith id 304 | 305 | {-# MINIMAL unzipWith | unzip #-} 306 | 307 | unzipDefault :: Functor f => f (a, b) -> (f a, f b) 308 | unzipDefault x = (fst <$> x, snd <$> x) 309 | 310 | -- | Indexed version of 'Semialign'. 311 | -- 312 | -- @since 1.2 313 | class (FunctorWithIndex i f, Semialign f) => SemialignWithIndex i f | f -> i where 314 | -- | Analogous to 'alignWith', but also provides an index. 315 | ialignWith :: (i -> These a b -> c) -> f a -> f b -> f c 316 | ialignWith f a b = imap f (align a b) 317 | 318 | -- | Indexed version of 'Zip'. 319 | -- 320 | -- @since 1.2 321 | class (SemialignWithIndex i f, Zip f) => ZipWithIndex i f | f -> i where 322 | -- | Analogous to 'zipWith', but also provides an index. 323 | izipWith :: (i -> a -> b -> c) -> f a -> f b -> f c 324 | izipWith f a b = imap (uncurry . f) (zip a b) 325 | 326 | -- | Indexed version of 'Repeat'. 327 | -- 328 | -- @since 1.2 329 | class (ZipWithIndex i f, Repeat f) => RepeatWithIndex i f | f -> i where 330 | -- | Analogous to 'repeat', but also provides an index. 331 | -- 332 | -- This should be the same as 'tabulate' for representable functors. 333 | irepeat :: (i -> a) -> f a 334 | irepeat f = imap (\i f' -> f' i) (repeat f) 335 | 336 | ------------------------------------------------------------------------------- 337 | -- base 338 | ------------------------------------------------------------------------------- 339 | 340 | instance Semialign ((->) e) where 341 | align f g x = These (f x) (g x) 342 | alignWith h f g x = h (These (f x) (g x)) 343 | 344 | instance Zip ((->) e) where 345 | zip f g x = (f x, g x) 346 | 347 | instance Repeat ((->) e) where 348 | repeat = pure 349 | 350 | instance SemialignWithIndex e ((->) e) where 351 | ialignWith h f g x = h x (These (f x) (g x)) 352 | instance ZipWithIndex e ((->) e) where 353 | izipWith h f g x = h x (f x) (g x) 354 | instance RepeatWithIndex e ((->) e) where 355 | irepeat = id 356 | 357 | instance Semialign Maybe where 358 | align Nothing Nothing = Nothing 359 | align (Just a) Nothing = Just (This a) 360 | align Nothing (Just b) = Just (That b) 361 | align (Just a) (Just b) = Just (These a b) 362 | 363 | instance Zip Maybe where 364 | zip Nothing _ = Nothing 365 | zip (Just _) Nothing = Nothing 366 | zip (Just a) (Just b) = Just (a, b) 367 | 368 | instance Repeat Maybe where 369 | repeat = Just 370 | 371 | instance Unalign Maybe where 372 | unalign Nothing = (Nothing, Nothing) 373 | unalign (Just (This a)) = (Just a, Nothing) 374 | unalign (Just (That b)) = (Nothing, Just b) 375 | unalign (Just (These a b)) = (Just a, Just b) 376 | 377 | instance Unzip Maybe where 378 | unzip = unzipDefault 379 | 380 | instance Align Maybe where 381 | nil = Nothing 382 | 383 | instance SemialignWithIndex () Maybe 384 | instance ZipWithIndex () Maybe 385 | instance RepeatWithIndex () Maybe 386 | 387 | instance Semialign [] where 388 | align xs [] = This <$> xs 389 | align [] ys = That <$> ys 390 | align (x:xs) (y:ys) = These x y : align xs ys 391 | 392 | instance Align [] where 393 | nil = [] 394 | 395 | instance Zip [] where 396 | zip = Prelude.zip 397 | zipWith = Prelude.zipWith 398 | 399 | instance Repeat [] where 400 | repeat = Prelude.repeat 401 | 402 | instance Unzip [] where 403 | unzip = Prelude.unzip 404 | 405 | instance SemialignWithIndex Int [] 406 | instance ZipWithIndex Int [] 407 | instance RepeatWithIndex Int [] 408 | 409 | -- | @'zipWith' = 'liftA2'@ . 410 | instance Semialign ZipList where 411 | alignWith f (ZipList xs) (ZipList ys) = ZipList (alignWith f xs ys) 412 | 413 | instance Align ZipList where 414 | nil = ZipList [] 415 | 416 | instance Zip ZipList where 417 | zipWith f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys) 418 | 419 | instance Repeat ZipList where 420 | repeat = pure 421 | 422 | instance Unzip ZipList where 423 | unzip (ZipList xs) = (ZipList ys, ZipList zs) where 424 | (ys, zs) = unzip xs 425 | 426 | instance SemialignWithIndex Int ZipList 427 | instance ZipWithIndex Int ZipList 428 | instance RepeatWithIndex Int ZipList 429 | 430 | ------------------------------------------------------------------------------- 431 | -- semigroups 432 | ------------------------------------------------------------------------------- 433 | 434 | instance Semialign NonEmpty where 435 | align (x :| xs) (y :| ys) = These x y :| align xs ys 436 | 437 | instance Zip NonEmpty where 438 | zip = NE.zip 439 | zipWith = NE.zipWith 440 | 441 | instance Repeat NonEmpty where 442 | repeat = NE.repeat 443 | 444 | instance Unzip NonEmpty where 445 | unzip = NE.unzip 446 | 447 | instance SemialignWithIndex Int NonEmpty 448 | instance ZipWithIndex Int NonEmpty 449 | instance RepeatWithIndex Int NonEmpty 450 | 451 | #if !(MIN_VERSION_base(4,16,0)) 452 | deriving instance Semialign Option 453 | deriving instance Align Option 454 | deriving instance Unalign Option 455 | deriving instance Zip Option 456 | deriving instance Repeat Option 457 | deriving instance Unzip Option 458 | 459 | -- deriving instance SemialignWithIndex () Option 460 | -- deriving instance ZipWithIndex () Option 461 | -- deriving instance RepeatWithIndex () Option 462 | #endif 463 | 464 | ------------------------------------------------------------------------------- 465 | -- containers: ListLike 466 | ------------------------------------------------------------------------------- 467 | 468 | instance Semialign Seq where 469 | align xs ys = case compare xn yn of 470 | EQ -> Seq.zipWith fc xs ys 471 | LT -> case Seq.splitAt xn ys of 472 | (ysl, ysr) -> Seq.zipWith These xs ysl `mappend` fmap That ysr 473 | GT -> case Seq.splitAt yn xs of 474 | (xsl, xsr) -> Seq.zipWith These xsl ys `mappend` fmap This xsr 475 | where 476 | xn = Seq.length xs 477 | yn = Seq.length ys 478 | fc = These 479 | 480 | alignWith f xs ys = case compare xn yn of 481 | EQ -> Seq.zipWith fc xs ys 482 | LT -> case Seq.splitAt xn ys of 483 | (ysl, ysr) -> Seq.zipWith fc xs ysl `mappend` fmap (f . That) ysr 484 | GT -> case Seq.splitAt yn xs of 485 | (xsl, xsr) -> Seq.zipWith fc xsl ys `mappend` fmap (f . This) xsr 486 | where 487 | xn = Seq.length xs 488 | yn = Seq.length ys 489 | fc x y = f (These x y) 490 | 491 | instance Align Seq where 492 | nil = Seq.empty 493 | 494 | instance Unzip Seq where 495 | unzip = Seq.unzip 496 | unzipWith = Seq.unzipWith 497 | 498 | instance Zip Seq where 499 | zip = Seq.zip 500 | zipWith = Seq.zipWith 501 | 502 | instance SemialignWithIndex Int Seq 503 | instance ZipWithIndex Int Seq 504 | 505 | instance Semialign T.Tree where 506 | align (T.Node x xs) (T.Node y ys) = T.Node (These x y) (alignWith (these (fmap This) (fmap That) align) xs ys) 507 | 508 | instance Zip T.Tree where 509 | zipWith f (T.Node x xs) (T.Node y ys) = T.Node (f x y) (zipWith (zipWith f) xs ys) 510 | 511 | instance Repeat T.Tree where 512 | repeat x = n where n = T.Node x (repeat n) 513 | 514 | instance Unzip T.Tree where 515 | unzipWith f = go where 516 | go (T.Node x xs) = (T.Node y ys, T.Node z zs) where 517 | ~(y, z) = f x 518 | ~(ys, zs) = unzipWith go xs 519 | 520 | ------------------------------------------------------------------------------- 521 | -- containers: MapLike 522 | ------------------------------------------------------------------------------- 523 | 524 | instance Ord k => Semialign (Map k) where 525 | alignWith f = Map.merge (Map.mapMissing (\_ x -> f (This x))) 526 | (Map.mapMissing (\_ y -> f (That y))) 527 | (Map.zipWithMatched (\_ x y -> f (These x y))) 528 | 529 | instance (Ord k) => Align (Map k) where 530 | nil = Map.empty 531 | 532 | instance Ord k => Unalign (Map k) where 533 | unalign xs = (Map.mapMaybe justHere xs, Map.mapMaybe justThere xs) 534 | 535 | instance Ord k => Unzip (Map k) where unzip = unzipDefault 536 | 537 | instance Ord k => Zip (Map k) where 538 | zipWith = Map.intersectionWith 539 | 540 | instance Semialign IntMap where 541 | alignWith f = IntMap.merge (IntMap.mapMissing (\_ x -> f (This x))) 542 | (IntMap.mapMissing (\_ y -> f (That y))) 543 | (IntMap.zipWithMatched (\_ x y -> f (These x y))) 544 | 545 | instance Align IntMap where 546 | nil = IntMap.empty 547 | 548 | instance Unalign IntMap where 549 | unalign xs = (IntMap.mapMaybe justHere xs, IntMap.mapMaybe justThere xs) 550 | 551 | instance Unzip IntMap where unzip = unzipDefault 552 | 553 | instance Zip IntMap where 554 | zipWith = IntMap.intersectionWith 555 | 556 | instance SemialignWithIndex Int IntMap 557 | instance ZipWithIndex Int IntMap where 558 | izipWith = IntMap.intersectionWithKey 559 | instance Ord k => SemialignWithIndex k (Map k) where 560 | instance Ord k => ZipWithIndex k (Map k) where 561 | izipWith = Map.intersectionWithKey 562 | 563 | ------------------------------------------------------------------------------- 564 | -- transformers 565 | ------------------------------------------------------------------------------- 566 | 567 | instance Semialign Identity where 568 | alignWith f (Identity a) (Identity b) = Identity (f (These a b)) 569 | 570 | instance Zip Identity where 571 | zipWith f (Identity a) (Identity b) = Identity (f a b) 572 | 573 | instance Repeat Identity where 574 | repeat = pure 575 | 576 | instance Unzip Identity where 577 | unzip (Identity ~(a, b)) = (Identity a, Identity b) 578 | 579 | instance SemialignWithIndex () Identity 580 | instance ZipWithIndex () Identity 581 | instance RepeatWithIndex () Identity 582 | 583 | instance (Semialign f, Semialign g) => Semialign (Product f g) where 584 | align (Pair a b) (Pair c d) = Pair (align a c) (align b d) 585 | alignWith f (Pair a b) (Pair c d) = Pair (alignWith f a c) (alignWith f b d) 586 | 587 | instance (Unalign f, Unalign g) => Unalign (Product f g) where 588 | unalign (Pair a b) = (Pair al bl, Pair ar br) where 589 | ~(al, ar) = unalign a 590 | ~(bl, br) = unalign b 591 | 592 | instance (Align f, Align g) => Align (Product f g) where 593 | nil = Pair nil nil 594 | 595 | instance (Zip f, Zip g) => Zip (Product f g) where 596 | zip (Pair a b) (Pair c d) = Pair (zip a c) (zip b d) 597 | zipWith f (Pair a b) (Pair c d) = Pair (zipWith f a c) (zipWith f b d) 598 | 599 | instance (Repeat f, Repeat g) => Repeat (Product f g) where 600 | repeat x = Pair (repeat x) (repeat x) 601 | 602 | instance (Unzip f, Unzip g) => Unzip (Product f g) where 603 | unzip (Pair a b) = (Pair al bl, Pair ar br) where 604 | ~(al, ar) = unzip a 605 | ~(bl, br) = unzip b 606 | 607 | instance (SemialignWithIndex i f, SemialignWithIndex j g) => SemialignWithIndex (Either i j) (Product f g) where 608 | ialignWith f (Pair fa ga) (Pair fb gb) = Pair fc gc where 609 | fc = ialignWith (f . Left) fa fb 610 | gc = ialignWith (f . Right) ga gb 611 | 612 | instance (ZipWithIndex i f, ZipWithIndex j g) => ZipWithIndex (Either i j) (Product f g) where 613 | izipWith f (Pair fa ga) (Pair fb gb) = Pair fc gc where 614 | fc = izipWith (f . Left) fa fb 615 | gc = izipWith (f . Right) ga gb 616 | 617 | instance (RepeatWithIndex i f, RepeatWithIndex j g) => RepeatWithIndex (Either i j) (Product f g) where 618 | irepeat f = Pair (irepeat (f . Left)) (irepeat (f . Right)) 619 | 620 | 621 | instance (Semialign f, Semialign g) => Semialign (Compose f g) where 622 | alignWith f (Compose x) (Compose y) = Compose (alignWith g x y) where 623 | g (This ga) = fmap (f . This) ga 624 | g (That gb) = fmap (f . That) gb 625 | g (These ga gb) = alignWith f ga gb 626 | 627 | instance (Align f, Semialign g) => Align (Compose f g) where 628 | nil = Compose nil 629 | 630 | instance (Zip f, Zip g) => Zip (Compose f g) where 631 | zipWith f (Compose x) (Compose y) = Compose (zipWith (zipWith f) x y) 632 | 633 | instance (Repeat f, Repeat g) => Repeat (Compose f g) where 634 | repeat x = Compose (repeat (repeat x)) 635 | 636 | instance (Unzip f, Unzip g) => Unzip (Compose f g) where 637 | unzipWith f (Compose x) = (Compose y, Compose z) where 638 | ~(y, z) = unzipWith (unzipWith f) x 639 | 640 | -- This is unlawful instance. 641 | -- 642 | -- instance (Unalign f, Unalign g) => Unalign (Compose f g) where 643 | -- unalignWith f (Compose x) = (Compose y, Compose z) where 644 | -- ~(y, z) = unalignWith (uncurry These . unalignWith f) x 645 | 646 | instance (SemialignWithIndex i f, SemialignWithIndex j g) => SemialignWithIndex (i, j) (Compose f g) where 647 | ialignWith f (Compose fga) (Compose fgb) = Compose $ ialignWith g fga fgb where 648 | g i (This ga) = imap (\j -> f (i, j) . This) ga 649 | g i (That gb) = imap (\j -> f (i, j) . That) gb 650 | g i (These ga gb) = ialignWith (\j -> f (i, j)) ga gb 651 | 652 | instance (ZipWithIndex i f, ZipWithIndex j g) => ZipWithIndex (i, j) (Compose f g) where 653 | izipWith f (Compose fga) (Compose fgb) = Compose fgc where 654 | fgc = izipWith (\i -> izipWith (\j -> f (i, j))) fga fgb 655 | 656 | instance (RepeatWithIndex i f, RepeatWithIndex j g) => RepeatWithIndex (i, j) (Compose f g) where 657 | irepeat f = Compose (irepeat (\i -> irepeat (\j -> f (i, j)))) 658 | 659 | ------------------------------------------------------------------------------- 660 | -- vector 661 | ------------------------------------------------------------------------------- 662 | 663 | -- Based on the Data.Vector.Fusion.Stream.Monadic zipWith implementation 664 | instance Monad m => Align (Stream m) where 665 | nil = Stream.empty 666 | 667 | instance Monad m => Semialign (Stream m) where 668 | alignWith f (Stream stepa ta) (Stream stepb tb) 669 | = Stream step (ta, tb, Nothing, False) 670 | where 671 | step (sa, sb, Nothing, False) = do 672 | r <- stepa sa 673 | return $ case r of 674 | Yield x sa' -> Skip (sa', sb, Just x, False) 675 | Skip sa' -> Skip (sa', sb, Nothing, False) 676 | Done -> Skip (sa, sb, Nothing, True) 677 | 678 | step (sa, sb, av, adone) = do 679 | r <- stepb sb 680 | return $ case r of 681 | Yield y sb' -> Yield (f $ maybe (That y) (`These` y) av) 682 | (sa, sb', Nothing, adone) 683 | Skip sb' -> Skip (sa, sb', av, adone) 684 | Done -> case (av, adone) of 685 | (Just x, False) -> Yield (f $ This x) (sa, sb, Nothing, adone) 686 | (_, True) -> Done 687 | #if __GLASGOW_HASKELL__ < 902 688 | _ -> Skip (sa, sb, Nothing, False) 689 | #endif 690 | 691 | instance Monad m => Zip (Stream m) where 692 | zipWith = Stream.zipWith 693 | 694 | instance Monad m => Align (Bundle m v) where 695 | nil = Bundle.empty 696 | 697 | instance Monad m => Semialign (Bundle m v) where 698 | alignWith f Bundle{sElems = sa, sSize = na} Bundle{sElems = sb, sSize = nb} 699 | = Bundle.fromStream (alignWith f sa sb) (Bundle.larger na nb) 700 | 701 | instance Monad m => Zip (Bundle m v) where 702 | zipWith = Bundle.zipWith 703 | 704 | instance Semialign V.Vector where 705 | alignWith = alignVectorWith 706 | 707 | instance Zip V.Vector where 708 | zipWith = V.zipWith 709 | 710 | instance Align V.Vector where 711 | nil = Data.Vector.Generic.empty 712 | 713 | instance Unzip V.Vector where 714 | unzip = V.unzip 715 | 716 | alignVectorWith :: (Vector v a, Vector v b, Vector v c) 717 | => (These a b -> c) -> v a -> v b -> v c 718 | alignVectorWith f x y = unstream $ alignWith f (stream x) (stream y) 719 | 720 | instance SemialignWithIndex Int V.Vector where 721 | instance ZipWithIndex Int V.Vector where 722 | izipWith = V.izipWith 723 | 724 | ------------------------------------------------------------------------------- 725 | -- unordered-containers 726 | ------------------------------------------------------------------------------- 727 | 728 | instance (Eq k, Hashable k) => Align (HashMap k) where 729 | nil = HM.empty 730 | 731 | instance (Eq k, Hashable k) => Semialign (HashMap k) where 732 | align m n = HM.unionWith merge (HM.map This m) (HM.map That n) 733 | where merge (This a) (That b) = These a b 734 | merge _ _ = oops "Align HashMap: merge" 735 | 736 | instance (Eq k, Hashable k) => Zip (HashMap k) where 737 | zipWith = HM.intersectionWith 738 | 739 | instance (Eq k, Hashable k) => Unzip (HashMap k) where unzip = unzipDefault 740 | 741 | instance (Eq k, Hashable k) => Unalign (HashMap k) where 742 | unalign xs = (HM.mapMaybe justHere xs, HM.mapMaybe justThere xs) 743 | 744 | instance (Eq k, Hashable k) => SemialignWithIndex k (HashMap k) where 745 | instance (Eq k, Hashable k) => ZipWithIndex k (HashMap k) where 746 | izipWith = HM.intersectionWithKey 747 | 748 | ------------------------------------------------------------------------------- 749 | -- tagged 750 | ------------------------------------------------------------------------------- 751 | 752 | instance Semialign (Tagged b) where 753 | alignWith f (Tagged x) (Tagged y) = Tagged (f (These x y)) 754 | 755 | instance Zip (Tagged b) where 756 | zipWith f (Tagged x) (Tagged y) = Tagged (f x y) 757 | 758 | instance Repeat (Tagged b) where 759 | repeat = Tagged 760 | 761 | instance Unzip (Tagged b) where 762 | unzip (Tagged ~(a, b)) = (Tagged a, Tagged b) 763 | 764 | instance SemialignWithIndex () (Tagged b) 765 | instance ZipWithIndex () (Tagged b) 766 | instance RepeatWithIndex () (Tagged b) 767 | 768 | instance Semialign Proxy where 769 | alignWith _ _ _ = Proxy 770 | align _ _ = Proxy 771 | 772 | instance Align Proxy where 773 | nil = Proxy 774 | 775 | instance Unalign Proxy where 776 | unalign _ = (Proxy, Proxy) 777 | 778 | instance Zip Proxy where 779 | zipWith _ _ _ = Proxy 780 | zip _ _ = Proxy 781 | 782 | instance Repeat Proxy where 783 | repeat _ = Proxy 784 | 785 | instance Unzip Proxy where 786 | unzip _ = (Proxy, Proxy) 787 | 788 | instance SemialignWithIndex Void Proxy 789 | instance ZipWithIndex Void Proxy 790 | instance RepeatWithIndex Void Proxy 791 | 792 | ------------------------------------------------------------------------------- 793 | -- combinators 794 | ------------------------------------------------------------------------------- 795 | 796 | -- | Align two structures and combine with '<>'. 797 | salign :: (Semialign f, Semigroup a) => f a -> f a -> f a 798 | salign = alignWith (mergeThese (<>)) 799 | 800 | -- | Align two structures as in 'zip', but filling in blanks with 'Nothing'. 801 | padZip :: (Semialign f) => f a -> f b -> f (Maybe a, Maybe b) 802 | padZip = alignWith (fromThese Nothing Nothing . bimap Just Just) 803 | 804 | -- | Align two structures as in 'zipWith', but filling in blanks with 'Nothing'. 805 | padZipWith :: (Semialign f) => (Maybe a -> Maybe b -> c) -> f a -> f b -> f c 806 | padZipWith f xs ys = uncurry f <$> padZip xs ys 807 | 808 | -- | Left-padded 'zipWith'. 809 | lpadZipWith :: (Maybe a -> b -> c) -> [a] -> [b] -> [c] 810 | lpadZipWith f xs ys = catMaybes $ padZipWith (\x y -> f x <$> y) xs ys 811 | 812 | -- | Left-padded 'zip'. 813 | lpadZip :: [a] -> [b] -> [(Maybe a, b)] 814 | lpadZip = lpadZipWith (,) 815 | 816 | -- | Right-padded 'zipWith'. 817 | rpadZipWith :: (a -> Maybe b -> c) -> [a] -> [b] -> [c] 818 | rpadZipWith f xs ys = lpadZipWith (flip f) ys xs 819 | 820 | -- | Right-padded 'zip'. 821 | rpadZip :: [a] -> [b] -> [(a, Maybe b)] 822 | rpadZip = rpadZipWith (,) 823 | -------------------------------------------------------------------------------- /semialign/src/Data/Zip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | -- | Zipping and unzipping of functors with non-uniform shapes. 5 | -- 6 | module Data.Zip ( 7 | Semialign (..), 8 | Zip (..), 9 | Repeat (..), 10 | Unzip (..), 11 | unzipDefault, 12 | Zippy (..), 13 | ) where 14 | 15 | import Control.Applicative (Applicative (..)) 16 | import Data.Monoid (Monoid (..)) 17 | import Data.Semigroup (Semigroup (..)) 18 | import Prelude (Eq, Functor (..), Ord, Read, Show, ($), (.)) 19 | 20 | import Data.Semialign.Internal 21 | 22 | #ifdef MIN_VERSION_semigroupoids 23 | import Data.Functor.Apply (Apply (..)) 24 | #endif 25 | 26 | ------------------------------------------------------------------------------- 27 | -- Zippy 28 | ------------------------------------------------------------------------------- 29 | 30 | newtype Zippy f a = Zippy { getZippy :: f a } 31 | deriving (Eq, Ord, Show, Read, Functor) 32 | 33 | instance (Zip f, Semigroup a) => Semigroup (Zippy f a) where 34 | Zippy x <> Zippy y = Zippy $ zipWith (<>) x y 35 | 36 | instance (Repeat f, Monoid a) => Monoid (Zippy f a) where 37 | mempty = Zippy $ repeat mempty 38 | mappend (Zippy x) (Zippy y) = Zippy $ zipWith mappend x y 39 | 40 | #ifdef MIN_VERSION_semigroupoids 41 | instance Zip f => Apply (Zippy f) where 42 | Zippy f <.> Zippy x = Zippy $ zipWith ($) f x 43 | #endif 44 | 45 | instance Repeat f => Applicative (Zippy f) where 46 | pure = Zippy . repeat 47 | #ifdef MIN_VERSION_semigroupoids 48 | (<*>) = (<.>) 49 | #else 50 | Zippy f <*> Zippy x = Zippy $ zipWith ($) f x 51 | #endif 52 | 53 | liftA2 f (Zippy x) (Zippy y) = Zippy $ zipWith f x y 54 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.23 2 | packages: 3 | - these 4 | - these-lens 5 | - semialign 6 | - semialign-indexed 7 | - monad-chronicle 8 | - these-tests 9 | 10 | extra-deps: 11 | - assoc-1 12 | -------------------------------------------------------------------------------- /these-lens/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.0.2 2 | 3 | - Support GHC-8.6.5...GHC-9.10.1 4 | 5 | # 1.0.1.2 6 | 7 | - Add `lens-5` support 8 | 9 | # 1.0.1.1 10 | 11 | - Add `Each These` instance 12 | 13 | # 1.0.0.1 14 | 15 | - Drop `base-compat` dependency 16 | 17 | # 1 18 | 19 | Split out of `these` package. 20 | -------------------------------------------------------------------------------- /these-lens/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, C. McCann 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 C. McCann 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 | -------------------------------------------------------------------------------- /these-lens/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | packages: ../these 3 | tests: False 4 | benchmarks: False 5 | -------------------------------------------------------------------------------- /these-lens/src/Data/These/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | module Data.These.Lens ( 7 | -- * Traversals 8 | here, there, 9 | 10 | -- * Prisms 11 | _This, _That, _These, 12 | ) where 13 | 14 | import Control.Applicative (pure, (<$>)) 15 | import Prelude (Either (..), flip, uncurry, ($), (.)) 16 | 17 | import Control.Lens (Prism', Traversal, prism) 18 | import Data.These 19 | 20 | -- $setup 21 | -- >>> import Data.These 22 | -- >>> import Control.Lens 23 | -- >>> import Prelude (show) 24 | 25 | ------------------------------------------------------------------------------- 26 | -- Traversals 27 | ------------------------------------------------------------------------------- 28 | 29 | -- | A 'Control.Lens.Traversal' of the first half of a 'These', suitable for use with "Control.Lens". 30 | -- 31 | -- >>> over here show (That 1) 32 | -- That 1 33 | -- 34 | -- >>> over here show (These 'a' 2) 35 | -- These "'a'" 2 36 | -- 37 | here :: Traversal (These a c) (These b c) a b 38 | here f (This x) = This <$> f x 39 | here f (These x y) = flip These y <$> f x 40 | here _ (That x) = pure (That x) 41 | 42 | -- | A 'Control.Lens.Traversal' of the second half of a 'These', suitable for use with "Control.Lens". 43 | -- 44 | -- @ 45 | -- 'there' :: 'Control.Lens.Traversal' ('These' t b) ('These' t b) a b 46 | -- @ 47 | -- 48 | -- >>> over there show (That 1) 49 | -- That "1" 50 | -- 51 | -- >>> over there show (These 'a' 2) 52 | -- These 'a' "2" 53 | -- 54 | there :: Traversal (These c a) (These c b) a b 55 | there _ (This x) = pure (This x) 56 | there f (These x y) = These x <$> f y 57 | there f (That x) = That <$> f x 58 | 59 | ------------------------------------------------------------------------------- 60 | -- Prisms 61 | ------------------------------------------------------------------------------- 62 | 63 | -- | A 'Control.Lens.Prism'' selecting the 'This' constructor. 64 | -- 65 | -- /Note:/ cannot change type. 66 | _This :: Prism' (These a b) a 67 | _This = prism This (these Right (Left . That) (\x y -> Left $ These x y)) 68 | 69 | -- | A 'Control.Lens.Prism'' selecting the 'That' constructor. 70 | -- 71 | -- /Note:/ cannot change type. 72 | _That :: Prism' (These a b) b 73 | _That = prism That (these (Left . This) Right (\x y -> Left $ These x y)) 74 | 75 | -- | A 'Control.Lens.Prism'' selecting the 'These' constructor. 'These' names are ridiculous! 76 | -- 77 | -- /Note:/ cannot change type. 78 | _These :: Prism' (These a b) (a, b) 79 | _These = prism (uncurry These) (these (Left . This) (Left . That) (\x y -> Right (x, y))) 80 | -------------------------------------------------------------------------------- /these-lens/these-lens.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: these-lens 3 | version: 1.0.2 4 | x-revision: 1 5 | synopsis: Lenses for These 6 | homepage: https://github.com/haskellari/these 7 | license: BSD3 8 | license-file: LICENSE 9 | author: C. McCann, Oleg Grenrus 10 | maintainer: Oleg Grenrus 11 | category: Data, These, Lens 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | description: This package provides Prism and Traversals for @These@. 15 | tested-with: 16 | GHC ==8.6.5 17 | || ==8.8.4 18 | || ==8.10.7 19 | || ==9.0.2 20 | || ==9.2.8 21 | || ==9.4.8 22 | || ==9.6.6 23 | || ==9.8.4 24 | || ==9.10.1 25 | || ==9.12.1 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/haskellari/these.git 30 | subdir: these-lens 31 | 32 | library 33 | default-language: Haskell2010 34 | ghc-options: -Wall -Wno-trustworthy-safe 35 | hs-source-dirs: src 36 | exposed-modules: Data.These.Lens 37 | 38 | -- ghc boot libs 39 | build-depends: base >=4.12.0.0 && <4.22 40 | build-depends: these >=1.2.1 && <1.3 41 | 42 | -- other dependencies 43 | build-depends: lens >=5.2.1 && <5.4 44 | -------------------------------------------------------------------------------- /these-optics/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.0.2 2 | 3 | - Support GHC-8.6.5...GHC-9.10.1 4 | 5 | # 1.0.1.2 6 | 7 | - Support GHC-9.0 8 | 9 | # 1.0.1.1 10 | 11 | - Add `Each These` instance 12 | 13 | # 1 14 | 15 | Split out of `these` package. 16 | -------------------------------------------------------------------------------- /these-optics/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, C. McCann 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 C. McCann 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 | -------------------------------------------------------------------------------- /these-optics/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | packages: ../these 3 | tests: False 4 | benchmarks: False 5 | -------------------------------------------------------------------------------- /these-optics/src/Data/These/Optics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | module Data.These.Optics ( 9 | -- * Affine traversals 10 | here, there, 11 | 12 | -- * Prisms 13 | _This, _That, _These, 14 | ) where 15 | 16 | import Data.These 17 | import Data.These.Combinators (swapThese) 18 | import Optics.Core 19 | (AffineTraversal, Each (..), Prism', Swapped (..), atraversalVL, iso, 20 | itraversalVL, prism) 21 | 22 | -- $setup 23 | -- >>> import Data.These 24 | -- >>> import Optics.Core 25 | 26 | ------------------------------------------------------------------------------- 27 | -- Traversals 28 | ------------------------------------------------------------------------------- 29 | 30 | -- | An 'AffineTraversal' of the first half of a 'These'. 31 | -- 32 | -- >>> over here show (That 1) 33 | -- That 1 34 | -- 35 | -- >>> over here show (These 'a' 2) 36 | -- These "'a'" 2 37 | -- 38 | here :: AffineTraversal (These a c) (These b c) a b 39 | here = atraversalVL here' where 40 | here' :: Functor f => (forall r. r -> f r) -> (a -> f b) -> These a c -> f (These b c) 41 | here' _ f (This x) = This <$> f x 42 | here' _ f (These x y) = flip These y <$> f x 43 | here' point _ (That x) = point (That x) 44 | 45 | -- | An 'AffineTraversal' of the second half of a 'These'. 46 | -- 47 | -- >>> over there show (That 1) 48 | -- That "1" 49 | -- 50 | -- >>> over there show (These 'a' 2) 51 | -- These 'a' "2" 52 | -- 53 | there :: AffineTraversal (These c a) (These c b) a b 54 | there = atraversalVL there' where 55 | there' :: Functor f => (forall r. r -> f r) -> (a -> f b) -> These c a -> f (These c b) 56 | there' point _ (This x) = point (This x) 57 | there' _ f (These x y) = These x <$> f y 58 | there' _ f (That x) = That <$> f x 59 | 60 | ------------------------------------------------------------------------------- 61 | -- Prisms 62 | ------------------------------------------------------------------------------- 63 | 64 | -- | A 'Prism'' selecting the 'This' constructor. 65 | -- 66 | -- /Note:/ cannot change type. 67 | _This :: Prism' (These a b) a 68 | _This = prism This (these Right (Left . That) (\x y -> Left $ These x y)) 69 | 70 | -- | A 'Prism'' selecting the 'That' constructor. 71 | -- 72 | -- /Note:/ cannot change type. 73 | _That :: Prism' (These a b) b 74 | _That = prism That (these (Left . This) Right (\x y -> Left $ These x y)) 75 | 76 | -- | A 'Prism'' selecting the 'These' constructor. 'These' names are ridiculous! 77 | -- 78 | -- /Note:/ cannot change type. 79 | _These :: Prism' (These a b) (a, b) 80 | _These = prism (uncurry These) (these (Left . This) (Left . That) (\x y -> Right (x, y))) 81 | 82 | ------------------------------------------------------------------------------- 83 | -- Orphans 84 | ------------------------------------------------------------------------------- 85 | 86 | instance Swapped These where 87 | swapped = iso swapThese swapThese 88 | 89 | -- | @since 1.0.1 90 | instance (a ~ a', b ~ b') => Each (Either () ()) (These a a') (These b b') a b where 91 | each = itraversalVL aux where 92 | aux f (This a) = This <$> f (Left ()) a 93 | aux f (That b) = That <$> f (Right ()) b 94 | aux f (These a b) = These <$> f (Left ()) a <*> f (Right ()) b 95 | -------------------------------------------------------------------------------- /these-optics/these-optics.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: these-optics 3 | version: 1.0.2 4 | x-revision: 1 5 | synopsis: Optics for These 6 | homepage: https://github.com/haskellari/these 7 | license: BSD3 8 | license-file: LICENSE 9 | author: C. McCann, Oleg Grenrus 10 | maintainer: Oleg Grenrus 11 | category: Data, These, Optics 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | description: This package provides Prism and Traversals for @These@. 15 | tested-with: 16 | GHC ==8.6.5 17 | || ==8.8.4 18 | || ==8.10.7 19 | || ==9.0.2 20 | || ==9.2.8 21 | || ==9.4.8 22 | || ==9.6.6 23 | || ==9.8.4 24 | || ==9.10.1 25 | || ==9.12.1 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/haskellari/these.git 30 | subdir: these-optics 31 | 32 | library 33 | default-language: Haskell2010 34 | ghc-options: -Wall -Wno-trustworthy-safe 35 | hs-source-dirs: src 36 | exposed-modules: Data.These.Optics 37 | 38 | -- ghc boot libs 39 | build-depends: base >=4.12 && <4.22 40 | 41 | -- these 42 | build-depends: these >=1.2.1 && <1.3 43 | 44 | -- other dependencies 45 | build-depends: optics-core >=0.4.1.1 && <0.5 46 | -------------------------------------------------------------------------------- /these-tests/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus 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 C. McCann 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 | -------------------------------------------------------------------------------- /these-tests/src/Dummy.hs: -------------------------------------------------------------------------------- 1 | module Dummy () where 2 | -------------------------------------------------------------------------------- /these-tests/test/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty (TestTree, defaultMain, testGroup) 4 | 5 | import Tests.Crosswalk 6 | import Tests.Semialign 7 | import Tests.SemialignWithIndex 8 | import Tests.These 9 | 10 | main :: IO () 11 | main = defaultMain tests 12 | 13 | tests :: TestTree 14 | tests = testGroup "Tests" 15 | [ theseProps 16 | , alignProps 17 | , alignWithKeyProps 18 | , crosswalkProps 19 | ] 20 | -------------------------------------------------------------------------------- /these-tests/test/Tests/AlignWrong.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | module Tests.AlignWrong where 4 | 5 | import Prelude hiding (zip, zipWith) 6 | 7 | import Data.Map (Map) 8 | import Test.QuickCheck (Arbitrary (..)) 9 | 10 | import qualified Data.Map as Map 11 | 12 | import Data.Semialign 13 | import Data.These 14 | 15 | --------------------------------------------------------------------------- 16 | -- WrongMap doesn't satisfy Align laws 17 | ------------------------------------------------------------------------------- 18 | 19 | newtype WrongMap k v = WM (Map k v) deriving (Eq, Ord, Show, Functor, Foldable) 20 | 21 | instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (WrongMap k v) where 22 | arbitrary = WM <$> arbitrary 23 | shrink (WM m) = WM <$> shrink m 24 | 25 | instance Ord k => Align (WrongMap k) where 26 | nil = WM Map.empty 27 | 28 | instance Ord k => Semialign (WrongMap k) where 29 | align (WM x) (WM y) 30 | | Map.null y = WM $ This <$> x 31 | | Map.null x = WM $ That <$> y 32 | | otherwise = WM $ Map.intersectionWith These x y 33 | 34 | instance Ord k => Zip (WrongMap k) where 35 | zip (WM x) (WM y) = WM (Map.intersectionWith (,) x y) 36 | 37 | ------------------------------------------------------------------------------- 38 | -- WeirdMap 39 | ------------------------------------------------------------------------------- 40 | 41 | -- | Sequence-like __invalid__ 'Align' instance for Map. 42 | -- 43 | -- Satisfies first five laws; 44 | -- Doesn't satisfy /assoc/ or /toList/ laws. 45 | -- 46 | newtype WeirdMap k v = WeirdMap (Map k v) 47 | deriving (Eq, Ord, Show, Functor, Foldable) 48 | 49 | instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (WeirdMap k v) where 50 | arbitrary = WeirdMap <$> arbitrary 51 | shrink (WeirdMap m) = WeirdMap <$> shrink m 52 | 53 | instance Ord k => Align (WeirdMap k) where 54 | nil = WeirdMap Map.empty 55 | 56 | instance Ord k => Semialign (WeirdMap k) where 57 | alignWith f (WeirdMap x) (WeirdMap y) = WeirdMap $ Map.fromList $ 58 | alignWith g (Map.toList x) (Map.toList y) 59 | where 60 | g (This (k, a)) = (k, f (This a)) 61 | g (That (k, a)) = (k, f (That a)) 62 | g (These (k, a) (_, b)) = (k, f (These a b)) 63 | 64 | instance Ord k => Zip (WeirdMap k) where 65 | zipWith f (WeirdMap x) (WeirdMap y) = WeirdMap $ Map.fromList $ 66 | zipWith (\(k, a) (_, b) -> (k, f a b)) (Map.toList x) (Map.toList y) 67 | 68 | ------------------------------------------------------------------------------- 69 | -- R does satisfy Align laws, though is weird 70 | -- https://github.com/isomorphism/these/issues/96 71 | ------------------------------------------------------------------------------- 72 | 73 | newtype R a = Nest [[a]] 74 | deriving (Show, Eq, Ord, Functor, Foldable) 75 | 76 | instance Align R where 77 | nil = Nest [] 78 | 79 | instance Semialign R where 80 | align (Nest ass) (Nest bss) 81 | | null ass = That <$> Nest bss 82 | | null bss = This <$> Nest ass 83 | | shape ass == shape bss = Nest $ zipWith (zipWith These) ass bss 84 | | otherwise = Nest [align (concat ass) (concat bss)] 85 | where 86 | shape = fmap (() <$) 87 | 88 | instance Zip R where 89 | -- doesn't work with align above 90 | zip (Nest ass) (Nest bss) = Nest $ zipWith (zipWith (,)) ass bss 91 | 92 | instance Arbitrary a => Arbitrary (R a) where 93 | arbitrary = Nest <$> arbitrary 94 | shrink (Nest xss) = Nest <$> shrink xss 95 | -------------------------------------------------------------------------------- /these-tests/test/Tests/Crosswalk.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Tests.Crosswalk (crosswalkProps) where 5 | 6 | import Control.Monad.Trans.Instances () 7 | import Data.Functor.Compose (Compose (..)) 8 | import Data.Functor.Identity (Identity (..)) 9 | import Data.Map (Map) 10 | import Data.Semigroup (Semigroup (..)) 11 | import Data.Sequence (Seq) 12 | import Data.Typeable (Typeable, typeOf1) 13 | import Test.QuickCheck (Arbitrary (..), Property, (===)) 14 | import Test.QuickCheck.Function (Fun (..)) 15 | import Test.QuickCheck.Instances () 16 | import Test.QuickCheck.Poly (A, B, OrdA) 17 | import Test.Tasty (TestTree, testGroup) 18 | import Test.Tasty.QuickCheck (testProperty) 19 | 20 | import qualified Data.Vector as V 21 | 22 | import Data.Crosswalk 23 | import Data.Semialign 24 | import Data.These 25 | 26 | import Tests.Orphans () 27 | 28 | crosswalkProps :: TestTree 29 | crosswalkProps = testGroup "Crosswalk" 30 | [ crosswalkLaws (P :: P []) 31 | , crosswalkLaws (P :: P Maybe) 32 | , crosswalkLaws (P :: P Identity) 33 | , crosswalkLaws (P :: P (These Int)) 34 | , crosswalkLaws (P :: P Seq) 35 | , crosswalkLaws (P :: P V.Vector) 36 | , crosswalkLaws (P :: P ((,) Int)) 37 | , crosswalkLaws (P :: P (Compose [] [])) 38 | ] 39 | 40 | ------------------------------------------------------------------------------- 41 | -- Crosswalk laws 42 | ------------------------------------------------------------------------------- 43 | 44 | -- For old GHC to work 45 | data P (a :: * -> *) = P 46 | 47 | crosswalkLaws 48 | :: forall (t :: * -> *). 49 | ( Typeable t, Crosswalk t 50 | , Eq (t A), Show (t A), Arbitrary (t A) 51 | , Eq (t B), Show (t B), Arbitrary (t B) 52 | ) 53 | => P t 54 | -> TestTree 55 | crosswalkLaws _ = testGroup ("CrossWalk " <> name) 56 | [ testProperty "crosswalk (const nil) = const nil" firstLaw 57 | , testProperty "crosswalk f = sequenceL . fmap f" secondLaw 58 | ] 59 | where 60 | name = show (typeOf1 (undefined :: t ())) 61 | 62 | -- f = Map OrdA 63 | -- a, b = Int 64 | firstLaw :: t A -> Property 65 | firstLaw x = lhs === rhs 66 | where 67 | lhs = crosswalk (const nil) x 68 | rhs = const nil x :: Map OrdA (t A) 69 | 70 | secondLaw :: Fun A (Map OrdA B) -> t A -> Property 71 | secondLaw (Fun _ f) x = lhs === rhs 72 | where 73 | lhs = crosswalk f x 74 | rhs = sequenceL . fmap f $ x 75 | -------------------------------------------------------------------------------- /these-tests/test/Tests/Orphans.hs: -------------------------------------------------------------------------------- 1 | module Tests.Orphans () where 2 | -------------------------------------------------------------------------------- /these-tests/test/Tests/Semialign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | -- Const instances 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | module Tests.Semialign (alignProps, semialignLaws) where 10 | 11 | import Prelude hiding (repeat, unzip, zip, zipWith) 12 | 13 | import Algebra.Lattice 14 | (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..)) 15 | import Algebra.Lattice.M2 (M2) 16 | import Control.Applicative (Const (..), ZipList (..)) 17 | import Control.Lens (folded, toListOf) 18 | import Control.Monad (join) 19 | import Control.Monad.Trans.Instances () 20 | import Data.Bifunctor (bimap) 21 | import Data.Bifunctor.Assoc (assoc) 22 | import Data.Bifunctor.Swap (swap) 23 | import Data.Foldable (toList) 24 | import Data.Functor.Compose (Compose (..)) 25 | import Data.Functor.Identity (Identity (..)) 26 | import Data.Functor.Product (Product (..)) 27 | import Data.HashMap.Strict (HashMap) 28 | import Data.IntMap (IntMap) 29 | import Data.List.NonEmpty (NonEmpty) 30 | import Data.Map (Map) 31 | import Data.Maybe (mapMaybe) 32 | import Data.Proxy (Proxy) 33 | import Data.Sequence (Seq) 34 | import Data.Tagged (Tagged) 35 | import Data.Typeable (Typeable, typeOf1) 36 | import Test.QuickCheck 37 | (Arbitrary (..), Property, counterexample, (.&&.), (===)) 38 | import Test.QuickCheck.Function (Fun (..)) 39 | import Test.QuickCheck.Instances () 40 | import Test.QuickCheck.Poly (A, B, C) 41 | import Test.Tasty (TestTree, testGroup) 42 | import Test.Tasty.QuickCheck (testProperty) 43 | 44 | import qualified Data.Tree as T 45 | import qualified Data.Vector as V 46 | 47 | import Data.Semialign 48 | import Data.These 49 | import Data.These.Combinators 50 | 51 | import Data.These.Lens 52 | 53 | import Tests.Orphans () 54 | 55 | ------------------------------------------------------------------------------- 56 | -- Props 57 | ------------------------------------------------------------------------------- 58 | 59 | alignProps :: TestTree 60 | alignProps = testGroup "Align" 61 | [ semialignLaws (CAll :: CSemialign []) 62 | , semialignLaws (CUnalign :: CSemialign (HashMap String)) 63 | , semialignLaws (CUnalign :: CSemialign (Map Char)) 64 | , semialignLaws (CUnalign :: CSemialign IntMap) 65 | , semialignLaws (CUnAll :: CSemialign Maybe) 66 | , semialignLaws (CAll :: CSemialign (Product [] Maybe)) 67 | , semialignLaws (CUnAll :: CSemialign (Product Maybe Maybe)) 68 | , semialignLaws (CAll :: CSemialign (Compose [] Maybe)) 69 | , semialignLaws (CAlign :: CSemialign Seq) 70 | , semialignLaws (CAlign :: CSemialign V.Vector) 71 | , semialignLaws (CAlign :: CSemialign ZipList) 72 | , semialignLaws (CZip :: CSemialign T.Tree) 73 | , semialignLaws (CZip :: CSemialign NonEmpty) 74 | , semialignLaws (CZip :: CSemialign Identity) 75 | , semialignLaws (CUnAll :: CSemialign Proxy) 76 | , semialignLaws (CZip :: CSemialign (Tagged Char)) 77 | -- note: with e.g. N5 (which isn't distributive lattice) distributivity laws fail! 78 | , semialignLaws (CZip :: CSemialign (Const M2)) 79 | ] 80 | 81 | ------------------------------------------------------------------------------- 82 | -- Const 83 | ------------------------------------------------------------------------------- 84 | 85 | instance Lattice a => Semialign (Const a) where 86 | alignWith _ (Const a) (Const b) = Const (a \/ b) 87 | 88 | -- This is valid when @a@ is distributive lattice 89 | -- otherwise distributivity laws don't hold. 90 | instance Lattice a => Zip (Const a) where 91 | zipWith _ (Const a) (Const b) = Const (a /\ b) 92 | 93 | -- Note: idempotency of lattice makes this valid! 94 | instance Lattice a => Unzip (Const a) where 95 | unzip (Const a) = (Const a, Const a) 96 | 97 | instance BoundedJoinSemiLattice a => Align (Const a) where 98 | nil = Const bottom 99 | 100 | instance BoundedMeetSemiLattice a => Repeat (Const a) where 101 | repeat _ = Const top 102 | 103 | ------------------------------------------------------------------------------- 104 | -- Align laws 105 | ------------------------------------------------------------------------------- 106 | 107 | data CSemialign f where 108 | -- CSemialign :: Semialign f => CSemialign f 109 | CAlign :: Align f => CSemialign f 110 | CUnalign :: (Align f, Unalign f) => CSemialign f 111 | CZip :: Repeat f => CSemialign f 112 | CAll :: (Align f, Repeat f) => CSemialign f 113 | CUnAll :: (Align f, Repeat f, Unalign f) => CSemialign f 114 | 115 | semialignLaws 116 | :: forall (f :: * -> *). 117 | ( Semialign f, Unzip f, Foldable f, Typeable f 118 | , Eq (f A), Show (f A), Arbitrary (f A) 119 | , Eq (f B), Show (f B), Arbitrary (f B) 120 | , Eq (f C), Show (f C), Arbitrary (f C) 121 | , Eq (f (A, (B, C))), Show (f (A, (B, C))) 122 | , Eq (f (A, A)), Show (f (A, A)) 123 | , Eq (f (A, B)), Show (f (A, B)), Arbitrary (f (A, B)) 124 | , Eq (f (C, Int)), Show (f (C, Int)) 125 | , Eq (f (These (A, B) C)), Show (f (These (A, B) C)) 126 | , Eq (f (These (A, C) (B, C))), Show (f (These (A, C) (B, C))) 127 | , Eq (f (These A (A, B))), Show (f (These A (A, B))) 128 | , Eq (f (These A (These B C))), Show (f (These A (These B C))) 129 | , Eq (f (These A A)), Show (f (These A A)) 130 | , Eq (f (These A B)), Show (f (These A B)), Arbitrary (f (These A B)) 131 | , Eq (f (These C Int)), Show (f (These C Int)) 132 | ) 133 | => CSemialign f 134 | -> TestTree 135 | semialignLaws p = testGroup name $ case p of 136 | -- CSemialign -> semialignLaws' 137 | CAlign -> [semialignLaws' p, unzipLaws' p, alignLaws' p] 138 | CUnalign -> [semialignLaws' p, unzipLaws' p, unalignLaws' p, alignLaws' p] 139 | CZip -> [semialignLaws' p, unzipLaws' p, zipLaws' p] 140 | CAll -> [semialignLaws' p, unzipLaws' p, alignLaws' p, zipLaws' p] 141 | CUnAll -> [semialignLaws' p, unzipLaws' p, unalignLaws' p, alignLaws' p, zipLaws' p] 142 | where 143 | name = show (typeOf1 (undefined :: f ())) 144 | 145 | {-# NOINLINE semialignLaws' #-} 146 | {-# NOINLINE unzipLaws' #-} 147 | {-# NOINLINE alignLaws' #-} 148 | {-# NOINLINE zipLaws' #-} 149 | {-# NOINLINE unalignLaws' #-} 150 | 151 | semialignLaws' 152 | :: forall f proxy. (Zip f, Foldable f 153 | , Eq (f A), Show (f A), Arbitrary (f A) 154 | , Eq (f B), Show (f B), Arbitrary (f B) 155 | , Eq (f C), Show (f C), Arbitrary (f C) 156 | , Eq (f (A, A)), Show (f (A, A)) 157 | , Eq (f (These A A)), Show (f (These A A)) 158 | , Eq (f (These C Int)), Show (f (These C Int)) 159 | , Eq (f (C, Int)), Show (f (C, Int)) 160 | , Eq (f (These A B)), Show (f (These A B)) 161 | , Eq (f (These A (These B C))), Show (f (These A (These B C))) 162 | , Eq (f (A, B)), Show (f (A, B)), Arbitrary (f (A, B)) 163 | , Eq (f (A, (B, C))), Show (f (A, (B, C))) 164 | , Eq (f (These A (A, B))), Show (f (These A (A, B))) 165 | , Eq (f (These (A, B) C)), Show (f (These (A, B) C)) 166 | , Eq (f (These (A, C) (B, C))), Show (f (These (A, C) (B, C))) 167 | ) 168 | => proxy f -> TestTree 169 | semialignLaws' _ = testGroup "Semialign" 170 | [ testProperty "idempotency align" idempAlign 171 | , testProperty "idempotency zip" idempZip 172 | 173 | , testProperty "commutativity align" swapProp 174 | , testProperty "commutativity zip" zipSwapProp 175 | 176 | , testProperty "associativity align" assocProp 177 | , testProperty "associativity zip" zipAssocProp 178 | 179 | , testProperty "absoption 1" absorb1Prop 180 | , testProperty "absoption 2" absorb2Prop 181 | 182 | , testProperty "alignWith" alignWithProp 183 | , testProperty "zipWith" zipWithProp 184 | 185 | , testProperty "functoriality align" bimapAlignProp 186 | , testProperty "functoriality zip" bimapZipProp 187 | 188 | , testProperty "fst-zip" fstZipProp 189 | , testProperty "snd-zip" sndZipProp 190 | , testProperty "zip-fst-snd" zipFstSndProp 191 | 192 | #ifdef MIN_VERSION_lens 193 | , testProperty "alignToList" alignToListProp 194 | #endif 195 | 196 | , testProperty "distributivity 1" distr1'Prop 197 | , testProperty "distributivity 2" distr2Prop 198 | , testProperty "distributivity 3'" distr2'Prop 199 | 200 | -- testProperty "distributivity 4" distr1Prop 201 | ] 202 | where 203 | idempAlign :: f A -> Property 204 | idempAlign xs = join align xs === fmap (join These) xs 205 | 206 | idempZip :: f A -> Property 207 | idempZip xs = join zip xs === fmap (join (,)) xs 208 | 209 | bimapAlignProp :: f A -> f B -> Fun A C -> Fun B Int -> Property 210 | bimapAlignProp xs ys (Fun _ f) (Fun _ g) = 211 | align (f <$> xs) (g <$> ys) === (bimap f g <$> align xs ys) 212 | 213 | bimapZipProp :: f A -> f B -> Fun A C -> Fun B Int -> Property 214 | bimapZipProp xs ys (Fun _ f) (Fun _ g) = 215 | zip (f <$> xs) (g <$> ys) === (bimap f g <$> zip xs ys) 216 | 217 | alignWithProp :: f A -> f B -> Fun (These A B) C -> Property 218 | alignWithProp xs ys (Fun _ f) = 219 | alignWith f xs ys === (f <$> align xs ys) 220 | 221 | zipWithProp :: f A -> f B -> Fun (A, B) C -> Property 222 | zipWithProp xs ys (Fun _ f) = 223 | zipWith (curry f) xs ys === (f <$> zip xs ys) 224 | 225 | swapProp :: f A -> f B -> Property 226 | swapProp xs ys = align xs ys === fmap swap (align ys xs) 227 | 228 | assocProp :: f A -> f B -> f C -> Property 229 | assocProp xs ys zs = lhs === fmap assocThese rhs 230 | where 231 | rhs = (xs `align` ys) `align` zs 232 | lhs = xs `align` (ys `align` zs) 233 | 234 | #ifdef MIN_VERSION_lens 235 | alignToListProp :: f A -> f B -> Property 236 | alignToListProp xs ys = 237 | toList xs === toListOf (folded . here) xys 238 | .&&. 239 | toList xs === mapMaybe justHere (toList xys) 240 | .&&. 241 | toList ys === toListOf (folded . there) xys 242 | where 243 | xys = align xs ys 244 | #endif 245 | 246 | fstZipProp :: f A -> Property 247 | fstZipProp xs = fmap fst (zip xs xs) === xs 248 | 249 | sndZipProp :: f A -> Property 250 | sndZipProp xs = fmap fst (zip xs xs) === xs 251 | 252 | zipFstSndProp :: f (A, B) -> Property 253 | zipFstSndProp xs = zip (fmap fst xs) (fmap snd xs) === xs 254 | 255 | zipSwapProp :: f A -> f B -> Property 256 | zipSwapProp xs ys = zip xs ys === fmap swap (zip ys xs) 257 | 258 | zipAssocProp :: f A -> f B -> f C -> Property 259 | zipAssocProp xs ys zs = lhs === fmap assoc rhs 260 | where 261 | rhs = (xs `zip` ys) `zip` zs 262 | lhs = xs `zip` (ys `zip` zs) 263 | 264 | absorb1Prop :: f A -> f B -> Property 265 | absorb1Prop xs ys = fmap fst (zip xs (align xs ys)) === xs 266 | 267 | absorb2Prop :: f A -> f B -> Property 268 | absorb2Prop xs ys = lhs === rhs where 269 | lhs = fmap toThis (align xs (zip xs ys)) 270 | rhs = fmap This xs 271 | 272 | toThis (This a) = This a 273 | toThis (These a _) = This a 274 | toThis (That b) = That b 275 | 276 | -- distr1Prop :: f A -> f B -> f C -> Property 277 | -- distr1Prop xs ys zs = lhs === rhs where 278 | -- lhs = distrThesePair <$> align (zip xs ys) zs 279 | -- rhs = zip (align xs zs) (align ys zs) 280 | 281 | distr1'Prop :: f A -> f B -> f C -> Property 282 | distr1'Prop xs ys zs = lhs === rhs where 283 | lhs = align (zip xs ys) zs 284 | rhs = undistrThesePair <$> zip (align xs zs) (align ys zs) 285 | 286 | distr2Prop :: f A -> f B -> f C -> Property 287 | distr2Prop xs ys zs = lhs === rhs where 288 | lhs = distrPairThese <$> zip (align xs ys) zs 289 | rhs = align (zip xs zs) (zip ys zs) 290 | 291 | distr2'Prop :: f A -> f B -> f C -> Property 292 | distr2'Prop xs ys zs = lhs === rhs where 293 | lhs = distrPairThese <$> zip (align xs ys) zs 294 | rhs = align (zip xs zs) (zip ys zs) 295 | 296 | alignLaws' 297 | :: forall f proxy. (Align f 298 | , Eq (f A), Show (f A), Arbitrary (f A) 299 | , Eq (f B), Show (f B), Arbitrary (f B) 300 | , Eq (f (These A B)), Show (f (These A B)) 301 | ) 302 | => proxy f -> TestTree 303 | alignLaws' _ = testGroup "Align" 304 | [ testProperty "right identity" rightIdentityProp 305 | , testProperty "left identity" leftIdentityProp 306 | ] 307 | where 308 | rightIdentityProp :: f A -> Property 309 | rightIdentityProp xs = (xs `align` (nil :: f B)) === fmap This xs 310 | 311 | leftIdentityProp :: Align f => f B -> Property 312 | leftIdentityProp xs = ((nil :: f A) `align` xs) === fmap That xs 313 | 314 | zipLaws' 315 | :: forall f proxy. (Repeat f 316 | , Eq (f A), Show (f A), Arbitrary (f A) 317 | ) 318 | => proxy f -> TestTree 319 | zipLaws' _ = testGroup "Zip" 320 | [ testProperty "right identity" zipRightIdentityProp 321 | , testProperty "left identity" zipLeftIdentityProp 322 | ] 323 | where 324 | zipRightIdentityProp :: f A -> B -> Property 325 | zipRightIdentityProp xs y = (fst <$> zip xs (repeat y)) === xs 326 | 327 | zipLeftIdentityProp :: B -> f A -> Property 328 | zipLeftIdentityProp x ys = (snd <$> zip (repeat x) ys) === ys 329 | 330 | unalignLaws' 331 | :: forall f proxy. (Unalign f 332 | , Eq (f A), Show (f A), Arbitrary (f A) 333 | , Eq (f B), Show (f B), Arbitrary (f B) 334 | , Eq (f C), Show (f C), Arbitrary (f C) 335 | , Eq (f (These A B)), Show (f (These A B)), Arbitrary (f (These A B)) 336 | ) 337 | => proxy f -> TestTree 338 | unalignLaws' _ = testGroup "Unalign" 339 | [ testProperty "right inverse" invProp 340 | , testProperty "left inverse" leftProp 341 | , testProperty "unalignWith via unalign" unalignWithProp 342 | , testProperty "unalign via unalignWith" unalignProp 343 | ] 344 | where 345 | unalignWithProp :: f A -> Fun A (These B C) -> Property 346 | unalignWithProp xs (Fun _ f) = unalignWith f xs === unalign (f <$> xs) 347 | 348 | unalignProp :: f (These A B) -> Property 349 | unalignProp xs = unalign xs === unalignWith id xs 350 | 351 | invProp :: f (These A B) -> Property 352 | invProp xs = uncurry align (unalign xs) === xs 353 | 354 | leftProp :: f A -> f B -> Property 355 | leftProp xs ys = counterexample (show xys) $ unalign xys === (xs, ys) where 356 | xys = align xs ys 357 | 358 | 359 | unzipLaws' 360 | :: forall f proxy. (Unzip f 361 | , Eq (f A), Show (f A), Arbitrary (f A) 362 | , Eq (f B), Show (f B), Arbitrary (f B) 363 | , Eq (f C), Show (f C), Arbitrary (f C) 364 | , Eq (f (A, B)), Show (f (A, B)), Arbitrary (f (A, B)) 365 | ) 366 | => proxy f -> TestTree 367 | unzipLaws' _ = testGroup "Unzip" 368 | [ testProperty "unzip = unzipDefault" def 369 | , testProperty "unzipWith via unzip" unzipWithProp 370 | , testProperty "unzip via unzipWith" unzipProp 371 | , testProperty "right inverse" invProp 372 | , testProperty "left inverse" leftProp 373 | ] 374 | where 375 | def :: f (A, B) -> Property 376 | def xs = unzip xs === unzipDefault xs 377 | 378 | unzipWithProp :: f A -> Fun A (B, C) -> Property 379 | unzipWithProp xs (Fun _ f) = unzipWith f xs === unzip (f <$> xs) 380 | 381 | unzipProp :: f (A, B) -> Property 382 | unzipProp xs = unzip xs === unzipWith id xs 383 | 384 | invProp :: f (A, B) -> Property 385 | invProp xs = uncurry zip (unzip xs) === xs 386 | 387 | leftProp :: f A -> Property 388 | leftProp xs = unzip (zip xs xs) === (xs, xs) 389 | -------------------------------------------------------------------------------- /these-tests/test/Tests/SemialignWithIndex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Tests.SemialignWithIndex (alignWithKeyProps) where 4 | 5 | import Prelude hiding (repeat, zip) 6 | 7 | import Data.Functor.WithIndex (FunctorWithIndex (imap)) 8 | import Data.Typeable (Typeable, typeOf1) 9 | import Test.QuickCheck 10 | (Arbitrary (..), CoArbitrary, Property, once, (===)) 11 | import Test.QuickCheck.Function (Fun (..), Function, applyFun) 12 | import Test.QuickCheck.Instances () 13 | import Test.QuickCheck.Poly (A, B, C) 14 | import Test.Tasty (TestTree, testGroup) 15 | import Test.Tasty.QuickCheck (testProperty) 16 | 17 | import Control.Applicative (ZipList) 18 | import Data.HashMap.Strict (HashMap) 19 | import Data.IntMap (IntMap) 20 | import Data.Map (Map) 21 | import Data.Sequence (Seq) 22 | import Data.Vector (Vector) 23 | 24 | import Data.Semialign 25 | import Data.Semialign.Indexed 26 | import Data.These 27 | 28 | import Tests.Orphans () 29 | 30 | ------------------------------------------------------------------------------- 31 | -- Props 32 | ------------------------------------------------------------------------------- 33 | 34 | alignWithKeyProps :: TestTree 35 | alignWithKeyProps = testGroup "AlignWithIndex" 36 | [ testProperty "example" $ once exampleI 37 | , semialignIndexedLaws (P :: P []) -- cannot test irepeat, because it's infinite. 38 | , semialignIndexedLaws (P :: P ZipList) 39 | , semialignIndexedLaws (P :: P IntMap) 40 | , semialignIndexedLaws (P :: P (Map Int)) 41 | , semialignIndexedLaws (P :: P (HashMap Char)) 42 | , semialignIndexedLaws (P :: P Seq) 43 | , semialignIndexedLaws (P :: P Vector) 44 | , repeatIndexedLaws (P :: P Maybe) 45 | ] 46 | where 47 | exampleI = ialignWith (,) "foo" "quux" === exampleV 48 | 49 | exampleV = 50 | [ (0, These 'f' 'q') 51 | , (1, These 'o' 'u') 52 | , (2, These 'o' 'u') 53 | , (3, That 'x') 54 | ] 55 | 56 | ------------------------------------------------------------------------------- 57 | -- Laws 58 | ------------------------------------------------------------------------------- 59 | 60 | data P (f :: * -> *) = P 61 | 62 | repeatIndexedLaws 63 | :: forall f i. (RepeatWithIndex i f, Typeable f 64 | , Function i, CoArbitrary i, Show i 65 | , Eq (f A), Show (f A), Arbitrary (f A) 66 | , Eq (f B), Show (f B), Arbitrary (f B) 67 | , Eq (f C), Show (f C), Arbitrary (f C) 68 | ) 69 | => P f 70 | -> TestTree 71 | repeatIndexedLaws p = testGroup name $ 72 | semialignIndexedLaws' p ++ 73 | [ testProperty "irepeat definition" irepeatDef 74 | ] 75 | where 76 | name = show (typeOf1 (undefined :: f ())) 77 | 78 | irepeatDef :: Fun i A -> Property 79 | irepeatDef f' = irepeat f === imap (\i g -> g i) (repeat f :: f (i -> A)) where 80 | f = applyFun f' 81 | 82 | semialignIndexedLaws 83 | :: forall f i. (ZipWithIndex i f, Typeable f 84 | , Function i, CoArbitrary i, Show i 85 | , Eq (f A), Show (f A), Arbitrary (f A) 86 | , Eq (f B), Show (f B), Arbitrary (f B) 87 | , Eq (f C), Show (f C), Arbitrary (f C) 88 | ) 89 | => P f 90 | -> TestTree 91 | semialignIndexedLaws p = testGroup name $ semialignIndexedLaws' p where 92 | name = show (typeOf1 (undefined :: f ())) 93 | 94 | 95 | semialignIndexedLaws' 96 | :: forall f i. (ZipWithIndex i f, Typeable f 97 | , Function i, CoArbitrary i, Show i 98 | , Eq (f A), Show (f A), Arbitrary (f A) 99 | , Eq (f B), Show (f B), Arbitrary (f B) 100 | , Eq (f C), Show (f C), Arbitrary (f C) 101 | ) 102 | => P f 103 | -> [TestTree] 104 | semialignIndexedLaws' _ = 105 | [ testProperty "ialignWith definition" ialignDef 106 | , testProperty "izipWith definition" izipDef 107 | ] 108 | where 109 | ialignDef :: Fun (i, These A B) C -> f A -> f B -> Property 110 | ialignDef f' xs ys = ialignWith f xs ys === imap f (align xs ys) where 111 | f i ab = applyFun f' (i, ab) 112 | 113 | izipDef :: Fun (i, A, B) C -> f A -> f B -> Property 114 | izipDef f' xs ys = izipWith f xs ys === imap (uncurry . f) (zip xs ys) where 115 | f i a b = applyFun f' (i, a, b) 116 | -------------------------------------------------------------------------------- /these-tests/test/Tests/These.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | module Tests.These (theseProps) where 6 | 7 | import Control.Applicative (liftA) 8 | import Control.Monad (ap, liftM) 9 | import Data.Functor.Compose (Compose (..)) 10 | import Data.Functor.Identity (Identity (..)) 11 | import Data.List (nub) 12 | import Data.List.NonEmpty (NonEmpty) 13 | import Data.Semigroup (Semigroup (..)) 14 | import Data.Traversable (fmapDefault, foldMapDefault) 15 | import Data.Typeable (Typeable, typeOf, typeOf1) 16 | import Test.QuickCheck (Arbitrary (..), Property, (===)) 17 | import Test.QuickCheck.Function (Fun (..), applyFun) 18 | import Test.QuickCheck.Instances () 19 | import Test.QuickCheck.Poly (A, B, C) 20 | import Test.Tasty (TestTree, testGroup) 21 | import Test.Tasty.QuickCheck (testProperty) 22 | 23 | import qualified Data.Binary as Binary 24 | import qualified Data.IntMap as IntMap 25 | import qualified Data.Map as Map 26 | 27 | import Data.Align 28 | import Data.These 29 | 30 | theseProps :: TestTree 31 | theseProps = testGroup "These" 32 | [ functorLaws (CTraversable :: CFunctor (These Int)) 33 | , functorLaws (CMonad :: CFunctor (These (NonEmpty Int))) 34 | , testProperty "Map value laziness property" mapStrictnessProp 35 | , testProperty "IntMap value laziness property" intmapStrictnessProp 36 | , binaryProps 37 | , semigroupLaws (CSemigroup :: CSemigroup (These String String)) 38 | , testGroup "Extras" 39 | [ semigroupLaws (CSemigroup :: CSemigroup (SearchResult String String)) 40 | , semigroupLaws (CMonoid :: CSemigroup String) 41 | ] 42 | ] 43 | 44 | ------------------------------------------------------------------------------- 45 | -- SearchResult 46 | ------------------------------------------------------------------------------- 47 | 48 | -- | Either a, or b, or both a and b 49 | -- 50 | -- See https://github.com/isomorphism/these/issues/80 51 | data SearchResult a b = Scanned a | Found b | ScannedAndFound a b 52 | deriving (Eq, Ord, Show, Typeable) 53 | 54 | instance (Arbitrary a, Arbitrary b) => Arbitrary (SearchResult a b) where 55 | arbitrary = srFromThese <$> arbitrary 56 | 57 | srFromThese :: These a b -> SearchResult a b 58 | srFromThese (This a) = Scanned a 59 | srFromThese (That b) = Found b 60 | srFromThese (These a b) = ScannedAndFound a b 61 | 62 | -- | Accumulate 'a's from left to right, until one 'b' is found 63 | instance Semigroup a => Semigroup (SearchResult a b) where 64 | ScannedAndFound a b <> _ = ScannedAndFound a b 65 | Found b <> _ = Found b 66 | Scanned a <> Scanned a' = Scanned (a <> a') 67 | Scanned a <> Found b = ScannedAndFound a b 68 | Scanned a <> ScannedAndFound a' b = ScannedAndFound (a <> a') b 69 | 70 | ------------------------------------------------------------------------------- 71 | -- Semigroup & Monoid Laws 72 | ------------------------------------------------------------------------------- 73 | 74 | data CSemigroup a where 75 | CSemigroup :: Semigroup a => CSemigroup a 76 | CMonoid :: (Semigroup a, Monoid a) => CSemigroup a 77 | 78 | semigroupLaws 79 | :: forall a. (Typeable a, Show a, Eq a, Arbitrary a) 80 | => CSemigroup a 81 | -> TestTree 82 | semigroupLaws c = testGroup name $ case c of 83 | CSemigroup -> [semigroupLaws' c] 84 | CMonoid -> [semigroupLaws' c, monoidLaws' c] 85 | where 86 | name = show (typeOf (undefined :: a)) 87 | 88 | semigroupLaws' 89 | :: forall a proxy. (Semigroup a, Show a, Eq a, Arbitrary a) 90 | => proxy a -> TestTree 91 | semigroupLaws' _ = testGroup "Semigroup" 92 | [ testProperty "associativity" assocProp 93 | ] 94 | where 95 | assocProp :: a -> a -> a -> Property 96 | assocProp x y z = (x <> y) <> z === x <> (y <> z) 97 | 98 | monoidLaws' 99 | :: forall a proxy. (Semigroup a, Monoid a, Show a, Eq a, Arbitrary a) 100 | => proxy a -> TestTree 101 | monoidLaws' _ = testGroup "Monoid" 102 | [ testProperty "associativity" assocProp 103 | , testProperty "left-identity" idLeftProp 104 | , testProperty "right-identity" idRightProp 105 | , testProperty "mappend = (<>)" mappendDefProp 106 | ] 107 | where 108 | assocProp :: a -> a -> a -> Property 109 | assocProp x y z = (x `mappend` y) `mappend` z === x `mappend` (y `mappend` z) 110 | 111 | idLeftProp :: a -> Property 112 | idLeftProp x = mappend mempty x === x 113 | 114 | idRightProp :: a -> Property 115 | idRightProp x = mappend x mempty === x 116 | 117 | mappendDefProp :: a -> a -> Property 118 | mappendDefProp x y = mappend x y === (x <> y) 119 | 120 | ------------------------------------------------------------------------------- 121 | -- Functor .. Traversable 122 | ------------------------------------------------------------------------------- 123 | 124 | data CFunctor f where 125 | CFunctor :: Functor f => CFunctor f 126 | CTraversable :: Traversable f => CFunctor f 127 | CApplicative :: Applicative f => CFunctor f 128 | CMonad :: (Applicative f, Monad f) => CFunctor f 129 | 130 | functorLaws 131 | :: forall f. (Typeable f 132 | , Eq (f A), Show (f A), Arbitrary (f A) 133 | , Eq (f B), Show (f B), Arbitrary (f B) 134 | , Eq (f C), Show (f C), Arbitrary (f C) 135 | , Show (f (Fun A B)), Arbitrary (f (Fun A B)) 136 | , Show (f (Fun B C)), Arbitrary (f (Fun B C)) 137 | ) 138 | => CFunctor f 139 | -> TestTree 140 | functorLaws c = testGroup name $ case c of 141 | CFunctor -> [functorLaws' c] 142 | CTraversable -> [functorLaws' c, traversableLaws' c] 143 | CApplicative -> [functorLaws' c, applicativeLaws' c] 144 | CMonad -> [functorLaws' c, applicativeLaws' c, monadLaws' c] 145 | where 146 | name = show (typeOf1 (undefined :: f ())) 147 | 148 | functorLaws' 149 | :: forall f proxy. ( Functor f 150 | , Eq (f A), Show (f A), Arbitrary (f A) 151 | , Eq (f C), Show (f C), Arbitrary (f C) 152 | ) 153 | => proxy f -> TestTree 154 | functorLaws' _ = testGroup "Functor" 155 | [ testProperty "identity" functorIdentityProp 156 | , testProperty "composition" functorCompositionProp 157 | ] 158 | where 159 | functorIdentityProp :: f A -> Property 160 | functorIdentityProp x = fmap id x === x 161 | 162 | functorCompositionProp :: f A -> Fun A B -> Fun B C -> Property 163 | functorCompositionProp x (Fun _ f) (Fun _ g) = fmap g (fmap f x) === fmap (g . f) x 164 | 165 | traversableLaws' 166 | :: forall f proxy. ( Traversable f 167 | , Eq (f A), Show (f A), Arbitrary (f A) 168 | , Eq (f B), Show (f B), Arbitrary (f B) 169 | , Eq (f C), Show (f C), Arbitrary (f C) 170 | ) 171 | => proxy f -> TestTree 172 | traversableLaws' _ = testGroup "Traversable" 173 | [ testProperty "identity" traversableIdentityProp 174 | , testProperty "identity'" traversableIdentityProp' 175 | , testProperty "composition" traversableCompositionProp 176 | , testProperty "functor" traversableFunctorProp 177 | , testProperty "foldable" traversableFoldableProp 178 | ] 179 | where 180 | traversableIdentityProp :: f A -> Property 181 | traversableIdentityProp x = traverse Identity x === Identity x 182 | 183 | traversableIdentityProp' :: f A -> Property 184 | traversableIdentityProp' x = traverse pure x === (pure x :: Maybe (f A)) 185 | 186 | traversableCompositionProp :: f A -> Fun A (Maybe B) -> Fun B (Either Bool C) -> Property 187 | traversableCompositionProp x (Fun _ f) (Fun _ g) = traverse (Compose . fmap g . f) x === (Compose . fmap (traverse g) . traverse f $ x) 188 | 189 | traversableFunctorProp :: f A -> Fun A B -> Property 190 | traversableFunctorProp x (Fun _ f) = fmap f x === fmapDefault f x 191 | 192 | traversableFoldableProp :: f A -> Fun A [B] -> Property 193 | traversableFoldableProp x (Fun _ f) = foldMap f x === foldMapDefault f x 194 | 195 | applicativeLaws' 196 | :: forall f proxy. ( Applicative f 197 | , Eq (f A), Show (f A), Arbitrary (f A) 198 | , Eq (f B), Show (f B), Arbitrary (f B) 199 | , Eq (f C), Show (f C), Arbitrary (f C) 200 | , Show (f (Fun A B)), Arbitrary (f (Fun A B)) 201 | , Show (f (Fun B C)), Arbitrary (f (Fun B C)) 202 | ) 203 | => proxy f -> TestTree 204 | applicativeLaws' _ = testGroup "Applicative" 205 | [ testProperty "identity" identity 206 | , testProperty "composition" composition 207 | , testProperty "homomorphism" homomorphism 208 | , testProperty "interchange" interchange 209 | , testProperty "fmap = liftA" fmapLiftA 210 | ] 211 | where 212 | identity :: f A -> Property 213 | identity v = (pure id <*> v) === v 214 | 215 | composition :: f (Fun B C) -> f (Fun A B) -> f A -> Property 216 | composition u' v' w = (pure (.) <*> u <*> v <*> w) === (u <*> (v <*> w)) where 217 | u = fmap applyFun u' 218 | v = fmap applyFun v' 219 | 220 | homomorphism :: Fun A B -> A -> Property 221 | homomorphism (Fun _ f) x = (pure f <*> pure x) === (pure (f x) :: f B) 222 | 223 | interchange :: f (Fun A B) -> A -> Property 224 | interchange u' y = (u <*> pure y) === (pure ($ y) <*> u) 225 | where 226 | u = fmap applyFun u' 227 | 228 | fmapLiftA :: f A -> Fun A B -> Property 229 | fmapLiftA x (Fun _ f) = fmap f x === liftA f x 230 | 231 | monadLaws' 232 | :: forall f proxy. ( Monad f, Applicative f 233 | , Eq (f A), Show (f A), Arbitrary (f A) 234 | , Eq (f B), Show (f B), Arbitrary (f B) 235 | , Eq (f C), Show (f C), Arbitrary (f C) 236 | , Show (f (Fun A B)), Arbitrary (f (Fun A B)) 237 | ) 238 | => proxy f -> TestTree 239 | monadLaws' _ = testGroup "Monad" 240 | [ testProperty "right identity" rightIdentity 241 | , testProperty "left identity" leftIdentity 242 | , testProperty "composition" composition 243 | , testProperty "pure = return" pureReturn 244 | , testProperty "(<*>) = ap" apAp 245 | , testProperty "fmap = liftM " fmapLiftM 246 | ] 247 | where 248 | rightIdentity :: f A -> Property 249 | rightIdentity m = (m >>= return) === m 250 | 251 | leftIdentity :: A -> Fun A (f B) -> Property 252 | leftIdentity x (Fun _ k) = (return x >>= k) === k x 253 | 254 | composition :: f A -> Fun A (f B) -> Fun B (f C) -> Property 255 | composition m (Fun _ f) (Fun _ g) = lhs === rhs where 256 | lhs = (m >>= f) >>= g 257 | rhs = m >>= (\x -> f x >>= g) 258 | 259 | pureReturn :: A -> Property 260 | pureReturn x = pure x === (return x :: f A) 261 | 262 | apAp :: f (Fun A B) -> f A -> Property 263 | apAp f' x = (f <*> x) === ap f x where 264 | f = fmap applyFun f' 265 | 266 | fmapLiftM :: f A -> Fun A B -> Property 267 | fmapLiftM x (Fun _ f) = fmap f x === liftM f x 268 | 269 | ------------------------------------------------------------------------------- 270 | -- binary 271 | ------------------------------------------------------------------------------- 272 | 273 | binaryProps :: TestTree 274 | binaryProps = testProperty "binary / roundtrip" prop 275 | where 276 | prop :: These Int String -> Property 277 | prop x = x === Binary.decode (Binary.encode x) 278 | 279 | ------------------------------------------------------------------------------- 280 | -- Strictness woes 281 | ------------------------------------------------------------------------------- 282 | 283 | -- Even the `align` is/was defined using strict combinators, this will still work: 284 | mapStrictnessProp :: [Int] -> [Int] -> Bool 285 | mapStrictnessProp lkeys rkeys = length (nub lkeys) <= Map.size (lhs `align` rhs) 286 | where lhs = Map.fromList $ fmap (,loop) lkeys 287 | rhs = Map.fromList $ fmap (,loop) rkeys 288 | 289 | loop :: Int 290 | loop = error "break" 291 | 292 | intmapStrictnessProp :: [Int] -> [Int] -> Bool 293 | intmapStrictnessProp lkeys rkeys = length (nub lkeys) <= IntMap.size (lhs `align` rhs) 294 | where lhs = IntMap.fromList $ fmap (,loop) lkeys 295 | rhs = IntMap.fromList $ fmap (,loop) rkeys 296 | 297 | loop :: Int 298 | loop = error "break" 299 | -------------------------------------------------------------------------------- /these-tests/these-tests.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: these-tests 3 | version: 0 4 | synopsis: Tests for these packages. 5 | description: 6 | Tests for these, these-lens, monad-chronicle, semialign and semialign-indexed 7 | 8 | homepage: https://github.com/haskellari/these 9 | license: BSD3 10 | license-file: LICENSE 11 | author: C. McCann, Oleg Grenrus 12 | maintainer: Oleg Grenrus 13 | category: Data, Control, These, Tests 14 | build-type: Simple 15 | tested-with: 16 | GHC ==8.6.5 17 | || ==8.8.4 18 | || ==8.10.7 19 | || ==9.0.2 20 | || ==9.2.8 21 | || ==9.4.8 22 | || ==9.6.6 23 | || ==9.8.4 24 | || ==9.10.1 25 | || ==9.12.1 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/haskellari/these.git 30 | 31 | library 32 | default-language: Haskell2010 33 | hs-source-dirs: src 34 | exposed-modules: Dummy 35 | build-depends: base <5 36 | 37 | test-suite test 38 | default-language: Haskell2010 39 | type: exitcode-stdio-1.0 40 | hs-source-dirs: test 41 | ghc-options: -Wall 42 | main-is: Tests.hs 43 | other-modules: 44 | Tests.AlignWrong 45 | Tests.Crosswalk 46 | Tests.Orphans 47 | Tests.Semialign 48 | Tests.SemialignWithIndex 49 | Tests.These 50 | 51 | -- library constrained dependencies 52 | build-depends: 53 | assoc 54 | , base <5 55 | , binary 56 | , containers 57 | , hashable 58 | , indexed-traversable 59 | , lens 60 | , QuickCheck 61 | , semialign 62 | , tagged 63 | , these 64 | , these-lens 65 | , transformers 66 | , unordered-containers 67 | , vector 68 | 69 | -- additional dependencies 70 | build-depends: 71 | lattices >=2.2.1 && <2.3 72 | , quickcheck-instances >=0.3.23 && <0.4 73 | , tasty >=1.2 && <1.6 74 | , tasty-quickcheck >=0.11 && <0.12 75 | , transformers-compat >=0.6.5 && <0.8 76 | -------------------------------------------------------------------------------- /these/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.2.1 2 | 3 | - Support GHC-8.6.5...GHC-9.10.1 4 | 5 | # 1.2 6 | 7 | - Depend on `bifunctor-classes-compat` instead of `bifunctors` 8 | See changelog note in `bifunctors-5.6`: https://hackage.haskell.org/package/bifunctors-5.6/changelog 9 | This is breaking change, but affects only GHC-8.0 and older users. 10 | In that case you should check various combinations of newer/older 11 | `bifunctors`, `these` (and e.g. `semialign`) packages. 12 | - Depend on `assoc-1.1`. Since version 1.1 `assoc` has an almost trivial 13 | dependency footprint, so `these` depends on it unconditionally. 14 | - Add `Bifoldable1 These` instance 15 | - Add `Foldable1 (Data.Functor.These1 f g)` instance 16 | - Change `Eq (These1 f g a)`, `Ord`, `Read`, `Show`, `NFData` instances similarly to how 17 | they are changed for `Product` and `Sum` in `base-4.18.0.0`. 18 | 19 | # 1.1.1.1 20 | 21 | - Workaround GCC-4 C-preprocessor bug 22 | 23 | # 1.1.1 24 | 25 | - These doesn't depend on `base-compat` anymore 26 | - Add `NFData1/2`, `Hashable1/2`, `Eq1/2` ... instances 27 | 28 | # 1.1 29 | 30 | - Reverse dependency with `aeson`. 31 | - The `QuickCheck` instances are moved into `quickcheck-instances` 32 | - The `semigroupoids` instances are gone for now. 33 | 34 | # 1.0.1 35 | 36 | - add `partitionEithersNE :: NonEmpty (Either a b) -> These (NonEmpty a) (NonEmpty b)` 37 | 38 | # 1 39 | 40 | This is major package reogranisation. Old `these` were split into 41 | 42 | - `these` providing only `These` type and some combinators 43 | - `these-lens` providing *lens* combinators 44 | - `semialign` providing `Semialign`, `Align`, `Zip`, `Unalign` and `Unzip` classes 45 | - `semialign-indexed` providing `SemialignWithIndex` (`izipWith` and `ialignWith` members). 46 | - `monad-chronicle` providing `ChronicleT` and `MonadChronicle` 47 | 48 | Also noticeable change is `unalign :: f (These a b) -> (f a, f b)`. 49 | For the old `f (These a b) -> (f (Maybe a), f (Maybe b))` use `unzipWith (unalign . Just)`. 50 | 51 | - Many instances are added. 52 | - Since annotations are removed for all but `these` package. 53 | 54 | # 0.8.1 55 | 56 | - Add `Semialign` `Tree`, `Tagged`, `(->) e`; `Align` `Compose` and `Proxy` instances 57 | - Allow `semigroups-0.19` and `hashable-1.3` 58 | 59 | # 0.8.0 60 | 61 | - Split `align` and `alignWith` into own class: `Semialign`. 62 | - `ialign` has default implementation 63 | - Add `Semialign` `NonEmpty` and `Identity` instances 64 | - Add `Swap` and `Assoc` instances (type classes from `assoc` package) 65 | - Move optics into `Data.These.Lens` module, 66 | and and some combinators `Data.These.Combinators`. 67 | Also some combinators are renamed, so naming is now consistent. 68 | As the result `Data.These` has very minimal exports. 69 | - Change type of `partitionThese` (nested pairs to triple) 70 | - Add `partitionHereThere :: [These a b] -> ([a],[b])` 71 | 72 | # 0.7.6 73 | 74 | - Tigthen lower bounds 75 | - Add dependency on `lens` 76 | - Add `assoc`, `reassoc`, `swap` and `Swapped` instance 77 | - Add since annotations for things added in 0.7.x 78 | - Add `AlignWithKey ZipList` instance 79 | - Add `Data.Align.Indexed` module. 80 | - Add `Data.Functor.These` with `These1` data type. 81 | - Add associativity law 82 | - Add `toList` property to enforce "align"-feel. 83 | - `Map` and `IntMap` `Align` instances implemented using merge combinators 84 | (when available) 85 | 86 | # 0.7.5 87 | 88 | - Add `Compose` and `(,)` `Crosswalk` instances 89 | - Add `bitraverseThese` 90 | - GHC-8.6 support 91 | 92 | # 0.7.4 93 | 94 | - `QuickCheck-2.10` support: `Arbitrary1/2` instances 95 | - GHC-8.2 support 96 | 97 | # 0.7.3 98 | 99 | - Add `salign :: (Align f, Semigroup a) => f a -> f a -> f a` 100 | 101 | # 0.7.2 102 | 103 | - Support `aeson-1`: add `FromJSON1`, `FromJSON2` `ToJSON1`, and `ToJSON2` `These` instances. 104 | 105 | # 0.7.1 106 | 107 | - Add `AlignWithKey` in `Data.Align.Key` (added dependency `keys`) 108 | - Add `These` instances for 109 | - `binary`: `Binary` 110 | - `aeson`: `FromJSON`, `ToJSON` 111 | - `QuickCheck`: `Arbitrary`, `CoArbitrary`, `Function` 112 | - `deepseq`: `NFData` 113 | 114 | # 0.7 115 | 116 | - Breaking change: Generalized `Monad`, `Applicative` instances of `These` and `Chronicle` to require only a `Semigroup` constraint 117 | - More efficient `Align Seq` implementation 118 | - Add `Crosswalk Seq` and `Vector` instances 119 | 120 | # 0.6.2.1 121 | 122 | - Support quickcheck-instances-0.3.12 (tests) 123 | 124 | # 0.6.2.0 125 | 126 | - Add support to bifunctors-5.1 127 | -------------------------------------------------------------------------------- /these/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus 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 C. McCann 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 | -------------------------------------------------------------------------------- /these/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: False 3 | benchmarks: False 4 | -------------------------------------------------------------------------------- /these/src/Data/Functor/These.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE Safe #-} 9 | module Data.Functor.These ( 10 | These1 (..), 11 | ) where 12 | 13 | import Data.Foldable (Foldable) 14 | import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) 15 | import Data.Monoid (Monoid (..)) 16 | import Data.Semigroup (Semigroup (..)) 17 | import Data.Traversable (Traversable) 18 | import GHC.Generics (Generic) 19 | import Prelude 20 | (Bool (..), Eq (..), Functor, Ord (..), Ordering (..), Read (..), 21 | Show (..), lex, readParen, return, seq, showChar, showParen, showString, 22 | ($), (&&), (.)) 23 | 24 | import qualified Data.Foldable as F 25 | import qualified Data.Foldable1 as F1 26 | 27 | import Control.DeepSeq (NFData (..), NFData1 (..)) 28 | 29 | import GHC.Generics (Generic1) 30 | 31 | import Data.Data (Data) 32 | import Data.Typeable (Typeable) 33 | 34 | ------------------------------------------------------------------------------- 35 | -- These1 36 | ------------------------------------------------------------------------------- 37 | 38 | data These1 f g a 39 | = This1 (f a) 40 | | That1 (g a) 41 | | These1 (f a) (g a) 42 | deriving (Functor, Foldable, Traversable, Generic, Generic1, Typeable, Data) 43 | 44 | ------------------------------------------------------------------------------- 45 | -- Eq1 46 | ------------------------------------------------------------------------------- 47 | 48 | instance (Eq1 f, Eq1 g) => Eq1 (These1 f g) where 49 | liftEq eq (This1 f) (This1 f') = liftEq eq f f' 50 | liftEq eq (That1 g) (That1 g') = liftEq eq g g' 51 | liftEq eq (These1 f g) (These1 f' g') = liftEq eq f f' && liftEq eq g g' 52 | 53 | liftEq _ This1 {} _ = False 54 | liftEq _ That1 {} _ = False 55 | liftEq _ These1 {} _ = False 56 | 57 | ------------------------------------------------------------------------------- 58 | -- Ord1 59 | ------------------------------------------------------------------------------- 60 | 61 | instance (Ord1 f, Ord1 g) => Ord1 (These1 f g) where 62 | liftCompare cmp (This1 f) (This1 f') = liftCompare cmp f f' 63 | liftCompare _cmp (This1 _) _ = LT 64 | liftCompare _cmp _ (This1 _) = GT 65 | 66 | liftCompare cmp (That1 g) (That1 g') = liftCompare cmp g g' 67 | liftCompare _cmp (That1 _) _ = LT 68 | liftCompare _cmp _ (That1 _) = GT 69 | 70 | liftCompare cmp (These1 f g) (These1 f' g') = 71 | liftCompare cmp f f' `mappend` liftCompare cmp g g' 72 | 73 | ------------------------------------------------------------------------------- 74 | -- Show1 75 | ------------------------------------------------------------------------------- 76 | 77 | instance (Show1 f, Show1 g) => Show1 (These1 f g) where 78 | liftShowsPrec sp sl d (This1 f) = showParen (d > 10) 79 | $ showString "This1 " 80 | . liftShowsPrec sp sl 11 f 81 | liftShowsPrec sp sl d (That1 g) = showParen (d > 10) 82 | $ showString "That1 " 83 | . liftShowsPrec sp sl 11 g 84 | liftShowsPrec sp sl d (These1 f g) = showParen (d > 10) 85 | $ showString "These1 " 86 | . liftShowsPrec sp sl 11 f 87 | . showChar ' ' 88 | . liftShowsPrec sp sl 11 g 89 | 90 | ------------------------------------------------------------------------------- 91 | -- Read1 92 | ------------------------------------------------------------------------------- 93 | 94 | instance (Read1 f, Read1 g) => Read1 (These1 f g) where 95 | liftReadsPrec rp rl d = readParen (d > 10) $ \s0 -> do 96 | (t, s1) <- lex s0 97 | case t of 98 | "This1" -> do 99 | (x, s2) <- liftReadsPrec rp rl 11 s1 100 | return (This1 x, s2) 101 | "That1" -> do 102 | (y, s2) <- liftReadsPrec rp rl 11 s1 103 | return (That1 y, s2) 104 | "These1" -> do 105 | (x, s2) <- liftReadsPrec rp rl 11 s1 106 | (y, s3) <- liftReadsPrec rp rl 11 s2 107 | return (These1 x y, s3) 108 | _ -> [] 109 | 110 | ------------------------------------------------------------------------------- 111 | -- Eq, Ord, Show, Read 112 | ------------------------------------------------------------------------------- 113 | 114 | instance (Eq (f a), Eq (g a), Eq a) => Eq (These1 f g a) where 115 | This1 f == This1 f' = f == f' 116 | That1 g == That1 g' = g == g' 117 | These1 f g == These1 f' g' = f == f' && g == g' 118 | 119 | This1 {} == _ = False 120 | That1 {} == _ = False 121 | These1 {} == _ = False 122 | 123 | instance (Ord (f a), Ord (g a), Ord a) => Ord (These1 f g a) where 124 | compare (This1 f) (This1 f') = compare f f' 125 | compare (This1 _) _ = LT 126 | compare _ (This1 _) = GT 127 | 128 | compare (That1 g) (That1 g') = compare g g' 129 | compare (That1 _) _ = LT 130 | compare _ (That1 _) = GT 131 | 132 | compare (These1 f g) (These1 f' g') = 133 | compare f f' `mappend` compare g g' 134 | 135 | instance (Show (f a), Show (g a), Show a) => Show (These1 f g a) where 136 | showsPrec d (This1 f) = showParen (d > 10) 137 | $ showString "This1 " 138 | . showsPrec 11 f 139 | showsPrec d (That1 g) = showParen (d > 10) 140 | $ showString "That1 " 141 | . showsPrec 11 g 142 | showsPrec d (These1 f g) = showParen (d > 10) 143 | $ showString "These1 " 144 | . showsPrec 11 f 145 | . showChar ' ' 146 | . showsPrec 11 g 147 | 148 | instance (Read (f a), Read (g a), Read a) => Read (These1 f g a) where 149 | readsPrec d = readParen (d > 10) $ \s0 -> do 150 | (t, s1) <- lex s0 151 | case t of 152 | "This1" -> do 153 | (x, s2) <- readsPrec 11 s1 154 | return (This1 x, s2) 155 | "That1" -> do 156 | (y, s2) <- readsPrec 11 s1 157 | return (That1 y, s2) 158 | "These1" -> do 159 | (x, s2) <- readsPrec 11 s1 160 | (y, s3) <- readsPrec 11 s2 161 | return (These1 x y, s3) 162 | _ -> [] 163 | 164 | ------------------------------------------------------------------------------- 165 | -- deepseq 166 | ------------------------------------------------------------------------------- 167 | 168 | -- | This instance is available only with @deepseq >= 1.4.3.0@ 169 | instance (NFData1 f, NFData1 g) => NFData1 (These1 f g) where 170 | liftRnf r (This1 x) = liftRnf r x 171 | liftRnf r (That1 y) = liftRnf r y 172 | liftRnf r (These1 x y) = liftRnf r x `seq` liftRnf r y 173 | 174 | -- | Available always 175 | -- 176 | -- @since 1.2 177 | instance (NFData (f a), NFData (g a), NFData a) => NFData (These1 f g a) where 178 | rnf (This1 x) = rnf x 179 | rnf (That1 y) = rnf y 180 | rnf (These1 x y) = rnf x `seq` rnf y 181 | 182 | ------------------------------------------------------------------------------- 183 | -- foldable1 184 | ------------------------------------------------------------------------------- 185 | 186 | -- | @since 1.2 187 | instance (F1.Foldable1 f, F1.Foldable1 g) => F1.Foldable1 (These1 f g) where 188 | foldMap1 f (This1 x) = F1.foldMap1 f x 189 | foldMap1 f (That1 y) = F1.foldMap1 f y 190 | foldMap1 f (These1 x y) = F1.foldMap1 f x <> F1.foldMap1 f y 191 | 192 | foldrMap1 f g (This1 x) = F1.foldrMap1 f g x 193 | foldrMap1 f g (That1 y) = F1.foldrMap1 f g y 194 | foldrMap1 f g (These1 x y) = F.foldr g (F1.foldrMap1 f g y) x 195 | 196 | head (This1 x) = F1.head x 197 | head (That1 y) = F1.head y 198 | head (These1 x _) = F1.head x 199 | 200 | last (This1 x) = F1.last x 201 | last (That1 y) = F1.last y 202 | last (These1 _ y) = F1.last y 203 | -------------------------------------------------------------------------------- /these/src/Data/These.hs: -------------------------------------------------------------------------------- 1 | -- | The 'These' type and associated operations. 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE Safe #-} 6 | module Data.These ( 7 | These(..) 8 | 9 | -- * Functions to get rid of 'These' 10 | , these 11 | , fromThese 12 | , mergeThese 13 | , mergeTheseWith 14 | 15 | -- * Partition 16 | , partitionThese 17 | , partitionHereThere 18 | , partitionEithersNE 19 | 20 | -- * Distributivity 21 | -- 22 | -- | These distributivity combinators aren't isomorphisms! 23 | , distrThesePair 24 | , undistrThesePair 25 | , distrPairThese 26 | , undistrPairThese 27 | ) where 28 | 29 | import Control.Applicative (Applicative (..), (<$>)) 30 | import Control.DeepSeq (NFData (..), NFData1 (..), NFData2 (..)) 31 | import Data.Bifoldable (Bifoldable (..)) 32 | import Data.Bifoldable1 (Bifoldable1 (..)) 33 | import Data.Bifunctor (Bifunctor (..)) 34 | import Data.Bifunctor.Assoc (Assoc (..)) 35 | import Data.Bifunctor.Swap (Swap (..)) 36 | import Data.Binary (Binary (..)) 37 | import Data.Bitraversable (Bitraversable (..)) 38 | import Data.Data (Data, Typeable) 39 | import Data.Either (partitionEithers) 40 | import Data.Foldable (Foldable (..)) 41 | import Data.Functor.Classes 42 | (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..), 43 | Show1 (..), Show2 (..)) 44 | import Data.Hashable (Hashable (..)) 45 | import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..)) 46 | import Data.List.NonEmpty (NonEmpty (..)) 47 | import Data.Monoid (Monoid (..)) 48 | import Data.Semigroup (Semigroup (..)) 49 | import Data.Traversable (Traversable (..)) 50 | import GHC.Generics (Generic, Generic1) 51 | import Prelude 52 | (Bool (..), Either (..), Eq (..), Functor (..), Int, Monad (..), 53 | Ord (..), Ordering (..), Read (..), Show (..), fail, id, lex, readParen, 54 | seq, showParen, showString, ($), (&&), (.)) 55 | 56 | -- $setup 57 | -- >>> import Control.Lens 58 | -- >>> import Data.List.NonEmpty (NonEmpty (..)) 59 | -- >>> import Prelude (Either (..), map, ($)) 60 | 61 | -- -------------------------------------------------------------------------- 62 | -- | The 'These' type represents values with two non-exclusive possibilities. 63 | -- 64 | -- This can be useful to represent combinations of two values, where the 65 | -- combination is defined if either input is. Algebraically, the type 66 | -- @'These' A B@ represents @(A + B + AB)@, which doesn't factor easily into 67 | -- sums and products--a type like @'Either' A (B, 'Maybe' A)@ is unclear and 68 | -- awkward to use. 69 | -- 70 | -- 'These' has straightforward instances of 'Functor', 'Monad', &c., and 71 | -- behaves like a hybrid error/writer monad, as would be expected. 72 | -- 73 | -- For zipping and unzipping of structures with 'These' values, see 74 | -- "Data.Align". 75 | data These a b = This a | That b | These a b 76 | deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Generic1) 77 | 78 | ------------------------------------------------------------------------------- 79 | -- Eliminators 80 | ------------------------------------------------------------------------------- 81 | 82 | -- | Case analysis for the 'These' type. 83 | these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c 84 | these l _ _ (This a) = l a 85 | these _ r _ (That x) = r x 86 | these _ _ lr (These a x) = lr a x 87 | 88 | -- | Takes two default values and produces a tuple. 89 | fromThese :: a -> b -> These a b -> (a, b) 90 | fromThese x y = these (`pair` y) (x `pair`) pair where 91 | pair = (,) 92 | 93 | -- | Coalesce with the provided operation. 94 | mergeThese :: (a -> a -> a) -> These a a -> a 95 | mergeThese = these id id 96 | 97 | -- | 'bimap' and coalesce results with the provided operation. 98 | mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c 99 | mergeTheseWith f g op t = mergeThese op $ bimap f g t 100 | 101 | ------------------------------------------------------------------------------- 102 | -- Partitioning 103 | ------------------------------------------------------------------------------- 104 | 105 | -- | Select each constructor and partition them into separate lists. 106 | partitionThese :: [These a b] -> ([a], [b], [(a, b)]) 107 | partitionThese [] = ([], [], []) 108 | partitionThese (t:ts) = case t of 109 | This x -> (x : xs, ys, xys) 110 | That y -> ( xs, y : ys, xys) 111 | These x y -> ( xs, ys, (x,y) : xys) 112 | where 113 | ~(xs,ys,xys) = partitionThese ts 114 | 115 | -- | Select 'here' and 'there' elements and partition them into separate lists. 116 | -- 117 | -- @since 0.8 118 | partitionHereThere :: [These a b] -> ([a], [b]) 119 | partitionHereThere [] = ([], []) 120 | partitionHereThere (t:ts) = case t of 121 | This x -> (x : xs, ys) 122 | That y -> ( xs, y : ys) 123 | These x y -> (x : xs, y : ys) 124 | where 125 | ~(xs,ys) = partitionHereThere ts 126 | 127 | -- | Like 'partitionEithers' but for 'NonEmpty' types. 128 | -- 129 | -- * either all are 'Left' 130 | -- * either all are 'Right' 131 | -- * or there is both 'Left' and 'Right' stuff 132 | -- 133 | -- /Note:/ this is not online algorithm. In the worst case it will traverse 134 | -- the whole list before deciding the result constructor. 135 | -- 136 | -- >>> partitionEithersNE $ Left 'x' :| [Right 'y'] 137 | -- These ('x' :| "") ('y' :| "") 138 | -- 139 | -- >>> partitionEithersNE $ Left 'x' :| map Left "yz" 140 | -- This ('x' :| "yz") 141 | -- 142 | -- @since 1.0.1 143 | partitionEithersNE :: NonEmpty (Either a b) -> These (NonEmpty a) (NonEmpty b) 144 | partitionEithersNE (x :| xs) = case (x, ls, rs) of 145 | (Left y, ys, []) -> This (y :| ys) 146 | (Left y, ys, z:zs) -> These (y :| ys) (z :| zs) 147 | (Right z, [], zs) -> That (z :| zs) 148 | (Right z, y:ys, zs) -> These (y :| ys) (z :| zs) 149 | where 150 | (ls, rs) = partitionEithers xs 151 | 152 | 153 | ------------------------------------------------------------------------------- 154 | -- Distributivity 155 | ------------------------------------------------------------------------------- 156 | 157 | distrThesePair :: These (a, b) c -> (These a c, These b c) 158 | distrThesePair (This (a, b)) = (This a, This b) 159 | distrThesePair (That c) = (That c, That c) 160 | distrThesePair (These (a, b) c) = (These a c, These b c) 161 | 162 | undistrThesePair :: (These a c, These b c) -> These (a, b) c 163 | undistrThesePair (This a, This b) = This (a, b) 164 | undistrThesePair (That c, That _) = That c 165 | undistrThesePair (These a c, These b _) = These (a, b) c 166 | undistrThesePair (This _, That c) = That c 167 | undistrThesePair (This a, These b c) = These (a, b) c 168 | undistrThesePair (That c, This _) = That c 169 | undistrThesePair (That c, These _ _) = That c 170 | undistrThesePair (These a c, This b) = These (a, b) c 171 | undistrThesePair (These _ c, That _) = That c 172 | 173 | 174 | distrPairThese :: (These a b, c) -> These (a, c) (b, c) 175 | distrPairThese (This a, c) = This (a, c) 176 | distrPairThese (That b, c) = That (b, c) 177 | distrPairThese (These a b, c) = These (a, c) (b, c) 178 | 179 | undistrPairThese :: These (a, c) (b, c) -> (These a b, c) 180 | undistrPairThese (This (a, c)) = (This a, c) 181 | undistrPairThese (That (b, c)) = (That b, c) 182 | undistrPairThese (These (a, c) (b, _)) = (These a b, c) 183 | 184 | ------------------------------------------------------------------------------- 185 | -- Instances 186 | ------------------------------------------------------------------------------- 187 | 188 | instance (Semigroup a, Semigroup b) => Semigroup (These a b) where 189 | This a <> This b = This (a <> b) 190 | This a <> That y = These a y 191 | This a <> These b y = These (a <> b) y 192 | That x <> This b = These b x 193 | That x <> That y = That (x <> y) 194 | That x <> These b y = These b (x <> y) 195 | These a x <> This b = These (a <> b) x 196 | These a x <> That y = These a (x <> y) 197 | These a x <> These b y = These (a <> b) (x <> y) 198 | 199 | instance Functor (These a) where 200 | fmap _ (This x) = This x 201 | fmap f (That y) = That (f y) 202 | fmap f (These x y) = These x (f y) 203 | 204 | instance Foldable (These a) where 205 | foldr _ z (This _) = z 206 | foldr f z (That x) = f x z 207 | foldr f z (These _ x) = f x z 208 | 209 | instance Traversable (These a) where 210 | traverse _ (This a) = pure $ This a 211 | traverse f (That x) = That <$> f x 212 | traverse f (These a x) = These a <$> f x 213 | sequenceA (This a) = pure $ This a 214 | sequenceA (That x) = That <$> x 215 | sequenceA (These a x) = These a <$> x 216 | 217 | instance Bifunctor These where 218 | bimap f _ (This a ) = This (f a) 219 | bimap _ g (That x) = That (g x) 220 | bimap f g (These a x) = These (f a) (g x) 221 | 222 | instance Bifoldable These where 223 | bifold = these id id mappend 224 | bifoldMap f g = these f g (\x y -> mappend (f x) (g y)) 225 | bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z)) 226 | bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y) 227 | 228 | -- | @since 1.2 229 | instance Bifoldable1 These where 230 | bifold1 = these id id (<>) 231 | bifoldMap1 f g = these f g (\x y -> f x <> g y) 232 | 233 | instance Bitraversable These where 234 | bitraverse f _ (This x) = This <$> f x 235 | bitraverse _ g (That x) = That <$> g x 236 | bitraverse f g (These x y) = These <$> f x <*> g y 237 | 238 | instance (Semigroup a) => Applicative (These a) where 239 | pure = That 240 | This a <*> _ = This a 241 | That _ <*> This b = This b 242 | That f <*> That x = That (f x) 243 | That f <*> These b x = These b (f x) 244 | These a _ <*> This b = This (a <> b) 245 | These a f <*> That x = These a (f x) 246 | These a f <*> These b x = These (a <> b) (f x) 247 | 248 | 249 | instance (Semigroup a) => Monad (These a) where 250 | return = pure 251 | This a >>= _ = This a 252 | That x >>= k = k x 253 | These a x >>= k = case k x of 254 | This b -> This (a <> b) 255 | That y -> These a y 256 | These b y -> These (a <> b) y 257 | 258 | ------------------------------------------------------------------------------- 259 | -- Data.Functor.Classes 260 | ------------------------------------------------------------------------------- 261 | 262 | -- | @since 1.1.1 263 | instance Eq2 These where 264 | liftEq2 f _ (This a) (This a') = f a a' 265 | liftEq2 _ g (That b) (That b') = g b b' 266 | liftEq2 f g (These a b) (These a' b') = f a a' && g b b' 267 | liftEq2 _ _ _ _ = False 268 | 269 | -- | @since 1.1.1 270 | instance Eq a => Eq1 (These a) where 271 | liftEq = liftEq2 (==) 272 | 273 | -- | @since 1.1.1 274 | instance Ord2 These where 275 | liftCompare2 f _ (This a) (This a') = f a a' 276 | liftCompare2 _ _ (This _) _ = LT 277 | liftCompare2 _ _ _ (This _) = GT 278 | liftCompare2 _ g (That b) (That b') = g b b' 279 | liftCompare2 _ _ (That _) _ = LT 280 | liftCompare2 _ _ _ (That _) = GT 281 | liftCompare2 f g (These a b) (These a' b') = f a a' `mappend` g b b' 282 | 283 | -- | @since 1.1.1 284 | instance Ord a => Ord1 (These a) where 285 | liftCompare = liftCompare2 compare 286 | 287 | -- | @since 1.1.1 288 | instance Show a => Show1 (These a) where 289 | liftShowsPrec = liftShowsPrec2 showsPrec showList 290 | 291 | -- | @since 1.1.1 292 | instance Show2 These where 293 | liftShowsPrec2 sa _ _sb _ d (This a) = showParen (d > 10) 294 | $ showString "This " 295 | . sa 11 a 296 | liftShowsPrec2 _sa _ sb _ d (That b) = showParen (d > 10) 297 | $ showString "That " 298 | . sb 11 b 299 | liftShowsPrec2 sa _ sb _ d (These a b) = showParen (d > 10) 300 | $ showString "These " 301 | . sa 11 a 302 | . showString " " 303 | . sb 11 b 304 | 305 | -- | @since 1.1.1 306 | instance Read2 These where 307 | liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> cons s 308 | where 309 | cons s0 = do 310 | (ident, s1) <- lex s0 311 | case ident of 312 | "This" -> do 313 | (a, s2) <- ra 11 s1 314 | return (This a, s2) 315 | "That" -> do 316 | (b, s2) <- rb 11 s1 317 | return (That b, s2) 318 | "These" -> do 319 | (a, s2) <- ra 11 s1 320 | (b, s3) <- rb 11 s2 321 | return (These a b, s3) 322 | _ -> [] 323 | 324 | -- | @since 1.1.1 325 | instance Read a => Read1 (These a) where 326 | liftReadsPrec = liftReadsPrec2 readsPrec readList 327 | 328 | ------------------------------------------------------------------------------- 329 | -- assoc 330 | ------------------------------------------------------------------------------- 331 | 332 | -- | @since 0.8 333 | instance Swap These where 334 | swap (This a) = That a 335 | swap (That b) = This b 336 | swap (These a b) = These b a 337 | 338 | -- | @since 0.8 339 | instance Assoc These where 340 | assoc (This (This a)) = This a 341 | assoc (This (That b)) = That (This b) 342 | assoc (That c) = That (That c) 343 | assoc (These (That b) c) = That (These b c) 344 | assoc (This (These a b)) = These a (This b) 345 | assoc (These (This a) c) = These a (That c) 346 | assoc (These (These a b) c) = These a (These b c) 347 | 348 | unassoc (This a) = This (This a) 349 | unassoc (That (This b)) = This (That b) 350 | unassoc (That (That c)) = That c 351 | unassoc (That (These b c)) = These (That b) c 352 | unassoc (These a (This b)) = This (These a b) 353 | unassoc (These a (That c)) = These (This a) c 354 | unassoc (These a (These b c)) = These (These a b) c 355 | 356 | ------------------------------------------------------------------------------- 357 | -- deepseq 358 | ------------------------------------------------------------------------------- 359 | 360 | -- | @since 0.7.1 361 | instance (NFData a, NFData b) => NFData (These a b) where 362 | rnf (This a) = rnf a 363 | rnf (That b) = rnf b 364 | rnf (These a b) = rnf a `seq` rnf b 365 | 366 | -- | @since 1.1.1 367 | instance NFData a => NFData1 (These a) where 368 | liftRnf _rnfB (This a) = rnf a 369 | liftRnf rnfB (That b) = rnfB b 370 | liftRnf rnfB (These a b) = rnf a `seq` rnfB b 371 | 372 | -- | @since 1.1.1 373 | instance NFData2 These where 374 | liftRnf2 rnfA _rnfB (This a) = rnfA a 375 | liftRnf2 _rnfA rnfB (That b) = rnfB b 376 | liftRnf2 rnfA rnfB (These a b) = rnfA a `seq` rnfB b 377 | 378 | ------------------------------------------------------------------------------- 379 | -- binary 380 | ------------------------------------------------------------------------------- 381 | 382 | -- | @since 0.7.1 383 | instance (Binary a, Binary b) => Binary (These a b) where 384 | put (This a) = put (0 :: Int) >> put a 385 | put (That b) = put (1 :: Int) >> put b 386 | put (These a b) = put (2 :: Int) >> put a >> put b 387 | 388 | get = do 389 | i <- get 390 | case (i :: Int) of 391 | 0 -> This <$> get 392 | 1 -> That <$> get 393 | 2 -> These <$> get <*> get 394 | _ -> fail "Invalid These index" 395 | 396 | ------------------------------------------------------------------------------- 397 | -- hashable 398 | ------------------------------------------------------------------------------- 399 | 400 | instance (Hashable a, Hashable b) => Hashable (These a b) where 401 | hashWithSalt salt (This a) = 402 | salt `hashWithSalt` (0 :: Int) `hashWithSalt` a 403 | hashWithSalt salt (That b) = 404 | salt `hashWithSalt` (1 :: Int) `hashWithSalt` b 405 | hashWithSalt salt (These a b) = 406 | salt `hashWithSalt` (2 :: Int) `hashWithSalt` a `hashWithSalt` b 407 | 408 | -- | @since 1.1.1 409 | instance Hashable a => Hashable1 (These a) where 410 | liftHashWithSalt _hashB salt (This a) = 411 | salt `hashWithSalt` (0 :: Int) `hashWithSalt` a 412 | liftHashWithSalt hashB salt (That b) = 413 | (salt `hashWithSalt` (1 :: Int)) `hashB` b 414 | liftHashWithSalt hashB salt (These a b) = 415 | (salt `hashWithSalt` (2 :: Int) `hashWithSalt` a) `hashB` b 416 | 417 | -- | @since 1.1.1 418 | instance Hashable2 These where 419 | liftHashWithSalt2 hashA _hashB salt (This a) = 420 | (salt `hashWithSalt` (0 :: Int)) `hashA` a 421 | liftHashWithSalt2 _hashA hashB salt (That b) = 422 | (salt `hashWithSalt` (1 :: Int)) `hashB` b 423 | liftHashWithSalt2 hashA hashB salt (These a b) = 424 | (salt `hashWithSalt` (2 :: Int)) `hashA` a `hashB` b 425 | -------------------------------------------------------------------------------- /these/src/Data/These/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | This module provides 3 | -- 4 | -- * specialised versions of class members e.g. 'bitraverseThese' 5 | -- * non-lens variants of "Data.These.Lens" things, e.g 'justHere' 6 | module Data.These.Combinators ( 7 | -- * Specialised combinators 8 | -- ** Bifunctor 9 | bimapThese, 10 | mapHere, 11 | mapThere, 12 | -- ** Bitraversable 13 | bitraverseThese, 14 | -- ** Associativity and commutativity 15 | swapThese, 16 | assocThese, 17 | unassocThese, 18 | 19 | -- * Other operations 20 | -- ** preview 21 | -- 22 | -- | 23 | -- @ 24 | -- 'justThis' = 'Control.Lens.preview' '_This' 25 | -- 'justThat' = 'Control.Lens.preview' '_That' 26 | -- 'justThese' = 'Control.Lens.preview' '_These' 27 | -- 'justHere' = 'Control.Lens.preview' 'here' 28 | -- 'justThere' = 'Control.Lens.preview' 'there' 29 | -- @ 30 | justThis, 31 | justThat, 32 | justThese, 33 | justHere, 34 | justThere, 35 | 36 | -- ** toListOf 37 | -- 38 | -- | 39 | -- @ 40 | -- 'catThis' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_This') 41 | -- 'catThat' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_That') 42 | -- 'catThese' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_These') 43 | -- 'catHere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'here') 44 | -- 'catThere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'there') 45 | -- @ 46 | catThis, 47 | catThat, 48 | catThese, 49 | catHere, 50 | catThere, 51 | 52 | -- * is / has 53 | -- 54 | -- | 55 | -- @ 56 | -- 'isThis' = 'Control.Lens.Extra.is' '_This' 57 | -- 'isThat' = 'Control.Lens.Extra.is' '_That' 58 | -- 'isThese' = 'Control.Lens.Extra.is' '_These' 59 | -- 'hasHere' = 'Control.Lens.has' 'here' 60 | -- 'hasThere' = 'Control.Lens.has' 'there' 61 | -- @ 62 | isThis, 63 | isThat, 64 | isThese, 65 | hasHere, 66 | hasThere, 67 | 68 | -- * over / map 69 | -- 70 | -- @ 71 | -- 'mapThis' = 'Control.Lens.over' '_This' 72 | -- 'mapThat' = 'Control.Lens.over' '_That' 73 | -- 'mapThese' = 'Control.Lens.over' '_These' 74 | -- 'mapHere' = 'Control.Lens.over' 'here' 75 | -- 'mapThere' = 'Control.Lens.over' 'there' 76 | -- @ 77 | mapThis, 78 | mapThat, 79 | mapThese, 80 | ) where 81 | 82 | import Control.Applicative (Applicative (..)) 83 | import Data.Bifunctor (bimap, first, second) 84 | import Data.Bitraversable (bitraverse) 85 | import Data.Maybe (isJust, mapMaybe) 86 | import Data.These 87 | import Prelude (Bool (..), Maybe (..), curry, uncurry, (.)) 88 | 89 | import Data.Bifunctor.Assoc (assoc, unassoc) 90 | import Data.Bifunctor.Swap (swap) 91 | 92 | -- $setup 93 | -- >>> import Data.These 94 | 95 | ------------------------------------------------------------------------------- 96 | -- bifunctors 97 | ------------------------------------------------------------------------------- 98 | 99 | -- | 'Bifunctor' 'bimap'. 100 | bimapThese :: (a -> c) -> (b -> d) -> These a b -> These c d 101 | bimapThese = bimap 102 | 103 | -- | @'mapHere' = 'Control.Lens.over' 'here'@ 104 | mapHere :: (a -> c) -> These a b -> These c b 105 | mapHere = first 106 | 107 | -- | @'mapThere' = 'Control.Lens.over' 'there'@ 108 | mapThere :: (b -> d) -> These a b -> These a d 109 | mapThere = second 110 | 111 | -- | 'Bitraversable' 'bitraverse'. 112 | bitraverseThese :: Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d) 113 | bitraverseThese = bitraverse 114 | 115 | ------------------------------------------------------------------------------- 116 | -- assoc 117 | ------------------------------------------------------------------------------- 118 | 119 | -- | 'These' is commutative. 120 | -- 121 | -- @ 122 | -- 'swapThese' . 'swapThese' = 'id' 123 | -- @ 124 | -- 125 | -- @since 0.8 126 | swapThese :: These a b -> These b a 127 | swapThese = swap 128 | 129 | -- | 'These' is associative. 130 | -- 131 | -- @ 132 | -- 'assocThese' . 'unassocThese' = 'id' 133 | -- 'unassocThese' . 'assocThese' = 'id' 134 | -- @ 135 | -- 136 | -- @since 0.8 137 | assocThese :: These (These a b) c -> These a (These b c) 138 | assocThese = assoc 139 | 140 | -- | 'These' is associative. See 'assocThese'. 141 | -- 142 | -- @since 0.8 143 | unassocThese :: These a (These b c) -> These (These a b) c 144 | unassocThese = unassoc 145 | 146 | ------------------------------------------------------------------------------- 147 | -- preview 148 | ------------------------------------------------------------------------------- 149 | 150 | -- | 151 | -- 152 | -- >>> justHere (This 'x') 153 | -- Just 'x' 154 | -- 155 | -- >>> justHere (That 'y') 156 | -- Nothing 157 | -- 158 | -- >>> justHere (These 'x' 'y') 159 | -- Just 'x' 160 | -- 161 | justHere :: These a b -> Maybe a 162 | justHere (This a) = Just a 163 | justHere (That _) = Nothing 164 | justHere (These a _) = Just a 165 | 166 | -- | 167 | -- 168 | -- >>> justThere (This 'x') 169 | -- Nothing 170 | -- 171 | -- >>> justThere (That 'y') 172 | -- Just 'y' 173 | -- 174 | -- >>> justThere (These 'x' 'y') 175 | -- Just 'y' 176 | -- 177 | justThere :: These a b -> Maybe b 178 | justThere (This _) = Nothing 179 | justThere (That b) = Just b 180 | justThere (These _ b) = Just b 181 | 182 | justThis :: These a b -> Maybe a 183 | justThis (This a) = Just a 184 | justThis _ = Nothing 185 | 186 | justThat :: These a b -> Maybe b 187 | justThat (That x) = Just x 188 | justThat _ = Nothing 189 | 190 | justThese :: These a b -> Maybe (a, b) 191 | justThese (These a x) = Just (a, x) 192 | justThese _ = Nothing 193 | 194 | ------------------------------------------------------------------------------- 195 | -- toListOf 196 | ------------------------------------------------------------------------------- 197 | 198 | -- | Select all 'This' constructors from a list. 199 | catThis :: [These a b] -> [a] 200 | catThis = mapMaybe justThis 201 | 202 | -- | Select all 'That' constructors from a list. 203 | catThat :: [These a b] -> [b] 204 | catThat = mapMaybe justThat 205 | 206 | -- | Select all 'These' constructors from a list. 207 | catThese :: [These a b] -> [(a, b)] 208 | catThese = mapMaybe justThese 209 | 210 | catHere :: [These a b] -> [a] 211 | catHere = mapMaybe justHere 212 | 213 | catThere :: [These a b] -> [b] 214 | catThere = mapMaybe justThere 215 | 216 | ------------------------------------------------------------------------------- 217 | -- is 218 | ------------------------------------------------------------------------------- 219 | 220 | isThis, isThat, isThese :: These a b -> Bool 221 | -- | @'isThis' = 'isJust' . 'justThis'@ 222 | isThis = isJust . justThis 223 | 224 | -- | @'isThat' = 'isJust' . 'justThat'@ 225 | isThat = isJust . justThat 226 | 227 | -- | @'isThese' = 'isJust' . 'justThese'@ 228 | isThese = isJust . justThese 229 | 230 | hasHere, hasThere :: These a b -> Bool 231 | -- | @'hasHere' = 'isJust' . 'justHere'@ 232 | hasHere = isJust . justHere 233 | 234 | -- | @'hasThere' = 'isJust' . 'justThere'@ 235 | hasThere = isJust . justThere 236 | 237 | ------------------------------------------------------------------------------- 238 | -- over / map 239 | ------------------------------------------------------------------------------- 240 | 241 | mapThis :: (a -> a) -> These a b -> These a b 242 | mapThis f (This x) = This (f x) 243 | mapThis _ y = y 244 | 245 | mapThat :: (b -> b) -> These a b -> These a b 246 | mapThat f (That x) = That (f x) 247 | mapThat _ y = y 248 | 249 | mapThese :: ((a, b) -> (a, b)) -> These a b -> These a b 250 | mapThese f (These x y) = uncurry These (curry f x y) 251 | mapThese _ z = z 252 | -------------------------------------------------------------------------------- /these/these.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: these 3 | version: 1.2.1 4 | x-revision: 2 5 | synopsis: An either-or-both data type. 6 | homepage: https://github.com/haskellari/these 7 | license: BSD3 8 | license-file: LICENSE 9 | author: C. McCann, Oleg Grenrus 10 | maintainer: Oleg Grenrus 11 | category: Data, These 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | description: 15 | This package provides a data type @These a b@ which can hold a value of either 16 | type or values of each type. This is usually thought of as an "inclusive or" 17 | type (contrasting @Either a b@ as "exclusive or") or as an "outer join" type 18 | (contrasting @(a, b)@ as "inner join"). 19 | . 20 | @ 21 | data These a b = This a | That b | These a b 22 | @ 23 | . 24 | Since version 1, this package was split into parts: 25 | . 26 | * For @Align@ and @Zip@ type-classes. 27 | . 28 | * For @SemialignWithIndex@ class, providing @ialignWith@ and @izipWith@. 29 | . 30 | * For lens combinators. 31 | . 32 | * For transformers variant of @These@. 33 | 34 | tested-with: 35 | GHC ==8.6.5 36 | || ==8.8.4 37 | || ==8.10.7 38 | || ==9.0.2 39 | || ==9.2.8 40 | || ==9.4.8 41 | || ==9.6.6 42 | || ==9.8.4 43 | || ==9.10.1 44 | || ==9.12.1 45 | 46 | source-repository head 47 | type: git 48 | location: https://github.com/haskellari/these.git 49 | subdir: these 50 | 51 | library 52 | default-language: Haskell2010 53 | ghc-options: -Wall -Wno-trustworthy-safe 54 | hs-source-dirs: src 55 | exposed-modules: 56 | Data.Functor.These 57 | Data.These 58 | Data.These.Combinators 59 | 60 | -- ghc boot libs 61 | build-depends: 62 | base >=4.12.0.0 && <4.22 63 | , binary >=0.8.6.0 && <0.10 64 | , deepseq >=1.4.4.0 && <1.6 65 | 66 | -- other dependencies 67 | -- note: we need to depend on assoc-1.1 to be sure that 68 | -- Bifunctor type class comes from bifunctor-classes-compat 69 | build-depends: 70 | assoc >=1.1.1 && <1.2 71 | , hashable >=1.4.4.0 && <1.6 72 | 73 | if !impl(ghc >=9.6) 74 | build-depends: foldable1-classes-compat >=0.1 && <0.2 75 | 76 | x-docspec-extra-packages: lens 77 | --------------------------------------------------------------------------------