├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── example ├── Api.hs ├── Client.hs ├── Docs.hs └── Server.hs ├── src └── Data │ ├── WorldPeace.hs │ └── WorldPeace │ ├── Internal.hs │ ├── Internal │ └── Prism.hs │ ├── Product.hs │ └── Union.hs ├── stack.yaml ├── stack.yaml.lock ├── test ├── DocTest.hs ├── Spec.hs └── Test │ └── TypeErrors.hs └── world-peace.cabal /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [master] 8 | 9 | jobs: 10 | cabal: 11 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | os: [ubuntu-latest, macOS-latest] 16 | cabal: ["latest"] 17 | ghc: 18 | - "8.6.5" 19 | - "8.8.3" 20 | - "8.10.1" 21 | 22 | steps: 23 | - uses: actions/checkout@v2 24 | #if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 25 | 26 | - uses: actions/setup-haskell@v1.1 27 | id: setup-haskell-cabal 28 | name: Setup Haskell 29 | with: 30 | ghc-version: ${{ matrix.ghc }} 31 | cabal-version: ${{ matrix.cabal }} 32 | 33 | - uses: actions/cache@v1 34 | name: Cache cabal-store 35 | with: 36 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 37 | key: ${{ runner.os }}-${{ matrix.ghc }}-cabal 38 | 39 | - name: Build 40 | run: | 41 | cabal update 42 | cabal build all --enable-tests --enable-benchmarks --write-ghc-environment-files=always 43 | 44 | - name: Test 45 | run: | 46 | cabal test all --enable-tests 47 | 48 | stack: 49 | name: stack / ghc ${{ matrix.ghc }} 50 | runs-on: ubuntu-latest 51 | strategy: 52 | matrix: 53 | stack: ["latest"] 54 | 55 | steps: 56 | - uses: actions/checkout@v2 57 | #if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 58 | 59 | - uses: actions/setup-haskell@v1.1 60 | name: Setup Haskell Stack 61 | with: 62 | stack-version: ${{ matrix.stack }} 63 | 64 | - uses: actions/cache@v1 65 | name: Cache ~/.stack 66 | with: 67 | path: ~/.stack 68 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 69 | 70 | - name: Build 71 | run: | 72 | stack build --test --bench --no-run-tests --no-run-benchmarks 73 | 74 | - name: Test 75 | run: | 76 | stack test 77 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 1.0.2.0 2 | 3 | * Get building on GHC-8.10 by quantifying kind in some type class instances. 4 | Thanks [@ocharles](https://github.com/ocharles)! 5 | [#8](https://github.com/cdepillabout/world-peace/pull/8) 6 | 7 | ## 1.0.1.0 8 | 9 | * Update `IsMember` to show a nice custom type error. Thanks @chshersh! [#5] 10 | 11 | ## 1.0.0.0 12 | 13 | * Add the functions `relaxOpenUnion` and `relaxUnion` for being able to add 14 | additional types to an `OpenUnion`. [#3] 15 | * Add the functions `openUnionRemove`, `unionRemove`, `openUnionHandle`, and 16 | `unionHandle` for being able to pull individual types out of an 17 | `OpenUnion`. [#3] 18 | 19 | ## 0.1.0.0 20 | 21 | * Initial release. 22 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Dennis Gosnell (c) 2017-2018 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 Author name here 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build build-example clean dump-splices dump-th example-client example-docs example-server ghci haddock haddock-server lint test upload watch watch-example watch-haddock watch-test 2 | all: build 3 | 4 | build: 5 | stack build 6 | 7 | clean: 8 | stack clean 9 | 10 | # dump the template haskell 11 | dump-splices: dump-th 12 | dump-th: 13 | mkdir -p test/test-dir/empty-dir 14 | -stack build --ghc-options="-ddump-splices" 15 | @echo 16 | @echo "Splice files:" 17 | @echo 18 | @find "$$(stack path --dist-dir)" -name "*.dump-splices" | sort 19 | 20 | haddock: 21 | stack build --haddock 22 | 23 | # Run ghci using stack. 24 | ghci: 25 | stack ghci 26 | 27 | test: 28 | stack test 29 | 30 | # Run hlint. 31 | lint: 32 | hlint src/ 33 | 34 | # This runs a small python websever on port 8001 serving up haddocks for 35 | # packages you have installed. 36 | # 37 | # In order to run this, you need to have run `make build-haddock`. 38 | haddock-server: 39 | cd "$$(stack path --local-doc-root)" && python -m http.server 8001 40 | 41 | # Upload this package to hackage. 42 | upload: 43 | stack upload . 44 | 45 | # Watch for changes. 46 | watch: 47 | stack build --file-watch --fast . 48 | 49 | watch-haddock: 50 | stack build --haddock --file-watch --fast . 51 | 52 | watch-test: 53 | stack test --file-watch --fast . 54 | 55 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Data.WorldPeace 3 | ========================== 4 | 5 | [![Build Status](https://github.com/cdepillabout/world-peace/workflows/CI/badge.svg)](https://github.com/cdepillabout/world-peace/actions) 6 | [![Hackage](https://img.shields.io/hackage/v/world-peace.svg)](https://hackage.haskell.org/package/world-peace) 7 | [![Stackage LTS](http://stackage.org/package/world-peace/badge/lts)](http://stackage.org/lts/package/world-peace) 8 | [![Stackage Nightly](http://stackage.org/package/world-peace/badge/nightly)](http://stackage.org/nightly/package/world-peace) 9 | ![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) 10 | 11 | This package defines open union and open product types. It also defines many 12 | combinators for working with these types. 13 | 14 | See the [hackage documentation](https://hackage.haskell.org/package/world-peace) 15 | for more explanation and examples. 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Api where 9 | 10 | import Data.Aeson 11 | (FromJSON(parseJSON), ToJSON(toJSON), Value, withText) 12 | import Data.Aeson.Types (Parser) 13 | import Data.String (IsString) 14 | import Data.Text (unpack) 15 | import Network.HTTP.Types (Status, status400, status404) 16 | import Servant.API (Capture, JSON, Post, (:>), (:<|>)) 17 | import Text.Read (readMaybe) 18 | import Web.HttpApiData (FromHttpApiData, ToHttpApiData) 19 | 20 | import Servant.Checked.Exceptions (NoThrow, Throws) 21 | import Servant.Checked.Exceptions.Internal.Servant.API (ErrStatus(toErrStatus)) 22 | 23 | --------- 24 | -- API -- 25 | --------- 26 | 27 | -- | This is our main 'Api' type. We will create a server, a client, and 28 | -- documentation for this api. 29 | -- 30 | -- This api is composed of three routes, 'ApiStrictSearch', 'ApiLaxSearch', and 31 | -- 'ApiNoErrSearch'. 32 | type Api = ApiStrictSearch :<|> ApiLaxSearch :<|> ApiNoErrSearch 33 | 34 | -- | This is a strict search api. You pass it a @\"query\"@, and it returns a 35 | -- 'SearchResponse'. It potentially returns a 'BadSearchTermErr' if your query 36 | -- is not the string @\"hello\"@. It returns an 'IncorrectCapitialization' 37 | -- error if your query is not capitalized like @\"Hello\"@. 38 | -- 39 | -- Notice how we are using 'Throws' to indicate we will potentially throw an 40 | -- error. Also, notice how we can list multiple 'Throws'. 41 | type ApiStrictSearch = 42 | "strict-search" :> 43 | Capture "query" SearchQuery :> 44 | Throws BadSearchTermErr :> 45 | Throws IncorrectCapitalization :> 46 | Post '[JSON] SearchResponse 47 | 48 | -- | This is similar to 'ApiStrictSearch', but it doesn't force the query to be 49 | -- capitalized correctly. It only returns a 'BadSearchTermErr'. 50 | type ApiLaxSearch = 51 | "lax-search" :> 52 | Capture "query" SearchQuery :> 53 | Throws BadSearchTermErr :> 54 | Post '[JSON] SearchResponse 55 | 56 | -- | This is similar to 'ApiLaxSearch', but it doesn't force the query to use 57 | -- correct terms. It does not return an error. 58 | type ApiNoErrSearch = 59 | "no-err-search" :> 60 | Capture "query" SearchQuery :> 61 | NoThrow :> 62 | Post '[JSON] SearchResponse 63 | 64 | ------------------------------ 65 | -- Parameters and Responses -- 66 | ------------------------------ 67 | 68 | -- | This 'SearchQuery' type is just a newtype wrapper around a 'String'. 69 | newtype SearchQuery = SearchQuery 70 | { unSearchQuery :: String 71 | } deriving ( Eq 72 | , FromHttpApiData 73 | , FromJSON 74 | , IsString 75 | , Ord 76 | , Read 77 | , Show 78 | , ToHttpApiData 79 | , ToJSON 80 | ) 81 | 82 | -- | This 'SearchResponse' type is just a newtype wrapper around a 'String'. 83 | newtype SearchResponse = SearchResponse 84 | { unSearchResponse :: String 85 | } deriving ( Eq 86 | , FromHttpApiData 87 | , FromJSON 88 | , IsString 89 | , Ord 90 | , Read 91 | , Show 92 | , ToHttpApiData 93 | , ToJSON 94 | ) 95 | 96 | ------------ 97 | -- Errors -- 98 | ------------ 99 | 100 | -- | This error is returned when the search query is not the string @\"hello\"@. 101 | data BadSearchTermErr = BadSearchTermErr deriving (Eq, Read, Show) 102 | 103 | instance ToJSON BadSearchTermErr where 104 | toJSON :: BadSearchTermErr -> Value 105 | toJSON = toJSON . show 106 | 107 | instance FromJSON BadSearchTermErr where 108 | parseJSON :: Value -> Parser BadSearchTermErr 109 | parseJSON = withText "BadSearchTermErr" $ 110 | maybe (fail "could not parse as BadSearchTermErr") pure . readMaybe . unpack 111 | 112 | instance ErrStatus BadSearchTermErr where 113 | toErrStatus :: BadSearchTermErr -> Status 114 | toErrStatus _ = status404 115 | 116 | -- | This error is returned when the search query is @\"hello\"@, but it is not 117 | -- capitalized correctly. For example, the search query @\"hello\"@ will 118 | -- return an 'IncorrectCapitialization' error. However, the search query 119 | -- @\"Hello\"@ will return a success. 120 | data IncorrectCapitalization = IncorrectCapitalization deriving (Eq, Read, Show) 121 | 122 | instance ToJSON IncorrectCapitalization where 123 | toJSON :: IncorrectCapitalization -> Value 124 | toJSON = toJSON . show 125 | 126 | instance FromJSON IncorrectCapitalization where 127 | parseJSON :: Value -> Parser IncorrectCapitalization 128 | parseJSON = withText "IncorrectCapitalization" $ 129 | maybe (fail "could not parse as IncorrectCapitalization") pure . readMaybe . unpack 130 | 131 | instance ErrStatus IncorrectCapitalization where 132 | toErrStatus :: IncorrectCapitalization -> Status 133 | toErrStatus _ = status400 134 | 135 | ---------- 136 | -- Port -- 137 | ---------- 138 | 139 | -- | The port to run the server on. 140 | port :: Int 141 | port = 8201 142 | -------------------------------------------------------------------------------- /example/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE InstanceSigs #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Main where 19 | 20 | import Data.Monoid ((<>)) 21 | import Data.Proxy (Proxy(Proxy)) 22 | import Network.HTTP.Client (defaultManagerSettings, newManager) 23 | import Options.Applicative 24 | (Parser, (<**>), argument, execParser, fullDesc, help, helper, info, long, 25 | metavar, progDesc, short, str, switch) 26 | import Servant.API ((:<|>)((:<|>))) 27 | import Servant.Client 28 | (BaseUrl(BaseUrl), ClientEnv(ClientEnv), ClientM, Scheme(Http), 29 | client, runClientM) 30 | 31 | import Servant.Checked.Exceptions (Envelope, emptyEnvelope, catchesEnvelope) 32 | 33 | import Api 34 | (Api, BadSearchTermErr(BadSearchTermErr), 35 | IncorrectCapitalization(IncorrectCapitalization), 36 | SearchQuery(SearchQuery), SearchResponse(SearchResponse), port) 37 | 38 | ----------------------------------------- 39 | -- Clients generated by servant-client -- 40 | ----------------------------------------- 41 | 42 | -- We generate the client functions just like normal. Note that when we use 43 | -- 'Throws' or 'NoThrow', the client functions get generated with the 44 | -- 'Envelope' type. 45 | 46 | strictSearch 47 | :: SearchQuery 48 | -> ClientM (Envelope '[BadSearchTermErr, IncorrectCapitalization] SearchResponse) 49 | laxSearch 50 | :: SearchQuery 51 | -> ClientM (Envelope '[BadSearchTermErr] SearchResponse) 52 | noErrSearch 53 | :: SearchQuery 54 | -> ClientM (Envelope '[] SearchResponse) 55 | strictSearch :<|> laxSearch :<|> noErrSearch = client (Proxy :: Proxy Api) 56 | 57 | -------------------------------------- 58 | -- Command-line options and parsers -- 59 | -------------------------------------- 60 | 61 | -- The following are needed for using optparse-applicative to parse command 62 | -- line arguments. Most people shouldn't need to worry about how this works. 63 | 64 | data Options = Options { query :: String, useStrict :: Bool, useNoErr :: Bool } 65 | 66 | queryParser :: Parser String 67 | queryParser = argument str (metavar "QUERY") 68 | 69 | useStrictParser :: Parser Bool 70 | useStrictParser = 71 | switch $ 72 | long "strict" <> short 's' <> help "Whether or not to use the strict api" 73 | 74 | useNoErrParser :: Parser Bool 75 | useNoErrParser = 76 | switch $ 77 | long "no-err" <> 78 | short 'n' <> 79 | help "Whether or not to use the api that does not return an error" 80 | 81 | commandParser :: Parser Options 82 | commandParser = Options <$> queryParser <*> useStrictParser <*> useNoErrParser 83 | 84 | ------------------------------------------------------------------------- 85 | -- Command Runners (these use the clients generated by servant-client) -- 86 | ------------------------------------------------------------------------- 87 | 88 | -- | This function uses the 'strictSearch' function to send a 'SearchQuery' to 89 | -- the server. 90 | -- 91 | -- Note how 'catchesEnvelope' is used to handle the two error reponses and the 92 | -- success response. 93 | runStrict :: ClientEnv -> String -> IO () 94 | runStrict clientEnv query = do 95 | eitherRes <- runClientM (strictSearch $ SearchQuery query) clientEnv 96 | case eitherRes of 97 | Left servantErr -> putStrLn $ "Got a ServantErr: " <> show servantErr 98 | Right env -> 99 | putStrLn $ 100 | catchesEnvelope 101 | ( \BadSearchTermErr -> "the search term was not \"Hello\"" 102 | , \IncorrectCapitalization -> "the search term was not capitalized correctly" 103 | ) 104 | (\(SearchResponse searchResponse) -> "Success: " <> searchResponse) 105 | env 106 | 107 | -- | This function uses the 'laxSearch' function to send a 'SearchQuery' to 108 | -- the server. 109 | runLax :: ClientEnv -> String -> IO () 110 | runLax clientEnv query = do 111 | eitherRes <- runClientM (laxSearch $ SearchQuery query) clientEnv 112 | case eitherRes of 113 | Left servantErr -> putStrLn $ "Got a ServantErr: " <> show servantErr 114 | Right env -> 115 | putStrLn $ 116 | catchesEnvelope 117 | (\BadSearchTermErr -> "the search term was not \"Hello\"") 118 | (\(SearchResponse searchResponse) -> "Success: " <> searchResponse) 119 | env 120 | 121 | -- | This function uses the 'noErrSearch' function to send a 'SearchQuery' to 122 | -- the server. 123 | runNoErr :: ClientEnv -> String -> IO () 124 | runNoErr clientEnv query = do 125 | eitherRes <- runClientM (noErrSearch $ SearchQuery query) clientEnv 126 | case eitherRes of 127 | Left servantErr -> putStrLn $ "Got a ServantErr: " <> show servantErr 128 | Right env -> do 129 | let (SearchResponse res) = emptyEnvelope env 130 | putStrLn $ "Success: " <> res 131 | 132 | -- | Run 'runStrict', 'runLax', or 'runNoErr' depending on the command line options. 133 | run :: ClientEnv -> Options -> IO () 134 | run clientEnv Options{query, useStrict = True, useNoErr = _} = runStrict clientEnv query 135 | run clientEnv Options{query, useStrict = _, useNoErr = True} = runNoErr clientEnv query 136 | run clientEnv Options{query, useStrict = _, useNoErr = _} = runLax clientEnv query 137 | 138 | ---------- 139 | -- Main -- 140 | ---------- 141 | 142 | main :: IO () 143 | main = do 144 | manager <- newManager defaultManagerSettings 145 | let clientEnv = ClientEnv manager baseUrl 146 | options <- execParser opts 147 | run clientEnv options 148 | where 149 | opts = info (commandParser <**> helper) $ 150 | fullDesc <> 151 | progDesc "Send the QUERY to the example server and print the response." 152 | 153 | baseUrl :: BaseUrl 154 | baseUrl = BaseUrl Http "localhost" port "" 155 | -------------------------------------------------------------------------------- /example/Docs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE InstanceSigs #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | {-# OPTIONS_GHC -fno-warn-orphans #-} 17 | 18 | module Main where 19 | 20 | import Data.Proxy (Proxy(Proxy)) 21 | import Data.Text (Text) 22 | import Servant.API (Capture) 23 | import Servant.Docs 24 | (DocCapture(DocCapture), ToCapture(toCapture), ToSample(toSamples), 25 | docs, markdown) 26 | 27 | import Servant.Checked.Exceptions () 28 | 29 | import Api 30 | (Api, BadSearchTermErr(BadSearchTermErr), 31 | IncorrectCapitalization(IncorrectCapitalization), SearchQuery, 32 | SearchResponse) 33 | 34 | -- This module prints out documentation for 'Api'. 35 | -- 36 | -- Notice how we only need 'ToSample' instances for the two errors we are 37 | -- throwing with 'Throws': 'BadSearchTermErr' and 'IncorrectCapitialization'. 38 | -- We don't have to directly worry about writing instances for 'Envelope'. 39 | 40 | instance ToSample SearchResponse where 41 | toSamples :: Proxy SearchResponse -> [(Text, SearchResponse)] 42 | toSamples Proxy = [("This is a successful response.", "good")] 43 | 44 | instance ToCapture (Capture "query" SearchQuery) where 45 | toCapture :: Proxy (Capture "query" SearchQuery) -> DocCapture 46 | toCapture Proxy = 47 | DocCapture "query" "a search string like \"hello\" or \"bye\"" 48 | 49 | instance ToSample BadSearchTermErr where 50 | toSamples :: Proxy BadSearchTermErr -> [(Text, BadSearchTermErr)] 51 | toSamples Proxy = 52 | [("a completely incorrect search term was used", BadSearchTermErr)] 53 | 54 | instance ToSample IncorrectCapitalization where 55 | toSamples :: Proxy IncorrectCapitalization -> [(Text, IncorrectCapitalization)] 56 | toSamples Proxy = 57 | [ ( "the search term \"Hello\" has not been capitalized correctly" 58 | , IncorrectCapitalization) 59 | ] 60 | 61 | -- | Print the documentation rendered as markdown to stdout. 62 | main :: IO () 63 | main = putStrLn . markdown $ docs (Proxy :: Proxy Api) 64 | -------------------------------------------------------------------------------- /example/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE InstanceSigs #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Main where 18 | 19 | import Data.Char (toLower) 20 | import Data.Proxy (Proxy(Proxy)) 21 | import Network.Wai (Application) 22 | import Network.Wai.Handler.Warp (run) 23 | import Servant (Handler, (:<|>)((:<|>)), ServerT, serve) 24 | 25 | import Servant.Checked.Exceptions (Envelope, pureErrEnvelope, pureSuccEnvelope) 26 | 27 | import Api 28 | ( Api 29 | , BadSearchTermErr(BadSearchTermErr) 30 | , IncorrectCapitalization(IncorrectCapitalization) 31 | , SearchQuery(SearchQuery) 32 | , SearchResponse 33 | , port 34 | ) 35 | 36 | -- | This is our server root for the 'ServerT' for 'Api'. We only have two 37 | -- handlers, 'postStrictSearch' and 'postLaxSearch'. 38 | serverRoot :: ServerT Api Handler 39 | serverRoot = postStrictSearch :<|> postLaxSearch :<|> postNoErrSearch 40 | 41 | -- | This is the handler for 'Api.ApiStrictSearch'. 42 | -- 43 | -- If we get the 'SearchQuery' @\"Hello\"@, we return a 'SuccEnvelope'. 44 | -- However, if we get a search query like @\"hello\"@, we return an 45 | -- 'ErrEnvelope' with an 'IncorrectCapitialization' error. If we get a search 46 | -- query that is not @\"hello\"@, we return an 'ErrEnvelope' with a 47 | -- 'BadSearchTermErr'. 48 | -- 49 | -- Notice how we can use the polymorphic function 'pureErrEnvelope' to return 50 | -- either an 'IncorrectCapitialization' error, or a 'BadSearchTermErr', even 51 | -- though these two have different types. 52 | -- 53 | -- Also, notice how this function returns an 'Envelope' because we are using 54 | -- 'Throws' in the api definition. 55 | postStrictSearch 56 | :: SearchQuery 57 | -> Handler (Envelope '[BadSearchTermErr, IncorrectCapitalization] SearchResponse) 58 | postStrictSearch (SearchQuery "Hello") = pureSuccEnvelope "good" 59 | postStrictSearch (SearchQuery query) 60 | | fmap toLower query == "hello" = pureErrEnvelope IncorrectCapitalization 61 | | otherwise = pureErrEnvelope BadSearchTermErr 62 | 63 | -- | This is the handler for 'Api.ApiLaxSearch'. 64 | -- 65 | -- This is similar to 'postStrictSearch', but it doesn't require correct 66 | -- capitalization. 67 | postLaxSearch 68 | :: SearchQuery 69 | -> Handler (Envelope '[BadSearchTermErr] SearchResponse) 70 | postLaxSearch (SearchQuery query) 71 | | fmap toLower query == "hello" = pureSuccEnvelope "good" 72 | | otherwise = pureErrEnvelope BadSearchTermErr 73 | 74 | -- | This is the handler for 'Api.ApiNoErrSearch'. 75 | -- 76 | -- This is similar to 'postLaxSearch', but it doesn't require a correct search 77 | -- term. 78 | postNoErrSearch :: SearchQuery -> Handler (Envelope '[] SearchResponse) 79 | postNoErrSearch (SearchQuery _) = pureSuccEnvelope "good" 80 | 81 | -- | Create a WAI 'Application'. 82 | app :: Application 83 | app = serve (Proxy :: Proxy Api) serverRoot 84 | 85 | -- | Run the WAI 'Application' using 'run' on the port defined by 'port'. 86 | main :: IO () 87 | main = run port app 88 | -------------------------------------------------------------------------------- /src/Data/WorldPeace.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Data.WorldPeace 3 | 4 | Copyright : Dennis Gosnell 2017 5 | License : BSD3 6 | 7 | Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) 8 | Stability : experimental 9 | Portability : unknown 10 | 11 | This package defines a type called 'OpenUnion'. This represents an open union 12 | of possible types (also called an open sum type). 13 | 14 | Here is an example of taking a 'String', and lifting it up into an open union 15 | of a 'String' and 'Int': 16 | 17 | @ 18 | let int = 3 :: 'Int' 19 | let o = 'openUnionLift' int :: 'OpenUnion' \'['String', 'Int'] 20 | @ 21 | 22 | There are a couple different ways to pattern match on a 'OpenUnion'. 23 | 24 | The easiest one is to use 'catchesOpenUnion', which takes a tuple of handlers for 25 | each possible type in the 'OpenUnion': 26 | 27 | @ 28 | let strHandler = (\\str -> \"got a String: \" '++' str) :: 'String' -> 'String' 29 | intHandler = (\\int -> \"got an Int: \" '++' 'show' int) :: 'Int' -> 'String' 30 | in 'catchesOpenUnion' (strHandler, intHandler) u :: 'String' 31 | @ 32 | 33 | The above will print @got an Int: 3@. 34 | 35 | There is also the 'openUnionMatch' function, as well as 'fromOpenUnion' and 36 | 'openUnion'. Read the documentation below for more information. 37 | -} 38 | 39 | module Data.WorldPeace 40 | ( 41 | -- * 'OpenUnion' 42 | OpenUnion 43 | -- ** 'OpenUnion' Helpers 44 | , openUnion 45 | , fromOpenUnion 46 | , fromOpenUnionOr 47 | , openUnionPrism 48 | , openUnionLift 49 | , openUnionMatch 50 | , catchesOpenUnion 51 | , relaxOpenUnion 52 | , openUnionRemove 53 | , openUnionHandle 54 | , IsMember 55 | , Contains 56 | -- ** 'Union' (used by 'OpenUnion') 57 | -- | 'OpenUnion' is a type synonym around 'Union'. Most users will be able to 58 | -- work directly with 'OpenUnion' and ignore this 'Union' type. 59 | , Union(..) 60 | -- *** Union helpers 61 | , union 62 | , absurdUnion 63 | , umap 64 | , catchesUnion 65 | , relaxUnion 66 | , unionRemove 67 | , unionHandle 68 | -- *** Union optics 69 | , _This 70 | , _That 71 | -- *** Typeclasses used with Union 72 | , ElemRemove 73 | , Remove 74 | , Nat(Z, S) 75 | , RIndex 76 | , UElem(..) 77 | -- ** 'OpenProduct' 78 | -- | This 'OpenProduct' type is used to easily create a case-analysis for 79 | -- 'Union's. You can see it being used in 'catchesOpenUnion' and 80 | -- The 'ToProduct' type class makes it easy to convert a 81 | -- tuple to a 'Product'. This class is used so that the end user only has to worry 82 | -- about working with tuples, and can mostly ignore this 'Product' type. 83 | , OpenProduct 84 | , Product(..) 85 | , ToOpenProduct 86 | , tupleToOpenProduct 87 | , ToProduct 88 | , tupleToProduct 89 | , ReturnX 90 | ) where 91 | 92 | import Data.WorldPeace.Product 93 | import Data.WorldPeace.Union 94 | -------------------------------------------------------------------------------- /src/Data/WorldPeace/Internal.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.WorldPeace.Internal 3 | ( module X 4 | ) where 5 | 6 | import Data.WorldPeace.Internal.Prism as X 7 | -------------------------------------------------------------------------------- /src/Data/WorldPeace/Internal/Prism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | {- | 4 | Module : Data.WorldPeace.Internal.Prism 5 | License : BSD3 6 | Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) 7 | Stability : experimental 8 | Portability : unknown 9 | 10 | These functions are for working with Optics popularized by the 11 | package. Documentation can be 12 | found in the lens package. These functions are redefined here to remove the 13 | dependency on the lens package. 14 | -} 15 | 16 | module Data.WorldPeace.Internal.Prism 17 | ( Prism 18 | , prism 19 | , Prism' 20 | , prism' 21 | , Iso 22 | , iso 23 | , review 24 | , preview 25 | , (<>~) 26 | ) where 27 | 28 | import Data.Profunctor.Unsafe((#.)) 29 | import Control.Applicative 30 | import Data.Coerce 31 | import Data.Functor.Identity 32 | import Data.Monoid 33 | import Data.Profunctor 34 | import Data.Tagged 35 | 36 | type Iso s t a b 37 | = forall p f. (Profunctor p, Functor f) => 38 | p a (f b) -> p s (f t) 39 | 40 | type Prism s t a b 41 | = forall p f. (Choice p, Applicative f) => 42 | p a (f b) -> p s (f t) 43 | 44 | type Prism' s a = Prism s s a a 45 | 46 | type ASetter s t a b = (a -> Identity b) -> s -> Identity t 47 | 48 | iso :: (s -> a) -> (b -> t) -> Iso s t a b 49 | iso sa bt = dimap sa (fmap bt) 50 | {-# INLINE iso #-} 51 | 52 | prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b 53 | prism bt seta = dimap seta (either pure (fmap bt)) . right' 54 | {-# INLINE prism #-} 55 | 56 | prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a 57 | prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) 58 | {-# INLINE prism' #-} 59 | 60 | review :: Prism' t b -> b -> t 61 | review p = coerce . p . Tagged . Identity 62 | {-# INLINE review #-} 63 | 64 | preview :: Prism' s a -> s -> Maybe a 65 | preview l = coerce . l (Const . First . Just) 66 | {-# INLINE preview #-} 67 | 68 | over :: ASetter s t a b -> (a -> b) -> s -> t 69 | over l f = runIdentity #. l (Identity #. f) 70 | {-# INLINE over #-} 71 | 72 | infixr 4 <>~ 73 | (<>~) :: Monoid a => ASetter s t a a -> a -> s -> t 74 | l <>~ n = over l (`mappend` n) 75 | {-# INLINE (<>~) #-} 76 | -------------------------------------------------------------------------------- /src/Data/WorldPeace/Product.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | {- | 18 | Module : Data.WorldPeace.Product 19 | 20 | Copyright : Dennis Gosnell 2017 21 | License : BSD3 22 | 23 | Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) 24 | Stability : experimental 25 | Portability : unknown 26 | 27 | This module defines an open product type. This is used in the case-analysis 28 | handler for the open sum type ('Data.WorldPeace.Union.catchesUnion'). 29 | -} 30 | 31 | module Data.WorldPeace.Product 32 | where 33 | 34 | import Data.Functor.Identity (Identity(Identity)) 35 | 36 | -- $setup 37 | -- >>> -- :set -XDataKinds 38 | 39 | ------------- 40 | -- Product -- 41 | ------------- 42 | 43 | -- | An extensible product type. This is similar to 44 | -- 'Data.WorldPeace.Union.Union', except a product type 45 | -- instead of a sum type. 46 | data Product (f :: u -> *) (as :: [u]) where 47 | Nil :: Product f '[] 48 | Cons :: !(f a) -> Product f as -> Product f (a ': as) 49 | 50 | -- | This type class provides a way to turn a tuple into a 'Product'. 51 | class ToProduct (tuple :: *) (f :: u -> *) (as :: [u]) | f as -> tuple where 52 | -- | Convert a tuple into a 'Product'. See 'tupleToProduct' for examples. 53 | toProduct :: tuple -> Product f as 54 | 55 | -- | Convert a single value into a 'Product'. 56 | instance forall u (f :: u -> *) (a :: u). ToProduct (f a) f '[a] where 57 | toProduct :: f a -> Product f '[a] 58 | toProduct fa = Cons fa Nil 59 | 60 | -- | Convert a tuple into a 'Product'. 61 | instance forall u (f :: u -> *) (a :: u) (b :: u). ToProduct (f a, f b) f '[a, b] where 62 | toProduct :: (f a, f b) -> Product f '[a, b] 63 | toProduct (fa, fb) = Cons fa $ Cons fb Nil 64 | 65 | -- | Convert a 3-tuple into a 'Product'. 66 | instance forall u (f :: u -> *) (a :: u) (b :: u) (c :: u). ToProduct (f a, f b, f c) f '[a, b, c] where 67 | toProduct :: (f a, f b, f c) -> Product f '[a, b, c] 68 | toProduct (fa, fb, fc) = Cons fa $ Cons fb $ Cons fc Nil 69 | 70 | -- | Convert a 4-tuple into a 'Product'. 71 | instance forall u (f :: u -> *) (a :: u) (b :: u) (c :: u) (d :: u). ToProduct (f a, f b, f c, f d) f '[a, b, c, d] where 72 | toProduct :: (f a, f b, f c, f d) -> Product f '[a, b, c, d] 73 | toProduct (fa, fb, fc, fd) = Cons fa $ Cons fb $ Cons fc $ Cons fd Nil 74 | 75 | -- | Turn a tuple into a 'Product'. 76 | -- 77 | -- >>> tupleToProduct (Identity 1, Identity 2.0) :: Product Identity '[Int, Double] 78 | -- Cons (Identity 1) (Cons (Identity 2.0) Nil) 79 | tupleToProduct :: ToProduct t f as => t -> Product f as 80 | tupleToProduct = toProduct 81 | 82 | ----------------- 83 | -- OpenProduct -- 84 | ----------------- 85 | 86 | -- | @'Product' 'Identity'@ is used as a standard open product type. 87 | type OpenProduct = Product Identity 88 | 89 | -- | 'ToOpenProduct' gives us a way to convert a tuple to an 'OpenProduct'. 90 | -- See 'tupleToOpenProduct'. 91 | class ToOpenProduct (tuple :: *) (as :: [*]) | as -> tuple where 92 | toOpenProduct :: tuple -> OpenProduct as 93 | 94 | -- | Convert a single value into an 'OpenProduct'. 95 | instance forall (a :: *). ToOpenProduct a '[a] where 96 | toOpenProduct :: a -> OpenProduct '[a] 97 | toOpenProduct a = Cons (Identity a) Nil 98 | 99 | -- | Convert a tuple into an 'OpenProduct'. 100 | instance 101 | forall (a :: *) (b :: *). ToOpenProduct (a, b) '[a, b] where 102 | toOpenProduct :: (a, b) -> OpenProduct '[a, b] 103 | toOpenProduct (a, b) = Cons (Identity a) $ Cons (Identity b) Nil 104 | 105 | -- | Convert a 3-tuple into an 'OpenProduct'. 106 | instance 107 | forall (a :: *) (b :: *) (c :: *). ToOpenProduct (a, b, c) '[a, b, c] where 108 | toOpenProduct :: (a, b, c) -> OpenProduct '[a, b, c] 109 | toOpenProduct (a, b, c) = 110 | Cons (Identity a) $ Cons (Identity b) $ Cons (Identity c) Nil 111 | 112 | -- | Convert a 4-tuple into an 'OpenProduct'. 113 | instance 114 | forall (a :: *) (b :: *) (c :: *) (d :: *). 115 | ToOpenProduct (a, b, c, d) '[a, b, c, d] where 116 | toOpenProduct :: (a, b, c, d) -> OpenProduct '[a, b, c, d] 117 | toOpenProduct (a, b, c, d) = 118 | Cons (Identity a) 119 | . Cons (Identity b) 120 | . Cons (Identity c) 121 | $ Cons (Identity d) Nil 122 | 123 | -- | Turn a tuple into an 'OpenProduct'. 124 | -- 125 | -- ==== __Examples__ 126 | -- 127 | -- Turn a triple into an 'OpenProduct': 128 | -- 129 | -- >>> tupleToOpenProduct (1, 2.0, "hello") :: OpenProduct '[Int, Double, String] 130 | -- Cons (Identity 1) (Cons (Identity 2.0) (Cons (Identity "hello") Nil)) 131 | -- 132 | -- Turn a single value into an 'OpenProduct': 133 | -- 134 | -- >>> tupleToOpenProduct 'c' :: OpenProduct '[Char] 135 | -- Cons (Identity 'c') Nil 136 | tupleToOpenProduct :: ToOpenProduct t as => t -> OpenProduct as 137 | tupleToOpenProduct = toOpenProduct 138 | 139 | --------------- 140 | -- Instances -- 141 | --------------- 142 | 143 | -- | Show 'Nil' values. 144 | instance Show (Product f '[]) where 145 | show :: Product f '[] -> String 146 | show Nil = "Nil" 147 | 148 | -- | Show 'Cons' values. 149 | instance (Show (f a), Show (Product f as)) => Show (Product f (a ': as)) where 150 | showsPrec :: Int -> (Product f (a ': as)) -> String -> String 151 | showsPrec n (Cons fa prod) = showParen (n > 10) $ 152 | showString "Cons " . showsPrec 11 fa . showString " " . showsPrec 11 prod 153 | -------------------------------------------------------------------------------- /src/Data/WorldPeace/Union.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | {-# LANGUAGE UndecidableInstances #-} 19 | 20 | {- | 21 | Module : Data.WorldPeace.Union 22 | 23 | Copyright : Dennis Gosnell 2017 24 | License : BSD3 25 | 26 | Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) 27 | Stability : experimental 28 | Portability : unknown 29 | 30 | This module defines extensible sum-types. This is similar to how 31 | defines extensible records. 32 | 33 | A large portion of the code from this module was taken from the 34 | package. 35 | -} 36 | 37 | module Data.WorldPeace.Union 38 | ( 39 | -- * Union 40 | Union(..) 41 | , union 42 | , catchesUnion 43 | , absurdUnion 44 | , umap 45 | , relaxUnion 46 | , unionRemove 47 | , unionHandle 48 | -- ** Optics 49 | , _This 50 | , _That 51 | -- ** Typeclasses 52 | , Nat(Z, S) 53 | , RIndex 54 | , ReturnX 55 | , UElem(..) 56 | , IsMember 57 | , Contains 58 | , Remove 59 | , ElemRemove 60 | -- * OpenUnion 61 | , OpenUnion 62 | , openUnion 63 | , fromOpenUnion 64 | , fromOpenUnionOr 65 | , openUnionPrism 66 | , openUnionLift 67 | , openUnionMatch 68 | , catchesOpenUnion 69 | , relaxOpenUnion 70 | , openUnionRemove 71 | , openUnionHandle 72 | -- * Setup code for doctests 73 | -- $setup 74 | ) where 75 | 76 | import Control.Applicative ((<|>)) 77 | import Control.DeepSeq (NFData(rnf)) 78 | import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Value) 79 | import Data.Aeson.Types (Parser) 80 | import Data.Functor.Identity (Identity(Identity, runIdentity)) 81 | import Data.Kind (Constraint) 82 | import Data.Proxy 83 | import Data.Type.Bool (If) 84 | import Data.Typeable (Typeable) 85 | import GHC.TypeLits (ErrorMessage(..), TypeError) 86 | import Text.Read (Read(readPrec), ReadPrec, (<++)) 87 | 88 | import Data.WorldPeace.Internal.Prism 89 | ( Prism 90 | , Prism' 91 | , iso 92 | , preview 93 | , prism 94 | , prism' 95 | , review 96 | ) 97 | import Data.WorldPeace.Product 98 | ( Product(Cons, Nil) 99 | , ToOpenProduct 100 | , ToProduct 101 | , tupleToOpenProduct 102 | , tupleToProduct 103 | ) 104 | 105 | -- $setup 106 | -- >>> :set -XConstraintKinds 107 | -- >>> :set -XDataKinds 108 | -- >>> :set -XGADTs 109 | -- >>> :set -XKindSignatures 110 | -- >>> :set -XTypeOperators 111 | -- >>> import Data.Text (Text) 112 | -- >>> import Text.Read (readMaybe) 113 | -- >>> import Data.Type.Equality ((:~:)(Refl)) 114 | 115 | ------------------------ 116 | -- Type-level helpers -- 117 | ------------------------ 118 | 119 | -- | A partial relation that gives the index of a value in a list. 120 | -- 121 | -- ==== __Examples__ 122 | -- 123 | -- Find the first item: 124 | -- 125 | -- >>> Refl :: RIndex String '[String, Int] :~: 'Z 126 | -- Refl 127 | -- 128 | -- Find the third item: 129 | -- 130 | -- >>> Refl :: RIndex Char '[String, Int, Char] :~: 'S ('S 'Z) 131 | -- Refl 132 | type family RIndex (r :: k) (rs :: [k]) :: Nat where 133 | RIndex r (r ': rs) = 'Z 134 | RIndex r (s ': rs) = 'S (RIndex r rs) 135 | 136 | -- | Text of the error message. 137 | type NoElementError (r :: k) (rs :: [k]) = 138 | 'Text "You require open sum type to contain the following element:" 139 | ':$$: 'Text " " ':<>: 'ShowType r 140 | ':$$: 'Text "However, given list can store elements only of the following types:" 141 | ':$$: 'Text " " ':<>: 'ShowType rs 142 | 143 | -- | This type family checks whether @a@ is inside @as@ and produces 144 | -- compile-time error if not. 145 | type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where 146 | CheckElemIsMember a as = 147 | If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as)) 148 | 149 | -- | Type-level version of the 'elem' function. 150 | -- 151 | -- >>> Refl :: Elem String '[Double, String, Char] :~: 'True 152 | -- Refl 153 | -- >>> Refl :: Elem String '[Double, Char] :~: 'False 154 | -- Refl 155 | type family Elem (x :: k) (xs :: [k]) :: Bool where 156 | Elem _ '[] = 'False 157 | Elem x (x ': xs) = 'True 158 | Elem x (y ': xs) = Elem x xs 159 | 160 | -- | Change a list of types into a list of functions that take the given type 161 | -- and return @x@. 162 | -- 163 | -- >>> Refl :: ReturnX Double '[String, Int] :~: '[String -> Double, Int -> Double] 164 | -- Refl 165 | -- 166 | -- Don't do anything with an empty list: 167 | -- 168 | -- >>> Refl :: ReturnX Double '[] :~: '[] 169 | -- Refl 170 | type family ReturnX x as where 171 | ReturnX x (a ': as) = ((a -> x) ': ReturnX x as) 172 | ReturnX x '[] = '[] 173 | 174 | -- | A mere approximation of the natural numbers. And their image as lifted by 175 | -- @-XDataKinds@ corresponds to the actual natural numbers. 176 | data Nat = Z | S !Nat 177 | 178 | -- | This is a helpful 'Constraint' synonym to assert that @a@ is a member of 179 | -- @as@. You can see how it is used in functions like 'openUnionLift'. 180 | type IsMember (a :: u) (as :: [u]) = (CheckElemIsMember a as, UElem a as (RIndex a as)) 181 | 182 | -- | A type family to assert that all of the types in a list are contained 183 | -- within another list. 184 | -- 185 | -- >>> Refl :: Contains '[String] '[String, Char] :~: (IsMember String '[String, Char], (() :: Constraint)) 186 | -- Refl 187 | -- 188 | -- >>> Refl :: Contains '[] '[Int, Char] :~: (() :: Constraint) 189 | -- Refl 190 | type family Contains (as :: [k]) (bs :: [k]) :: Constraint where 191 | Contains '[] _ = () 192 | Contains (a ': as) bs = (IsMember a bs, Contains as bs) 193 | 194 | ----------------------------- 195 | -- Union (from Data.Union) -- 196 | ----------------------------- 197 | 198 | -- | A 'Union' is parameterized by a universe @u@, an interpretation @f@ 199 | -- and a list of labels @as@. The labels of the union are given by 200 | -- inhabitants of the kind @u@; the type of values at any label @a :: 201 | -- u@ is given by its interpretation @f a :: *@. 202 | -- 203 | -- What does this mean in practice? It means that a type like 204 | -- @'Union' 'Identity' \'['String', 'Int']@ can be _either_ an 205 | -- @'Identity' 'String'@ or an @'Identity' 'Int'@. 206 | -- 207 | -- You need to pattern match on the 'This' and 'That' constructors to figure 208 | -- out whether you are holding a 'String' or 'Int': 209 | -- 210 | -- >>> let u = That (This (Identity 1)) :: Union Identity '[String, Int] 211 | -- >>> :{ 212 | -- case u of 213 | -- This (Identity str) -> "we got a string: " ++ str 214 | -- That (This (Identity int)) -> "we got an int: " ++ show int 215 | -- :} 216 | -- "we got an int: 1" 217 | -- 218 | -- There are multiple functions that let you perform this pattern matching 219 | -- easier: 'union', 'catchesUnion', 'unionMatch' 220 | -- 221 | -- There is also a type synonym 'OpenUnion' for the common case of 222 | -- @'Union' 'Indentity'@, as well as helper functions for working with it. 223 | data Union (f :: u -> *) (as :: [u]) where 224 | This :: !(f a) -> Union f (a ': as) 225 | That :: !(Union f as) -> Union f (a ': as) 226 | deriving (Typeable) 227 | 228 | -- | Case analysis for 'Union'. 229 | -- 230 | -- See 'unionHandle' for a more flexible version of this. 231 | -- 232 | -- ==== __Examples__ 233 | -- 234 | -- Here is an example of matching on a 'This': 235 | -- 236 | -- >>> let u = This (Identity "hello") :: Union Identity '[String, Int] 237 | -- >>> let runIdent = runIdentity :: Identity String -> String 238 | -- >>> union (const "not a String") runIdent u 239 | -- "hello" 240 | -- 241 | -- Here is an example of matching on a 'That': 242 | -- 243 | -- >>> let v = That (This (Identity 3.5)) :: Union Identity '[String, Double, Int] 244 | -- >>> union (const "not a String") runIdent v 245 | -- "not a String" 246 | union :: (Union f as -> c) -> (f a -> c) -> Union f (a ': as) -> c 247 | union _ onThis (This a) = onThis a 248 | union onThat _ (That u) = onThat u 249 | 250 | -- | Since a union with an empty list of labels is uninhabited, we 251 | -- can recover any type from it. 252 | absurdUnion :: Union f '[] -> a 253 | absurdUnion u = case u of {} 254 | 255 | -- | Map over the interpretation @f@ in the 'Union'. 256 | -- 257 | -- ==== __Examples__ 258 | -- 259 | -- Here is an example of changing a @'Union' 'Identity' \'['String', 'Int']@ to 260 | -- @'Union' 'Maybe' \'['String', 'Int']@: 261 | -- 262 | -- >>> let u = This (Identity "hello") :: Union Identity '[String, Int] 263 | -- >>> umap (Just . runIdentity) u :: Union Maybe '[String, Int] 264 | -- Just "hello" 265 | umap :: (forall a . f a -> g a) -> Union f as -> Union g as 266 | umap f (This a) = This $ f a 267 | umap f (That u) = That $ umap f u 268 | 269 | catchesUnionProduct 270 | :: forall x f as. 271 | Applicative f 272 | => Product f (ReturnX x as) -> Union f as -> f x 273 | catchesUnionProduct (Cons f _) (This a) = f <*> a 274 | catchesUnionProduct (Cons _ p) (That u) = catchesUnionProduct p u 275 | catchesUnionProduct Nil _ = undefined 276 | 277 | -- | An alternate case anaylsis for a 'Union'. This method uses a tuple 278 | -- containing handlers for each potential value of the 'Union'. This is 279 | -- somewhat similar to the 'Control.Exception.catches' function. 280 | -- 281 | -- ==== __Examples__ 282 | -- 283 | -- Here is an example of handling a 'Union' with two possible values. Notice 284 | -- that a normal tuple is used: 285 | -- 286 | -- >>> let u = This $ Identity 3 :: Union Identity '[Int, String] 287 | -- >>> let intHandler = (Identity $ \int -> show int) :: Identity (Int -> String) 288 | -- >>> let strHandler = (Identity $ \str -> str) :: Identity (String -> String) 289 | -- >>> catchesUnion (intHandler, strHandler) u :: Identity String 290 | -- Identity "3" 291 | -- 292 | -- Given a 'Union' like @'Union' 'Identity' \'['Int', 'String']@, the type of 293 | -- 'catchesUnion' becomes the following: 294 | -- 295 | -- @ 296 | -- 'catchesUnion' 297 | -- :: ('Identity' ('Int' -> 'String'), 'Identity' ('String' -> 'String')) 298 | -- -> 'Union' 'Identity' \'['Int', 'String'] 299 | -- -> 'Identity' 'String' 300 | -- @ 301 | -- 302 | -- Checkout 'catchesOpenUnion' for more examples. 303 | catchesUnion 304 | :: (Applicative f, ToProduct tuple f (ReturnX x as)) 305 | => tuple -> Union f as -> f x 306 | catchesUnion tuple u = catchesUnionProduct (tupleToProduct tuple) u 307 | 308 | -- | Relaxes a 'Union' to a larger set of types. 309 | -- 310 | -- Note that the result types have to completely contain the input types. 311 | -- 312 | -- >>> let u = This (Identity 3.5) :: Union Identity '[Double, String] 313 | -- >>> relaxUnion u :: Union Identity '[Char, Double, Int, String, Float] 314 | -- Identity 3.5 315 | -- 316 | -- The original types can be in a different order in the result 'Union': 317 | -- 318 | -- >>> let u = That (This (Identity 3.5)) :: Union Identity '[String, Double] 319 | -- >>> relaxUnion u :: Union Identity '[Char, Double, Int, String, Float] 320 | -- Identity 3.5 321 | relaxUnion :: Contains as bs => Union f as -> Union f bs 322 | relaxUnion (This as) = unionLift as 323 | relaxUnion (That u) = relaxUnion u 324 | 325 | -- | Lens-compatible 'Prism' for 'This'. 326 | -- 327 | -- ==== __Examples__ 328 | -- 329 | -- Use '_This' to construct a 'Union': 330 | -- 331 | -- >>> review _This (Just "hello") :: Union Maybe '[String] 332 | -- Just "hello" 333 | -- 334 | -- Use '_This' to try to destruct a 'Union' into a @f a@: 335 | -- 336 | -- >>> let u = This (Identity "hello") :: Union Identity '[String, Int] 337 | -- >>> preview _This u :: Maybe (Identity String) 338 | -- Just (Identity "hello") 339 | -- 340 | -- Use '_This' to try to destruct a 'Union' into a @f a@ (unsuccessfully): 341 | -- 342 | -- >>> let v = That (This (Identity 3.5)) :: Union Identity '[String, Double, Int] 343 | -- >>> preview _This v :: Maybe (Identity String) 344 | -- Nothing 345 | _This :: Prism (Union f (a ': as)) (Union f (b ': as)) (f a) (f b) 346 | _This = prism This (union (Left . That) Right) 347 | {-# INLINE _This #-} 348 | 349 | -- | Lens-compatible 'Prism' for 'That'. 350 | -- 351 | -- ==== __Examples__ 352 | -- 353 | -- Use '_That' to construct a 'Union': 354 | -- 355 | -- >>> let u = This (Just "hello") :: Union Maybe '[String] 356 | -- >>> review _That u :: Union Maybe '[Double, String] 357 | -- Just "hello" 358 | -- 359 | -- Use '_That' to try to peel off a 'That' from a 'Union': 360 | -- 361 | -- >>> let v = That (This (Identity "hello")) :: Union Identity '[Int, String] 362 | -- >>> preview _That v :: Maybe (Union Identity '[String]) 363 | -- Just (Identity "hello") 364 | -- 365 | -- Use '_That' to try to peel off a 'That' from a 'Union' (unsuccessfully): 366 | -- 367 | -- >>> let w = This (Identity 3.5) :: Union Identity '[Double, String] 368 | -- >>> preview _That w :: Maybe (Union Identity '[String]) 369 | -- Nothing 370 | _That :: Prism (Union f (a ': as)) (Union f (a ': bs)) (Union f as) (Union f bs) 371 | _That = prism That (union Right (Left . This)) 372 | {-# INLINE _That #-} 373 | 374 | ------------------ 375 | -- type classes -- 376 | ------------------ 377 | 378 | -- | @'UElem' a as i@ provides a way to potentially get an @f a@ out of a 379 | -- @'Union' f as@ ('unionMatch'). It also provides a way to create a 380 | -- @'Union' f as@ from an @f a@ ('unionLift'). 381 | -- 382 | -- This is safe because of the 'RIndex' contraint. This 'RIndex' constraint 383 | -- tells us that there /actually is/ an @a@ in @as@ at index @i@. 384 | -- 385 | -- As an end-user, you should never need to implement an additional instance of 386 | -- this typeclass. 387 | class i ~ RIndex a as => UElem (a :: k) (as :: [k]) (i :: Nat) where 388 | {-# MINIMAL unionPrism | (unionLift, unionMatch) #-} 389 | 390 | -- | This is implemented as @'prism'' 'unionLift' 'unionMatch'@. 391 | unionPrism :: Prism' (Union f as) (f a) 392 | unionPrism = prism' unionLift unionMatch 393 | 394 | -- | This is implemented as @'review' 'unionPrism'@. 395 | unionLift :: f a -> Union f as 396 | unionLift = review unionPrism 397 | 398 | -- | This is implemented as @'preview' 'unionPrism'@. 399 | unionMatch :: Union f as -> Maybe (f a) 400 | unionMatch = preview unionPrism 401 | 402 | instance UElem a (a ': as) 'Z where 403 | unionPrism :: Prism' (Union f (a ': as)) (f a) 404 | unionPrism = _This 405 | {-# INLINE unionPrism #-} 406 | 407 | instance 408 | ( RIndex a (b ': as) ~ ('S i) 409 | , UElem a as i 410 | ) 411 | => UElem a (b ': as) ('S i) where 412 | 413 | unionPrism :: Prism' (Union f (b ': as)) (f a) 414 | unionPrism = _That . unionPrism 415 | {-# INLINE unionPrism #-} 416 | 417 | -- | This type family removes a type from a type-level list. 418 | -- 419 | -- This is used to compute the type of the returned 'Union' in 'unionRemove'. 420 | -- 421 | -- ==== __Examples__ 422 | -- 423 | -- >>> Refl :: Remove Double '[Double, String] :~: '[String] 424 | -- Refl 425 | -- 426 | -- If the list contains multiple of the type, then they are all removed. 427 | -- 428 | -- >>> Refl :: Remove Double '[Char, Double, String, Double] :~: '[Char, String] 429 | -- Refl 430 | -- 431 | -- If the list is empty, then nothing is removed. 432 | -- 433 | -- >>> Refl :: Remove Double '[] :~: '[] 434 | -- Refl 435 | type family Remove (a :: k) (as :: [k]) :: [k] where 436 | Remove a '[] = '[] 437 | Remove a (a ': xs) = Remove a xs 438 | Remove a (b ': xs) = b ': Remove a xs 439 | 440 | -- | This is used internally to figure out which instance to pick for the 441 | -- 'ElemRemove\'' type class. 442 | -- 443 | -- This is needed to work around overlapping instances. 444 | -- 445 | -- >>> Refl :: RemoveCase Double '[Double, String] :~: 'CaseFirstSame 446 | -- Refl 447 | -- 448 | -- >>> Refl :: RemoveCase Double '[Char, Double, Double] :~: 'CaseFirstDiff 449 | -- Refl 450 | -- 451 | -- >>> Refl :: RemoveCase Double '[] :~: 'CaseEmpty 452 | -- Refl 453 | type family RemoveCase (a :: k) (as :: [k]) :: Cases where 454 | RemoveCase a '[] = 'CaseEmpty 455 | RemoveCase a (a ': xs) = 'CaseFirstSame 456 | RemoveCase a (b ': xs) = 'CaseFirstDiff 457 | 458 | -- | This type alias is a 'Constraint' that is used when working with 459 | -- functions like 'unionRemove' or 'unionHandle'. 460 | -- 461 | -- 'ElemRemove' gives you a way to specific types from a 'Union'. 462 | -- 463 | -- Note that @'ElemRemove' a as@ doesn't force @a@ to be in @as@. We are able 464 | -- to use 'unionRemove' to try to pull out a 'String' from a 465 | -- @'Union' 'Identity' \'['Double']@ (even though there is no way this 'Union' 466 | -- could contain a 'String'): 467 | -- 468 | -- >>> let u = This (Identity 3.5) :: Union Identity '[Double] 469 | -- >>> unionRemove u :: Either (Union Identity '[Double]) (Identity String) 470 | -- Left (Identity 3.5) 471 | -- 472 | -- When writing your own functions using 'unionRemove', in order to make sure 473 | -- the @a@ is in @as@, you should combine 'ElemRemove' with 'IsMember'. 474 | -- 475 | -- 'ElemRemove' uses some tricks to work correctly, so the underlying 'ElemRemove\''typeclass 476 | -- is not exported. 477 | type ElemRemove a as = ElemRemove' a as (RemoveCase a as) 478 | 479 | -- | This function allows you to try to remove individual types from a 'Union'. 480 | -- 481 | -- This can be used to handle only certain types in a 'Union', instead of 482 | -- having to handle all of them at the same time. 483 | -- 484 | -- ==== __Examples__ 485 | -- 486 | -- Handling a type in a 'Union': 487 | -- 488 | -- >>> let u = This (Identity "hello") :: Union Identity '[String, Double] 489 | -- >>> unionRemove u :: Either (Union Identity '[Double]) (Identity String) 490 | -- Right (Identity "hello") 491 | -- 492 | -- Failing to handle a type in a 'Union': 493 | -- 494 | -- >>> let u = That (This (Identity 3.5)) :: Union Identity '[String, Double] 495 | -- >>> unionRemove u :: Either (Union Identity '[Double]) (Identity String) 496 | -- Left (Identity 3.5) 497 | -- 498 | -- Note that if you have a 'Union' with multiple of the same type, they will 499 | -- all be handled at the same time: 500 | -- 501 | -- >>> let u = That (This (Identity 3.5)) :: Union Identity '[String, Double, Char, Double] 502 | -- >>> unionRemove u :: Either (Union Identity '[String, Char]) (Identity Double) 503 | -- Right (Identity 3.5) 504 | unionRemove 505 | :: forall a as f 506 | . ElemRemove a as 507 | => Union f as 508 | -> Either (Union f (Remove a as)) (f a) 509 | unionRemove = unionRemove' (Proxy @(RemoveCase a as)) 510 | {-# INLINE unionRemove #-} 511 | 512 | -- | This is used as a promoted data type to give a tag to the three different 513 | -- instances of 'ElemRemove\''. These also correspond to the three different 514 | -- cases of 'Remove' and 'RemoveCase'. 515 | data Cases = CaseEmpty | CaseFirstSame | CaseFirstDiff 516 | 517 | -- | This is an internal typeclass used for removing elements from a 'Union'. 518 | -- 519 | -- The most surprising thing about this is the last argument, @caseMatch@. 520 | -- This is used to stop GHC from seeing overlapping instances: 521 | -- 522 | -- https://kseo.github.io/posts/2017-02-05-avoid-overlapping-instances-with-closed-type-families.html 523 | -- 524 | -- Each of the instances of this correspond to one case in 'Remove' and 525 | -- 'RemoveCase'. 526 | class ElemRemove' (a :: k) (as :: [k]) (caseMatch :: Cases) where 527 | unionRemove' :: Proxy caseMatch -> Union f as -> Either (Union f (Remove a as)) (f a) 528 | 529 | instance ElemRemove' a '[] 'CaseEmpty where 530 | unionRemove' 531 | :: Proxy 'CaseEmpty -> Union f '[] -> Either (Union f '[]) (f a) 532 | unionRemove' _ u = absurdUnion u 533 | {-# INLINE unionRemove' #-} 534 | 535 | instance 536 | ( ElemRemove' a xs (RemoveCase a xs) 537 | ) => 538 | ElemRemove' a (a ': xs) 'CaseFirstSame where 539 | unionRemove' 540 | :: forall f 541 | . Proxy 'CaseFirstSame 542 | -> Union f (a ': xs) 543 | -> Either (Union f (Remove a xs)) (f a) 544 | unionRemove' _ (This a) = Right a 545 | unionRemove' _ (That u) = unionRemove' (Proxy @(RemoveCase a xs)) u 546 | 547 | instance 548 | ( ElemRemove' a xs (RemoveCase a xs) 549 | , -- We need to specify this equality because GHC doesn't realize it will 550 | -- always work out this way. We know that for this case, @a@ and @b@ 551 | -- will always be different (because of how the 'RemoveCase' type family 552 | -- works and the fact that there is already another instance that handles 553 | -- the case when @a@ and @b@ are the same type). 554 | -- 555 | -- However, GHC doesn't realize this, so we have to specify it. 556 | Remove a (b ': xs) ~ (b ': Remove a xs) 557 | ) => 558 | ElemRemove' a (b ': xs) 'CaseFirstDiff where 559 | unionRemove' 560 | :: forall f 561 | . Proxy 'CaseFirstDiff 562 | -> Union f (b ': xs) 563 | -> Either (Union f (b ': Remove a xs)) (f a) 564 | unionRemove' _ (This b) = Left (This b) 565 | unionRemove' _ (That u) = 566 | case unionRemove' (Proxy @(RemoveCase a xs)) u of 567 | Right fa -> Right fa 568 | Left u2 -> Left (That u2) 569 | 570 | -- | Handle a single case on a 'Union'. This is similar to 'union' but lets 571 | -- you handle any case within the 'Union'. 572 | -- 573 | -- ==== __Examples__ 574 | -- 575 | -- Handling the first item in a 'Union'. 576 | -- 577 | -- >>> let u = This 3.5 :: Union Identity '[Double, Int] 578 | -- >>> let printDouble = print :: Identity Double -> IO () 579 | -- >>> let printUnion = print :: Union Identity '[Int] -> IO () 580 | -- >>> unionHandle printUnion printDouble u 581 | -- Identity 3.5 582 | -- 583 | -- Handling a middle item in a 'Union'. 584 | -- 585 | -- >>> let u2 = That (This 3.5) :: Union Identity '[Char, Double, Int] 586 | -- >>> let printUnion = print :: Union Identity '[Char, Int] -> IO () 587 | -- >>> unionHandle printUnion printDouble u2 588 | -- Identity 3.5 589 | -- 590 | -- If you have duplicates in your 'Union', they will both get handled with 591 | -- a single call to 'unionHandle'. 592 | -- 593 | -- >>> let u3 = That (This 3.5) :: Union Identity '[Double, Double, Int] 594 | -- >>> let printUnion = print :: Union Identity '[Int] -> IO () 595 | -- >>> unionHandle printUnion printDouble u3 596 | -- Identity 3.5 597 | -- 598 | -- Use 'absurdUnion' to handle an empty 'Union'. 599 | -- 600 | -- >>> let u4 = This 3.5 :: Union Identity '[Double] 601 | -- >>> unionHandle (absurdUnion :: Union Identity '[] -> IO ()) printDouble u4 602 | -- Identity 3.5 603 | unionHandle 604 | :: ElemRemove a as 605 | => (Union f (Remove a as) -> b) 606 | -> (f a -> b) 607 | -> Union f as 608 | -> b 609 | unionHandle unionHandler aHandler u = 610 | either unionHandler aHandler $ unionRemove u 611 | 612 | --------------- 613 | -- OpenUnion -- 614 | --------------- 615 | 616 | -- | We can use @'Union' 'Identity'@ as a standard open sum type. 617 | -- 618 | -- See the documentation for 'Union'. 619 | type OpenUnion = Union Identity 620 | 621 | -- | Case analysis for 'OpenUnion'. 622 | -- 623 | -- ==== __Examples__ 624 | -- 625 | -- Here is an example of successfully matching: 626 | -- 627 | -- >>> let string = "hello" :: String 628 | -- >>> let o = openUnionLift string :: OpenUnion '[String, Int] 629 | -- >>> openUnion (const "not a String") id o 630 | -- "hello" 631 | -- 632 | -- Here is an example of unsuccessfully matching: 633 | -- 634 | -- >>> let double = 3.5 :: Double 635 | -- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int] 636 | -- >>> openUnion (const "not a String") id p 637 | -- "not a String" 638 | openUnion 639 | :: (OpenUnion as -> c) -> (a -> c) -> OpenUnion (a ': as) -> c 640 | openUnion onThat onThis = union onThat (onThis . runIdentity) 641 | 642 | -- | This is similar to 'fromMaybe' for an 'OpenUnion'. 643 | -- 644 | -- ==== __Examples__ 645 | -- 646 | -- Here is an example of successfully matching: 647 | -- 648 | -- >>> let string = "hello" :: String 649 | -- >>> let o = openUnionLift string :: OpenUnion '[String, Int] 650 | -- >>> fromOpenUnion (const "not a String") o 651 | -- "hello" 652 | -- 653 | -- Here is an example of unsuccessfully matching: 654 | -- 655 | -- >>> let double = 3.5 :: Double 656 | -- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int] 657 | -- >>> fromOpenUnion (const "not a String") p 658 | -- "not a String" 659 | fromOpenUnion 660 | :: (OpenUnion as -> a) -> OpenUnion (a ': as) -> a 661 | fromOpenUnion onThat = openUnion onThat id 662 | 663 | -- | Flipped version of 'fromOpenUnion'. 664 | fromOpenUnionOr 665 | :: OpenUnion (a ': as) -> (OpenUnion as -> a) -> a 666 | fromOpenUnionOr = flip fromOpenUnion 667 | 668 | -- | Just like 'unionPrism' but for 'OpenUnion'. 669 | openUnionPrism 670 | :: forall a as. 671 | IsMember a as 672 | => Prism' (OpenUnion as) a 673 | openUnionPrism = unionPrism . iso runIdentity Identity 674 | {-# INLINE openUnionPrism #-} 675 | 676 | -- | Just like 'unionLift' but for 'OpenUnion'. 677 | -- 678 | -- ==== __Examples__ 679 | -- 680 | -- Creating an 'OpenUnion': 681 | -- 682 | -- >>> let string = "hello" :: String 683 | -- >>> openUnionLift string :: OpenUnion '[Double, String, Int] 684 | -- Identity "hello" 685 | -- 686 | -- You will get a compile error if you try to create an 'OpenUnion' that 687 | -- doesn't contain the type: 688 | -- 689 | -- >>> let float = 3.5 :: Float 690 | -- >>> openUnionLift float :: OpenUnion '[Double, Int] 691 | -- ... 692 | -- • You require open sum type to contain the following element: 693 | -- Float 694 | -- However, given list can store elements only of the following types: 695 | -- '[Double, Int] 696 | -- ... 697 | openUnionLift 698 | :: forall a as. 699 | IsMember a as 700 | => a -> OpenUnion as 701 | openUnionLift = review openUnionPrism 702 | 703 | -- | Just like 'unionMatch' but for 'OpenUnion'. 704 | -- 705 | -- ==== __Examples__ 706 | -- 707 | -- Successful matching: 708 | -- 709 | -- >>> let string = "hello" :: String 710 | -- >>> let o = openUnionLift string :: OpenUnion '[Double, String, Int] 711 | -- >>> openUnionMatch o :: Maybe String 712 | -- Just "hello" 713 | -- 714 | -- Failure matching: 715 | -- 716 | -- >>> let double = 3.5 :: Double 717 | -- >>> let p = openUnionLift double :: OpenUnion '[Double, String] 718 | -- >>> openUnionMatch p :: Maybe String 719 | -- Nothing 720 | -- 721 | -- You will get a compile error if you try to pull out an element from 722 | -- the 'OpenUnion' that doesn't exist within it. 723 | -- 724 | -- >>> let o2 = openUnionLift double :: OpenUnion '[Double, Char] 725 | -- >>> openUnionMatch o2 :: Maybe Float 726 | -- ... 727 | -- • You require open sum type to contain the following element: 728 | -- Float 729 | -- However, given list can store elements only of the following types: 730 | -- '[Double, Char] 731 | -- ... 732 | openUnionMatch 733 | :: forall a as. 734 | IsMember a as 735 | => OpenUnion as -> Maybe a 736 | openUnionMatch = preview openUnionPrism 737 | 738 | -- | An alternate case anaylsis for an 'OpenUnion'. This method uses a tuple 739 | -- containing handlers for each potential value of the 'OpenUnion'. This is 740 | -- somewhat similar to the 'Control.Exception.catches' function. 741 | -- 742 | -- When working with large 'OpenUnion's, it can be easier to use 743 | -- 'catchesOpenUnion' than 'openUnion'. 744 | -- 745 | -- ==== __Examples__ 746 | -- 747 | -- Here is an example of handling an 'OpenUnion' with two possible values. 748 | -- Notice that a normal tuple is used: 749 | -- 750 | -- >>> let u = openUnionLift (3 :: Int) :: OpenUnion '[Int, String] 751 | -- >>> let intHandler = (\int -> show int) :: Int -> String 752 | -- >>> let strHandler = (\str -> str) :: String -> String 753 | -- >>> catchesOpenUnion (intHandler, strHandler) u :: String 754 | -- "3" 755 | -- 756 | -- Given an 'OpenUnion' like @'OpenUnion' \'['Int', 'String']@, the type of 757 | -- 'catchesOpenUnion' becomes the following: 758 | -- 759 | -- @ 760 | -- 'catchesOpenUnion' 761 | -- :: ('Int' -> x, 'String' -> x) 762 | -- -> 'OpenUnion' \'['Int', 'String'] 763 | -- -> x 764 | -- @ 765 | -- 766 | -- Here is an example of handling an 'OpenUnion' with three possible values: 767 | -- 768 | -- >>> let u = openUnionLift ("hello" :: String) :: OpenUnion '[Int, String, Double] 769 | -- >>> let intHandler = (\int -> show int) :: Int -> String 770 | -- >>> let strHandler = (\str -> str) :: String -> String 771 | -- >>> let dblHandler = (\dbl -> "got a double") :: Double -> String 772 | -- >>> catchesOpenUnion (intHandler, strHandler, dblHandler) u :: String 773 | -- "hello" 774 | -- 775 | -- Here is an example of handling an 'OpenUnion' with only one possible value. 776 | -- Notice how a tuple is not used, just a single value: 777 | -- 778 | -- >>> let u = openUnionLift (2.2 :: Double) :: OpenUnion '[Double] 779 | -- >>> let dblHandler = (\dbl -> "got a double") :: Double -> String 780 | -- >>> catchesOpenUnion dblHandler u :: String 781 | -- "got a double" 782 | catchesOpenUnion 783 | :: ToOpenProduct tuple (ReturnX x as) 784 | => tuple -> OpenUnion as -> x 785 | catchesOpenUnion tuple u = 786 | runIdentity $ 787 | catchesUnionProduct (tupleToOpenProduct tuple) u 788 | 789 | -- | Just like 'relaxUnion' but for 'OpenUnion'. 790 | -- 791 | -- >>> let u = openUnionLift (3.5 :: Double) :: Union Identity '[Double, String] 792 | -- >>> relaxOpenUnion u :: Union Identity '[Char, Double, Int, String, Float] 793 | -- Identity 3.5 794 | relaxOpenUnion :: Contains as bs => OpenUnion as -> OpenUnion bs 795 | relaxOpenUnion (This as) = unionLift as 796 | relaxOpenUnion (That u) = relaxUnion u 797 | 798 | -- | This function allows you to try to remove individual types from an 799 | -- 'OpenUnion'. 800 | -- 801 | -- This can be used to handle only certain types in an 'OpenUnion', instead of 802 | -- having to handle all of them at the same time. This can be more convenient 803 | -- than a function like 'catchesOpenUnion'. 804 | -- 805 | -- ==== __Examples__ 806 | -- 807 | -- Handling a type in an 'OpenUnion': 808 | -- 809 | -- >>> let u = openUnionLift ("hello" :: String) :: OpenUnion '[String, Double] 810 | -- >>> openUnionRemove u :: Either (OpenUnion '[Double]) String 811 | -- Right "hello" 812 | -- 813 | -- Failing to handle a type in an 'OpenUnion': 814 | -- 815 | -- >>> let u = openUnionLift (3.5 :: Double) :: OpenUnion '[String, Double] 816 | -- >>> openUnionRemove u :: Either (OpenUnion '[Double]) String 817 | -- Left (Identity 3.5) 818 | -- 819 | -- Note that if you have an 'OpenUnion' with multiple of the same type, they will 820 | -- all be handled at the same time: 821 | -- 822 | -- >>> let u = That (This (Identity 3.5)) :: OpenUnion '[String, Double, Char, Double] 823 | -- >>> openUnionRemove u :: Either (OpenUnion '[String, Char]) Double 824 | -- Right 3.5 825 | openUnionRemove 826 | :: forall a as 827 | . ElemRemove a as 828 | => OpenUnion as 829 | -> Either (OpenUnion (Remove a as)) a 830 | openUnionRemove = fmap runIdentity . unionRemove 831 | 832 | -- | Handle a single case in an 'OpenUnion'. This is similar to 'openUnion' 833 | -- but lets you handle any case within the 'OpenUnion', not just the first one. 834 | -- 835 | -- ==== __Examples__ 836 | -- 837 | -- Handling the first item in an 'OpenUnion': 838 | -- 839 | -- >>> let u = This 3.5 :: OpenUnion '[Double, Int] 840 | -- >>> let printDouble = print :: Double -> IO () 841 | -- >>> let printUnion = print :: OpenUnion '[Int] -> IO () 842 | -- >>> openUnionHandle printUnion printDouble u 843 | -- 3.5 844 | -- 845 | -- Handling a middle item in an 'OpenUnion': 846 | -- 847 | -- >>> let u2 = openUnionLift (3.5 :: Double) :: OpenUnion '[Char, Double, Int] 848 | -- >>> let printUnion = print :: OpenUnion '[Char, Int] -> IO () 849 | -- >>> openUnionHandle printUnion printDouble u2 850 | -- 3.5 851 | -- 852 | -- Failing to handle an item in an 'OpenUnion'. In the following example, the 853 | -- @printUnion@ function is called: 854 | -- 855 | -- >>> let u2 = openUnionLift 'c' :: OpenUnion '[Char, Double, Int] 856 | -- >>> let printUnion = print :: OpenUnion '[Char, Int] -> IO () 857 | -- >>> openUnionHandle printUnion printDouble u2 858 | -- Identity 'c' 859 | -- 860 | -- If you have duplicates in your 'OpenUnion', they will both get handled with 861 | -- a single call to 'openUnionHandle'. 862 | -- 863 | -- >>> let u3 = That (This 3.5) :: OpenUnion '[Double, Double, Int] 864 | -- >>> let printUnion = print :: OpenUnion '[Int] -> IO () 865 | -- >>> openUnionHandle printUnion printDouble u3 866 | -- 3.5 867 | -- 868 | -- Use 'absurdOpenUnion' to handle an empty 'OpenUnion': 869 | -- 870 | -- >>> let u4 = This 3.5 :: OpenUnion '[Double] 871 | -- >>> openUnionHandle (absurdUnion :: OpenUnion '[] -> IO ()) printDouble u4 872 | -- 3.5 873 | openUnionHandle 874 | :: ElemRemove a as 875 | => (OpenUnion (Remove a as) -> b) 876 | -> (a -> b) 877 | -> OpenUnion as 878 | -> b 879 | openUnionHandle unionHandler aHandler = 880 | unionHandle unionHandler (aHandler . runIdentity) 881 | 882 | --------------- 883 | -- Instances -- 884 | --------------- 885 | 886 | instance NFData (Union f '[]) where 887 | rnf = absurdUnion 888 | 889 | instance (NFData (f a), NFData (Union f as)) => NFData (Union f (a ': as)) where 890 | rnf = union rnf rnf 891 | 892 | instance Show (Union f '[]) where 893 | showsPrec _ = absurdUnion 894 | 895 | instance (Show (f a), Show (Union f as)) => Show (Union f (a ': as)) where 896 | showsPrec n = union (showsPrec n) (showsPrec n) 897 | 898 | -- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'. 899 | instance Read (Union f '[]) where 900 | readsPrec :: Int -> ReadS (Union f '[]) 901 | readsPrec _ _ = [] 902 | 903 | -- | This is only a valid instance when the 'Read' instances for the types 904 | -- don't overlap. 905 | -- 906 | -- For instance, imagine we are working with a 'Union' of a 'String' and a 'Double'. 907 | -- @3.5@ can only be read as a 'Double', not as a 'String'. 908 | -- Oppositely, @\"hello\"@ can only be read as a 'String', not as a 'Double'. 909 | -- 910 | -- >>> let o = readMaybe "Identity 3.5" :: Maybe (Union Identity '[Double, String]) 911 | -- >>> o 912 | -- Just (Identity 3.5) 913 | -- >>> o >>= openUnionMatch :: Maybe Double 914 | -- Just 3.5 915 | -- >>> o >>= openUnionMatch :: Maybe String 916 | -- Nothing 917 | -- 918 | -- >>> let p = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Double, String]) 919 | -- >>> p 920 | -- Just (Identity "hello") 921 | -- >>> p >>= openUnionMatch :: Maybe Double 922 | -- Nothing 923 | -- >>> p >>= openUnionMatch :: Maybe String 924 | -- Just "hello" 925 | -- 926 | -- However, imagine are we working with a 'Union' of a 'String' and 927 | -- 'Data.Text.Text'. @\"hello\"@ can be 'read' as both a 'String' and 928 | -- 'Data.Text.Text'. However, in the following example, it can only be read as 929 | -- a 'String': 930 | -- 931 | -- >>> let q = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[String, Text]) 932 | -- >>> q 933 | -- Just (Identity "hello") 934 | -- >>> q >>= openUnionMatch :: Maybe String 935 | -- Just "hello" 936 | -- >>> q >>= openUnionMatch :: Maybe Text 937 | -- Nothing 938 | -- 939 | -- If the order of the types is flipped around, we are are able to read @\"hello\"@ 940 | -- as a 'Text' but not as a 'String'. 941 | -- 942 | -- >>> let r = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Text, String]) 943 | -- >>> r 944 | -- Just (Identity "hello") 945 | -- >>> r >>= openUnionMatch :: Maybe String 946 | -- Nothing 947 | -- >>> r >>= openUnionMatch :: Maybe Text 948 | -- Just "hello" 949 | instance (Read (f a), Read (Union f as)) => Read (Union f (a ': as)) where 950 | readPrec :: ReadPrec (Union f (a ': as)) 951 | readPrec = fmap This readPrec <++ fmap That readPrec 952 | 953 | instance Eq (Union f '[]) where 954 | (==) = absurdUnion 955 | 956 | instance (Eq (f a), Eq (Union f as)) => Eq (Union f (a ': as)) where 957 | This a1 == This a2 = a1 == a2 958 | That u1 == That u2 = u1 == u2 959 | _ == _ = False 960 | 961 | instance Ord (Union f '[]) where 962 | compare = absurdUnion 963 | 964 | instance (Ord (f a), Ord (Union f as)) => Ord (Union f (a ': as)) 965 | where 966 | compare (This a1) (This a2) = compare a1 a2 967 | compare (That u1) (That u2) = compare u1 u2 968 | compare (This _) (That _) = LT 969 | compare (That _) (This _) = GT 970 | 971 | instance ToJSON (Union f '[]) where 972 | toJSON :: Union f '[] -> Value 973 | toJSON = absurdUnion 974 | 975 | instance (ToJSON (f a), ToJSON (Union f as)) => ToJSON (Union f (a ': as)) where 976 | toJSON :: Union f (a ': as) -> Value 977 | toJSON = union toJSON toJSON 978 | 979 | -- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'. 980 | instance FromJSON (Union f '[]) where 981 | parseJSON :: Value -> Parser (Union f '[]) 982 | parseJSON _ = fail "Value of Union f '[] can never be created" 983 | 984 | -- | This is only a valid instance when the 'FromJSON' instances for the types 985 | -- don't overlap. 986 | -- 987 | -- This is similar to the 'Read' instance. 988 | instance (FromJSON (f a), FromJSON (Union f as)) => FromJSON (Union f (a ': as)) where 989 | parseJSON :: Value -> Parser (Union f (a ': as)) 990 | parseJSON val = fmap This (parseJSON val) <|> fmap That (parseJSON val) 991 | 992 | -- instance f ~ Identity => Exception (Union f '[]) 993 | 994 | -- instance 995 | -- ( f ~ Identity 996 | -- , Exception a 997 | -- , Typeable as 998 | -- , Exception (Union f as) 999 | -- ) => Exception (Union f (a ': as)) 1000 | -- where 1001 | -- toException = union toException (toException . runIdentity) 1002 | -- fromException sE = matchR <|> matchL 1003 | -- where 1004 | -- matchR = This . Identity <$> fromException sE 1005 | -- matchL = That <$> fromException sE 1006 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-16.2 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | 37 | # Enable Hackage-friendly mode, for more details see 38 | # https://docs.haskellstack.org/en/stable/yaml_configuration/#pvp-bounds 39 | # This has been disabled because of the following exchange: 40 | # https://github.com/cdepillabout/pretty-simple/pull/1#issuecomment-272706215 41 | #pvp-bounds: both 42 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 531674 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/2.yaml 11 | sha256: 4b08fb9338ca297de7ade8318f4be1216f14dff8c0426c001fb7886ee88cb84a 12 | original: lts-16.2 13 | -------------------------------------------------------------------------------- /test/DocTest.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main (main) where 3 | 4 | import Prelude 5 | 6 | import Data.Monoid ((<>)) 7 | import System.FilePath.Glob (glob) 8 | import Test.DocTest (doctest) 9 | 10 | main :: IO () 11 | main = glob "src/**/*.hs" >>= doDocTest 12 | 13 | doDocTest :: [String] -> IO () 14 | doDocTest options = doctest $ options <> ghcExtensions 15 | 16 | ghcExtensions :: [String] 17 | ghcExtensions = 18 | [ 19 | -- "-XConstraintKinds" 20 | -- , "-XDataKinds" 21 | "-XDeriveDataTypeable" 22 | , "-XDeriveGeneric" 23 | -- , "-XEmptyDataDecls" 24 | , "-XFlexibleContexts" 25 | -- , "-XFlexibleInstances" 26 | -- , "-XGADTs" 27 | -- , "-XGeneralizedNewtypeDeriving" 28 | -- , "-XInstanceSigs" 29 | -- , "-XMultiParamTypeClasses" 30 | -- , "-XNoImplicitPrelude" 31 | , "-XOverloadedStrings" 32 | -- , "-XPolyKinds" 33 | -- , "-XRankNTypes" 34 | -- , "-XRecordWildCards" 35 | , "-XScopedTypeVariables" 36 | -- , "-XStandaloneDeriving" 37 | -- , "-XTupleSections" 38 | -- , "-XTypeFamilies" 39 | -- , "-XTypeOperators" 40 | ] 41 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Main where 8 | 9 | import Data.Functor.Identity (Identity(Identity)) 10 | import Test.Tasty (TestTree, defaultMain, testGroup) 11 | import Test.Tasty.HUnit ((@?=), testCase) 12 | 13 | import Data.WorldPeace (Union(..), unionRemove) 14 | import Test.TypeErrors (unionRemoveTypeErrors) 15 | 16 | main :: IO () 17 | main = defaultMain tests 18 | 19 | tests :: TestTree 20 | tests = 21 | testGroup 22 | "tests" 23 | [ unionRemoveTests 24 | , unionRemoveTypeErrors 25 | ] 26 | 27 | unionRemoveTests :: TestTree 28 | unionRemoveTests = 29 | testGroup 30 | "unionRemove" 31 | [ testCase "match final element" $ do 32 | let u = This (Identity "hello") :: Union Identity '[String] 33 | removed = unionRemove u :: Either (Union Identity '[]) (Identity String) 34 | removed @?= Right (Identity "hello") 35 | , testCase "fail to match final element" $ do 36 | let u = This (Identity "hello") :: Union Identity '[String] 37 | removed = unionRemove u :: Either (Union Identity '[String]) (Identity Double) 38 | removed @?= Left u 39 | , testCase "match leading non-final element" $ do 40 | let u = This (Identity "hello") :: Union Identity '[String, Double] 41 | removed = unionRemove u :: Either (Union Identity '[Double]) (Identity String) 42 | removed @?= Right (Identity "hello") 43 | , testCase "fail match leading non-final element" $ do 44 | let u = That (This (Identity 3.5)) :: Union Identity '[String, Double] 45 | removed = unionRemove u :: Either (Union Identity '[Double]) (Identity String) 46 | removed @?= Left (This (Identity 3.5)) 47 | , testCase "match non-leading non-final element" $ do 48 | let u = That (This (Identity "hello")) :: Union Identity '[Char, String, Double] 49 | removed = unionRemove u :: Either (Union Identity '[Char, Double]) (Identity String) 50 | removed @?= Right (Identity "hello") 51 | , testCase "fail match non-leading non-final element 1" $ do 52 | let u = That (That (This (Identity 3.5))) :: Union Identity '[Char, String, Double] 53 | removed = unionRemove u :: Either (Union Identity '[Char, Double]) (Identity String) 54 | removed @?= Left (That (This (Identity 3.5))) 55 | , testCase "fail match non-leading non-final element 2" $ do 56 | let u = This (Identity 'c') :: Union Identity '[Char, String, Double] 57 | removed = unionRemove u :: Either (Union Identity '[Char, Double]) (Identity String) 58 | removed @?= Left (This (Identity 'c')) 59 | , testCase "fail match non-existing element" $ do 60 | let u = This (Identity 'c') :: Union Identity '[Char, String, Double] 61 | removed = unionRemove u :: Either (Union Identity '[Char, String, Double]) (Identity Float) 62 | removed @?= Left u 63 | , testCase "match multiple 1" $ do 64 | let u = This (Identity 'c') :: Union Identity '[Char, Char] 65 | removed = unionRemove u :: Either (Union Identity '[]) (Identity Char) 66 | removed @?= Right (Identity 'c') 67 | , testCase "match multiple 2" $ do 68 | let u = That (This (Identity 'c')) :: Union Identity '[Char, Char] 69 | removed = unionRemove u :: Either (Union Identity '[]) (Identity Char) 70 | removed @?= Right (Identity 'c') 71 | , testCase "match multiple 3" $ do 72 | let u = That (This (Identity 'c')) :: Union Identity '[Double, Char, String, Char, Float] 73 | removed = unionRemove u :: Either (Union Identity '[Double, String, Float]) (Identity Char) 74 | removed @?= Right (Identity 'c') 75 | , testCase "fail to match multiple 1" $ do 76 | let u = That (That (This (Identity 3.5))) :: Union Identity '[Char, Char, Double] 77 | removed = unionRemove u :: Either (Union Identity '[Double]) (Identity Char) 78 | removed @?= Left (This (Identity 3.5)) 79 | , testCase "fail to match multiple 2" $ do 80 | let u = That (That (This (Identity 3.5))) :: Union Identity '[String, Char, Float, Char, Double] 81 | removed = unionRemove u :: Either (Union Identity '[String, Float, Double]) (Identity Char) 82 | removed @?= Left (That (This (Identity 3.5))) 83 | , testCase "type inference works somewhat 1" $ do 84 | let u = This (Identity 3.5) :: Union Identity '[Double, Char, Int] 85 | unionRemove u @?= Right (Identity (3.5 :: Double)) 86 | , testCase "type inference works somewhat 2" $ do 87 | let u = That (This (Identity 'c')) :: Union Identity '[Double, Char, Int] 88 | unionRemove u @?= Right (Identity ('c')) 89 | ] 90 | -------------------------------------------------------------------------------- /test/Test/TypeErrors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | -- Deferring type errors is necessary for should-not-typecheck to work. 8 | {-# OPTIONS_GHC -fdefer-type-errors #-} 9 | {-# OPTIONS_GHC -Wno-deferred-type-errors #-} 10 | 11 | module Test.TypeErrors where 12 | 13 | import Data.Functor.Identity (Identity(Identity)) 14 | import Test.ShouldNotTypecheck (shouldNotTypecheck) 15 | import Test.Tasty (TestTree, testGroup) 16 | import Test.Tasty.HUnit (testCase) 17 | 18 | import Data.WorldPeace (Union(..), unionRemove) 19 | 20 | 21 | unionRemoveTypeErrors :: TestTree 22 | unionRemoveTypeErrors = 23 | testGroup 24 | "unionRemove should not typecheck" 25 | [ testCase "too few types in resulting union 1" $ do 26 | let u = This (Identity "hello") :: Union Identity '[String] 27 | shouldNotTypecheck 28 | (unionRemove u :: Either (Union Identity '[]) (Identity Double)) 29 | 30 | , testCase "too few types in resulting union 2" $ do 31 | let u = This (Identity "hello") :: Union Identity '[String, Char, Double] 32 | shouldNotTypecheck 33 | (unionRemove u :: Either (Union Identity '[String]) (Identity Double)) 34 | 35 | , testCase "too many types in resulting union 1" $ do 36 | let u = This (Identity "hello") :: Union Identity '[String] 37 | shouldNotTypecheck 38 | (unionRemove u :: Either (Union Identity '[String, String]) (Identity Double)) 39 | 40 | , testCase "too many types in resulting union 2" $ do 41 | let u = This (Identity "hello") :: Union Identity '[String, Char, Double] 42 | shouldNotTypecheck 43 | (unionRemove u :: Either (Union Identity '[String, Char, Double]) (Identity Double)) 44 | 45 | , testCase "does not pull out multiple" $ do 46 | let u = This (Identity "hello") :: Union Identity '[String, String, Double] 47 | shouldNotTypecheck 48 | (unionRemove u :: Either (Union Identity '[String, Double]) (Identity String)) 49 | ] 50 | -------------------------------------------------------------------------------- /world-peace.cabal: -------------------------------------------------------------------------------- 1 | name: world-peace 2 | version: 1.0.2.0 3 | synopsis: Open Union and Open Product Types 4 | description: Please see . 5 | homepage: https://github.com/cdepillabout/world-peace 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dennis Gosnell 9 | maintainer: cdep.illabout@gmail.com 10 | copyright: 2017-2018 Dennis Gosnell 11 | category: Data 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | , README.md 15 | , stack.yaml 16 | cabal-version: >=1.10 17 | 18 | library 19 | hs-source-dirs: src 20 | exposed-modules: Data.WorldPeace 21 | , Data.WorldPeace.Internal 22 | , Data.WorldPeace.Internal.Prism 23 | , Data.WorldPeace.Product 24 | , Data.WorldPeace.Union 25 | build-depends: base >= 4.9 && < 5 26 | , aeson 27 | , deepseq 28 | , profunctors 29 | , tagged 30 | default-language: Haskell2010 31 | ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction 32 | other-extensions: QuasiQuotes 33 | , TemplateHaskell 34 | 35 | test-suite world-peace-doctest 36 | type: exitcode-stdio-1.0 37 | main-is: DocTest.hs 38 | hs-source-dirs: test 39 | build-depends: base 40 | , doctest 41 | , Glob 42 | , text 43 | default-language: Haskell2010 44 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 45 | 46 | test-suite world-peace-test 47 | type: exitcode-stdio-1.0 48 | main-is: Spec.hs 49 | other-modules: Test.TypeErrors 50 | hs-source-dirs: test 51 | build-depends: base 52 | , tasty 53 | , tasty-hunit 54 | , should-not-typecheck 55 | , world-peace 56 | default-language: Haskell2010 57 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction 58 | 59 | source-repository head 60 | type: git 61 | location: git@github.com:cdepillabout/world-peace.git 62 | --------------------------------------------------------------------------------