servant-checked-exceptions 1.1.0.0 → 2.0.0.0

raw patch · 18 files changed

+77/−1857 lines, 18 filesdep +servant-checked-exceptions-coredep +world-peacedep −Globdep −doctestdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: servant-checked-exceptions-core, world-peace

Dependencies removed: Glob, doctest

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• README.md +10/−0
• Setup.hs +0/−2
• example/Client.hs +1/−1
• servant-checked-exceptions.cabal +3/−18
• src/Servant/Checked/Exceptions.hs +10/−118
• src/Servant/Checked/Exceptions/Internal.hs +4/−5
• src/Servant/Checked/Exceptions/Internal/Envelope.hs +0/−485
• src/Servant/Checked/Exceptions/Internal/Prism.hs +0/−75
• src/Servant/Checked/Exceptions/Internal/Product.hs +0/−153
• src/Servant/Checked/Exceptions/Internal/Servant/API.hs +5/−118
• src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs +0/−163
• src/Servant/Checked/Exceptions/Internal/Servant/Server.hs +18/−4
• src/Servant/Checked/Exceptions/Internal/Union.hs +0/−574
• src/Servant/Checked/Exceptions/Internal/Util.hs +0/−52
• stack.yaml +0/−41
• test/DocTest.hs +0/−40
• test/Spec.hs +8/−8

@@ -1,3 +1,21 @@+## 2.0.0.0++*   Split into two package `servant-checked-exceptions-core` and+    `servant-checked-exceptions`. The former defines the core types+    and functions for using checked exceptions in a servant API;+    the latter reexports the former and adds instances for `HasServer`+    and `HasClient`. The rationale is described further in+    [issue 25](https://github.com/cdepillabout/servant-checked-exceptions/issues/25)+    +    Most users should only depend on `servant-checked-exceptions`.+    But users who need access to core types without incurring a dependency+    on `servant-server` and `servant-client` can depend on+    `servant-checked-exceptions-core` instead.++*   Split `Exceptions` module into `Envelope` and `Verbs` in+    `servant-checked-exceptions-core`, for better module organization.+    More information in+    [issue 18](https://github.com/cdepillabout/servant-checked-exceptions/issues/18)  ## 1.1.0.0 

@@ -210,3 +210,13 @@ ```  You can see that both the success and error responses are documented.++## Packaging the core types++[`servant-checked-exceptions-core`](https://hackage.haskell.org/package/servant-checked-exceptions-core)+exports the core types need for building an API with checked exceptions,+allowing you to avoid depending on server-side libraries like `warp`, `Glob`+and `servant-server`. This can be useful if you are writing an API meant to be+shared with ghcjs and run in a browser, where these dependencies aren't+available.+

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -142,7 +142,7 @@ main :: IO () main = do   manager <- newManager defaultManagerSettings-  let clientEnv = ClientEnv manager baseUrl+  let clientEnv = ClientEnv manager baseUrl Nothing   options <- execParser opts   run clientEnv options   where

@@ -1,5 +1,5 @@ name:                servant-checked-exceptions-version:             1.1.0.0+version:             2.0.0.0 synopsis:            Checked exceptions for Servant APIs. description:         Please see <https://github.com/cdepillabout/servant-checked-exceptions#readme README.md>. homepage:            https://github.com/cdepillabout/servant-checked-exceptions@@ -12,7 +12,6 @@ build-type:          Simple extra-source-files:  CHANGELOG.md                    , README.md-                   , stack.yaml cabal-version:       >=1.10  flag buildexample@@ -23,16 +22,10 @@   hs-source-dirs:      src   exposed-modules:     Servant.Checked.Exceptions                      , Servant.Checked.Exceptions.Internal-                     , Servant.Checked.Exceptions.Internal.Envelope-                     , Servant.Checked.Exceptions.Internal.Prism-                     , Servant.Checked.Exceptions.Internal.Product                      , Servant.Checked.Exceptions.Internal.Servant                      , Servant.Checked.Exceptions.Internal.Servant.API                      , Servant.Checked.Exceptions.Internal.Servant.Client-                     , Servant.Checked.Exceptions.Internal.Servant.Docs                      , Servant.Checked.Exceptions.Internal.Servant.Server-                     , Servant.Checked.Exceptions.Internal.Union-                     , Servant.Checked.Exceptions.Internal.Util   build-depends:       base >= 4.9 && < 5                      , aeson                      , bytestring@@ -42,12 +35,14 @@                      , profunctors                      , tagged                      , servant >= 0.12+                     , servant-checked-exceptions-core                      , servant-client >= 0.12                      , servant-client-core >= 0.12                      , servant-docs >= 0.10                      , servant-server >= 0.12                      , text                      , wai+                     , world-peace   default-language:    Haskell2010   ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction   other-extensions:    QuasiQuotes@@ -117,16 +112,6 @@     buildable:         True   else     buildable:         False--test-suite servant-checked-exceptions-doctest-  type:                exitcode-stdio-1.0-  main-is:             DocTest.hs-  hs-source-dirs:      test-  build-depends:       base-                     , doctest-                     , Glob-  default-language:    Haskell2010-  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N  test-suite servant-checked-exceptions-test   type:                exitcode-stdio-1.0

@@ -79,129 +79,21 @@ Checkout the <https://github.com/cdepillabout/servant-checked-exceptions/tree/master/example example> in the repository on Github.  It includes a fleshed-out example of an-<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Api.hs api>,-<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Server.hs server>,-<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Client.hs client>,+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/servant-checked-exceptions/example/Api.hs api>,+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/servant-checked-exceptions/example/Server.hs server>,+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/servant-checked-exceptions/example/Client.hs client>, and-<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Docs.hs documentation>.+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/servant-checked-exceptions-core/example/Docs.hs documentation>. The <https://github.com/cdepillabout/servant-checked-exceptions README.md> shows how to compile and run the examples. -} -module Servant.Checked.Exceptions-  (-  -- * Servant Types-  -- ** 'Throws' API parameter-    Throws-  -- ** 'NoThrow' API parameter-  , NoThrow-  -- ** HTTP Error Status Code-  , ErrStatus(toErrStatus)-  , Status-  -- ** Verbs-  , VerbWithErr-  -- *** Specialized Verbs-  -- **** HTTP 200-  , GetWithErr-  , PostWithErr-  , PutWithErr-  , DeleteWithErr-  , PatchWithErr-  -- **** HTTP 201-  , PostCreatedWithErr-  -- **** HTTP 202-  , GetAcceptedWithErr-  , PostAcceptedWithErr-  , DeleteAcceptedWithErr-  , PatchAcceptedWithErr-  , PutAcceptedWithErr-  -- **** HTTP 203-  , GetNonAuthoritativeWithErr-  , PostNonAuthoritativeWithErr-  , DeleteNonAuthoritativeWithErr-  , PatchNonAuthoritativeWithErr-  , PutNonAuthoritativeWithErr-  -- **** HTTP 204-  , GetNoContentWithErr-  , PostNoContentWithErr-  , DeleteNoContentWithErr-  , PatchNoContentWithErr-  , PutNoContentWithErr-  -- **** HTTP 205-  , GetResetContentWithErr-  , PostResetContentWithErr-  , DeleteResetContentWithErr-  , PatchResetContentWithErr-  , PutResetContentWithErr-  -- **** HTTP 206-  , GetPartialContentWithErr-  -- * 'Envelope' response wrapper-  , Envelope(..)-  -- ** 'Envelope' helper functions-  -- *** 'Envelope' constructors-  , toSuccEnvelope-  , toErrEnvelope-  , pureSuccEnvelope-  , pureErrEnvelope-  -- *** 'Envelope' destructors-  , envelope-  , emptyEnvelope-  , fromEnvelope-  , fromEnvelopeOr-  , fromEnvelopeM-  , fromEnvelopeOrM-  , errEnvelopeMatch-  , catchesEnvelope-  -- *** 'Envelope' optics-  , _SuccEnvelope-  , _ErrEnvelope-  , _ErrEnvelopeErr-  -- *** 'Envelope' and 'Either'-  , envelopeToEither-  , eitherToEnvelope-  , isoEnvelopeEither-  -- *** 'OpenUnion' (used in 'ErrEnvelope')-  , OpenUnion-  -- **** 'OpenUnion' Helpers-  , openUnion-  , fromOpenUnion-  , fromOpenUnionOr-  , openUnionPrism-  , openUnionLift-  , openUnionMatch-  , catchesOpenUnion-  -- **** 'Union' (used by 'OpenUnion')-  -- | 'OpenUnion' is a type synonym around 'Union'. Most users will be able to-  -- work directly with 'OpenUnion' and ignore this 'Union' type.-  , Union(..)-  -- ***** Union helpers-  , union-  , absurdUnion-  , umap-  , catchesUnion-  -- ***** Union optics-  , _This-  , _That-  -- ***** Typeclasses used with Union-  , Nat(Z, S)-  , RIndex-  , UElem(..)-  , IsMember-  -- **** 'OpenProduct' (used by 'OpenUnion')-  -- | This 'Product' type is used to easily create a case-analysis for-  -- 'Union's.  You can see it being used in 'catchesOpenUnion' and-  -- 'catchesEnvelope'.  The 'ToProduct' type class makes it easy to convert a-  -- tuple to a 'Product'.  This makes it so the end user only has to worry-  -- about working with tuples, and can mostly ignore this 'Product' type.-  , OpenProduct-  , Product(..)-  , ToOpenProduct-  , tupleToOpenProduct-  , ToProduct-  , tupleToProduct-  , ReturnX-  ) where+{-# LANGUAGE PackageImports #-} -import Network.HTTP.Types (Status)+module Servant.Checked.Exceptions (+    module Servant.Checked.Exceptions+  , module Servant.Checked.Exceptions.Internal+  ) where +import "servant-checked-exceptions-core" Servant.Checked.Exceptions import Servant.Checked.Exceptions.Internal

@@ -12,15 +12,14 @@ -}  module Servant.Checked.Exceptions.Internal-  ( module Servant.Checked.Exceptions.Internal.Envelope-  , module Servant.Checked.Exceptions.Internal.Product+  ( -- * Reexported modules from servant-checked-exceptions-core+    module Servant.Checked.Exceptions.Internal.Envelope   , module Servant.Checked.Exceptions.Internal.Servant-  , module Servant.Checked.Exceptions.Internal.Union   , module Servant.Checked.Exceptions.Internal.Util+  , module Servant.Checked.Exceptions.Internal.Verbs   ) where  import Servant.Checked.Exceptions.Internal.Envelope-import Servant.Checked.Exceptions.Internal.Product import Servant.Checked.Exceptions.Internal.Servant-import Servant.Checked.Exceptions.Internal.Union import Servant.Checked.Exceptions.Internal.Util+import Servant.Checked.Exceptions.Internal.Verbs

@@ -1,485 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--{- |-Module      :  Servant.Checked.Exceptions.Internal.Envelope--Copyright   :  Dennis Gosnell 2017-License     :  BSD3--Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)-Stability   :  experimental-Portability :  unknown--This module defines the 'Envelope' type as a wrapper around a success value, or-a set of possible errors.  The errors are an 'OpenUnion', which is an-extensible sumtype.--Other than the 'Envelope' type, the most important thing in this module is the-'ToJSON' instance for 'Envelope'.--}--module Servant.Checked.Exceptions.Internal.Envelope-  (-  -- * Envelope-    Envelope(..)-  -- * Helper functions-  -- ** Envelope Constructors-  , toSuccEnvelope-  , toErrEnvelope-  , pureSuccEnvelope-  , pureErrEnvelope-  -- ** Envelope Destructors-  , envelope-  , emptyEnvelope-  , fromEnvelope-  , fromEnvelopeOr-  , fromEnvelopeM-  , fromEnvelopeOrM-  , errEnvelopeMatch-  , catchesEnvelope-  -- ** Optics-  , _SuccEnvelope-  , _ErrEnvelope-  , _ErrEnvelopeErr-  -- ** Either-  , envelopeToEither-  , eitherToEnvelope-  , isoEnvelopeEither-  -- * Setup code for doctests-  -- $setup-  ) where--import Control.Applicative ((<|>))-import Control.Monad.Fix (MonadFix(mfix))-import Data.Aeson-       (FromJSON(parseJSON), ToJSON(toJSON), Value, (.=), (.:), object,-        withObject)-import Data.Aeson.Types (Parser)-import Data.Data (Data)-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotent)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)--import Servant.Checked.Exceptions.Internal.Prism-       (Iso, Prism, Prism', iso, preview, prism)-import Servant.Checked.Exceptions.Internal.Product (ToOpenProduct)-import Servant.Checked.Exceptions.Internal.Union-       (IsMember, OpenUnion, absurdUnion, catchesOpenUnion, openUnionLift,-        openUnionPrism)-import Servant.Checked.Exceptions.Internal.Util (ReturnX)----- $setup--- >>> :set -XDataKinds--- >>> :set -XTypeOperators--- >>> import Data.Aeson (encode)--- >>> import Data.ByteString.Lazy.Char8 (hPutStrLn)--- >>> import Data.Text (Text)--- >>> import System.IO (stdout)--- >>> import Text.Read (readMaybe)--- >>> import Servant.Checked.Exceptions.Internal.Prism (review)--- >>> let putByteStrLn = hPutStrLn stdout----- | This 'Envelope' type is a used as a wrapper around either an 'OpenUnion'--- with an error or a successful value.  It is similar to an @'Either' e a@,--- but where the @e@ is specialized to @'OpenUnion' es@.  The most important--- difference from 'Either' is the the 'FromJSON' and 'ToJSON' instances.------ Given an @'Envelope' \'['String', 'Double'] ()@, we know that the envelope--- could be a 'SuccEnvelope' and contain @()@.  Or it could be a 'ErrEnvelope'--- that contains /either/ a 'String' /or/ a 'Double'.  It might be simpler to--- think of it as a type like @'Either' 'String' ('Either' 'Double' ())@.------ An 'Envelope' can be created with the 'toErrEnvelope' and 'toSuccEnvelope'--- functions.  The 'Prism's '_SuccEnvelope', '_ErrEnvelope', and--- '_ErrEnvelopeErr' can be used to get values out of an 'Envelope'.-data Envelope es a = ErrEnvelope (OpenUnion es) | SuccEnvelope a-  deriving (Foldable, Functor, Generic, Traversable)---- | Create an 'ErrEnvelope' from a member of the 'OpenUnion'.------ For instance, here is how to create an 'ErrEnvelope' that contains a--- 'Double':------ >>> let double = 3.5 :: Double--- >>> toErrEnvelope double :: Envelope '[String, Double, Int] ()--- ErrEnvelope (Identity 3.5)-toErrEnvelope :: IsMember e es => e -> Envelope es a-toErrEnvelope = ErrEnvelope . openUnionLift---- | This is a function to create a 'SuccEnvelope'.------ >>> toSuccEnvelope "hello" :: Envelope '[Double] String--- SuccEnvelope "hello"-toSuccEnvelope :: a -> Envelope es a-toSuccEnvelope = SuccEnvelope---- | 'pureErrEnvelope' is 'toErrEnvelope' lifted up to an 'Applicative'.-pureErrEnvelope :: (Applicative m, IsMember e es) => e -> m (Envelope es a)-pureErrEnvelope = pure . toErrEnvelope---- | 'pureSuccEnvelope' is 'toSuccEnvelope' lifted up to an 'Applicative'.-pureSuccEnvelope :: Applicative m => a -> m (Envelope es a)-pureSuccEnvelope = pure . toSuccEnvelope---- | Case analysis for 'Envelope's.------ ==== __Examples__------  Here is an example of matching on a 'SuccEnvelope':------ >>> let env = toSuccEnvelope "hello" :: Envelope '[Double, Int] String--- >>> envelope (const "not a String") id env--- "hello"------ Here is an example of matching on a 'ErrEnvelope':------ >>> let double = 3.5 :: Double--- >>> let env' = toErrEnvelope double :: Envelope '[Double, Int] String--- >>> envelope (const "not a String") id env'--- "not a String"-envelope :: (OpenUnion es -> c) -> (a -> c) -> Envelope es a -> c-envelope f _ (ErrEnvelope es) = f es-envelope _ f (SuccEnvelope a) = f a---- | Unwrap an 'Envelope' that cannot contain an error.------ ==== __Examples__------ >>> let env = toSuccEnvelope "hello" :: Envelope '[] String--- >>> emptyEnvelope env--- "hello"-emptyEnvelope :: Envelope '[] a -> a-emptyEnvelope (SuccEnvelope a) = a-emptyEnvelope (ErrEnvelope es) = absurdUnion es---- | Just like 'Data.Either.fromEither' but for 'Envelope'.------ ==== __Examples__------  Here is an example of successfully matching:------ >>> let env = toSuccEnvelope "hello" :: Envelope '[Double, Int] String--- >>> fromEnvelope (const "not a String") env--- "hello"------ Here is an example of unsuccessfully matching:------ >>> let double = 3.5 :: Double--- >>> let env' = toErrEnvelope double :: Envelope '[Double, Int] String--- >>> fromEnvelope (const "not a String") env'--- "not a String"-fromEnvelope :: (OpenUnion es -> a) -> Envelope es a -> a-fromEnvelope f = envelope f id---- | Lifted version of 'fromEnvelope'.-fromEnvelopeM-  :: Applicative m-  => (OpenUnion es -> m a) -> Envelope es a -> m a-fromEnvelopeM f = envelope f pure---- | Flipped version of 'fromEnvelope'.-fromEnvelopeOr :: Envelope es a -> (OpenUnion es -> a) -> a-fromEnvelopeOr = flip fromEnvelope---- | Flipped version of 'fromEnvelopeM'.-fromEnvelopeOrM-  :: Applicative m-  => Envelope es a -> (OpenUnion es -> m a) -> m a-fromEnvelopeOrM = flip fromEnvelopeM---- | Convert an 'Envelope' to an 'Either'.-envelopeToEither :: Envelope es a -> Either (OpenUnion es) a-envelopeToEither (ErrEnvelope es) = Left es-envelopeToEither (SuccEnvelope a) = Right a---- | Convert an 'Either' to an 'Envelope'.-eitherToEnvelope :: Either (OpenUnion es) a -> Envelope es a-eitherToEnvelope (Left es) = ErrEnvelope es-eitherToEnvelope (Right a) = SuccEnvelope a---- | Lens-compatible 'Iso' from 'Envelope' to 'Either'.-isoEnvelopeEither :: Iso (Envelope es a) (Envelope fs b) (Either (OpenUnion es) a) (Either (OpenUnion fs) b)-isoEnvelopeEither = iso envelopeToEither eitherToEnvelope---- | Lens-compatible 'Prism' to pull out an @a@ from a 'SuccEnvelope'.------ ==== __Examples__------ Use '_SuccEnvelope' to construct an 'Envelope':------ >>> review _SuccEnvelope "hello" :: Envelope '[Double] String--- SuccEnvelope "hello"------ Use '_SuccEnvelope' to try to destruct an 'Envelope' into an @a@:------ >>> let env = toSuccEnvelope "hello" :: Envelope '[Double] String--- >>> preview _SuccEnvelope env :: Maybe String--- Just "hello"------ Use '_SuccEnvelope' to try to destruct a 'Envelope into an @a@--- (unsuccessfully):------ >>> let double = 3.5 :: Double--- >>> let env' = toErrEnvelope double :: Envelope '[Double] String--- >>> preview _SuccEnvelope env' :: Maybe String--- Nothing-_SuccEnvelope :: Prism (Envelope es a) (Envelope es b) a b-_SuccEnvelope = prism SuccEnvelope $ envelope (Left . ErrEnvelope) Right---- | Lens-compatible 'Prism' to pull out an @'OpenUnion' es@ from a--- 'ErrEnvelope'.------ Most users will not use '_ErrEnvelope', but instead '_ErrEnvelopeErr'.------ ==== __Examples__------ Use '_ErrEnvelope' to construct an 'Envelope':------ >>> let string = "hello" :: String--- >>> review _ErrEnvelope (openUnionLift string) :: Envelope '[String] Double--- ErrEnvelope (Identity "hello")------ Use '_ErrEnvelope' to try to destruct an 'Envelope' into an--- @'OpenUnion' es@:------ >>> let double = 3.5 :: Double--- >>> let env = toErrEnvelope double :: Envelope '[Double] ()--- >>> preview _ErrEnvelope env :: Maybe (OpenUnion '[Double])--- Just (Identity 3.5)------ Use '_ErrEnvelope' to try to destruct a 'Envelope into an--- @'OpenUnion' es@ (unsuccessfully):------ >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()--- >>> preview _ErrEnvelope env' :: Maybe (OpenUnion '[Double])--- Nothing-_ErrEnvelope :: Prism (Envelope es a) (Envelope es' a) (OpenUnion es) (OpenUnion es')-_ErrEnvelope = prism ErrEnvelope $ envelope Right (Left . SuccEnvelope)---- | Lens-compatible 'Prism' to pull out a specific @e@ from an 'ErrEnvelope'.------ Most users will use '_ErrEnvelopeErr' instead of '_ErrEnvelope'.------ ==== __Examples__------ Use '_ErrEnvelopeErr' to construct an 'Envelope':------ >>> let string = "hello" :: String--- >>> review _ErrEnvelopeErr string :: Envelope '[String] Double--- ErrEnvelope (Identity "hello")------ Use '_ErrEnvelopeErr' to try to destruct an 'Envelope' into an @e@:------ >>> let double = 3.5 :: Double--- >>> let env = toErrEnvelope double :: Envelope '[Double] ()--- >>> preview _ErrEnvelopeErr env :: Maybe Double--- Just 3.5------ Use '_ErrEnvelopeErr' to try to destruct a 'Envelope into an--- @e@ (unsuccessfully):------ >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()--- >>> preview _ErrEnvelopeErr env' :: Maybe Double--- Nothing--- >>> let env'' = toErrEnvelope 'c' :: Envelope '[Double, Char] ()--- >>> preview _ErrEnvelopeErr env'' :: Maybe Double--- Nothing-_ErrEnvelopeErr :: forall e es a. IsMember e es => Prism' (Envelope es a) e-_ErrEnvelopeErr = _ErrEnvelope . openUnionPrism---- | Pull out a specific @e@ from an 'ErrEnvelope'.------ ==== __Examples__------ Successfully pull out an @e@:------ >>> let double = 3.5 :: Double--- >>> let env = toErrEnvelope double :: Envelope '[Double] ()--- >>> errEnvelopeMatch env :: Maybe Double--- Just 3.5------ Unsuccessfully pull out an @e@:------ >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()--- >>> errEnvelopeMatch env' :: Maybe Double--- Nothing--- >>> let env'' = toErrEnvelope 'c' :: Envelope '[Double, Char] ()--- >>> errEnvelopeMatch env'' :: Maybe Double--- Nothing-errEnvelopeMatch-  :: forall e es a.-     IsMember e es-  => Envelope es a -> Maybe e-errEnvelopeMatch = preview _ErrEnvelopeErr---- | An alternate case anaylsis for an 'Envelope'.  This method uses a tuple--- containing handlers for each potential value of the 'Envelope'.  This is--- somewhat similar to the 'Control.Exception.catches' function.------ When working with an 'Envelope' with a large number of possible error types,--- it can be easier to use 'catchesEnvelope' than 'envelope'.------ ==== __Examples__------ Here is an example of handling an 'SuccEnvelope' with two possible error values.--- Notice that a normal tuple is used:------ >>> let env = toSuccEnvelope 2.0 :: Envelope '[Int, String] Double--- >>> let intHandler = (\int -> show int) :: Int -> String--- >>> let strHandler = (\str -> str) :: String -> String--- >>> let succHandler = (\dbl -> "got a double") :: Double -> String--- >>> catchesEnvelope (intHandler, strHandler) succHandler env :: String--- "got a double"------ Here is an example of handling an 'ErrEnvelope' with two possible error values.--- Notice that a normal tuple is used to hold the handlers:------ >>> let env = toErrEnvelope (3 :: Int) :: Envelope '[Int, String] Double--- >>> let intHandler = (\int -> show int) :: Int -> String--- >>> let strHandler = (\str -> str) :: String -> String--- >>> let succHandler = (\dbl -> "got a double") :: Double -> String--- >>> catchesEnvelope (intHandler, strHandler) succHandler env :: String--- "3"------ Given an 'Envelope' like @'Envelope' \'['Int', 'String'] 'Double'@, the type of--- 'catchesEnvelope' becomes the following:------ @---   'catchesEnvelope'---     :: ('Int' -> x, 'String' -> x)---     -> ('Double' -> x)---     -> 'Envelope' \'['Int', 'String'] 'Double'---     -> x--- @------ Here is an example of handling an 'ErrEnvelope' with three possible values.--- Notice how a 3-tuple is used to hold the handlers:------ >>> let env = toErrEnvelope ("hi" :: String) :: Envelope '[Int, String, Char] Double--- >>> let intHandler = (\int -> show int) :: Int -> String--- >>> let strHandler = (\str -> str) :: String -> String--- >>> let chrHandler = (\chr -> [chr]) :: Char -> String--- >>> let succHandler = (\dbl -> "got a double") :: Double -> String--- >>> catchesEnvelope (intHandler, strHandler, chrHandler) succHandler env :: String--- "hi"------ Given an 'Envelope' like @'Envelope' \'['Int', 'String', 'Char'] 'Double'@,--- the type of 'catchesEnvelope' becomes the following:------ @---   'catchesEnvelope'---     :: ('Int' -> x, 'String' -> x, 'Char' -> x)---     -> ('Double' -> x)---     -> 'Envelope' \'['Int', 'String', 'Char'] 'Double'---     -> x--- @------ Here is an example of handling an 'ErrEnvelope' with only one possible error value.--- Notice that a normal handler is used (not a tuple):------ >>> let env = toErrEnvelope (3 :: Int) :: Envelope '[Int] Double--- >>> let intHandler = (\int -> show int) :: Int -> String--- >>> let succHandler = (\dbl -> "got a double") :: Double -> String--- >>> catchesEnvelope intHandler succHandler env :: String--- "3"------ Given an 'Envelope' like @'Envelope' \'['Int'] 'Double'@, the type of--- 'catchesEnvelope' becomes the following:------ @---   'catchesEnvelope'---     :: ('Int' -> x)---     -> ('Double' -> x)---     -> 'Envelope' \'['Int'] 'Double'---     -> x--- @-catchesEnvelope-  :: forall tuple es a x.-     ToOpenProduct tuple (ReturnX x es)-  => tuple -> (a -> x) -> Envelope es a -> x-catchesEnvelope _ a2x (SuccEnvelope a) = a2x a-catchesEnvelope tuple _ (ErrEnvelope u) = catchesOpenUnion tuple u---- | This 'ToJSON' instance encodes an 'Envelope' as an object with one of two--- keys depending on whether it is a 'SuccEnvelope' or an 'ErrEnvelope'.------ Here is an example of a 'SuccEnvelope':------ >>> let string = "hello" :: String--- >>> let env = toSuccEnvelope string :: Envelope '[Double] String--- >>> putByteStrLn $ encode env--- {"data":"hello"}------ Here is an example of a 'ErrEnvelope':------ >>> let double = 3.5 :: Double--- >>> let env' = toErrEnvelope double :: Envelope '[Double] String--- >>> putByteStrLn $ encode env'--- {"err":3.5}-instance (ToJSON (OpenUnion es), ToJSON a) => ToJSON (Envelope es a) where-  toJSON :: Envelope es a -> Value-  toJSON (ErrEnvelope es) = object ["err" .= es]-  toJSON (SuccEnvelope a) = object ["data" .= a]---- | This is only a valid instance when the 'FromJSON' instances for the @es@--- don't overlap.------ For an explanation, see the documentation on the 'FromJSON' instance for--- 'Servant.Checked.Exceptions.Internal.Union.Union'.-instance (FromJSON (OpenUnion es), FromJSON a) => FromJSON (Envelope es a) where-  parseJSON :: Value -> Parser (Envelope es a)-  parseJSON = withObject "Envelope" $ \obj ->-    SuccEnvelope <$> obj .: "data" <|>-    ErrEnvelope <$> obj .: "err"--deriving instance (Data (OpenUnion es), Data a, Typeable es) => Data (Envelope es a)-deriving instance (Eq (OpenUnion es), Eq a) => Eq (Envelope es a)-deriving instance (Ord (OpenUnion es), Ord a) => Ord (Envelope es a)-deriving instance (Read (OpenUnion es), Read a) => Read (Envelope es a)-deriving instance (Show (OpenUnion es), Show a) => Show (Envelope es a)-deriving instance (Typeable (OpenUnion es), Typeable a) => Typeable (Envelope es a)--instance Applicative (Envelope es) where-  pure :: a -> Envelope es a-  pure = SuccEnvelope--  (<*>) :: Envelope es (a -> b) -> Envelope es a -> Envelope es b-  ErrEnvelope es <*> _ = ErrEnvelope es-  SuccEnvelope f <*> r = fmap f r--instance Monad (Envelope es) where-  (>>=) :: Envelope es a -> (a -> Envelope es b) -> Envelope es b-  ErrEnvelope es >>= _ = ErrEnvelope es-  SuccEnvelope a >>= k = k a--instance MonadFix (Envelope es) where-  mfix :: (a -> Envelope es a) -> Envelope es a-  mfix f =-    let a = f (unSucc a)-    in a-    where-      unSucc :: Envelope es a -> a-      unSucc (SuccEnvelope x) = x-      unSucc (ErrEnvelope _) = errorWithoutStackTrace "mfix Envelope: ErrEnvelope"--instance Semigroup (Envelope es a) where-  (<>) :: Envelope es a -> Envelope es a -> Envelope es a-  ErrEnvelope _ <> b = b-  a      <> _ = a--  stimes :: Integral b => b -> Envelope es a -> Envelope es a-  stimes = stimesIdempotent

@@ -1,75 +0,0 @@-{-# LANGUAGE RankNTypes #-}--{- |-Module      :  Servant.Checked.Exceptions.Internal.Envelope-License     :  BSD3-Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)-Stability   :  experimental-Portability :  unknown--These functions are for working with Optics popularized by the-<https://hackage.haskell.org/package/lens lens> package. Documentation can be-found in the lens package.  These functions are redefined here to remove the-dependency on the lens package.--}--module Servant.Checked.Exceptions.Internal.Prism-  ( Prism-  , prism-  , Prism'-  , prism'-  , Iso-  , iso-  , review-  , preview-  , (<>~)-  ) where--import Data.Profunctor.Unsafe((#.))-import Control.Applicative-import Data.Coerce-import Data.Functor.Identity-import Data.Monoid-import Data.Profunctor-import Data.Tagged--type Iso s t a b-   = forall p f. (Profunctor p, Functor f) =>-                   p a (f b) -> p s (f t)--type Prism s t a b-   = forall p f. (Choice p, Applicative f) =>-                   p a (f b) -> p s (f t)--type Prism' s a = Prism s s a a--type ASetter s t a b = (a -> Identity b) -> s -> Identity t--iso :: (s -> a) -> (b -> t) -> Iso s t a b-iso sa bt = dimap sa (fmap bt)-{-# INLINE iso #-}--prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b-prism bt seta = dimap seta (either pure (fmap bt)) . right'-{-# INLINE prism #-}--prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a-prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))-{-# INLINE prism' #-}--review :: Prism' t b -> b -> t-review p = coerce . p . Tagged . Identity-{-# INLINE review #-}--preview :: Prism' s a -> s -> Maybe a-preview l = coerce . l (Const . First . Just)-{-# INLINE preview #-}--over :: ASetter s t a b -> (a -> b) -> s -> t-over l f = runIdentity #. l (Identity #. f)-{-# INLINE over #-}--infixr 4 <>~-(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t-l <>~ n = over l (`mappend` n)-{-# INLINE (<>~) #-}

@@ -1,153 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- |-Module      :  Servant.Checked.Exceptions.Internal.Product--Copyright   :  Dennis Gosnell 2017-License     :  BSD3--Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)-Stability   :  experimental-Portability :  unknown--This module defines an open product type.  This is used in the case-analysis-handler for the open sum type.--}--module Servant.Checked.Exceptions.Internal.Product-  where--import Data.Functor.Identity (Identity(Identity))---- $setup--- >>> -- :set -XDataKinds------------------ Product -------------------- | An extensible product type.  This is similar to--- 'Servant.Checked.Exceptions.Internal.Union.Union', except a product type--- instead of a sum type.-data Product (f :: u -> *) (as :: [u]) where-  Nil :: Product f '[]-  Cons :: !(f a) -> Product f as -> Product f (a ': as)---- | This type class provides a way to turn a tuple into a 'Product'.-class ToProduct (tuple :: *) (f :: u -> *) (as :: [u]) | f as -> tuple where-  -- | Convert a tuple into a 'Product'.  See 'tupleToProduct' for examples.-  toProduct :: tuple -> Product f as---- | Convert a single value into a 'Product'.-instance forall (f :: u -> *) (a :: u). ToProduct (f a) f '[a] where-  toProduct :: f a -> Product f '[a]-  toProduct fa = Cons fa Nil---- | Convert a tuple into a 'Product'.-instance forall (f :: u -> *) (a :: u) (b :: u). ToProduct (f a, f b) f '[a, b] where-  toProduct :: (f a, f b) -> Product f '[a, b]-  toProduct (fa, fb) = Cons fa $ Cons fb Nil---- | Convert a 3-tuple into a 'Product'.-instance forall (f :: u -> *) (a :: u) (b :: u) (c :: u). ToProduct (f a, f b, f c) f '[a, b, c] where-  toProduct :: (f a, f b, f c) -> Product f '[a, b, c]-  toProduct (fa, fb, fc) = Cons fa $ Cons fb $ Cons fc Nil---- | Convert a 4-tuple into a 'Product'.-instance forall (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-  toProduct :: (f a, f b, f c, f d) -> Product f '[a, b, c, d]-  toProduct (fa, fb, fc, fd) = Cons fa $ Cons fb $ Cons fc $ Cons fd Nil---- | Turn a tuple into a 'Product'.------ >>> tupleToProduct (Identity 1, Identity 2.0) :: Product Identity '[Int, Double]--- Cons (Identity 1) (Cons (Identity 2.0) Nil)-tupleToProduct :: ToProduct t f as => t -> Product f as-tupleToProduct = toProduct---------------------- OpenProduct ------------------------ | @'Product' 'Identity'@ is used as a standard open product type.-type OpenProduct = Product Identity---- | 'ToOpenProduct' gives us a way to convert a tuple to an 'OpenProduct'.--- See 'tupleToOpenProduct'.-class ToOpenProduct (tuple :: *) (as :: [*]) | as -> tuple where-  toOpenProduct :: tuple -> OpenProduct as---- | Convert a single value into an 'OpenProduct'.-instance forall (a :: *). ToOpenProduct a '[a] where-  toOpenProduct :: a -> OpenProduct '[a]-  toOpenProduct a = Cons (Identity a) Nil---- | Convert a tuple into an 'OpenProduct'.-instance-    forall (a :: *) (b :: *). ToOpenProduct (a, b) '[a, b] where-  toOpenProduct :: (a, b) -> OpenProduct '[a, b]-  toOpenProduct (a, b) = Cons (Identity a) $ Cons (Identity b) Nil---- | Convert a 3-tuple into an 'OpenProduct'.-instance-    forall (a :: *) (b :: *) (c :: *). ToOpenProduct (a, b, c) '[a, b, c] where-  toOpenProduct :: (a, b, c) -> OpenProduct '[a, b, c]-  toOpenProduct (a, b, c) =-    Cons (Identity a) $ Cons (Identity b) $ Cons (Identity c) Nil---- | Convert a 4-tuple into an 'OpenProduct'.-instance-    forall (a :: *) (b :: *) (c :: *) (d :: *).-    ToOpenProduct (a, b, c, d) '[a, b, c, d] where-  toOpenProduct :: (a, b, c, d) -> OpenProduct '[a, b, c, d]-  toOpenProduct (a, b, c, d) =-    Cons (Identity a)-      . Cons (Identity b)-      . Cons (Identity c)-      $ Cons (Identity d) Nil---- | Turn a tuple into an 'OpenProduct'.------ ==== __Examples__------ Turn a triple into an 'OpenProduct':------ >>> tupleToOpenProduct (1, 2.0, "hello") :: OpenProduct '[Int, Double, String]--- Cons (Identity 1) (Cons (Identity 2.0) (Cons (Identity "hello") Nil))------ Turn a single value into an 'OpenProduct':------ >>> tupleToOpenProduct 'c' :: OpenProduct '[Char]--- Cons (Identity 'c') Nil-tupleToOpenProduct :: ToOpenProduct t as => t -> OpenProduct as-tupleToOpenProduct = toOpenProduct-------------------- Instances ---------------------- | Show 'Nil' values.-instance Show (Product f '[]) where-  show :: Product f '[] -> String-  show Nil = "Nil"---- | Show 'Cons' values.-instance (Show (f a), Show (Product f as)) => Show (Product f (a ': as)) where-  showsPrec :: Int -> (Product f (a ': as)) -> String -> String-  showsPrec n (Cons fa prod) = showParen (n > 10) $-    showString "Cons " . showsPrec 11 fa . showString " " . showsPrec 11 prod-

@@ -1,120 +1,7 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--{- |-Module      :  Servant.Checked.Exceptions.Internal.Servant.API--Copyright   :  Dennis Gosnell 2017-License     :  BSD3--Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)-Stability   :  experimental-Portability :  unknown--This module defines the 'Throws' and 'Throwing' types.--}--module Servant.Checked.Exceptions.Internal.Servant.API where--import Data.Typeable (Typeable)-import GHC.Exts (Constraint)-import GHC.Generics (Generic)-import GHC.TypeLits (Nat)-import Network.HTTP.Types (Status, StdMethod(DELETE, GET, PATCH, POST, PUT))-import Servant.API ((:>))--import Servant.Checked.Exceptions.Internal.Util (Snoc)---- | 'Throws' is used in Servant API definitions and signifies that an API will--- throw the given error.------ Here is an example of how to create an API that potentially returns a--- 'String' as an error, or an 'Int' on success:------ >>> import Servant.API (Get, JSON, (:>))--- >>> type API = Throws String :> Get '[JSON] Int-data Throws (e :: *)---- | 'NoThrow' is used to indicate that an API will not throw an error, but--- that it will still return a response wrapped in a--- 'Servant.Checked.Exceptions.Internal.Envelope.Envelope'.------ ==== __Examples__------ Create an API using 'NoThrow':------ >>> import Servant.API (Get, JSON, (:>))--- >>> type API = NoThrow :> Get '[JSON] Int------ A servant-server handler for this type would look like the following:------ @---   apiHandler :: 'Servant.Handler' ('Servant.Checked.Exceptions.Internal.Envelope.Envelope' \'[] Int)---   apiHandler = 'Servant.Checked.Exceptions.Internal.Envelope.pureSuccEnvelope' 3--- @-data NoThrow---- | This is used internally and should not be used by end-users.-data Throwing (e :: [*])---- | Used by the 'HasServer' and 'HasClient' instances for--- @'Throwing' es ':>' api ':>' apis@ to detect @'Throwing' es@ followed--- immediately by @'Throws' e@.-type family ThrowingNonterminal api where-  ThrowingNonterminal (Throwing es :> Throws e :> api) =-    Throwing (Snoc es e) :> api-  ThrowingNonterminal (Throwing es :> c :> api) =-    c :> Throwing es :> api--data VerbWithErr-    (method :: k1)-    (successStatusCode :: Nat)-    (contentTypes :: [*])-    (es :: [*])-    a-  deriving (Generic, Typeable)--type GetWithErr    = VerbWithErr 'GET    200-type PostWithErr   = VerbWithErr 'POST   200-type PutWithErr    = VerbWithErr 'PUT    200-type DeleteWithErr = VerbWithErr 'DELETE 200-type PatchWithErr  = VerbWithErr 'PATCH  200--type PostCreatedWithErr = VerbWithErr 'POST 201--type GetAcceptedWithErr    = VerbWithErr 'GET 202-type PostAcceptedWithErr   = VerbWithErr 'POST 202-type DeleteAcceptedWithErr = VerbWithErr 'DELETE 202-type PatchAcceptedWithErr  = VerbWithErr 'PATCH 202-type PutAcceptedWithErr    = VerbWithErr 'PUT 202--type GetNonAuthoritativeWithErr    = VerbWithErr 'GET 203-type PostNonAuthoritativeWithErr   = VerbWithErr 'POST 203-type DeleteNonAuthoritativeWithErr = VerbWithErr 'DELETE 203-type PatchNonAuthoritativeWithErr  = VerbWithErr 'PATCH 203-type PutNonAuthoritativeWithErr    = VerbWithErr 'PUT 203--type GetNoContentWithErr    = VerbWithErr 'GET 204-type PostNoContentWithErr   = VerbWithErr 'POST 204-type DeleteNoContentWithErr = VerbWithErr 'DELETE 204-type PatchNoContentWithErr  = VerbWithErr 'PATCH 204-type PutNoContentWithErr    = VerbWithErr 'PUT 204--type GetResetContentWithErr    = VerbWithErr 'GET 205-type PostResetContentWithErr   = VerbWithErr 'POST 205-type DeleteResetContentWithErr = VerbWithErr 'DELETE 205-type PatchResetContentWithErr  = VerbWithErr 'PATCH 205-type PutResetContentWithErr    = VerbWithErr 'PUT 205--type GetPartialContentWithErr = VerbWithErr 'GET 206+{-# LANGUAGE PackageImports #-} -class ErrStatus e where-  toErrStatus :: e -> Status+module Servant.Checked.Exceptions.Internal.Servant.API (+  module Servant.Checked.Exceptions.Internal.Servant.API+  ) where -type family AllErrStatus (es :: [k]) :: Constraint where-  AllErrStatus '[] = ()-  AllErrStatus (a ': as) = (ErrStatus a, AllErrStatus as)+import "servant-checked-exceptions-core" Servant.Checked.Exceptions.Internal.Servant.API

@@ -1,163 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{- |-Module      :  Servant.Checked.Exceptions.Internal.Servant.Docs--Copyright   :  Dennis Gosnell 2017-License     :  BSD3--Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)-Stability   :  experimental-Portability :  unknown--This module exports 'HasDocs' instances for 'Throws' and 'Throwing'.--}--module Servant.Checked.Exceptions.Internal.Servant.Docs where--import Data.Proxy (Proxy(Proxy))-import Data.ByteString.Lazy (ByteString)-import Data.Function ((&))-import Data.Monoid ((<>))-import Data.Text (Text)-import Network.HTTP.Media (MediaType)-import Servant.API (Verb, (:>))-import Servant.API.ContentTypes (AllMimeRender(allMimeRender))-import Servant.Docs-       (Action, API, DocOptions, Endpoint, HasDocs(docsFor),-        ToSample(toSamples))-import Servant.Docs.Internal (apiEndpoints, respBody, response)--import Servant.Checked.Exceptions.Internal.Envelope-       (Envelope, toErrEnvelope, toSuccEnvelope)-import Servant.Checked.Exceptions.Internal.Prism ((<>~))-import Servant.Checked.Exceptions.Internal.Servant.API-       (NoThrow, Throws, Throwing)-import Servant.Checked.Exceptions.Internal.Util (Snoc)---- TODO: Make sure to also account for when headers are being used.---- | Change a 'Throws' into 'Throwing'.-instance (HasDocs (Throwing '[e] :> api)) => HasDocs (Throws e :> api) where-  docsFor-    :: Proxy (Throws e :> api)-    -> (Endpoint, Action)-    -> DocOptions-    -> API-  docsFor Proxy = docsFor (Proxy :: Proxy (Throwing '[e] :> api))---- | When @'Throwing' es@ comes before a 'Verb', generate the documentation for--- the same 'Verb', but returning an @'Envelope' es@.  Also add documentation--- for the potential @es@.-instance-       ( CreateRespBodiesFor es ctypes-       , HasDocs (Verb method status ctypes (Envelope es a))-       )-    => HasDocs (Throwing es :> Verb method status ctypes a) where-  docsFor-    :: Proxy (Throwing es :> Verb method status ctypes a)-    -> (Endpoint, Action)-    -> DocOptions-    -> API-  docsFor Proxy (endpoint, action) docOpts =-    let api =-          docsFor-            (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))-            (endpoint, action)-            docOpts-    in api & apiEndpoints . traverse . response . respBody <>~-        createRespBodiesFor (Proxy :: Proxy es) (Proxy :: Proxy ctypes)---- | When 'NoThrow' comes before a 'Verb', generate the documentation for--- the same 'Verb', but returning an @'Envelope' \'[]@.-instance (HasDocs (Verb method status ctypes (Envelope '[] a)))-    => HasDocs (NoThrow :> Verb method status ctypes a) where-  docsFor-    :: Proxy (NoThrow :> Verb method status ctypes a)-    -> (Endpoint, Action)-    -> DocOptions-    -> API-  docsFor Proxy (endpoint, action) docOpts =-    docsFor-      (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))-      (endpoint, action)-      docOpts---- | Create samples for a given @list@ of types, under given @ctypes@.------ Additional instances of this class should not need to be created.-class CreateRespBodiesFor list ctypes where-  createRespBodiesFor-    :: Proxy list-    -> Proxy ctypes-    -> [(Text, MediaType, ByteString)]---- | An empty list of types has no samples.-instance CreateRespBodiesFor '[] ctypes where-  createRespBodiesFor-    :: Proxy '[]-    -> Proxy ctypes-    -> [(Text, MediaType, ByteString)]-  createRespBodiesFor Proxy Proxy = []---- | Create a response body for each of the error types.-instance-       ( AllMimeRender ctypes (Envelope '[e] ())-       , CreateRespBodiesFor es ctypes-       , ToSample e-       )-    => CreateRespBodiesFor (e ': es) ctypes where-  createRespBodiesFor-    :: Proxy (e ': es)-    -> Proxy ctypes-    -> [(Text, MediaType, ByteString)]-  createRespBodiesFor Proxy ctypes =-    createRespBodyFor (Proxy :: Proxy e) ctypes <>-    createRespBodiesFor (Proxy :: Proxy es) ctypes---- | Create a sample for a given @e@ under given @ctypes@.-createRespBodyFor-  :: forall e ctypes.-     (AllMimeRender ctypes (Envelope '[e] ()), ToSample e)-  => Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]-createRespBodyFor Proxy ctypes = concatMap enc samples-    where-      samples :: [(Text, Envelope '[e] ())]-      samples = fmap toErrEnvelope <$> toSamples (Proxy :: Proxy e)--      enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]-      enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s---- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the--- @e@ onto the @es@.-instance (HasDocs (Throwing (Snoc es e) :> api)) =>-    HasDocs (Throwing es :> Throws e :> api) where-  docsFor-    :: Proxy (Throwing es :> Throws e :> api)-    -> (Endpoint, Action)-    -> DocOptions-    -> API-  docsFor Proxy =-    docsFor (Proxy :: Proxy (Throwing (Snoc es e) :> api))---- | We can generate a sample of an @'Envelope' es a@ as long as there is a way--- to generate a sample of the @a@.------ This doesn't need to worry about generating a sample of @es@, because that is--- taken care of in the 'HasDocs' instance for @'Throwing' es@.-instance ToSample a => ToSample (Envelope es a) where-  toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)]-  toSamples Proxy = fmap toSuccEnvelope <$> toSamples (Proxy :: Proxy a)

@@ -32,13 +32,28 @@ import Data.Functor.Identity import Data.Maybe import Data.Proxy (Proxy(Proxy))+import Data.WorldPeace (OpenUnion, Union(That, This)) import GHC.TypeLits (KnownNat, natVal) import Network.HTTP.Types import Network.Wai-import Servant.API.ContentTypes -- (AcceptHeader(AcceptHeader), AllCTRender, handleAcceptH)+import Servant.API.ContentTypes+  ( AcceptHeader(AcceptHeader)+  , AllCTRender+  , AllMime+  , canHandleAcceptH+  , handleAcceptH+  ) import Servant.Server.Internal (ct_wildcard) import Servant.Server.Internal.Router (Router, Router', leafRouter)-import Servant.Server.Internal.RoutingApplication -- (Delayed, DelayedIO, RouteResult(FailFatal, Route), addAcceptCheck, addMethodCheck, runAction)+import Servant.Server.Internal.RoutingApplication+  ( Delayed+  , DelayedIO+  , RouteResult(FailFatal, Route)+  , addAcceptCheck+  , addMethodCheck+  , delayedFail+  , runAction+  ) import Servant   ( (:<|>)(..)   , (:>)@@ -54,7 +69,6 @@   )  import Servant.Checked.Exceptions.Internal.Envelope (Envelope, envelope)-import Servant.Checked.Exceptions.Internal.Union (OpenUnion, Union(That, This)) import Servant.Checked.Exceptions.Internal.Servant.API   ( AllErrStatus   , ErrStatus(toErrStatus)@@ -62,8 +76,8 @@   , Throwing   , ThrowingNonterminal   , Throws-  , VerbWithErr   )+import Servant.Checked.Exceptions.Verbs (VerbWithErr)  -- TODO: Make sure to also account for when headers are being used. -- This might be hard to do:

@@ -1,574 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- |-Module      :  Servant.Checked.Exceptions.Internal.Union--Copyright   :  Dennis Gosnell 2017-License     :  BSD3--Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)-Stability   :  experimental-Portability :  unknown--This module defines extensible sum-types.  This is similar to how-<https://hackage.haskell.org/package/vinyl vinyl> defines extensible records.--This is used extensively in the definition of the 'Envelope' type in-"Servant.Checked.Exceptions.Internal.Envelope".--A large portion of the code from this module was taken from the-<https://hackage.haskell.org/package/union union> package.--}--module Servant.Checked.Exceptions.Internal.Union-  (-  -- * Union-    Union(..)-  , union-  , catchesUnion-  , absurdUnion-  , umap-  -- ** Optics-  , _This-  , _That-  -- ** Typeclasses-  , Nat(Z, S)-  , RIndex-  , UElem(..)-  , IsMember-  -- * OpenUnion-  , OpenUnion-  , openUnion-  , fromOpenUnion-  , fromOpenUnionOr-  , openUnionPrism-  , openUnionLift-  , openUnionMatch-  , catchesOpenUnion-  -- * Setup code for doctests-  -- $setup-  ) where---- Imports for Union stuff-import Control.Applicative ((<|>))-import Control.DeepSeq (NFData(rnf))-import Data.Aeson-       (FromJSON(parseJSON), ToJSON(toJSON), Value)-import Data.Aeson.Types (Parser)-import Data.Functor.Identity (Identity(Identity, runIdentity))-import Data.Typeable (Typeable)-import Text.Read (Read(readPrec), ReadPrec, (<++))--import Servant.Checked.Exceptions.Internal.Prism (Prism, Prism', iso, preview, prism, prism', review)-import Servant.Checked.Exceptions.Internal.Product-       (Product(Cons, Nil), ToOpenProduct, ToProduct, tupleToOpenProduct,-        tupleToProduct)-import Servant.Checked.Exceptions.Internal.Util (ReturnX)---- $setup--- >>> :set -XDataKinds--- >>> :set -XTypeOperators--- >>> import Data.Text (Text)--- >>> import Text.Read (readMaybe)--------------------------------------------------------- Type-level helpers (from Data.Vinyl.TypeLevel) ----------------------------------------------------------- | A partial relation that gives the index of a value in a list.------ ==== __Examples__------ Find the first item:------ >>> import Data.Type.Equality ((:~:)(Refl))--- >>> Refl :: RIndex String '[String, Int] :~: 'Z--- Refl------ Find the third item:------ >>> Refl :: RIndex Char '[String, Int, Char] :~: 'S ('S 'Z)--- Refl-type family RIndex (r :: k) (rs :: [k]) :: Nat where-  RIndex r (r ': rs) = 'Z-  RIndex r (s ': rs) = 'S (RIndex r rs)---- | A mere approximation of the natural numbers. And their image as lifted by--- @-XDataKinds@ corresponds to the actual natural numbers.-data Nat = Z | S !Nat---------------------------------- Union (from Data.Union) ------------------------------------ | A 'Union' is parameterized by a universe @u@, an interpretation @f@--- and a list of labels @as@. The labels of the union are given by--- inhabitants of the kind @u@; the type of values at any label @a ::--- u@ is given by its interpretation @f a :: *@.-data Union (f :: u -> *) (as :: [u]) where-  This :: !(f a) -> Union f (a ': as)-  That :: !(Union f as) -> Union f (a ': as)-  deriving (Typeable)---- | Case analysis for 'Union'.------ ==== __Examples__------  Here is an example of matching on a 'This':------ >>> let u = This (Identity "hello") :: Union Identity '[String, Int]--- >>> let runIdent = runIdentity :: Identity String -> String--- >>> union (const "not a String") runIdent u--- "hello"------ Here is an example of matching on a 'That':------ >>> let v = That (This (Identity 3.3)) :: Union Identity '[String, Double, Int]--- >>> union (const "not a String") runIdent v--- "not a String"-union :: (Union f as -> c) -> (f a -> c) -> Union f (a ': as) -> c-union _ onThis (This a) = onThis a-union onThat _ (That u) = onThat u---- | Since a union with an empty list of labels is uninhabited, we--- can recover any type from it.-absurdUnion :: Union f '[] -> a-absurdUnion u = case u of {}---- | Map over the interpretation @f@ in the 'Union'.------ ==== __Examples__------ Here is an example of changing a @'Union' 'Identity' \'['String', 'Int']@ to--- @'Union' 'Maybe' \'['String', 'Int']@:------ >>> let u = This (Identity "hello") :: Union Identity '[String, Int]--- >>> umap (Just . runIdentity) u :: Union Maybe '[String, Int]--- Just "hello"-umap :: (forall a . f a -> g a) -> Union f as -> Union g as-umap f (This a) = This $ f a-umap f (That u) = That $ umap f u--catchesUnionProduct-  :: forall x f as.-     Applicative f-  => Product f (ReturnX x as) -> Union f as -> f x-catchesUnionProduct (Cons f _) (This a) = f <*> a-catchesUnionProduct (Cons _ p) (That u) = catchesUnionProduct p u-catchesUnionProduct Nil _ = undefined---- | An alternate case anaylsis for a 'Union'.  This method uses a tuple--- containing handlers for each potential value of the 'Union'.  This is--- somewhat similar to the 'Control.Exception.catches' function.------ ==== __Examples__------ Here is an example of handling a 'Union' with two possible values.  Notice--- that a normal tuple is used:------ >>> let u = This $ Identity 3 :: Union Identity '[Int, String]--- >>> let intHandler = (Identity $ \int -> show int) :: Identity (Int -> String)--- >>> let strHandler = (Identity $ \str -> str) :: Identity (String -> String)--- >>> catchesUnion (intHandler, strHandler) u :: Identity String--- Identity "3"------ Given a 'Union' like @'Union' 'Identity' \'['Int', 'String']@, the type of--- 'catchesUnion' becomes the following:------ @---   'catchesUnion'---     :: ('Identity' ('Int' -> 'String'), 'Identity' ('String' -> 'String'))---     -> 'Union' 'Identity' \'['Int', 'String']---     -> 'Identity' 'String'--- @------ Checkout 'catchesOpenUnion' for more examples.-catchesUnion-  :: (Applicative f, ToProduct tuple f (ReturnX x as))-  => tuple -> Union f as -> f x-catchesUnion tuple u = catchesUnionProduct (tupleToProduct tuple) u---- | Lens-compatible 'Prism' for 'This'.------ ==== __Examples__------ Use '_This' to construct a 'Union':------ >>> review _This (Just "hello") :: Union Maybe '[String]--- Just "hello"------ Use '_This' to try to destruct a 'Union' into a @f a@:------ >>> let u = This (Identity "hello") :: Union Identity '[String, Int]--- >>> preview _This u :: Maybe (Identity String)--- Just (Identity "hello")------ Use '_This' to try to destruct a 'Union' into a @f a@ (unsuccessfully):------ >>> let v = That (This (Identity 3.3)) :: Union Identity '[String, Double, Int]--- >>> preview _This v :: Maybe (Identity String)--- Nothing-_This :: Prism (Union f (a ': as)) (Union f (b ': as)) (f a) (f b)-_This = prism This (union (Left . That) Right)-{-# INLINE _This #-}---- | Lens-compatible 'Prism' for 'That'.------ ==== __Examples__------ Use '_That' to construct a 'Union':------ >>> let u = This (Just "hello") :: Union Maybe '[String]--- >>> review _That u :: Union Maybe '[Double, String]--- Just "hello"------ Use '_That' to try to peel off a 'That' from a 'Union':------ >>> let v = That (This (Identity "hello")) :: Union Identity '[Int, String]--- >>> preview _That v :: Maybe (Union Identity '[String])--- Just (Identity "hello")------ Use '_That' to try to peel off a 'That' from a 'Union' (unsuccessfully):------ >>> let w = This (Identity 3.5) :: Union Identity '[Double, String]--- >>> preview _That w :: Maybe (Union Identity '[String])--- Nothing-_That :: Prism (Union f (a ': as)) (Union f (a ': bs)) (Union f as) (Union f bs)-_That = prism That (union Right (Left . This))-{-# INLINE _That #-}----------------------- type classes ------------------------- | @'UElem' a as i@ provides a way to potentially get an @f a@ out of a--- @'Union' f as@ ('unionMatch').  It also provides a way to create a--- @'Union' f as@ from an @f a@ ('unionLift').------ This is safe because of the 'RIndex' contraint. This 'RIndex' constraint--- tells us that there /actually is/ an @a@ in @as@ at index @i@.------ As an end-user, you should never need to implement an additional instance of--- this typeclass.-class i ~ RIndex a as => UElem (a :: u) (as :: [u]) (i :: Nat) where-  {-# MINIMAL unionPrism | unionLift, unionMatch #-}--  -- | This is implemented as @'prism'' 'unionLift' 'unionMatch'@.-  unionPrism :: Prism' (Union f as) (f a)-  unionPrism = prism' unionLift unionMatch--  -- | This is implemented as @'review' 'unionPrism'@.-  unionLift :: f a -> Union f as-  unionLift = review unionPrism--  -- | This is implemented as @'preview' 'unionPrism'@.-  unionMatch :: Union f as -> Maybe (f a)-  unionMatch = preview unionPrism--instance UElem a (a ': as) 'Z where-  unionPrism :: Prism' (Union f (a ': as)) (f a)-  unionPrism = _This-  {-# INLINE unionPrism #-}--instance-    ( RIndex a (b ': as) ~ ('S i)-    , UElem a as i-    )-    => UElem a (b ': as) ('S i) where-  unionPrism :: Prism' (Union f (b ': as)) (f a)-  unionPrism = _That . unionPrism-  {-# INLINE unionPrism #-}---- | This is a helpful 'Constraint' synonym to assert that @a@ is a member of--- @as@.-type IsMember (a :: u) (as :: [u]) = UElem a as (RIndex a as)-------------------- OpenUnion ---------------------- | We can use @'Union' 'Identity'@ as a standard open sum type.-type OpenUnion = Union Identity---- | Case analysis for 'OpenUnion'.------ ==== __Examples__------  Here is an example of successfully matching:------ >>> let string = "hello" :: String--- >>> let o = openUnionLift string :: OpenUnion '[String, Int]--- >>> openUnion (const "not a String") id o--- "hello"------ Here is an example of unsuccessfully matching:------ >>> let double = 3.3 :: Double--- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int]--- >>> openUnion (const "not a String") id p--- "not a String"-openUnion-  :: (OpenUnion as -> c) -> (a -> c) -> OpenUnion (a ': as) -> c-openUnion onThat onThis = union onThat (onThis . runIdentity)---- | This is similar to 'fromMaybe' for an 'OpenUnion'.------ ==== __Examples__------  Here is an example of successfully matching:------ >>> let string = "hello" :: String--- >>> let o = openUnionLift string :: OpenUnion '[String, Int]--- >>> fromOpenUnion (const "not a String") o--- "hello"------ Here is an example of unsuccessfully matching:------ >>> let double = 3.3 :: Double--- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int]--- >>> fromOpenUnion (const "not a String") p--- "not a String"-fromOpenUnion-  :: (OpenUnion as -> a) -> OpenUnion (a ': as) -> a-fromOpenUnion onThat = openUnion onThat id---- | Flipped version of 'fromOpenUnion'.-fromOpenUnionOr-  :: OpenUnion (a ': as) -> (OpenUnion as -> a) -> a-fromOpenUnionOr = flip fromOpenUnion---- | Just like 'unionPrism' but for 'OpenUnion'.-openUnionPrism-  :: forall a as.-     IsMember a as-  => Prism' (OpenUnion as) a-openUnionPrism = unionPrism . iso runIdentity Identity-{-# INLINE openUnionPrism #-}---- | Just like 'unionLift' but for 'OpenUnion'.------ Creating an 'OpenUnion':------ >>> let string = "hello" :: String--- >>> openUnionLift string :: OpenUnion '[Double, String, Int]--- Identity "hello"-openUnionLift-  :: forall a as.-     IsMember a as-  => a -> OpenUnion as-openUnionLift = review openUnionPrism---- | Just like 'unionMatch' but for 'OpenUnion'.------ ==== __Examples__------ Successful matching:------ >>> let string = "hello" :: String--- >>> let o = openUnionLift string :: OpenUnion '[Double, String, Int]--- >>> openUnionMatch o :: Maybe String--- Just "hello"------ Failure matching:------ >>> let double = 3.3 :: Double--- >>> let p = openUnionLift double :: OpenUnion '[Double, String]--- >>> openUnionMatch p :: Maybe String--- Nothing-openUnionMatch-  :: forall a as.-     IsMember a as-  => OpenUnion as -> Maybe a-openUnionMatch = preview openUnionPrism---- | An alternate case anaylsis for an 'OpenUnion'.  This method uses a tuple--- containing handlers for each potential value of the 'OpenUnion'.  This is--- somewhat similar to the 'Control.Exception.catches' function.------ When working with large 'OpenUnion's, it can be easier to use--- 'catchesOpenUnion' than 'openUnion'.------ ==== __Examples__------ Here is an example of handling an 'OpenUnion' with two possible values.--- Notice that a normal tuple is used:------ >>> let u = openUnionLift (3 :: Int) :: OpenUnion '[Int, String]--- >>> let intHandler = (\int -> show int) :: Int -> String--- >>> let strHandler = (\str -> str) :: String -> String--- >>> catchesOpenUnion (intHandler, strHandler) u :: String--- "3"------ Given an 'OpenUnion' like @'OpenUnion' \'['Int', 'String']@, the type of--- 'catchesOpenUnion' becomes the following:------ @---   'catchesOpenUnion'---     :: ('Int' -> x, 'String' -> x)---     -> 'OpenUnion' \'['Int', 'String']---     -> x--- @------ Here is an example of handling an 'OpenUnion' with three possible values:------ >>> let u = openUnionLift ("hello" :: String) :: OpenUnion '[Int, String, Double]--- >>> let intHandler = (\int -> show int) :: Int -> String--- >>> let strHandler = (\str -> str) :: String -> String--- >>> let dblHandler = (\dbl -> "got a double") :: Double -> String--- >>> catchesOpenUnion (intHandler, strHandler, dblHandler) u :: String--- "hello"------ Here is an example of handling an 'OpenUnion' with only one possible value.--- Notice how a tuple is not used, just a single value:------ >>> let u = openUnionLift (2.2 :: Double) :: OpenUnion '[Double]--- >>> let dblHandler = (\dbl -> "got a double") :: Double -> String--- >>> catchesOpenUnion dblHandler u :: String--- "got a double"-catchesOpenUnion-  :: ToOpenProduct tuple (ReturnX x as)-  => tuple -> OpenUnion as -> x-catchesOpenUnion tuple u =-  runIdentity $-    catchesUnionProduct (tupleToOpenProduct tuple) u-------------------- Instances --------------------instance NFData (Union f '[]) where-  rnf = absurdUnion--instance (NFData (f a), NFData (Union f as)) => NFData (Union f (a ': as)) where-  rnf = union rnf rnf--instance Show (Union f '[]) where-  showsPrec _ = absurdUnion--instance (Show (f a), Show (Union f as)) => Show (Union f (a ': as)) where-  showsPrec n = union (showsPrec n) (showsPrec n)---- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'.-instance Read (Union f '[]) where-  readsPrec :: Int -> ReadS (Union f '[])-  readsPrec _ _ = []---- | This is only a valid instance when the 'Read' instances for the types--- don't overlap.------ For instance, imagine we are working with a 'Union' of a 'String' and a 'Double'.--- @3.5@ can only be read as a 'Double', not as a 'String'.--- Oppositely, @\"hello\"@ can only be read as a 'String', not as a 'Double'.------ >>> let o = readMaybe "Identity 3.5" :: Maybe (Union Identity '[Double, String])--- >>> o--- Just (Identity 3.5)--- >>> o >>= openUnionMatch :: Maybe Double--- Just 3.5--- >>> o >>= openUnionMatch :: Maybe String--- Nothing------ >>> let p = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Double, String])--- >>> p--- Just (Identity "hello")--- >>> p >>= openUnionMatch :: Maybe Double--- Nothing--- >>> p >>= openUnionMatch :: Maybe String--- Just "hello"------ However, imagine are we working with a 'Union' of a 'String' and--- 'Data.Text.Text'.  @\"hello\"@ can be 'read' as both a 'String' and--- 'Data.Text.Text'.  However, in the following example, it can only be read as--- a 'String':------ >>> let q = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[String, Text])--- >>> q--- Just (Identity "hello")--- >>> q >>= openUnionMatch :: Maybe String--- Just "hello"--- >>> q >>= openUnionMatch :: Maybe Text--- Nothing------ If the order of the types is flipped around, we are are able to read @\"hello\"@--- as a 'Text' but not as a 'String'.------ >>> let r = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Text, String])--- >>> r--- Just (Identity "hello")--- >>> r >>= openUnionMatch :: Maybe String--- Nothing--- >>> r >>= openUnionMatch :: Maybe Text--- Just "hello"-instance (Read (f a), Read (Union f as)) => Read (Union f (a ': as)) where-  readPrec :: ReadPrec (Union f (a ': as))-  readPrec = fmap This readPrec <++ fmap That readPrec--instance Eq (Union f '[]) where-  (==) = absurdUnion--instance (Eq (f a), Eq (Union f as)) => Eq (Union f (a ': as)) where-    This a1 == This a2 = a1 == a2-    That u1 == That u2 = u1 == u2-    _       == _       = False--instance Ord (Union f '[]) where-  compare = absurdUnion--instance (Ord (f a), Ord (Union f as)) => Ord (Union f (a ': as))-  where-    compare (This a1) (This a2) = compare a1 a2-    compare (That u1) (That u2) = compare u1 u2-    compare (This _)  (That _)  = LT-    compare (That _)  (This _)  = GT--instance ToJSON (Union f '[]) where-  toJSON :: Union f '[] -> Value-  toJSON = absurdUnion--instance (ToJSON (f a), ToJSON (Union f as)) => ToJSON (Union f (a ': as)) where-  toJSON :: Union f (a ': as) -> Value-  toJSON = union toJSON toJSON---- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'.-instance FromJSON (Union f '[]) where-  parseJSON :: Value -> Parser (Union f '[])-  parseJSON _ = fail "Value of Union f '[] can never be created"---- | This is only a valid instance when the 'FromJSON' instances for the types--- don't overlap.------ This is similar to the 'Read' instance.-instance (FromJSON (f a), FromJSON (Union f as)) => FromJSON (Union f (a ': as)) where-  parseJSON :: Value -> Parser (Union f (a ': as))-  parseJSON val = fmap This (parseJSON val) <|> fmap That (parseJSON val)---- instance f ~ Identity => Exception (Union f '[])---- instance---     ( f ~ Identity---     , Exception a---     , Typeable as---     , Exception (Union f as)---     ) => Exception (Union f (a ': as))---   where---     toException = union toException (toException . runIdentity)---     fromException sE = matchR <|> matchL---       where---         matchR = This . Identity <$> fromException sE---         matchL = That <$> fromException sE

@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--{- |-Module      :  Servant.Checked.Exceptions.Internal.Util--Copyright   :  Dennis Gosnell 2017-License     :  BSD3--Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)-Stability   :  experimental-Portability :  unknown--Additional helpers.--}--module Servant.Checked.Exceptions.Internal.Util where---- | A type-level @snoc@.------ Append to an empty list:------ >>> Refl :: Snoc '[] Double :~: '[Double]--- Refl------ Append to a non-empty list:------ >>> Refl :: Snoc '[Char] String :~: '[Char, String]--- Refl-type family Snoc (as :: [k]) (b :: k) where-  Snoc '[] b = '[b]-  Snoc (a ': as) b = (a ': Snoc as b)---- | Change a list of types into a list of functions that take the given type--- and return @x@.------ >>> Refl :: ReturnX Double '[String, Int] :~: '[String -> Double, Int -> Double]--- Refl------ Don't do anything with an empty list:------ >>> Refl :: ReturnX Double '[] :~: '[]--- Refl-type family ReturnX x as where-  ReturnX x (a ': as) = ((a -> x) ': ReturnX x as)-  ReturnX x '[] = '[]---- $setup--- >>> import Data.Type.Equality ((:~:)(Refl))-

@@ -1,41 +0,0 @@-# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html--# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)-resolver: nightly-2018-02-26--# Local packages, usually specified by relative directory name-packages:-- '.'--# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)-extra-deps: []--# Override default flag values for local packages and extra-deps-flags: {}--# Extra package databases containing global packages-extra-package-dbs: []--# Control whether we use the GHC we find on the path-# system-ghc: true--# Require a specific version of stack, using version ranges-# require-stack-version: -any # Default-# require-stack-version: >= 1.0.0--# Override the architecture used by stack, especially useful on Windows-# arch: i386-# arch: x86_64--# Extra directories used by stack for building-# extra-include-dirs: [/path/to/dir]-# extra-lib-dirs: [/path/to/dir]--# Allow a newer minor version of GHC than the snapshot specifies-# compiler-check: newer-minor--# Enable Hackage-friendly mode, for more details see-#  https://docs.haskellstack.org/en/stable/yaml_configuration/#pvp-bounds-# This has been disabled because of the following exchange:-# https://github.com/cdepillabout/pretty-simple/pull/1#issuecomment-272706215-#pvp-bounds: both

@@ -1,40 +0,0 @@--module Main (main) where--import Prelude--import Data.Monoid ((<>))-import System.FilePath.Glob (glob)-import Test.DocTest (doctest)--main :: IO ()-main = glob "src/**/*.hs" >>= doDocTest--doDocTest :: [String] -> IO ()-doDocTest options = doctest $ options <> ghcExtensions--ghcExtensions :: [String]-ghcExtensions =-    [-    --   "-XConstraintKinds"-    -- , "-XDataKinds"-      "-XDeriveDataTypeable"-    , "-XDeriveGeneric"-    -- , "-XEmptyDataDecls"-    , "-XFlexibleContexts"-    -- , "-XFlexibleInstances"-    -- , "-XGADTs"-    -- , "-XGeneralizedNewtypeDeriving"-    -- , "-XInstanceSigs"-    -- , "-XMultiParamTypeClasses"-    -- , "-XNoImplicitPrelude"-    , "-XOverloadedStrings"-    -- , "-XPolyKinds"-    -- , "-XRankNTypes"-    -- , "-XRecordWildCards"-    , "-XScopedTypeVariables"-    -- , "-XStandaloneDeriving"-    -- , "-XTupleSections"-    -- , "-XTypeFamilies"-    -- , "-XTypeOperators"-    ]

@@ -158,9 +158,9 @@   toErrStatus :: Int -> Status   toErrStatus _ = status404 -type TestThrows = Capture "foobar" Double :> Throws Int :> Get '[JSON] String+type TestThrows = "throws" :> Capture "foobar" Double :> Throws Int :> Get '[JSON] String -type TestNoThrow = Capture "baz" Integer :> NoThrow :> Get '[JSON] String+type TestNoThrow = "nothrow" :> NoThrow :> Get '[JSON] String  type TestApi = TestThrows :<|> TestNoThrow @@ -171,10 +171,10 @@ testThrowsGet double =   if double < 0     then pureErrEnvelope (0 :: Int)-    else pureSuccEnvelope "success"+    else pureSuccEnvelope "successThrows" -testNoThrowsGet :: Integer -> Handler (Envelope '[] String)-testNoThrowsGet _ = pureSuccEnvelope "success"+testNoThrowsGet :: Handler (Envelope '[] String)+testNoThrowsGet = pureSuccEnvelope "successNoThrow"  app :: Application app = serve (Proxy :: Proxy TestApi) server@@ -185,9 +185,9 @@     with (pure app) $ do       describe "Throws" $ do         it "handler can return error envelope" $-          get "/-5" `shouldRespondWith` "{\"err\":0}" { matchStatus = 404 }+          get "/throws/-5" `shouldRespondWith` "{\"err\":0}" { matchStatus = 404 }         it "handler can return success envelope" $-          get "/10" `shouldRespondWith` "{\"data\":\"success\"}"+          get "/throws/10" `shouldRespondWith` "{\"data\":\"successThrows\"}"       describe "NoThrow" $ do         it "handler can return success envelope" $-          get "/10" `shouldRespondWith` "{\"data\":\"success\"}"+          get "/nothrow" `shouldRespondWith` "{\"data\":\"successNoThrow\"}"