├── .github ├── FUNDING.yml └── workflows │ └── haskell.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── cabal.project ├── doctest └── DoctestDriver.hs ├── examples ├── LICENSE ├── oops-examples.cabal └── src │ └── Examples.hs ├── gen └── Data │ └── Variant │ └── Gen.hs ├── hie.yaml ├── oops.cabal ├── src ├── Control │ └── Monad │ │ └── Oops.hs └── Data │ └── Variant.hs └── test ├── Data └── VariantSpec.hs └── Spec.hs /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | github: [newhoggy] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2] 4 | patreon: # Replace with a single Patreon username 5 | open_collective: # Replace with a single Open Collective username 6 | ko_fi: # Replace with a single Ko-fi username 7 | tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel 8 | community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry 9 | liberapay: # Replace with a single Liberapay username 10 | issuehunt: # Replace with a single IssueHunt username 11 | otechie: # Replace with a single Otechie username 12 | custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2'] 13 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Binaries 2 | 3 | defaults: 4 | run: 5 | shell: bash 6 | 7 | on: 8 | push: 9 | branches: 10 | - main 11 | pull_request: 12 | 13 | jobs: 14 | build: 15 | runs-on: ${{ matrix.os }} 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | ghc: ["9.8.1", "9.6.3", "9.4.8", "9.2.8", "9.0.2", "8.10.7"] 21 | os: [ubuntu-latest, macOS-latest, windows-latest] 22 | exclude: 23 | - os: windows-latest 24 | ghc: "9.4.2" 25 | 26 | env: 27 | # Modify this value to "invalidate" the cabal cache. 28 | CABAL_CACHE_VERSION: "2024-01-05" 29 | 30 | steps: 31 | - uses: actions/checkout@v2 32 | 33 | - uses: haskell-actions/setup@v2 34 | id: setup-haskell 35 | with: 36 | ghc-version: ${{ matrix.ghc }} 37 | cabal-version: '3.10.2.1' 38 | 39 | - name: Set some window specific things 40 | if: matrix.os == 'windows-latest' 41 | run: echo 'EXE_EXT=.exe' >> $GITHUB_ENV 42 | 43 | - name: Configure project 44 | run: | 45 | cabal configure --enable-tests --enable-benchmarks --write-ghc-environment-files=ghc8.4.4+ 46 | cabal build all --enable-tests --enable-benchmarks --dry-run 47 | 48 | - name: Cabal cache over S3 49 | uses: action-works/cabal-cache-s3@v1 50 | env: 51 | AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} 52 | AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} 53 | with: 54 | region: us-west-2 55 | dist-dir: dist-newstyle 56 | store-path: ${{ steps.setup-haskell.outputs.cabal-store }} 57 | threads: 16 58 | archive-uri: ${{ secrets.BINARY_CACHE_URI }}/${{ env.CABAL_CACHE_VERSION }}/${{ runner.os }}/${{ matrix.cabal }}/${{ matrix.ghc }} 59 | skip: "${{ secrets.BINARY_CACHE_URI == '' }}" 60 | 61 | - name: Cabal cache over HTTPS 62 | uses: action-works/cabal-cache-s3@v1 63 | with: 64 | dist-dir: dist-newstyle 65 | store-path: ${{ steps.setup-haskell.outputs.cabal-store }} 66 | threads: 16 67 | archive-uri: https://cache.haskellworks.io/${{ env.CABAL_CACHE_VERSION }}/${{ runner.os }}/${{ matrix.cabal }}/${{ matrix.ghc }} 68 | skip: "${{ secrets.BINARY_CACHE_URI != '' }}" 69 | 70 | - name: Build 71 | run: cabal build all --enable-tests --enable-benchmarks 72 | 73 | - name: Test 74 | run: cabal test all --enable-tests --enable-benchmarks 75 | 76 | check: 77 | needs: build 78 | runs-on: ubuntu-latest 79 | outputs: 80 | tag: ${{ steps.tag.outputs.tag }} 81 | 82 | steps: 83 | - uses: actions/checkout@v2 84 | 85 | - name: Check if cabal project is sane 86 | run: | 87 | PROJECT_DIR=$PWD 88 | mkdir -p $PROJECT_DIR/build/sdist 89 | for i in $(git ls-files | grep '\.cabal'); do 90 | cd $PROJECT_DIR && cd `dirname $i` 91 | cabal check 92 | done 93 | 94 | - name: Tag new version 95 | id: tag 96 | if: ${{ github.ref == 'refs/heads/main' }} 97 | env: 98 | server: http://hackage.haskell.org 99 | username: ${{ secrets.HACKAGE_USER }} 100 | password: ${{ secrets.HACKAGE_PASS }} 101 | run: | 102 | package_version="$(cat *.cabal | grep '^version:' | cut -d : -f 2 | xargs)" 103 | 104 | echo "Package version is v$package_version" 105 | 106 | git fetch --unshallow origin 107 | 108 | if git tag "v$package_version"; then 109 | echo "Tagging with new version "v$package_version"" 110 | 111 | if git push origin "v$package_version"; then 112 | echo "Tagged with new version "v$package_version"" 113 | 114 | echo "::set-output name=tag::v$package_version" 115 | fi 116 | fi 117 | 118 | release: 119 | needs: [build, check] 120 | runs-on: ubuntu-latest 121 | if: ${{ needs.check.outputs.tag != '' }} 122 | outputs: 123 | upload_url: ${{ steps.create_release.outputs.upload_url }} 124 | 125 | steps: 126 | - uses: actions/checkout@v2 127 | 128 | - name: Create source distribution 129 | run: | 130 | PROJECT_DIR=$PWD 131 | mkdir -p $PROJECT_DIR/build/sdist 132 | for i in $(git ls-files | grep '\.cabal'); do 133 | cd $PROJECT_DIR && cd `dirname $i` 134 | cabal v2-sdist -o $PROJECT_DIR/build/sdist 135 | done; 136 | 137 | - name: Publish to hackage 138 | env: 139 | server: http://hackage.haskell.org 140 | username: ${{ secrets.HACKAGE_USER }} 141 | password: ${{ secrets.HACKAGE_PASS }} 142 | candidate: false 143 | run: | 144 | package_version="$(cat *.cabal | grep '^version:' | cut -d : -f 2 | xargs)" 145 | 146 | for PACKAGE_TARBALL in $(find ./build/sdist/ -name "*.tar.gz"); do 147 | PACKAGE_NAME=$(basename ${PACKAGE_TARBALL%.*.*}) 148 | 149 | if ${{ env.candidate }}; then 150 | TARGET_URL="${{ env.server }}/packages/candidates"; 151 | DOCS_URL="${{ env.server }}/package/$PACKAGE_NAME/candidate/docs" 152 | else 153 | TARGET_URL="${{ env.server }}/packages/upload"; 154 | DOCS_URL="${{ env.server }}/package/$PACKAGE_NAME/docs" 155 | fi 156 | 157 | HACKAGE_STATUS=$(curl --silent --head -w %{http_code} -XGET --anyauth --user "${{ env.username }}:${{ env.password }}" ${{ env.server }}/package/$PACKAGE_NAME -o /dev/null) 158 | 159 | if [ "$HACKAGE_STATUS" = "404" ]; then 160 | echo "Uploading $PACKAGE_NAME to $TARGET_URL" 161 | 162 | curl -X POST -f --user "${{ env.username }}:${{ env.password }}" $TARGET_URL -F "package=@$PACKAGE_TARBALL" 163 | echo "Uploaded $PACKAGE_NAME" 164 | else 165 | echo "Package $PACKAGE_NAME" already exists on Hackage. 166 | fi 167 | done 168 | 169 | - name: Create Release 170 | id: create_release 171 | uses: actions/create-release@v1 172 | env: 173 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} # This token is provided by Actions, you do not need to create your own token 174 | with: 175 | tag_name: ${{ github.ref }} 176 | release_name: Release ${{ github.ref }} 177 | body: Undocumented 178 | draft: true 179 | prerelease: false 180 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .ghc* 2 | dist-newstyle 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for oops 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | ## 0.2.0.1 6 | 7 | * Add examples 8 | https://github.com/haskell-works/oops/pull/16 9 | 10 | * Prefer use of `CouldBeF` with `CouldBe` 11 | https://github.com/haskell-works/oops/pull/15 12 | 13 | * CI concurrency 14 | https://github.com/haskell-works/oops/pull/14 15 | 16 | * Fix warnings 17 | https://github.com/haskell-works/oops/pull/12 18 | 19 | ## 0.2.0.0 20 | 21 | * New `onExceptionM` and `onExceptionThrowM` functions 22 | https://github.com/haskell-works/oops/pull/11 23 | 24 | ## 0.1.6.0 25 | 26 | * https://github.com/haskell-works/oops/pull/10 27 | 28 | ## 0.1.5.0 29 | 30 | * New combinators `leftM` and `nothingM` 31 | https://github.com/haskell-works/oops/pull/7 32 | 33 | ## 0.1.4.0 34 | 35 | * New combinators `catchAsNothingM`, `throwPureLeftM`, `throwPureNothingM`, `throwPureNothingAsM` 36 | https://github.com/haskell-works/oops/pull/6 37 | 38 | ## 0.1.3.0 39 | 40 | * New `runOops0` and `runOops1` functions 41 | https://github.com/haskell-works/oops/pull/5 42 | 43 | ## 0.1.2.0 44 | 45 | * New `catchAsLeftM` function 46 | https://github.com/haskell-works/oops/pull/4 47 | 48 | ## 0.1.1.0 49 | 50 | * Update `tested-with` declaration in `.cabal` file 51 | https://github.com/haskell-works/oops/pull/3 52 | 53 | ## v0.1.0.0 54 | 55 | * First version. Released on an unsuspecting world. 56 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023 John Ky 2 | Copyright (c) 2019 Tom Harding 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining 5 | a copy of this software and associated documentation files (the 6 | "Software"), to deal in the Software without restriction, including 7 | without limitation the rights to use, copy, modify, merge, publish, 8 | distribute, sublicense, and/or sell copies of the Software, and to 9 | permit persons to whom the Software is furnished to do so, subject to 10 | the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included 13 | in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 17 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 18 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 19 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 20 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 21 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Oops 🍌 2 | 3 | When we're writing functional code involving errors, we often find ourselves 4 | reaching for a type like `Either` (usually `ExceptT`): we put our "success 5 | type" on the `Right`, and our "error type" on the `Left`. When our code gets 6 | more complicated, however, we're going to find ourselves introducing *multiple* 7 | error types (see [Matt Parsons' 8 | blog](https://www.parsonsmatt.org/2018/11/03/trouble_with_typed_errors.html) 9 | for a nice introduction to this practice). This is great, but the solution is 10 | also a new problem: our error types are not all the same! In order to use the 11 | monad instance, we need all our results to have the same `Left` type. How do we 12 | have both? 13 | 14 | One solution is the nested `Either` type. As our error catalogue grows, so does 15 | our type signature: 16 | 17 | | Possible errors | Type | 18 | | --------------- | -------------------------------------------------- | 19 | | 1 | `ExceptT a IO ()` | 20 | | 2 | `ExceptT (Either a b) IO ()` | 21 | | 3 | `ExceptT (Either a (Either b c)) IO ()` | 22 | | 4 | `ExceptT (Either a (Either b (Either c d))) IO ()` | 23 | | ... | ... | 24 | 25 | This is _fine_: we can use some type synonyms to hide all this noise (`type 26 | Errors = Either ...`), or maybe even alias `Either` (`type (+) = Either`) to 27 | something smaller. Both are acceptable, but it comes with a big maintenance 28 | burden. The structure of the `Either` type is quite fragile, and adding more 29 | errors to the catalogue will invariably break other code (what was once added 30 | with `Right . Right . Right` is now `Right . Right . Left`). Add to that the 31 | fact that it's just _noisy_. What if we had... 32 | 33 | | Either | Variant | 34 | | ---------------------------------- | ----------------------- | 35 | | `a` | `Variant '[a]` | 36 | | `Either a b` | `Variant '[a, b]` | 37 | | `Either a (Either b c)` | `Variant '[a, b, c]` | 38 | | `Either a (Either b (Either c d))` | `Variant '[a, b, c, d]` | 39 | 40 | With the `Variant` type, we declare (in the type) the list of possible values, 41 | just as we do with `Either`. The only real difference at this point is that the 42 | syntax is nicer! Still, there must be more to it; what can we do with a 43 | `Variant`? 44 | 45 | > _The library also defines `VariantF`, which works in the same way, but the 46 | > type also mentions a type constructor, and the list of types are applied to 47 | > it. For example, `VariantF IO '[Int, String]` is actually either `IO Int` or 48 | > `IO String`. We can think of `Variant` as the special case of `VariantF 49 | > Identity`._ 50 | 51 | Typically, a module involving a `Variant` may need some of the following 52 | extensions, depending on what you're doing with it: 53 | 54 | ```haskell 55 | {-# LANGUAGE 56 | DataKinds 57 | , FlexibleContexts 58 | , MonoLocalBinds 59 | , RankNTypes 60 | , ScopedTypeVariables 61 | , TypeApplications 62 | , TypeOperators #-} 63 | ``` 64 | 65 | ## "Throwing" 66 | 67 | ```haskell 68 | throw :: xs `CouldBe` x => x -> Variant xs 69 | ``` 70 | 71 | Given some variant of types `xs` (e.g. `'[Int, String, Bool]`), if we have some 72 | type `x` in that variant, we say that the variant _could be_ `x`. `throw` lets 73 | us lift any type into a variant that _could be_ that type! In other words: 74 | 75 | ```haskell 76 | eg0 :: Int -> Variant '[Int] 77 | eg0 = throw 78 | 79 | eg1 :: Bool -> Variant '[Bool, String] 80 | eg1 = throw 81 | 82 | eg2 :: IO () -> Variant '[Int, IO (), Bool] 83 | eg2 = throw 84 | ``` 85 | 86 | Now, _why do we call it throw_? 87 | 88 | ## "Catching" 89 | 90 | ```haskell 91 | catch :: Catch x xs ys => Variant xs -> Either (Variant ys) x 92 | ``` 93 | 94 | The `catch` function effectively "plucks" a type _out_ of the constraint. In 95 | other words, if I `catch @String` on a `Variant '[Int, String, Bool]`, the 96 | result is `Either (Variant '[Int, Bool]) String`. This allows us to remove 97 | errors from the catalogue as we go up up the call stack. 98 | 99 | The name is a reference to the `throw`/`catch` exception systems in other 100 | languages. In Java, I may see a definition like this: 101 | 102 | ```java 103 | public static void whatever() throws ExceptionA, ExceptionB 104 | ``` 105 | 106 | The equivalent in Haskell using _this_ library would be: 107 | 108 | ```haskell 109 | main 110 | :: ( e `CouldBe` ExceptionA 111 | , e `CouldBe` ExceptionB 112 | ) 113 | => String -> Either e () 114 | ``` 115 | 116 | ## "Throwing" _and_ "Catching" 117 | 118 | The interesting thing about the above two functions is that you should almost 119 | _never_ see the `Catch` constraint in one of your signatures. Let's see an 120 | example: 121 | 122 | ```haskell 123 | data NetworkError = NetworkError 124 | data UserNotFoundError = UserNotFoundError 125 | 126 | getUser 127 | :: ( e `CouldBe` NetworkError 128 | , e `CouldBe` UserNotFoundError 129 | ) 130 | => String 131 | -> ExceptT (Variant e) IO String 132 | 133 | getUser = \case 134 | "Alice" -> throwM NetworkError 135 | "Tom" -> pure "Hi, Tom!" 136 | _ -> throwM UserNotFoundError 137 | ``` 138 | 139 | We've got ourselves a fresh (and extremely contrived) bit of business logic! 140 | Notice that, according to the constraints, a couple things could go wrong: we 141 | could have a network error, or fail to find the user! 142 | 143 | Now, let's say we're calling this from another function that does some more 144 | contrived business logic: 145 | 146 | ```haskell 147 | import Control.Monad.Oops 148 | 149 | renderProfile :: () 150 | => e `CouldBe` NetworkError 151 | => Text 152 | -> ExceptT (Variant e) IO () 153 | renderProfile username = do 154 | name <- catch @UserNotFoundError (getUser username) $ \_ -> do 155 | liftIO (putStrLn "ERROR! USER NOT FOUND. Defaulting to 'Alice'.") 156 | pure "Alice" 157 | 158 | liftIO (putStrLn name) 159 | ``` 160 | 161 | Here, we've tried to call `getUser`, and handled the `UserNotFoundError` 162 | explicitly. You'll notice that, as a result, _this_ signature doesn't mention 163 | it! Thanks to some careful instance trickery, a `CouldBe` and a `Catch` 164 | constraint will actually cancel each other out! 165 | 166 | ```haskell 167 | {-# LANGUAGE BlockArguments #-} 168 | 169 | import Control.Monad.Oops 170 | 171 | renderProfile :: () 172 | => Monad m 173 | => es `CouldBe` NetworkError 174 | => es `CouldBe` InvalidPassword 175 | => Text 176 | -> Text 177 | -> ExceptT (Variant es) IO () 178 | renderProfile username password = do 179 | name <- loginUser username password 180 | & do catch @UserNotFoundError \_ -> do 181 | liftIO (putStrLn "ERROR! USER NOT FOUND. Defaulting to 'Alice'.") 182 | pure "Alice" 183 | & do catch @InvalidPassowrd \e -> do 184 | liftIO (putStrLn "ERROR! INVALID PASSWORD.") 185 | throwM e 186 | 187 | liftIO (putStrLn name) 188 | ``` 189 | 190 | This library gives us all the benefits of Haskell's type system, forcing us to 191 | be explicit about all the possible errors we encounter, but doesn't force us to 192 | stick to a concrete error stack throughout. Our code is less fragile, our 193 | functions are decoupled, and error-handling is actually bearable! 194 | 195 | ## Examples 196 | Many [examples](examples/src/Examples.hs) can be found in the `oops-example` package. 197 | 198 | ## Troubleshooting 199 | 200 | ### Type inference 201 | Type-inference generally works, however the types inferred may not be the simplest or 202 | may be more generic than your needs. 203 | 204 | For example the following: 205 | 206 | ```haskell 207 | readInt :: (MonadError (Variant e) m, CouldBeF e Text) => String -> m Int 208 | ``` 209 | 210 | Can be simplified to one of the following: 211 | 212 | ```haskell 213 | readInt :: (MonadError (Variant e) m, CouldBe e Text) => String -> m Int 214 | readInt :: (MonadError (Variant e) m, e `CouldBe` Text) => String -> m Int 215 | readInt :: (MonadError (Variant e) IO, e `CouldBe` Text) => String -> IO Int 216 | readInt :: e `CouldBe` Text => String -> ExceptT (Variant e) m Int 217 | readInt :: e `CouldBe` Text => String -> ExceptT (Variant e) IO Int 218 | ``` 219 | 220 | ### Understanding error messages 221 | 222 | If you get the following error: 223 | 224 | ``` 225 | • Could not deduce (OO.CouldBeF e MyErrorType) 226 | arising from a use of ‘OO.throw’ 227 | from the context: (MonadError (Variant e) m, OO.CouldBeF e Text) 228 | bound by the type signature for: 229 | readIntV1 :: forall (e :: [*]) (m :: * -> *). 230 | (MonadError (Variant e) m, OO.CouldBeF e Text) => 231 | String -> m Int 232 | at /Users/jky/wrk/haskell-works/oops/examples/src/Examples.hs:(27,1)-(31,10) 233 | ``` 234 | 235 | It means the function body is throwing `MyErrorType` and the function doesn't have 236 | the constraint to declare the error propagates to the caller. 237 | 238 | In this case you have two choices: 239 | 240 | * Add the constraint to the function's type signature to propage the error to 241 | the caller. 242 | * Catch the exception in the function body and handle it. The handler can 243 | return a fallback value or throw an error of another type. 244 | 245 | If you get the following error: 246 | 247 | ``` 248 | • Uh oh! I couldn't find MyErrorType inside the variant! 249 | If you're pretty sure I'm wrong, perhaps the variant type is ambiguous; 250 | could you add some annotations? 251 | ``` 252 | 253 | It means the expression under `runOops` or similar throws an error that is not 254 | handled. 255 | 256 | In this case you have two choices: 257 | 258 | * Swap `runOops` or similar for something else that catches the uncaught error. 259 | 260 | * Catch the exception in the function body and handle it. The handler can 261 | return a fallback value or throw an error of the type caught by the `runOops` 262 | equvalent. Note `runOops` itself catches no errors, so in this case all 263 | errors must be handled. 264 | 265 | ## Resources 266 | 267 | For examples of `oops` code, see the [`Examples.hs` file](https://github.com/haskell-works/oops/blob/main/examples/src/Examples.hs). 268 | 269 | For examples of compile errors when using `oops` and how to fix them, 270 | see the [troubleshooting](https://github.com/haskell-works/oops/wiki/Troubleshooting) 271 | page. 272 | 273 | ## Projects using `oops` 274 | 275 | * [`cabal-cache`](https://github.com/haskell-works/cabal-cache) 276 | 277 | ## Credits 278 | 279 | This library is heavily based on the original [oops library](https://github.com/i-am-tom/oops) by Tom Harding. 280 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | examples 4 | -------------------------------------------------------------------------------- /doctest/DoctestDriver.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import System.FilePath.Glob (glob) 4 | import Test.DocTest (doctest) 5 | 6 | main :: IO () 7 | main = do 8 | sourceFiles <- glob "src/**/*.hs" 9 | doctest 10 | $ "-XHaskell2010" 11 | : sourceFiles 12 | -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023 John Ky 2 | Copyright (c) 2019 Tom Harding 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining 5 | a copy of this software and associated documentation files (the 6 | "Software"), to deal in the Software without restriction, including 7 | without limitation the rights to use, copy, modify, merge, publish, 8 | distribute, sublicense, and/or sell copies of the Software, and to 9 | permit persons to whom the Software is furnished to do so, subject to 10 | the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included 13 | in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 17 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 18 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 19 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 20 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 21 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /examples/oops-examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | name: oops-examples 4 | version: 0.2.0.0 5 | synopsis: Oops examples 6 | description: Oops examples. 7 | homepage: https://www.github.com/haskell-works/oops 8 | license: MIT 9 | license-file: LICENSE 10 | author: John Ky 11 | maintainer: newhoggy@gmail.com 12 | copyright: 2023 John Ky 13 | 2019 Tom Harding 14 | category: Data 15 | Control 16 | tested-with: GHC == 9.4.4, GHC == 9.2.5, GHC == 9.0.2, GHC == 8.10.7 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/haskell-works/oops 21 | 22 | common base { build-depends: base >= 4.12 && < 5 } 23 | 24 | common exceptions { build-depends: exceptions } 25 | common mtl { build-depends: mtl } 26 | common oops { build-depends: oops } 27 | common text { build-depends: text } 28 | common transformers { build-depends: transformers } 29 | 30 | common project-config 31 | default-language: Haskell2010 32 | default-extensions: BlockArguments 33 | RankNTypes 34 | ScopedTypeVariables 35 | ghc-options: -Wall 36 | 37 | library 38 | import: base, project-config, 39 | exceptions, 40 | mtl, 41 | oops, 42 | text, 43 | transformers, 44 | exposed-modules: Examples 45 | hs-source-dirs: src 46 | -------------------------------------------------------------------------------- /examples/src/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE MonoLocalBinds #-} 6 | {-# LANGUAGE DataKinds #-} 7 | 8 | module Examples where 9 | 10 | import Control.Monad.Except (MonadError, ExceptT, runExceptT) 11 | import Control.Monad.Oops ( CouldBe, Variant ) 12 | import Data.Text (Text) 13 | import Text.Read (readMaybe) 14 | import Data.Functor.Identity (Identity) 15 | import Control.Monad.Trans (MonadIO) 16 | import Data.Function ((&)) 17 | 18 | import qualified Control.Monad.Oops as OO 19 | import qualified System.IO as IO 20 | import Control.Monad.IO.Class (MonadIO(..)) 21 | import Control.Exception (IOException) 22 | import Control.Monad.Catch (MonadCatch) 23 | 24 | -- | A simple function that throws an error. 25 | -- 26 | -- The type is the one that is inferred by GHC. 27 | readIntV1 :: () 28 | => MonadError (Variant e) m 29 | => OO.CouldBeF e Text 30 | => String 31 | -> m Int 32 | readIntV1 s = case readMaybe @Int s of 33 | Just i -> return i 34 | Nothing -> OO.throw @Text "Not an integer" 35 | 36 | -- | A simple function that throws an error. 37 | -- 38 | -- This is the same as before, but we can rewrite constraint on 'e' differently. 39 | readIntV2 :: () 40 | => MonadError (Variant e) m 41 | => e `CouldBe` Text 42 | => String 43 | -> m Int 44 | readIntV2 s = case readMaybe @Int s of 45 | Just i -> return i 46 | Nothing -> OO.throw @Text "Not an integer" 47 | 48 | -- | A simple function that throws an error. 49 | -- 50 | -- We can also use 'ExceptT' 51 | readIntV3 :: () 52 | => e `CouldBe` Text 53 | => String 54 | -> ExceptT (Variant e) Identity Int 55 | readIntV3 s = case readMaybe @Int s of 56 | Just i -> return i 57 | Nothing -> OO.throw @Text "Not an integer" 58 | 59 | -- | A simple IO function that throws an error. 60 | -- 61 | -- We can also use 'ExceptT' of 'IO'. 62 | readIntV4 :: () 63 | => e `CouldBe` Text 64 | => String 65 | -> ExceptT (Variant e) IO Int 66 | readIntV4 s = case readMaybe @Int s of 67 | Just i -> return i 68 | Nothing -> OO.throw @Text "Not an integer" 69 | 70 | -- | A simple function that throws an error. 71 | -- 72 | -- Or use MonadIO instead of IO directly. 73 | readIntV5 :: () 74 | => MonadError (Variant e) m 75 | => MonadIO m 76 | => e `CouldBe` Text 77 | => String 78 | -> m Int 79 | readIntV5 s = case readMaybe @Int s of 80 | Just i -> return i 81 | Nothing -> OO.throw @Text "Not an integer" 82 | 83 | -- | A simple function that throws an error. 84 | -- 85 | -- Or use 'MonadIO' with 'ExceptT'. 86 | readIntV6 :: () 87 | => MonadIO m 88 | => e `CouldBe` Text 89 | => String 90 | -> ExceptT (Variant e) m Int 91 | readIntV6 s = case readMaybe @Int s of 92 | Just i -> return i 93 | Nothing -> OO.throw @Text "Not an integer" 94 | 95 | -- We can represent each error as a separate type. 96 | 97 | data NotAnInteger = NotAnInteger 98 | 99 | data NotPositive = NotPositive 100 | 101 | -- | A simple function can throw two errors 102 | readPositiveInt1 :: () 103 | => MonadIO m 104 | => e `CouldBe` NotAnInteger 105 | => e `CouldBe` NotPositive 106 | => String 107 | -> ExceptT (Variant e) m Int 108 | readPositiveInt1 s = 109 | case readMaybe @Int s of 110 | Just i -> 111 | if i > 0 112 | then return i 113 | else OO.throw NotPositive 114 | Nothing -> OO.throw NotAnInteger 115 | 116 | -- We can call a function that throws an error of type 'Text' and allow the 117 | -- error to propagate by declaring we also throw an error of type 'Text'. 118 | example1 :: () 119 | => e `CouldBe` Text 120 | => String 121 | -> ExceptT (Variant e) IO Int 122 | example1 s = do 123 | i <- readInt s 124 | liftIO $ IO.print i 125 | return i 126 | where 127 | readInt :: () 128 | => e `CouldBe` Text 129 | => String 130 | -> ExceptT (Variant e) IO Int 131 | readInt = error "unimplemented" 132 | 133 | -- Or alternatively, we can catch the error of type 'Text' and handle it. 134 | -- in which case the error doesn't propagate. Notice the 'e CouldBe Text' 135 | -- constraint is not needed in this case. 136 | example2 :: () 137 | => String 138 | -> ExceptT (Variant e) IO Int 139 | example2 s = do 140 | i <- readInt s 141 | & OO.catch @Text (\_ -> pure 0) 142 | liftIO $ IO.print i 143 | return i 144 | where 145 | readInt :: () 146 | => e `CouldBe` Text 147 | => String 148 | -> ExceptT (Variant e) IO Int 149 | readInt = error "unimplemented" 150 | 151 | -- When we don't throw any errors, we can use the 'runOops' function to 152 | -- convert the 'ExceptT' to an 'IO' action. 153 | example3 :: () 154 | => String 155 | -> IO Int 156 | example3 s = OO.runOops $ do 157 | i <- readInt s 158 | & OO.catch @Text (\_ -> pure 0) 159 | liftIO $ IO.print i 160 | return i 161 | where 162 | readInt :: () 163 | => e `CouldBe` Text 164 | => String 165 | -> ExceptT (Variant e) IO Int 166 | readInt = error "unimplemented" 167 | 168 | data FileNotFound = FileNotFound 169 | 170 | data FileNotReadable = FileNotReadable 171 | 172 | data Errors1 173 | = Errors1NotPositive NotPositive 174 | | Errors1NotAnInteger NotAnInteger 175 | 176 | -- We can call a function that throws multiple errors into a function 177 | -- that only throws one by just catching and rethrowing the one 178 | -- error. 179 | example4 :: () 180 | => MonadIO m 181 | => e `CouldBe` Errors1 182 | => String 183 | -> ExceptT (Variant e) m Int 184 | example4 s = do 185 | i <- readPositiveInt1 s 186 | & OO.catch @NotPositive (OO.throw . Errors1NotPositive) 187 | & OO.catch @NotAnInteger (OO.throw . Errors1NotAnInteger) 188 | liftIO $ IO.print i 189 | return i 190 | 191 | -------------------------------------------------------------------------------- 192 | -- Embedding 'Oops' into vanilla 'ExceptT' and 'Either' code. 193 | 194 | -- We we have a function that only throws one error, we can use 'runOopsInExceptT' 195 | -- to remove the 'Variant' wrapper leaving only the 'ExceptT'. 196 | example5 :: () 197 | => MonadIO m 198 | => String 199 | -> ExceptT Errors1 m Int 200 | example5 s = OO.runOopsInExceptT $ do 201 | i <- readPositiveInt1 s 202 | & OO.catch @NotPositive (OO.throw . Errors1NotPositive) 203 | & OO.catch @NotAnInteger (OO.throw . Errors1NotAnInteger) 204 | liftIO $ IO.print i 205 | return i 206 | 207 | -- We we have a function that only throws one error, we can use 'runOopsInEither' 208 | -- to remove the 'Variant' wrapper and the 'Except' leaving only the 'Either'. 209 | example6 :: () 210 | => MonadIO m 211 | => String 212 | -> m (Either Errors1 Int) 213 | example6 s = OO.runOopsInEither $ do 214 | i <- readPositiveInt1 s 215 | & OO.catch @NotPositive (OO.throw . Errors1NotPositive) 216 | & OO.catch @NotAnInteger (OO.throw . Errors1NotAnInteger) 217 | liftIO $ IO.print i 218 | return i 219 | 220 | -------------------------------------------------------------------------------- 221 | -- Embedding vanilla 'ExceptT' and 'Either' code into 'Oops' code. 222 | -- We can call a function that throws multiple errors into a function 223 | -- that only throws one by just catching and rethrowing the one 224 | -- error. 225 | 226 | -- We can call a function that throws vanilla 'ExceptT' errors and use 'onLeft' 227 | -- to catch and rethrow the errors as oops errors. 228 | example7 :: () 229 | => MonadIO m 230 | => e `CouldBe` NotPositive 231 | => e `CouldBe` NotAnInteger 232 | => String 233 | -> ExceptT (Variant e) m Int 234 | example7 s = do 235 | i <- readInt s 236 | & OO.onLeft OO.throw 237 | pos <- requirePositive i 238 | & OO.onLeft OO.throw 239 | liftIO $ IO.print pos 240 | return pos 241 | where 242 | readInt :: MonadIO m => String -> m (Either NotAnInteger Int) 243 | readInt = error "unimplemented" 244 | requirePositive :: MonadIO m => Int -> m (Either NotPositive Int) 245 | requirePositive = error "unimplemented" 246 | 247 | -- 'onLeftThrow' is shorthand for 'onLeft throw'. 248 | example8 :: () 249 | => MonadIO m 250 | => e `CouldBe` NotPositive 251 | => e `CouldBe` NotAnInteger 252 | => String 253 | -> ExceptT (Variant e) m Int 254 | example8 s = do 255 | i <- readInt s 256 | & OO.onLeftThrow 257 | pos <- requirePositive i 258 | & OO.onLeftThrow 259 | liftIO $ IO.print pos 260 | return pos 261 | where 262 | readInt :: MonadIO m => String -> m (Either NotAnInteger Int) 263 | readInt = error "unimplemented" 264 | requirePositive :: MonadIO m => Int -> m (Either NotPositive Int) 265 | requirePositive = error "unimplemented" 266 | 267 | -- We can similarly call a function that throws via vanilla 'ExceptT' 268 | example9 :: () 269 | => MonadIO m 270 | => e `CouldBe` NotPositive 271 | => e `CouldBe` NotAnInteger 272 | => String 273 | -> ExceptT (Variant e) m Int 274 | example9 s = do 275 | i <- liftIO (runExceptT (readInt s)) 276 | & OO.onLeftThrow 277 | pos <- liftIO (runExceptT (requirePositive i)) 278 | & OO.onLeftThrow 279 | liftIO $ IO.print pos 280 | return pos 281 | where 282 | readInt :: String -> ExceptT NotAnInteger IO Int 283 | readInt = error "unimplemented" 284 | requirePositive :: Int -> ExceptT NotPositive IO Int 285 | requirePositive = error "unimplemented" 286 | 287 | -- We can similarly call a function that throws via vanilla 'ExceptT' 288 | example10 :: () 289 | => MonadIO m 290 | => e `CouldBe` NotPositive 291 | => e `CouldBe` NotAnInteger 292 | => String 293 | -> ExceptT (Variant e) m Int 294 | example10 s = do 295 | i <- liftIO (runExceptT (readInt s)) 296 | & OO.onLeftThrow 297 | pos <- liftIO (runExceptT (requirePositive i)) 298 | & OO.onLeftThrow 299 | liftIO $ IO.print pos 300 | return pos 301 | where 302 | readInt :: String -> ExceptT NotAnInteger IO Int 303 | readInt = error "unimplemented" 304 | requirePositive :: Int -> ExceptT NotPositive IO Int 305 | requirePositive = error "unimplemented" 306 | 307 | -- We can also catch runtime exceptions and rethrow them as checked exceptions. 308 | example11 :: () 309 | => MonadIO m 310 | => MonadCatch m 311 | => e `CouldBe` IOException 312 | => ExceptT (Variant e) m String 313 | example11 = do 314 | i <- liftIO (IO.readFile "moo") 315 | & OO.onException @IOException OO.throw 316 | liftIO $ IO.print i 317 | return i 318 | 319 | -- The 'onExceptionThrow' is shorthand for 'onException throw'. 320 | example12 :: () 321 | => MonadIO m 322 | => MonadCatch m 323 | => e `CouldBe` IOException 324 | => ExceptT (Variant e) m String 325 | example12 = do 326 | i <- liftIO (IO.readFile "moo") 327 | & OO.onExceptionThrow @IOException 328 | liftIO $ IO.print i 329 | return i 330 | -------------------------------------------------------------------------------- /gen/Data/Variant/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module Data.Variant.Gen () where 6 | 7 | import Data.Variant 8 | import Test.QuickCheck.Arbitrary (Arbitrary (..)) 9 | 10 | instance (EithersF f xs nested, Arbitrary nested) => Arbitrary (VariantF f xs) where 11 | arbitrary = fmap fromEithersF arbitrary 12 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | -------------------------------------------------------------------------------- /oops.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | name: oops 4 | version: 0.2.0.1 5 | synopsis: Combinators for handling errors of many types in a composable way 6 | description: Combinators for handling errors of many types in a composable way. 7 | homepage: https://www.github.com/haskell-works/oops 8 | license: MIT 9 | license-file: LICENSE 10 | author: John Ky 11 | maintainer: newhoggy@gmail.com 12 | copyright: 2023 John Ky 13 | 2019 Tom Harding 14 | category: Data 15 | Control 16 | tested-with: GHC == 9.4.4, GHC == 9.2.5, GHC == 9.0.2, GHC == 8.10.7 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/haskell-works/oops 21 | 22 | common base { build-depends: base >= 4.12 && < 5 } 23 | 24 | common base-compat { build-depends: base-compat >= 0.10.5 && < 0.14 } 25 | common Glob { build-depends: Glob >= 0.10.2 && < 0.11 } 26 | common doctest { build-depends: doctest >= 0.16.2 && < 0.23 } 27 | common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 } 28 | common doctest-prop { build-depends: doctest-prop >= 0.2.0.1 && < 0.3 } 29 | common exceptions { build-depends: exceptions } 30 | common hedgehog-quickcheck { build-depends: hedgehog-quickcheck } 31 | common hedgehog { build-depends: hedgehog } 32 | common hspec { build-depends: hspec } 33 | common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog } 34 | common lens { build-depends: lens } 35 | common mtl { build-depends: mtl } 36 | common QuickCheck { build-depends: QuickCheck } 37 | common template-haskell { build-depends: template-haskell } 38 | common transformers { build-depends: transformers } 39 | 40 | common project-config 41 | default-language: Haskell2010 42 | default-extensions: BlockArguments 43 | RankNTypes 44 | ScopedTypeVariables 45 | ghc-options: -Wall 46 | 47 | library 48 | import: base, project-config, 49 | exceptions, 50 | mtl, 51 | QuickCheck, 52 | transformers, 53 | exposed-modules: Control.Monad.Oops 54 | Data.Variant 55 | hs-source-dirs: src 56 | default-language: Haskell2010 57 | 58 | test-suite doctest 59 | import: base, project-config, 60 | base-compat, 61 | doctest, 62 | doctest-discover, 63 | Glob, 64 | lens, 65 | QuickCheck, 66 | template-haskell, 67 | type: exitcode-stdio-1.0 68 | build-tool-depends: doctest-discover:doctest-discover 69 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 70 | main-is: DoctestDriver.hs 71 | hs-source-dirs: doctest 72 | default-language: Haskell2010 73 | build-depends: oops 74 | 75 | x-doctest-components: lib 76 | 77 | test-suite test 78 | import: base, project-config, 79 | base-compat, 80 | doctest-discover, 81 | doctest, 82 | hedgehog-quickcheck, 83 | hedgehog, 84 | hspec, 85 | hw-hspec-hedgehog, 86 | lens, 87 | mtl, 88 | QuickCheck, 89 | template-haskell, 90 | type: exitcode-stdio-1.0 91 | build-tool-depends: hspec-discover:hspec-discover 92 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 93 | main-is: Spec.hs 94 | hs-source-dirs: test 95 | default-language: Haskell2010 96 | build-depends: oops 97 | other-modules: Data.VariantSpec 98 | -------------------------------------------------------------------------------- /src/Control/Monad/Oops.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilyDependencies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Control.Monad.Oops 18 | ( -- * Catching and throwing exceptions 19 | catchF, 20 | catch, 21 | 22 | throwF, 23 | throw, 24 | 25 | snatchF, 26 | snatch, 27 | 28 | -- * Typeclasses to describe oops-style errors 29 | CouldBeF, 30 | CouldBe, 31 | CouldBeAnyOfF, 32 | CouldBeAnyOf, 33 | 34 | -- * Variant type to carry oops-style errors 35 | Variant, 36 | VariantF, 37 | 38 | -- * Embedding code with oops-style error handling into other code 39 | runOops, 40 | runOopsInExceptT, 41 | runOopsInEither, 42 | suspend, 43 | 44 | -- * Error handling 45 | catchOrMap, 46 | catchAsLeft, 47 | catchAsNothing, 48 | catchAndExitFailure, 49 | 50 | recover, 51 | recoverOrVoid, 52 | 53 | -- * Converting error values to oops-style error handling 54 | onLeft, 55 | onNothing, 56 | 57 | onLeftThrow, 58 | onNothingThrow, 59 | 60 | hoistEither, 61 | hoistMaybe, 62 | 63 | -- * Converting exceptions to oops-style error handling 64 | onExceptionThrow, 65 | onException, 66 | 67 | ) where 68 | 69 | import Control.Monad.Error.Class (MonadError (..)) 70 | import Control.Monad.Except (ExceptT(ExceptT)) 71 | import Control.Monad.IO.Class (MonadIO(liftIO)) 72 | import Control.Monad.Trans.Except (mapExceptT, runExceptT) 73 | import Data.Bifunctor (first) 74 | import Data.Functor.Identity (Identity (..)) 75 | import Data.Variant (Catch, CatchF, CouldBe, CouldBeAnyOf, CouldBeAnyOfF, CouldBeF, Variant, VariantF) 76 | import Data.Void (Void, absurd) 77 | 78 | import qualified Control.Monad.Catch as CMC 79 | import qualified Data.Variant as DV 80 | import qualified System.Exit as IO 81 | 82 | -- | When working in some monadic context, using 'catch' becomes trickier. The 83 | -- intuitive behaviour is that each 'catch' shrinks the variant in the left 84 | -- side of my 'MonadError', but this is therefore type-changing: as we can only 85 | -- 'throwError' and 'catchError' with a 'MonadError' type, this is impossible! 86 | -- 87 | -- To get round this problem, we have to specialise to 'ExceptT', which allows 88 | -- us to map over the error type and change it as we go. If the error we catch 89 | -- is the one in the variant that we want to handle, we pluck it out and deal 90 | -- with it. Otherwise, we "re-throw" the variant minus the one we've handled. 91 | catchF :: forall x e e' f m a. () 92 | => Monad m 93 | => CatchF x e e' 94 | => (f x -> ExceptT (VariantF f e') m a) 95 | -> ExceptT (VariantF f e ) m a 96 | -> ExceptT (VariantF f e') m a 97 | catchF h = mapExceptT (>>= go) 98 | where 99 | go = \case 100 | Right success -> pure (Right success) 101 | Left failure -> case DV.catchF @x failure of 102 | Right hit -> runExceptT (h hit) 103 | Left miss -> pure (Left miss) 104 | 105 | -- | Just the same as 'catchF', but specialised for our plain 'Variant' and 106 | -- sounding much less like a radio station. 107 | catch :: forall x e e' m a. () 108 | => Monad m 109 | => Catch x e e' 110 | => (x -> ExceptT (Variant e') m a) 111 | -> ExceptT (Variant e ) m a 112 | -> ExceptT (Variant e') m a 113 | catch h = catchF (h . runIdentity) 114 | 115 | -- | Same as 'catchF' except the error is not removed from the type. 116 | -- This is useful for writing recursive computations or computations that 117 | -- rethrow the same error type. 118 | snatchF 119 | :: forall x e f m a. () 120 | => Monad m 121 | => e `CouldBe` x 122 | => (f x -> ExceptT (VariantF f e) m a) 123 | -> ExceptT (VariantF f e) m a 124 | -> ExceptT (VariantF f e) m a 125 | snatchF h = mapExceptT (>>= go) 126 | where 127 | go = \case 128 | Right success -> pure (Right success) 129 | Left failure -> case DV.snatchF @_ @_ @x failure of 130 | Right hit -> runExceptT (h hit) 131 | Left miss -> pure (Left miss) 132 | 133 | 134 | -- | Same as 'catch' except the error is not removed from the type. 135 | -- This is useful for writing recursive computations or computations that 136 | -- rethrow the same error type. 137 | snatch :: forall x e m a. () 138 | => Monad m 139 | => e `CouldBe` x 140 | => (x -> ExceptT (Variant e) m a) 141 | -> ExceptT (Variant e) m a 142 | -> ExceptT (Variant e) m a 143 | snatch h = snatchF (h . runIdentity) 144 | 145 | -- | Throw an error into a variant 'MonadError' context. Note that this /isn't/ 146 | -- type-changing, so this can work for any 'MonadError', rather than just 147 | -- 'ExceptT'. 148 | throwF :: forall x e f m a. () 149 | => MonadError (VariantF f e) m 150 | => e `CouldBe` x 151 | => f x 152 | -> m a 153 | throwF = throwError . DV.throwF 154 | 155 | -- | Same as 'throwF', but without the @f@ context. Given a value of some type 156 | -- within a 'Variant' within a 'MonadError' context, "throw" the error. 157 | throw :: forall x e m a. () 158 | => MonadError (Variant e) m 159 | => e `CouldBe` x 160 | => x 161 | -> m a 162 | throw = throwF . Identity 163 | 164 | -- | Add 'ExceptT (Variant '[])' to the monad transformer stack. 165 | runOops :: () 166 | => Monad m 167 | => ExceptT (Variant '[]) m a 168 | -> m a 169 | runOops f = either (absurd . DV.preposterous) pure =<< runExceptT f 170 | 171 | -- | Run an oops expression that throws one error in an ExceptT. 172 | runOopsInExceptT :: forall x m a. Monad m => ExceptT (Variant '[x]) m a -> ExceptT x m a 173 | runOopsInExceptT = mapExceptT (fmap (first DV.toEithers)) 174 | 175 | -- | Run an oops expression that throws one error in an Either. 176 | -- 177 | -- This function can also be implemented this way (which could be instructive for implementing 178 | -- your own combinators) 179 | runOopsInEither :: forall x m a. Monad m => ExceptT (Variant '[x]) m a -> m (Either x a) 180 | runOopsInEither = runExceptT . mapExceptT (fmap (first DV.toEithers)) 181 | 182 | -- | Suspend the 'ExceptT` monad transformer from the top of the stack so that the 183 | -- stack can be manipulated without the 'ExceptT` layer. 184 | suspend :: forall x m a n b. () 185 | => (m (Either x a) -> n (Either x b)) 186 | -> ExceptT x m a 187 | -> ExceptT x n b 188 | suspend f = ExceptT . f . runExceptT 189 | 190 | -- | Catch the specified exception and return the caught value as 'Left'. If no 191 | -- value was caught, then return the returned value in 'Right'. 192 | catchOrMap :: forall x a e' m b. Monad m 193 | => (b -> a) 194 | -> (x -> ExceptT (Variant e') m a) 195 | -> ExceptT (Variant (x : e')) m b 196 | -> ExceptT (Variant e') m a 197 | catchOrMap g h = catch h . fmap g 198 | 199 | -- | Catch the specified exception and return the caught value as 'Left'. If no 200 | -- value was caught, then return the returned value in 'Right'. 201 | catchAsLeft :: forall x e m a. () 202 | => Monad m 203 | => ExceptT (Variant (x : e)) m a 204 | -> ExceptT (Variant e) m (Either x a) 205 | catchAsLeft = catchOrMap Right (pure . Left) 206 | 207 | -- | Catch the specified exception and return 'Nothing'. If no 208 | -- value was caught, then return the returned value in 'Just'. 209 | catchAsNothing :: forall x e m a. () 210 | => Monad m 211 | => ExceptT (Variant (x : e)) m a 212 | -> ExceptT (Variant e) m (Maybe a) 213 | catchAsNothing = catchOrMap Just (pure . const Nothing) 214 | 215 | -- | Catch the specified exception. If that exception is caught, exit the program. 216 | catchAndExitFailure :: forall x e m a. () 217 | => MonadIO m 218 | => ExceptT (Variant (x : e)) m a 219 | -> ExceptT (Variant e) m a 220 | catchAndExitFailure = catch @x (const (liftIO IO.exitFailure)) 221 | 222 | -- | When the expression of type 'Either x a' evaluates to 'Left x', throw the 'x', 223 | -- otherwise return 'a'. 224 | hoistEither :: forall x e m a. () 225 | => MonadError (Variant e) m 226 | => e `CouldBe` x 227 | => Monad m 228 | => Either x a 229 | -> m a 230 | hoistEither = either throw pure 231 | 232 | -- | When the expression of type 'Maybe a' evaluates to 'Nothing', throw the specified value, 233 | -- otherwise return 'a'. 234 | hoistMaybe :: forall e es m a. () 235 | => MonadError (Variant es) m 236 | => CouldBe es e 237 | => e 238 | -> Maybe a 239 | -> m a 240 | hoistMaybe e = maybe (throw e) pure 241 | 242 | -- | When the expression of type 'm (Either x a)' evaluates to 'pure (Left x)', throw the 'x', 243 | -- otherwise return 'a'. 244 | onLeftThrow :: forall x e m a. () 245 | => MonadError (Variant e) m 246 | => e `CouldBe` x 247 | => m (Either x a) 248 | -> m a 249 | onLeftThrow f = f >>= hoistEither 250 | 251 | -- | When the expression of type 'Maybe a' evaluates to 'Nothing', throw the specified value, 252 | -- otherwise return 'a'. 253 | onNothingThrow :: forall e es m a. () 254 | => MonadError (Variant es) m 255 | => CouldBe es e 256 | => e 257 | -> m (Maybe a) 258 | -> m a 259 | onNothingThrow e f = f >>= hoistMaybe e 260 | 261 | -- | Handle the 'Left' constructor of the returned 'Either' 262 | onLeft :: forall x m a. () 263 | => Monad m 264 | => (x -> m a) 265 | -> m (Either x a) 266 | -> m a 267 | onLeft g f = f >>= either g pure 268 | 269 | -- | Handle the 'Nothing' constructor of the returned 'Maybe' 270 | onNothing :: forall m a. () 271 | => Monad m 272 | => m a 273 | -> m (Maybe a) 274 | -> m a 275 | onNothing g f = f >>= maybe g pure 276 | 277 | -- | Catch the specified exception and return it instead. 278 | -- The evaluated computation must return the same type that is being caught. 279 | recover :: forall x e m a. () 280 | => Monad m 281 | => (x -> a) 282 | -> ExceptT (Variant (x : e)) m a 283 | -> ExceptT (Variant e) m a 284 | recover f = catch (pure . f) 285 | 286 | -- | Catch the specified exception and return it instead. The evaluated computation 287 | -- must return `Void` (ie. it never returns) 288 | recoverOrVoid :: forall x e m. () 289 | => Monad m 290 | => ExceptT (Variant (x : e)) m Void 291 | -> ExceptT (Variant e) m x 292 | recoverOrVoid = catchOrMap @x absurd pure 293 | 294 | -- | Catch an exception of the specified type 'x' and throw it as an error 295 | onExceptionThrow :: forall x e m a. () 296 | => CMC.MonadCatch m 297 | => CMC.Exception x 298 | => MonadError (Variant e) m 299 | => e `CouldBe` x 300 | => m a 301 | -> m a 302 | onExceptionThrow = onException @x throw 303 | 304 | -- | Catch an exception of the specified type 'x' and call the the handler 'h' 305 | onException :: forall x m a. () 306 | => CMC.MonadCatch m 307 | => CMC.Exception x 308 | => (x -> m a) 309 | -> m a 310 | -> m a 311 | onException h f = either h pure =<< CMC.try f 312 | -------------------------------------------------------------------------------- /src/Data/Variant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE EmptyCase #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE TypeFamilyDependencies #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | {-# LANGUAGE UndecidableInstances #-} 19 | 20 | {-| 21 | Module : Data.Variant 22 | Description : Generalised coproducts and methods for working with them. 23 | Copyright : (c) Tom Harding, 2019 24 | License : MIT 25 | Maintainer : tom.harding@habito.com 26 | Stability : experimental 27 | 28 | Traditionally in Haskell, we use @Either a b@ to represent a choice of two 29 | types. If we want to represent /three/ types, we use @Either a (Either b c)@, 30 | and this nesting can continue as far as it needs to. However, this approach 31 | comes with some difficulties: it's quite difficult to manipulate, and makes for 32 | some rather unwieldy type signatures. 33 | 34 | Thankfully, though, GHC provides us with GADTs, and they allow us to construct 35 | a type that encompasses a coproduct of any number of arguments: the 'Variant'. 36 | Just as @Left 3@ and @Right True@ are of type @Either Int Bool@, we can write 37 | @Here 3@ and @There (Here True)@ to do the same thing (ignoring 'Identity' 38 | wrappers). We can think of the 'Here' and 'There' constructors as an "index": 39 | the index of the type we're storing is the number of occurrences of 'There'. 40 | 41 | $setup 42 | >>> :set -XTypeOperators -XDataKinds -XTypeApplications 43 | 44 | > > > :t [ Here (Identity 'a'), There (There (Here (Identity True))) ] 45 | [ Here (Identity 'a'), There (There (Here (Identity True))) ] 46 | :: [VariantF Identity (Char : x : Bool : xs)] 47 | -} 48 | module Data.Variant 49 | ( -- * Generalised coproducts 50 | VariantF (..) 51 | , Variant 52 | 53 | -- * Scott encodings 54 | , variantF 55 | , variant 56 | 57 | -- * Church encodings 58 | , case_ 59 | , caseF 60 | 61 | -- * Injections 62 | , CouldBeF (..) 63 | , CouldBe (..) 64 | , CouldBeAnyOfF 65 | , CouldBeAnyOf 66 | 67 | -- * Projections 68 | , CatchF (..) 69 | , Catch (..) 70 | 71 | -- * Conversions to and from @Either@s 72 | , EithersF (..) 73 | , Eithers (..) 74 | 75 | -- * Folds 76 | , FoldF (..) 77 | , Fold (..) 78 | 79 | -- * Void conversions 80 | , preposterous 81 | , postposterous 82 | ) where 83 | 84 | import Data.Bifunctor (first) 85 | import Data.Function ((&)) 86 | import Data.Functor.Identity (Identity (..)) 87 | import Data.Kind (Constraint, Type) 88 | import Data.Void (Void, absurd) 89 | import GHC.TypeLits (ErrorMessage (..), TypeError) 90 | import Test.QuickCheck.Arbitrary (Arbitrary (..)) 91 | 92 | -- | The type @VariantF f '[x, y, z]@ is /either/ @f x@, @f y@, or @f z@. The 93 | -- We construct these with @Here@, @There . Here@, and @There . There . Here@ 94 | -- respectively, and we can think o fthe number of 'There'-nestings as being 95 | -- the index of our chosen type in the type-level list of options. 96 | -- 97 | -- Often, however, we'll want to avoid being too explicit about our list of 98 | -- types, preferring instead to describe it with constraints. See the methods 99 | -- below for more information! 100 | -- 101 | -- > > > :t [ Here (pure "Hello"), There (Here (pure True)) ] 102 | -- [ Here (pure "Hello"), There (Here (pure True)) ] 103 | -- :: Applicative f => [VariantF f ([Char] : Bool : xs)] 104 | data VariantF (f :: k -> Type) (xs :: [k]) where 105 | Here :: f x -> VariantF f (x ': xs) 106 | There :: VariantF f xs -> VariantF f (x ': xs) 107 | 108 | type family AllF (c :: Type -> Constraint) (f :: k -> Type) (xs :: [k]) :: Constraint where 109 | AllF c f '[ ] = () 110 | AllF c f (x ': xs) = (c (f x), AllF c f xs) 111 | 112 | deriving instance AllF Eq f xs => Eq (VariantF f xs) 113 | deriving instance AllF Show f xs => Show (VariantF f xs) 114 | deriving instance (AllF Eq f xs, AllF Ord f xs) => Ord (VariantF f xs) 115 | 116 | instance (AllF Semigroup f xs) => Semigroup (VariantF f xs) where 117 | Here x <> Here y = Here (x <> y) 118 | Here _ <> There y = There y 119 | There x <> Here _ = There x 120 | There x <> There y = There (x <> y) 121 | 122 | instance (Monoid (f x), Semigroup (VariantF f (x ': xs))) 123 | => Monoid (VariantF f (x ': xs)) where 124 | mempty = Here mempty 125 | 126 | -- | Often, you'll want to have a choice of types that /aren't/ all wrapped in 127 | -- a functor. For this, we provide the 'Variant' type synonym, as well as 128 | -- equivalents of all the functions below. These functions take care of 129 | -- wrapping and unwrapping the 'Identity' wrapper, too, so it should be 130 | -- invisible to users. 131 | type Variant (xs :: [Type]) 132 | = VariantF Identity xs 133 | 134 | -- | Remove the first possibility from a variant. One nice possibility here is 135 | -- a function that tells us whether the first type was the one in our variant: 136 | -- @variantF Left Right@. For example: 137 | -- 138 | -- >>> :set -XDataKinds 139 | -- >>> variantF Left Right (Here (Identity True) :: Variant '[Bool]) 140 | -- Left (Identity True) 141 | -- 142 | -- >>> variantF Left Right (There (Here (Identity 3)) :: Variant '[Bool, Int]) 143 | -- Right (Here (Identity 3)) 144 | variantF :: (f x -> r) -> (VariantF f xs -> r) -> VariantF f (x ': xs) -> r 145 | variantF here there = \case Here x -> here x; There xs -> there xs 146 | 147 | -- | Same as 'VariantF', but the value will be unwrapped (not in 'Identity') if 148 | -- found. 149 | -- 150 | -- >>> variant Left Right (Here (Identity True) :: Variant '[Bool]) 151 | -- Left True 152 | -- 153 | -- >>> variant Left Right (There (Here (Identity 3)) :: Variant '[Bool, Int]) 154 | -- Right (Here (Identity 3)) 155 | variant :: (x -> r) -> (Variant xs -> r) -> Variant (x ': xs) -> r 156 | variant here = variantF (here . runIdentity) 157 | 158 | class CaseF (xs :: [Type]) (f :: Type -> Type) (r :: Type) (o :: Type) 159 | | xs f r -> o, o -> f r xs where 160 | caseF' :: Either r (VariantF f xs) -> o 161 | 162 | instance CaseF '[x] f r ((f x -> r) -> r) where 163 | caseF' (Left r) _ = r 164 | caseF' (Right xs) f = xs & variantF f \_ -> 165 | error $ "Impossible case - something isn't happy when performing the " 166 | <> "exhaustivity check as this case shouldn't need a pattern-match." 167 | 168 | instance CaseF (y ': zs) f r ((f y -> r) -> o) 169 | => CaseF (x ': y ': zs) f r ((f x -> r) -> (f y -> r) -> o) where 170 | caseF' xs f = caseF' (xs >>= variantF (Left . f) Right) 171 | 172 | -- | The 'either' function provides us with a way of folding an 'Either' by 173 | -- providing a function for each possible constructor: 'Left' and 'Right'. In 174 | -- our case, we could have any number of functions to supply, depending on how 175 | -- many types are in our type-level index. 176 | -- 177 | -- This function specialises depending on the variant provided: 178 | -- 179 | -- > > > :t caseF (throw True :: Variant '[Bool]) 180 | -- caseF (throw True :: Variant '[Bool]) :: (Identity Bool -> r) -> r 181 | -- 182 | -- > > > :t caseF (throwF (pure True) :: VariantF IO '[Int, Bool]) 183 | -- caseF (throwF (pure True) :: VariantF IO '[Int, Bool]) 184 | -- :: (IO Int -> o) -> (IO Bool -> o) -> o 185 | caseF :: CaseF xs f r fold => VariantF f xs -> fold 186 | caseF = caseF' . Right 187 | 188 | class Case (xs :: [Type]) (r :: Type) (o :: Type) 189 | | xs r -> o, o -> r xs where 190 | case_' :: Either r (Variant xs) -> o 191 | 192 | instance Case '[x] r ((x -> r) -> r) where 193 | case_' (Left r) _ = r 194 | case_' (Right xs) f = xs & variantF (f . runIdentity) \_ -> 195 | error $ "Impossible case - something isn't happy when performing the " 196 | <> "exhaustivity check as this case shouldn't need a pattern-match." 197 | 198 | instance Case (y ': zs) r ((y -> r) -> o) 199 | => Case (x ': y ': zs) r ((x -> r) -> (y -> r) -> o) where 200 | case_' xs f = case_' (xs >>= variantF (Left . f . runIdentity) Right) 201 | 202 | -- | Same as 'caseF', but without the functor wrappers. Again, this function 203 | -- will specialise according to the provided variant: 204 | -- 205 | -- > > > :t case_ (throw True :: Variant '[Bool, Int]) 206 | -- case_ (throw True :: Variant '[Bool, Int]) 207 | -- :: (Bool -> o) -> (Int -> o) -> o 208 | -- 209 | -- You can also use @TypeApplications@ to check the specialisation for a 210 | -- particular variant: 211 | -- 212 | -- > > > :t case_ @'[Int, Bool, String] 213 | -- case_ @'[Int, Bool, String] 214 | -- :: Variant '[Int, Bool, String] 215 | -- -> (Int -> o) -> (Bool -> o) -> ([Char] -> o) -> o 216 | case_ :: Case xs r fold => Variant xs -> fold 217 | case_ = case_' . Right 218 | 219 | type family TypeNotFound (x :: k) :: l where 220 | TypeNotFound x 221 | = TypeError ( 'Text "Uh oh! I couldn't find " ':<>: 'ShowType x 222 | ':<>: 'Text " inside the variant!" 223 | ':$$: 'Text "If you're pretty sure I'm wrong, perhaps the variant " 224 | ':<>: 'Text "type is ambiguous;" 225 | ':$$: 'Text "could you add some annotations?" ) 226 | 227 | -- | When dealing with larger (or polymorphic) variants, it becomes difficult 228 | -- (or impossible) to construct 'VariantF' values explicitly. In that case, the 229 | -- 'throwF' function gives us a polymorphic way to lift values into variants. 230 | -- 231 | -- >>> throwF (pure "Hello") :: VariantF Maybe '[Bool, Int, Double, String] 232 | -- There (There (There (Here (Just "Hello")))) 233 | -- 234 | -- >>> throwF (pure True) :: VariantF Maybe '[Bool, Int, Double, String] 235 | -- Here (Just True) 236 | -- 237 | -- >>> throwF (pure True) :: VariantF IO '[Int, Double, String] 238 | -- ... 239 | -- ... • Uh oh! I couldn't find Bool inside the variant! 240 | -- ... If you're pretty sure I'm wrong, perhaps the variant type is ambiguous; 241 | -- ... could you add some annotations? 242 | -- ... 243 | class CouldBeF (xs :: [k]) (x :: k) where 244 | throwF :: f x -> VariantF f xs 245 | snatchF :: VariantF f xs -> Either (VariantF f xs) (f x) 246 | 247 | instance CouldBeF (x ': xs) x where 248 | throwF = Here 249 | snatchF = \case 250 | Here x -> Right x 251 | There xs -> Left (There xs) 252 | 253 | -- instance {-# INCOHERENT #-} (y ~ z, CatchF x xs ys) 254 | -- => CatchF x (y ': xs) (z ': ys) where 255 | -- catchF = \case 256 | -- There xs -> first There (catchF xs) 257 | -- Here _ -> 258 | -- error $ "Impossible case - something isn't happy when performing the " 259 | -- <> "exhaustivity check as this case shouldn't need a pattern-match." 260 | 261 | instance {-# OVERLAPPABLE #-} CouldBeF xs x 262 | => CouldBeF (y ': xs) x where 263 | throwF = There . throwF 264 | snatchF = \case 265 | There xs -> first There (snatchF xs) 266 | Here _ -> 267 | error $ "Impossible case - something isn't happy when performing the " 268 | <> "exhaustivity check as this case shouldn't need a pattern-match." 269 | 270 | instance TypeNotFound x => CouldBeF '[] x where 271 | throwF = error "Impossible!" 272 | snatchF = error "Impossible!" 273 | 274 | -- | Just as with 'CouldBeF', we can "throw" values /not/ in a functor context 275 | -- into a regular 'Variant'. 276 | -- 277 | -- >>> throw (3 :: Int) :: Variant '[Bool, Int, Double, String] 278 | -- There (Here (Identity 3)) 279 | -- 280 | -- >>> throw "Woo!" :: Variant '[Bool, Int, Double, String] 281 | -- There (There (There (Here (Identity "Woo!")))) 282 | class CouldBeF xs x => CouldBe (xs :: [Type]) (x :: Type) where 283 | throw :: x -> Variant xs 284 | snatch :: Variant xs -> Either (Variant xs) x 285 | 286 | instance CouldBeF xs x => CouldBe xs x where 287 | throw = throwF . Identity 288 | snatch = fmap runIdentity . snatchF 289 | 290 | type family All (cs :: [Constraint]) = (c :: Constraint) | c -> cs where 291 | All '[] = () 292 | All (c ': cs) = (c, All cs) 293 | 294 | type family Map (f :: k -> l) (xs :: [k]) = (ys :: [l]) where 295 | Map f (x ': xs) = f x ': Map f xs 296 | Map f '[] = '[] 297 | 298 | -- | As with 'CouldBeAnyOf', we can also constrain a variant to represent 299 | -- several possible types, as we might with several 'CouldBeF' constraints, 300 | -- using one type-level list. 301 | type e `CouldBeAnyOfF` xs = All (Map (CouldBeF e) xs) 302 | 303 | -- | Listing larger variants' constraints might amplify the noise of 304 | -- functions' signatures. The 'CouldBeAnyOfF' constraint lets us specify 305 | -- several types a variant may contain in a single type-level list, as opposed 306 | -- to several independent constraints. So, we could replace, 307 | -- 308 | -- f :: (e `CouldBe` Int, e `CouldBe` Bool, e `CouldBe` Char) => VariantF IO e 309 | -- 310 | -- with the equivalent constraint, 311 | -- 312 | -- f :: e `CouldBeAnyOf` '[Int, Bool, Char] => VariantF IO e 313 | -- 314 | -- As 'CouldBeAnyOf' is just short-hand, we can use 'throw' just like when we 315 | -- have 'CouldBe' constraints: 316 | -- 317 | -- >>> :set -XTypeOperators 318 | -- >>> :{ 319 | -- f :: e `CouldBeAnyOf` '[Int, Bool, Char] => Variant e 320 | -- f = throw 'c' 321 | -- :} 322 | -- 323 | -- ... and eliminate constraints in just the same way: 324 | -- 325 | -- >>> :{ 326 | -- g :: e `CouldBeAnyOf` '[Int, Bool] => Either (Variant e) Char 327 | -- g = catch @Char f 328 | -- :} 329 | type e `CouldBeAnyOf` xs = All (Map (CouldBe e) xs) 330 | 331 | -- | This is an odd constraint, as you should rarely need to /see/ it. GHC's 332 | -- partial instantiation tricks should mean that mentions of this class "cancel 333 | -- out" mentions of 'CouldBeF'. As an example, let's imagine a function that 334 | -- represents some business logic that potentially "throws" either an 'Int' or 335 | -- 'Bool' while it runs: 336 | -- 337 | -- >>> :set -XFlexibleContexts -XMonoLocalBinds -XTypeOperators 338 | -- >>> :{ 339 | -- f :: (e `CouldBe` Int, e `CouldBe` Bool) => VariantF IO e 340 | -- f = throwF (pure True) 341 | -- :} 342 | -- 343 | -- As we can see, there are two constraints here. However, if we "catch" one of 344 | -- these possible errors, we don't just add the 'CatchF' constraint: we /cancel 345 | -- out/ the constraint corresponding to the type we caught: 346 | -- 347 | -- >>> :{ 348 | -- g :: e `CouldBe` Int => Either (VariantF IO e) (IO Bool) 349 | -- g = catchF @Bool f 350 | -- :} 351 | -- 352 | -- This means that constraints only propagate for __uncaught__ exceptions, just 353 | -- as Java functions only need declare exceptions they /haven't/ caught. Once 354 | -- we've caught all the errors, the constraint disappears! This can be a nice 355 | -- way to work if you combine it with something like @ExceptT@. 356 | class CatchF x xs ys | xs x -> ys, xs ys -> x, x ys -> xs where 357 | catchF :: VariantF f xs -> Either (VariantF f ys) (f x) 358 | 359 | instance CatchF x (x ': xs) xs where 360 | catchF = \case 361 | Here x -> Right x 362 | There xs -> Left xs 363 | 364 | instance {-# INCOHERENT #-} (y ~ z, CatchF x xs ys) 365 | => CatchF x (y ': xs) (z ': ys) where 366 | catchF = \case 367 | There xs -> first There (catchF xs) 368 | Here _ -> 369 | error $ "Impossible case - something isn't happy when performing the " 370 | <> "exhaustivity check as this case shouldn't need a pattern-match." 371 | 372 | -- | 'throwF' is to 'catchF' as 'throw' is to @catch@. This function allows us 373 | -- to discharge constraints for 'Variant' types. We can revisit the 'catchF' 374 | -- example without the functor wrapper: 375 | -- 376 | -- >>> :{ 377 | -- f :: (e `CouldBe` Int, e `CouldBe` Bool) => Variant e 378 | -- f = throw True 379 | -- :} 380 | -- 381 | -- ... and be similarly excited when we make one of the constraints disappear: 382 | -- 383 | -- >>> :{ 384 | -- g :: e `CouldBe` Int => Either (Variant e) Bool 385 | -- g = catch @Bool f 386 | -- :} 387 | class CatchF x xs ys => Catch (x :: Type) (xs :: [Type]) (ys :: [Type]) where 388 | catch :: Variant xs -> Either (Variant ys) x 389 | 390 | instance CatchF x xs ys => Catch x xs ys where 391 | catch = fmap runIdentity . catchF 392 | 393 | -- | Occasionally, we might want to use our "nested 'Either'" analogue for 394 | -- whatever reason. For that situation the functions here allow you to swap 395 | -- between the two representations. 396 | -- 397 | -- > > > :t toEithersF @IO @'[String, Int, Bool] 398 | -- toEithersF @IO @'[String, Int, Bool] 399 | -- :: VariantF IO '[String, Int, Bool] 400 | -- -> Either (IO [Char]) (Either (IO Int) (IO Bool)) 401 | -- 402 | -- In order to maintain the round-tripping property (see below), the functional 403 | -- dependency only goes from the variant to the nested either. This is because 404 | -- the opposite doesn't always necessarily make sense. 405 | -- 406 | -- If @Variant '[a, b]@ is converted to @Either a b@, it would seem sensible to 407 | -- say the opposite is equally as mechanical. However, consider a nesting like 408 | -- @Either a (Either b c)@: should this translate to @Variant '[a, b, c]@ or 409 | -- @Variant '[a, Either b c]@? There's not a unique mapping in this direction, 410 | -- so we can't add the functional dependency. 411 | class EithersF (f :: Type -> Type) (xs :: [Type]) (o :: Type) 412 | | f xs -> o, o f -> xs where 413 | toEithersF :: VariantF f xs -> o 414 | fromEithersF :: o -> VariantF f xs 415 | 416 | instance EithersF f '[x] (f x) where 417 | toEithersF = variantF id \_ -> 418 | error $ "Impossible case - something isn't happy when performing the " 419 | <> "exhaustivity check as this case shouldn't need a pattern-match." 420 | 421 | fromEithersF = Here 422 | 423 | instance (Functor f, EithersF f (y ': xs) zs) 424 | => EithersF f (x ': y ': xs) (Either (f x) zs) where 425 | toEithersF = variantF Left (Right . toEithersF) 426 | fromEithersF = either Here (There . fromEithersF) 427 | 428 | -- | The @f@-less analogue of 'EithersF'. The same properties as described 429 | -- above will hold, with the same issues around 'fromEithers' result inference. 430 | -- 431 | -- > > > :t toEithers @'[String, Int, Bool] 432 | -- toEithers @'[String, Int, Bool] 433 | -- :: Variant '[String, Int, Bool] -> Either [Char] (Either Int Bool) 434 | -- 435 | -- The round-tripping property is also conserved: 436 | class Eithers (xs :: [Type]) (o :: Type) | xs -> o where 437 | toEithers :: Variant xs -> o 438 | fromEithers :: o -> Variant xs 439 | 440 | instance Eithers '[x] x where 441 | toEithers = variant id \_ -> 442 | error $ "Impossible case - something isn't happy when performing the " 443 | <> "exhaustivity check as this case shouldn't need a pattern-match." 444 | 445 | fromEithers = Here . Identity 446 | 447 | instance Eithers (y ': xs) zs => Eithers (x ': y ': xs) (Either x zs) where 448 | toEithers = variant Left (Right . toEithers) 449 | fromEithers = either (Here . Identity) (There . fromEithers) 450 | 451 | -- | A constraint-based fold requires a polymorphic function relying on a 452 | -- shared constraint between all members of the variant. If that's a lot of 453 | -- words, let's see a little example: 454 | -- 455 | -- >>> foldF @Show (throwF ["hello"] :: VariantF [] '[(), String, Bool]) show 456 | -- "[\"hello\"]" 457 | -- 458 | -- If everything in our variant is 'Show'-friendly, we can fold it with the 459 | -- 'show' function, and we just show whatever is in there! 460 | class FoldF (c :: Type -> Constraint) (xs :: [Type]) where 461 | foldF :: VariantF f xs -> (forall x. c x => f x -> m) -> m 462 | 463 | instance FoldF c '[] where 464 | foldF xs _ = absurd (preposterous xs) 465 | 466 | instance (c x, FoldF c xs) => FoldF c (x ': xs) where 467 | foldF (Here x ) f = f x 468 | foldF (There xs) f = foldF @c xs f 469 | 470 | -- | Similarly, we can fold the wrapper-less version in the same way. As an 471 | -- example, if all the types are the same, we can pull out whatever value is in 472 | -- there using the fold interface. 473 | -- 474 | -- >>> :set -XRankNTypes -XScopedTypeVariables 475 | -- >>> :{ 476 | -- fold' :: forall x xs. Fold ((~) x) xs => Variant xs -> x 477 | -- fold' xs = fold @((~) x) xs id 478 | -- :} 479 | -- 480 | -- If all the types in the list are the same, and we can turn values of that 481 | -- type into some result and return it. 482 | class FoldF c xs => Fold (c :: Type -> Constraint) (xs :: [Type]) where 483 | fold :: Variant xs -> (forall x. c x => x -> m) -> m 484 | 485 | instance FoldF c xs => Fold c xs where 486 | fold xs f = foldF @c xs (f . runIdentity) 487 | 488 | -- | A choice of zero types is an uninhabited type! This means we can convert 489 | -- it to 'Void'... 490 | preposterous :: VariantF f '[] -> Void 491 | preposterous = \case 492 | 493 | -- | ... and it also means we can convert back! 494 | postposterous :: Void -> VariantF f '[] 495 | postposterous = \case 496 | 497 | instance (EithersF f xs nested, Arbitrary nested) => Arbitrary (VariantF f xs) where 498 | arbitrary = fmap fromEithersF arbitrary 499 | -------------------------------------------------------------------------------- /test/Data/VariantSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Data.VariantSpec (spec) where 7 | 8 | import HaskellWorks.Hspec.Hedgehog (require) 9 | import Hedgehog ((===), forAll, property) 10 | import Test.Hspec (describe, it, Spec) 11 | 12 | import qualified Data.Variant as DV 13 | import qualified Hedgehog.Gen.QuickCheck as G 14 | 15 | {- HLINT ignore "Redundant do" -} 16 | 17 | spec :: Spec 18 | spec = describe "Data.VariantSpec" $ do 19 | it "VariantF" $ require $ property $ do 20 | x <-forAll $ G.arbitrary @(DV.VariantF Maybe '[Int, String]) 21 | 22 | DV.fromEithersF (DV.toEithersF x) === x 23 | it "Variant" $ require $ property $ do 24 | x <-forAll $ G.arbitrary @(DV.Variant '[Int, String, Bool]) 25 | 26 | DV.fromEithersF (DV.toEithersF x) === x 27 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------