servant-checked-exceptions-core 2.1.0.0 → 2.2.0.0

raw patch · 7 files changed

+872/−75 lines, 7 filesdep +contravariantdep +mtldep +transformersdep ~world-peacePVP ok

version bump matches the API change (PVP)

Dependencies added: contravariant, mtl, transformers

Dependency ranges changed: world-peace

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• servant-checked-exceptions-core.cabal +7/−2
• src/Servant/Checked/Exceptions.hs +36/−5
• src/Servant/Checked/Exceptions/Envelope.hs +29/−3
• src/Servant/Checked/Exceptions/Internal.hs +2/−0
• src/Servant/Checked/Exceptions/Internal/Envelope.hs +276/−65
• src/Servant/Checked/Exceptions/Internal/EnvelopeT.hs +508/−0

@@ -1,3 +1,17 @@+## 2.2.0.0++*   Add the `EnvelopeT` monad transformer. [#32]++*   Add a few combinators for `Envelope`:++        - `envelopeRemove`+        - `envelopeHandle`+        - `relaxEnvelope`+        - `liftA2Envelope`+        - `bindEnvelope`++    [#32]+ ## 2.1.0.0  *   Add support for servant-0.16 and remove support for all previous version of

@@ -1,5 +1,5 @@ name:                servant-checked-exceptions-core-version:             2.1.0.0+version:             2.2.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@@ -25,6 +25,7 @@                      , Servant.Checked.Exceptions.Verbs                      , Servant.Checked.Exceptions.Internal                      , Servant.Checked.Exceptions.Internal.Envelope+                     , Servant.Checked.Exceptions.Internal.EnvelopeT                      , Servant.Checked.Exceptions.Internal.Prism                      , Servant.Checked.Exceptions.Internal.Servant                      , Servant.Checked.Exceptions.Internal.Servant.API@@ -34,14 +35,18 @@   build-depends:       base >= 4.9 && < 5                      , aeson                      , bytestring+                       -- contravariant is needed for the Data.Functor.Contravariant module in GHC < 8.6+                     , contravariant >= 1.5                      , http-media                      , http-types+                     , mtl                      , profunctors                      , tagged+                     , transformers                      , servant >= 0.12                      , servant-docs >= 0.10                      , text-                     , world-peace+                     , world-peace >= 1.0.0.0   default-language:    Haskell2010   ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction   other-extensions:    QuasiQuotes

@@ -86,6 +86,14 @@ <https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Docs.hs documentation>. The <https://github.com/cdepillabout/servant-checked-exceptions README.md> shows how to compile and run the examples.++There is also an 'EnvelopeT' monad transformer.  'Envelope' and 'EnvelopeT'+have a similar relationship to 'Either' and 'ExceptT'.++The following is an example of how 'EnvelopeT' can be used:++<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/EnvelopeT.hs EnvelopeT example>+ -}  module Servant.Checked.Exceptions@@ -152,6 +160,12 @@   , fromEnvelopeOrM   , errEnvelopeMatch   , catchesEnvelope+  , envelopeRemove+  , envelopeHandle+  -- ** Other 'Envelope' combinators+  , relaxEnvelope+  , liftA2Envelope+  , bindEnvelope   -- *** 'Envelope' optics   , _SuccEnvelope   , _ErrEnvelope@@ -160,18 +174,35 @@   , envelopeToEither   , eitherToEnvelope   , isoEnvelopeEither+  -- * 'EnvelopeT' short-circuiting monad transformer+  , EnvelopeT(..)+  -- ** 'EnvelopeT' helper functions+  -- *** 'EnvelopeT' constructors+  , pureSuccEnvT+  , throwErrEnvT+  -- ** 'EnvelopeT' destructors+  , envelopeT+  , fromEnvT+  , fromEnvTOr+  , errEnvTMatch+  , catchesEnvT+  , emptyEnvT+  , envTRemove+  -- ** Other 'EnvelopeT' combinators+  , relaxEnvT+  , liftA2EnvT+  , bindEnvT+  -- ** 'Envelope' and 'ExceptT'+  , envTToExceptT+  , exceptTToEnvT   -- * Re-exported modules   -- | "Data.WorldPeace" exports the 'OpenUnion' type as well as other   -- combinators.  It also exports the 'OpenProduct' type and 'ToProduct' type   -- class used by some of the functions above.   , module Data.WorldPeace-  , module Servant.Checked.Exceptions.Internal.Servant.Docs   ) where  import Data.WorldPeace import Network.HTTP.Types (Status) -import Servant.Checked.Exceptions.Internal.Envelope-import Servant.Checked.Exceptions.Internal.Servant.API-import Servant.Checked.Exceptions.Internal.Servant.Docs-import Servant.Checked.Exceptions.Internal.Verbs+import Servant.Checked.Exceptions.Internal

@@ -2,12 +2,12 @@   -- * Envelope     Envelope(..)   -- * Helper functions-  -- ** Envelope Constructors+  -- ** Envelope constructors   , toSuccEnvelope   , toErrEnvelope   , pureSuccEnvelope   , pureErrEnvelope-  -- ** Envelope Destructors+  -- ** Envelope destructors   , envelope   , emptyEnvelope   , fromEnvelope@@ -16,6 +16,12 @@   , fromEnvelopeOrM   , errEnvelopeMatch   , catchesEnvelope+  , envelopeRemove+  , envelopeHandle+  -- ** Other Envelope combinators+  , relaxEnvelope+  , liftA2Envelope+  , bindEnvelope   -- ** Optics   , _SuccEnvelope   , _ErrEnvelope@@ -24,8 +30,28 @@   , envelopeToEither   , eitherToEnvelope   , isoEnvelopeEither+  -- * EnvelopeT+  , EnvelopeT(..)+  -- ** EnvelopeT constructors+  , pureSuccEnvT+  , throwErrEnvT+  -- ** EnvelopeT destructors+  , envelopeT+  , fromEnvT+  , fromEnvTOr+  , errEnvTMatch+  , catchesEnvT+  , emptyEnvT+  , envTRemove+  -- ** Other EnvelopeT combinators+  , relaxEnvT+  , liftA2EnvT+  , bindEnvT+  -- ** ExceptT+  , envTToExceptT+  , exceptTToEnvT   -- * Setup code for doctests   -- $setup   ) where -import Servant.Checked.Exceptions.Internal.Envelope+import Servant.Checked.Exceptions.Internal

@@ -1,11 +1,13 @@ module Servant.Checked.Exceptions.Internal   ( module Servant.Checked.Exceptions.Internal.Envelope+  , module Servant.Checked.Exceptions.Internal.EnvelopeT   , module Servant.Checked.Exceptions.Internal.Verbs   , module Servant.Checked.Exceptions.Internal.Servant   , module Servant.Checked.Exceptions.Internal.Util   ) where  import Servant.Checked.Exceptions.Internal.Envelope+import Servant.Checked.Exceptions.Internal.EnvelopeT import Servant.Checked.Exceptions.Internal.Verbs import Servant.Checked.Exceptions.Internal.Servant import Servant.Checked.Exceptions.Internal.Util

@@ -45,17 +45,28 @@   ) import Data.Aeson.Types (Parser) import Data.Data (Data)+import Data.Functor.Classes+  ( Show1+  , liftShowsPrec+  , showsUnaryWith+  ) import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotent) import Data.Typeable (Typeable) import Data.WorldPeace-  ( IsMember+  ( Contains+  , ElemRemove+  , IsMember   , OpenUnion+  , Remove   , ReturnX   , ToOpenProduct   , absurdUnion   , catchesOpenUnion+  , openUnionHandle   , openUnionLift   , openUnionPrism+  , openUnionRemove+  , relaxOpenUnion   ) import GHC.Generics (Generic) @@ -90,6 +101,88 @@ data Envelope es a = ErrEnvelope (OpenUnion es) | SuccEnvelope a   deriving (Foldable, Functor, Generic, Traversable) +-- | 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 (Show (OpenUnion es)) => Show1 (Envelope es) where+  liftShowsPrec+    :: (Int -> a -> ShowS)+    -> ([a] -> ShowS)+    -> Int+    -> Envelope es a+    -> ShowS+  liftShowsPrec showA _ d (SuccEnvelope a) =+    showsUnaryWith showA "SuccEnvelope" d a+  liftShowsPrec _ _ d (ErrEnvelope es) =+    showsUnaryWith showsPrec "ErrEnvelope" d es++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+ -- | Create an 'ErrEnvelope' from a member of the 'OpenUnion'. -- -- For instance, here is how to create an 'ErrEnvelope' that contains a@@ -106,13 +199,19 @@ -- >>> toSuccEnvelope "hello" :: Envelope '[Double] String -- SuccEnvelope "hello" toSuccEnvelope :: a -> Envelope es a-toSuccEnvelope = SuccEnvelope+toSuccEnvelope = pure  -- | 'pureErrEnvelope' is 'toErrEnvelope' lifted up to an 'Applicative'.+--+-- >>> pureErrEnvelope 'c' :: Maybe (Envelope '[Char] Int)+-- Just (ErrEnvelope (Identity 'c')) pureErrEnvelope :: (Applicative m, IsMember e es) => e -> m (Envelope es a) pureErrEnvelope = pure . toErrEnvelope  -- | 'pureSuccEnvelope' is 'toSuccEnvelope' lifted up to an 'Applicative'.+--+-- >>> pureSuccEnvelope 3 :: Maybe (Envelope '[Char] Int)+-- Just (SuccEnvelope 3) pureSuccEnvelope :: Applicative m => a -> m (Envelope es a) pureSuccEnvelope = pure . toSuccEnvelope @@ -136,6 +235,82 @@ envelope f _ (ErrEnvelope es) = f es envelope _ f (SuccEnvelope a) = f a +-- | Similar to 'liftA2', but more general.  This allows you to operate on two+-- 'Envelope's with different sets of errors.  The resulting 'Envelope' is a+-- combination of the errors in each of the input 'Envelope's.+--+-- ==== __Examples__+--+-- >>> let env1 = toSuccEnvelope "hello" :: Envelope '[Double, Int] String+-- >>> let env2 = toSuccEnvelope " world" :: Envelope '[Char] String+-- >>> liftA2Envelope (<>) env1 env2 :: Envelope '[Double, Int, Char] String+-- SuccEnvelope "hello world"+--+-- If either of the 'Envelope's is an 'ErrEnvelope', then return the 'ErrEnvelope'.+--+-- >>> let env3 = toErrEnvelope "some err" :: Envelope '[String, Double] Int+-- >>> let env4 = toSuccEnvelope 1 :: Envelope '[Char] Int+-- >>> liftA2Envelope (+) env3 env4 :: Envelope '[String, Double, Char] Int+-- ErrEnvelope (Identity "some err")+--+-- >>> let env5 = toSuccEnvelope "hello" :: Envelope '[Char] String+-- >>> let env6 = toErrEnvelope 3.5 :: Envelope '[(), Double] String+-- >>> liftA2Envelope (<>) env5 env6 :: Envelope '[Char, (), Double] String+-- ErrEnvelope (Identity 3.5)+--+-- If both of the 'Envelope's is an 'ErrEnvelope', then short-circuit and only+-- return the first 'ErrEnvelope'.+--+-- >>> let env7 = toErrEnvelope 3.5 :: Envelope '[(), Double] String+-- >>> let env8 = toErrEnvelope 'x' :: Envelope '[Int, Char] String+-- >>> liftA2Envelope (<>) env7 env8 :: Envelope '[(), Double, Int, Char] String+-- ErrEnvelope (Identity 3.5)+liftA2Envelope :: (Contains es1 fullEs, Contains es2 fullEs) => (a -> b -> c) -> Envelope es1 a -> Envelope es2 b -> Envelope fullEs c+liftA2Envelope f (SuccEnvelope a) (SuccEnvelope b) = SuccEnvelope (f a b)+liftA2Envelope _ (ErrEnvelope es) _ = ErrEnvelope (relaxOpenUnion es)+liftA2Envelope _ _ (ErrEnvelope es) = ErrEnvelope (relaxOpenUnion es)++-- | This is like 'liftA2Envelope' but for monadic bind ('>>=').+--+-- This allows you to bind on 'Envelope's that contain different errors.+--+-- The resulting 'Envelope' must have a superset of the errors in two input+-- 'Envelope's.+--+-- ==== __Examples__+--+-- >>> let env1 = toSuccEnvelope "hello" :: Envelope '[Double, Int] String+-- >>> let f1 str = toSuccEnvelope (length str) :: Envelope '[Char] Int+-- >>> bindEnvelope env1 f1 :: Envelope '[Double, Int, Char] Int+-- SuccEnvelope 5+--+-- If either of the 'Envelope's is an 'ErrEnvelope', then return the 'ErrEnvelope'.+--+-- >>> let env2 = toErrEnvelope "some err" :: Envelope '[String, Double] Int+-- >>> let f2 i = toSuccEnvelope (i + 1) :: Envelope '[Char] Int+-- >>> bindEnvelope env2 f2 :: Envelope '[String, Double, Char] Int+-- ErrEnvelope (Identity "some err")+--+-- >>> let env3 = toSuccEnvelope "hello" :: Envelope '[Char] String+-- >>> let f3 _ = toErrEnvelope 3.5 :: Envelope '[(), Double] Int+-- >>> bindEnvelope env3 f3 :: Envelope '[Char, (), Double] Int+-- ErrEnvelope (Identity 3.5)+--+-- If both of the 'Envelope's is an 'ErrEnvelope', then short-circuit and only+-- return the first 'ErrEnvelope'.+--+-- >>> let env4 = toErrEnvelope 3.5 :: Envelope '[(), Double] String+-- >>> let f4 _ = toErrEnvelope 'x' :: Envelope '[Int, Char] String+-- >>> bindEnvelope env4 f4 :: Envelope '[Char, (), Double, Int] String+-- ErrEnvelope (Identity 3.5)+bindEnvelope+  :: (Contains es1 fullEs, Contains es2 fullEs)+  => Envelope es1 a+  -> (a -> Envelope es2 b)+  -> Envelope fullEs b+bindEnvelope (SuccEnvelope a) f = relaxEnvelope $ f a+bindEnvelope (ErrEnvelope u) _ = relaxEnvelope (ErrEnvelope u)+ -- | Unwrap an 'Envelope' that cannot contain an error. -- -- ==== __Examples__@@ -395,72 +570,108 @@ 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'.+-- | Change the errors type in an 'Envelope' to a larger set. ----- Here is an example of a 'SuccEnvelope':+-- >>> let double = 3.5 :: Double+-- >>> let env = toErrEnvelope double :: Envelope '[Double, Int] Char+-- >>> relaxEnvelope env :: Envelope '[(), Int, Double, String] Char+-- ErrEnvelope (Identity 3.5)+relaxEnvelope :: Contains es biggerEs => Envelope es a -> Envelope biggerEs a+relaxEnvelope (SuccEnvelope a) = SuccEnvelope a+relaxEnvelope (ErrEnvelope u) = ErrEnvelope (relaxOpenUnion u)++-- | This function allows you to try to remove individual error types from an+-- 'Envelope'. ----- >>> let string = "hello" :: String--- >>> let env = toSuccEnvelope string :: Envelope '[Double] String--- >>> putByteStrLn $ encode env--- {"data":"hello"}+-- This can be used to handle only certain error types in an 'Envelope',+-- instead of having to handle all of them at the same time.  This can be more+-- convenient than a function like 'catchesEnvelope'. ----- Here is an example of a 'ErrEnvelope':+-- ==== __Examples__ ----- >>> 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.+-- Pulling out an error in an 'Envelope': ----- 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+-- >>> let env1 = toErrEnvelope "hello" :: Envelope '[String, Double] Float+-- >>> envelopeRemove env1 :: Either (Envelope '[Double] Float) String+-- Right "hello"+--+-- Failing to pull out an error in an 'Envelope':+--+-- >>> let env2 = toErrEnvelope (3.5 :: Double) :: Envelope '[String, Double] Float+-- >>> envelopeRemove env2 :: Either (Envelope '[Double] Float) String+-- Left (ErrEnvelope (Identity 3.5))+--+-- Note that if you have an 'Envelope' with multiple errors of the same type,+-- they will all be handled at the same time:+--+-- >>> let env3 = toErrEnvelope (3.5 :: Double) :: Envelope '[String, Double, Char, Double] Float+-- >>> envelopeRemove env3 :: Either (Envelope '[String, Char] Float) Double+-- Right 3.5+--+-- 'SuccEnvelope' gets passed through as expected:+--+-- >>> let env4 = toSuccEnvelope 3.5 :: Envelope '[String, Double] Float+-- >>> envelopeRemove env4 :: Either (Envelope '[Double] Float) String+-- Left (SuccEnvelope 3.5)+envelopeRemove+  :: forall e es a+   . ElemRemove e es+  => Envelope es a+  -> Either (Envelope (Remove e es) a) e+envelopeRemove (SuccEnvelope a) = Left (SuccEnvelope a)+envelopeRemove (ErrEnvelope u) =+  case openUnionRemove u of+    Left u2 -> Left (ErrEnvelope u2)+    Right e -> Right e -  stimes :: Integral b => b -> Envelope es a -> Envelope es a-  stimes = stimesIdempotent+-- | Handle a single case in an 'Envelope'.  This is similar to 'envelope'+-- but lets you handle any case within the 'Envelope', not just the first one.+--+-- ==== __Examples__+--+-- Handling the first item in an 'Envelope':+--+-- >>> let env1 = toErrEnvelope 3.5 :: Envelope '[Double, Int] Char+-- >>> let printDouble = print :: Double -> IO ()+-- >>> let printEnv = print :: Envelope '[Int] Char -> IO ()+-- >>> envelopeHandle printEnv printDouble env1+-- 3.5+--+-- Handling a middle item in an 'Envelope':+--+-- >>> let env2 = toErrEnvelope (3.5 :: Double) :: Envelope '[Char, Double, Int] Float+-- >>> let printEnv = print :: Envelope '[Char, Int] Float -> IO ()+-- >>> envelopeHandle printEnv printDouble env2+-- 3.5+--+-- Failing to handle an item in an 'Envelope'.  In the following example, the+-- @printEnv@ function is called:+--+-- >>> let env3 = toErrEnvelope 'c' :: Envelope '[Char, Double, Int] Float+-- >>> let printEnv = print :: Envelope '[Char, Int] Float -> IO ()+-- >>> envelopeHandle printEnv printDouble env3+-- ErrEnvelope (Identity 'c')+--+-- If you have duplicates in your 'Envelope', they will both get handled with+-- a single call to 'unionHandle'.+--+-- >>> let env4 = toErrEnvelope 3.5 :: Envelope '[Double, Double, Int] Char+-- >>> let printEnv = print :: Envelope '[Int] Char -> IO ()+-- >>> envelopeHandle printEnv printDouble env4+-- 3.5+--+-- 'SuccEnvelope' gets passed through as expected:+--+-- >>> let env5 = toSuccEnvelope 3.5 :: Envelope '[String, Double] Float+-- >>> let printEnv = print :: Envelope '[String] Float -> IO ()+-- >>> envelopeHandle printEnv printDouble env5+-- SuccEnvelope 3.5+envelopeHandle+  :: ElemRemove e es+  => (Envelope (Remove e es) a -> x)+  -> (e -> x)+  -> Envelope es a+  -> x+envelopeHandle handler _ (SuccEnvelope a) = handler (SuccEnvelope a)+envelopeHandle handler errHandler (ErrEnvelope u) =+  openUnionHandle (handler . ErrEnvelope) errHandler u

@@ -0,0 +1,508 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.EnvelopeT++Copyright   :  Dennis Gosnell 2019+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module defines the 'EnvelopeT' type and helper functions. 'EnvelopeT' is a+short-circuiting monad transformer.++'Envelope' is similar to 'Either' where multiple errors types are possible.+'EnvelopeT' is similar to 'ExceptT' in a similar manner.+-}++module Servant.Checked.Exceptions.Internal.EnvelopeT where++import Control.Monad.Except (ExceptT(ExceptT), MonadError(throwError, catchError))+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Reader (MonadReader, ask, local, reader)+import Control.Monad.RWS (MonadRWS)+import Control.Monad.State (MonadState, get, put, state)+import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.Writer (MonadWriter, listen, pass, tell, writer)+import Data.Functor.Classes+  ( Show1+  , liftShowList+  , liftShowsPrec+  , showsPrec1+  , showsUnaryWith+  )+import Data.Functor.Contravariant (Contravariant(contramap))+import Data.WorldPeace+  ( Contains+  , ElemRemove+  , IsMember+  , OpenUnion+  , Remove+  , ReturnX+  , ToOpenProduct+  , relaxOpenUnion+  )++import Servant.Checked.Exceptions.Internal.Envelope+  ( Envelope(ErrEnvelope, SuccEnvelope)+  , catchesEnvelope+  , liftA2Envelope+  , eitherToEnvelope+  , emptyEnvelope+  , envelope+  , envelopeRemove+  , envelopeToEither+  , errEnvelopeMatch+  , pureErrEnvelope+  , pureSuccEnvelope+  , relaxEnvelope+  )++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators+-- >>> import Data.Functor.Identity (Identity(Identity))++data EnvelopeT es m a = EnvelopeT+  { runEnvelopeT :: m (Envelope es a)+  } deriving Functor++instance (Show (OpenUnion es), Show1 m) => Show1 (EnvelopeT es m) where+  liftShowsPrec+    :: forall a+     . (Int -> a -> ShowS)+    -> ([a] -> ShowS)+    -> Int+    -> EnvelopeT es m a -> ShowS+  liftShowsPrec sp sl d (EnvelopeT m) =+    showsUnaryWith showInnerM "EnvelopeT" d m+    where+      showInnerM :: Int -> m (Envelope es a) -> ShowS+      showInnerM = liftShowsPrec sp' sl'++      sp' :: Int -> Envelope es a -> ShowS+      sp' = liftShowsPrec sp sl++      sl' :: [Envelope es a] -> ShowS+      sl' = liftShowList sp sl++instance (Show (OpenUnion e), Show1 m, Show a) => Show (EnvelopeT e m a) where+  showsPrec = showsPrec1++instance Monad m => Applicative (EnvelopeT es m) where+  pure :: a -> EnvelopeT es m a+  pure a = EnvelopeT $ pureSuccEnvelope a++  (<*>) :: EnvelopeT es m (a -> b) -> EnvelopeT es m a -> EnvelopeT es m b+  EnvelopeT a2b <*> EnvelopeT a = EnvelopeT $ go <$> a2b <*> a+    where+      go :: Envelope es (a -> b) -> Envelope es a -> Envelope es b+      go = (<*>)++instance Monad m => Monad (EnvelopeT es m) where+  (>>=) :: EnvelopeT es m a -> (a -> EnvelopeT es m b) -> EnvelopeT es m b+  (EnvelopeT m) >>= k = EnvelopeT $ do+    env <- m+    case env of+      SuccEnvelope a -> runEnvelopeT $ k a+      ErrEnvelope err -> pure $ ErrEnvelope err++instance MonadTrans (EnvelopeT es) where+  lift :: Monad m => m a -> EnvelopeT es m a+  lift m = EnvelopeT $ do+    val <- m+    pureSuccEnvelope val++instance MonadIO m => MonadIO (EnvelopeT es m) where+  liftIO :: IO a -> EnvelopeT es m a+  liftIO = lift . liftIO++instance Foldable m => Foldable (EnvelopeT es m) where+  foldMap f (EnvelopeT m) = foldMap (envelope (const mempty) f) m++instance (Traversable m) => Traversable (EnvelopeT es m) where+  traverse+    :: Applicative f => (a -> f b) -> EnvelopeT es m a -> f (EnvelopeT es m b)+  traverse f (EnvelopeT m) =+    fmap EnvelopeT $+      traverse (envelope (pure . ErrEnvelope) (fmap SuccEnvelope . f)) m++instance Contravariant m => Contravariant (EnvelopeT es m) where+  contramap :: (b -> a) -> EnvelopeT es m a -> EnvelopeT es m b+  contramap f (EnvelopeT m) = EnvelopeT $ contramap (fmap f) m++instance MonadRWS r w s m => MonadRWS r w s (EnvelopeT es m)++instance MonadError error m => MonadError error (EnvelopeT es m) where+  throwError = EnvelopeT . throwError++  catchError+    :: forall a+     . EnvelopeT es m a+    -> (error -> EnvelopeT es m a)+    -> EnvelopeT es m a+  catchError (EnvelopeT m) handler = EnvelopeT $ catchError m innerRunner+    where+      innerRunner :: error -> m (Envelope es a)+      innerRunner = runEnvelopeT . handler++instance MonadReader r m => MonadReader r (EnvelopeT es m) where+  ask = lift ask+  local f (EnvelopeT m) = EnvelopeT (local f m)+  reader = lift . reader++instance MonadState s m => MonadState s (EnvelopeT es m) where+  get = lift get+  put = lift . put+  state = lift . state++instance MonadWriter w m => MonadWriter w (EnvelopeT es m) where+  writer = lift . writer+  tell = lift . tell+  listen (EnvelopeT m) =+    EnvelopeT $ do+      (envelopeA, w) <- listen m+      pure $ fmap (,w) envelopeA+  pass (EnvelopeT m) =+    EnvelopeT $ do+      envel <- m+      pass . pure $+        case envel of+          SuccEnvelope (a, f) -> (SuccEnvelope a, f)+          ErrEnvelope es -> (ErrEnvelope es, id)++-- | This is 'pure' for 'EnvelopeT'.+--+-- >>> pureSuccEnvT "hello" :: EnvelopeT '[] Identity String+-- EnvelopeT (Identity (SuccEnvelope "hello"))+pureSuccEnvT :: Applicative m => a -> EnvelopeT es m a+pureSuccEnvT = EnvelopeT . pureSuccEnvelope++-- | Throw an error in an 'ErrEnvelope'.+--+-- >>> let double = 3.5 :: Double+-- >>> throwErrEnvT double :: EnvelopeT '[String, Double, Int] Identity ()+-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))+--+-- This is similar to 'throwError', but is specialized so you can throw just+-- one of the error types.+throwErrEnvT :: (Applicative m, IsMember e es) => e -> EnvelopeT es m a+throwErrEnvT = EnvelopeT . pureErrEnvelope++-- | Case analysis for 'EnvelopeT'.+--+-- ==== __Examples__+--+--  Here is an example of matching on a 'SuccEnvelope':+--+-- >>> let env = pure "hello" :: EnvelopeT '[Double, Int] Identity String+-- >>> envelopeT (\_ -> Identity "not a String") Identity env+-- Identity "hello"+--+-- Here is an example of matching on a 'ErrEnvelope':+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = throwErrEnvT double :: EnvelopeT '[Double, Int] Identity String+-- >>> envelopeT (\_ -> Identity "not a String") Identity env'+-- Identity "not a String"+envelopeT :: Monad m => (OpenUnion es -> m c) -> (a -> m c) -> EnvelopeT es m a -> m c+envelopeT errHandler succHandler (EnvelopeT m) = do+  envel <- m+  envelope errHandler succHandler envel++-- | Slight simplification of 'envelopeT'.+--+-- ==== __Examples__+--+--  Here is an example of successfully matching:+--+-- >>> let env = pure "hello" :: EnvelopeT '[Double, Int] Identity String+-- >>> fromEnvT (\_ -> Identity "not a String") env+-- Identity "hello"+--+-- Here is an example of unsuccessfully matching:+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = throwErrEnvT double :: EnvelopeT '[Double, Int] Identity String+-- >>> fromEnvT (\_ -> Identity "not a String") env'+-- Identity "not a String"+fromEnvT :: Monad m => (OpenUnion es -> m a) -> EnvelopeT es m a -> m a+fromEnvT f = envelopeT f pure++-- | Flipped version of 'fromEnvT'.+fromEnvTOr :: Monad m => EnvelopeT es m a -> (OpenUnion es -> m a) -> m a+fromEnvTOr = flip fromEnvT++-- | Try to pull out a specific @e@ from an 'ErrEnvelope'.+--+-- ==== __Examples__+--+-- Successfully pull out an @e@:+--+-- >>> let double = 3.5 :: Double+-- >>> let env = throwErrEnvT double :: EnvelopeT '[Double, Char] Identity ()+-- >>> errEnvTMatch env :: Identity (Maybe Double)+-- Identity (Just 3.5)+--+-- Unsuccessfully pull out an @e@:+--+-- >>> let env' = pure () :: EnvelopeT '[String, Double] Identity ()+-- >>> errEnvTMatch env' :: Identity (Maybe Double)+-- Identity Nothing+errEnvTMatch+  :: forall e es m a.+     (Functor m, IsMember e es)+  => EnvelopeT es m a+  -> m (Maybe e)+errEnvTMatch (EnvelopeT m) = fmap errEnvelopeMatch m++-- | An alternate case anaylsis for an 'EnvelopeT'.  This method uses a tuple+-- containing handlers for each potential value of the underlying '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 'catchesEnvT' than 'envelopeT'.+--+-- ==== __Examples__+--+-- Here is an example of handling an 'SuccEnvelope' with two possible error values.+-- Notice that a normal tuple is used:+--+-- >>> let env = pure 2.0 :: EnvelopeT '[Int, String] IO Double+-- >>> let intHandler = (\int -> pure $ show int) :: Int -> IO String+-- >>> let strHandler = (\str -> pure str) :: String -> IO String+-- >>> let succHandler = (\dbl -> pure "got a double") :: Double -> IO String+-- >>> catchesEnvT (intHandler, strHandler) succHandler env :: IO 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 = throwErrEnvT (3 :: Int) :: EnvelopeT '[Int, String] Identity Double+-- >>> let intHandler = (\int -> Identity $ show int) :: Int -> Identity String+-- >>> let strHandler = (\str -> Identity str) :: String -> Identity String+-- >>> let succHandler = (\dbl -> Identity "got a double") :: Double -> Identity String+-- >>> catchesEnvT (intHandler, strHandler) succHandler env :: Identity String+-- Identity "3"+--+-- Given an 'EnvelopeT' like @'EnvelopeT' \'['Int', 'String'] 'IO' 'Double'@,+-- the type of 'catchesEnvT' becomes the following:+--+-- @+--   'catchesEnvT'+--     :: ('Int' -> 'IO' x, 'String' -> 'IO' x)+--     -> ('Double' -> 'IO' x)+--     -> 'EnvelopeT' \'['Int', 'String'] 'IO' 'Double'+--     -> 'IO' 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 = throwErrEnvT ("hi" :: String) :: EnvelopeT '[Int, String, Char] IO Double+-- >>> let intHandler = (\int -> pure $ show int) :: Int -> IO String+-- >>> let strHandler = (\str -> pure str) :: String -> IO String+-- >>> let chrHandler = (\chr -> pure [chr]) :: Char -> IO String+-- >>> let succHandler = (\dbl -> pure "got a double") :: Double -> IO String+-- >>> catchesEnvT (intHandler, strHandler, chrHandler) succHandler env :: IO String+-- "hi"+--+-- Given an 'Envelope' like @'EnvelopeT' \'['Int', 'String', 'Char'] 'IO' 'Double'@,+-- the type of 'catchesEnvT' becomes the following:+--+-- @+--   'catchesEnvT'+--     :: ('Int' -> 'IO' x, 'String' -> 'IO' x, 'Char' -> 'IO' x)+--     -> ('Double' -> 'IO' x)+--     -> 'EnvelopeT' \'['Int', 'String', 'Char'] 'IO' 'Double'+--     -> x+-- @+catchesEnvT+  :: forall tuple es m a x+   .  (Monad m, ToOpenProduct tuple (ReturnX (m x) es))+  => tuple -> (a -> m x) -> EnvelopeT es m a -> m x+catchesEnvT tuple a2mx (EnvelopeT m) = do+  envel <- m+  catchesEnvelope tuple a2mx envel++-- | Convert an 'EnvelopeT' to an 'ExceptT'.+envTToExceptT :: Functor m => EnvelopeT es m a -> ExceptT (OpenUnion es) m a+envTToExceptT (EnvelopeT m) = ExceptT $ fmap envelopeToEither m++-- | Convert an 'ExceptT' to an 'EnvelopeT'.+exceptTToEnvT :: Functor m => ExceptT (OpenUnion es) m a -> EnvelopeT es m a+exceptTToEnvT (ExceptT m) = EnvelopeT $ fmap eitherToEnvelope m++-- | Safely unwrap an 'EnvelopeT'.+--+-- >>> let myenvT = pure "hello" :: EnvelopeT '[] IO String+-- >>> emptyEnvT myenvT :: IO String+-- "hello"+emptyEnvT :: Functor m => EnvelopeT '[] m a -> m a+emptyEnvT (EnvelopeT m) = fmap emptyEnvelope m++-- | Change the errors type in an 'EnvelopeT' to a larger set.+--+-- ==== __Examples__+--+-- >>> let double = 3.5 :: Double+-- >>> let envT1 = throwErrEnvT double :: EnvelopeT '[Int, Double] Identity Float+-- >>> relaxEnvT envT1 :: EnvelopeT '[Char, Int, String, Double] Identity Float+-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))+--+-- >>> let envT2 = pure double :: EnvelopeT '[Char, Int] Identity Double+-- >>> relaxEnvT envT2 :: EnvelopeT '[(), Char, String, Int] Identity Double+-- EnvelopeT (Identity (SuccEnvelope 3.5))+relaxEnvT :: (Functor m, Contains es1 es2) => EnvelopeT es1 m a -> EnvelopeT es2 m a+relaxEnvT (EnvelopeT m) = EnvelopeT $ fmap relaxEnvelope m++-- | Combine two 'EnvelopeT's.  Generalize the set of errors to include the errors+-- from both 'EnvelopeT's. Similar to 'liftA2' but more general.+--+-- ==== __Examples__+--+-- >>> let env1 = pure "hello" :: EnvelopeT '[Double, Int] Identity String+-- >>> let env2 = pure " world" :: EnvelopeT '[Char]  Identity String+-- >>> liftA2EnvT (<>) env1 env2 :: EnvelopeT '[Double, Int, Char] Identity String+-- EnvelopeT (Identity (SuccEnvelope "hello world"))+--+-- If either of the 'Envelope's is an 'ErrEnvelope', then return the 'ErrEnvelope'.+--+-- >>> let env3 = throwErrEnvT "some err" :: EnvelopeT '[String, Double] Identity Int+-- >>> let env4 = pure 1 :: EnvelopeT '[Char]  Identity Int+-- >>> liftA2EnvT (+) env3 env4 :: EnvelopeT '[String, Double, Char] Identity Int+-- EnvelopeT (Identity (ErrEnvelope (Identity "some err")))+--+-- >>> let env5 = pure "hello" :: EnvelopeT '[Char] Identity String+-- >>> let env6 = throwErrEnvT 3.5 :: EnvelopeT '[(), Double] Identity String+-- >>> liftA2EnvT (<>) env5 env6 :: EnvelopeT '[Char, (), Double] Identity String+-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))+--+-- If both of the 'EnvelopeT's is an 'ErrEnvelope', then short-circuit and only+-- return the first 'ErrEnvelope'.+--+-- >>> let env7 = throwErrEnvT 4.5 :: EnvelopeT '[(), Double] Identity String+-- >>> let env8 = throwErrEnvT 'x' :: EnvelopeT '[Int, Char] Identity String+-- >>> liftA2EnvT (<>) env7 env8 :: EnvelopeT '[(), Double, Int, Char] Identity String+-- EnvelopeT (Identity (ErrEnvelope (Identity 4.5)))+liftA2EnvT+  :: (Contains es1 fullEs, Contains es2 fullEs, Applicative m)+  => (a -> b -> c)+  -> EnvelopeT es1 m a+  -> EnvelopeT es2 m b+  -> EnvelopeT fullEs m c+liftA2EnvT f (EnvelopeT m) (EnvelopeT n) =+  EnvelopeT $ liftA2Envelope f <$> m <*> n++-- | This is like 'liftA2EnvT' but for monadic bind ('>>=').+--+-- This allows you to bind on 'EnvelopeT's that contain different errors.+--+-- The resulting 'EnvelopeT' must have a superset of the errors in two input+-- 'EnvelopeT's.+--+-- ==== __Examples__+--+-- >>> let env1 = pure "hello" :: EnvelopeT '[Double, Int] Identity String+-- >>> let f1 str = pure (length str) :: EnvelopeT '[Char] Identity Int+-- >>> bindEnvT env1 f1 :: EnvelopeT '[Double, Int, Char] Identity Int+-- EnvelopeT (Identity (SuccEnvelope 5))+--+-- If either of the 'EnvelopeT's holds an 'ErrEnvelope', then return the 'ErrEnvelope'.+--+-- >>> let env2 = throwErrEnvT "some err" :: EnvelopeT '[String, Double] Identity Int+-- >>> let f2 i = pureSuccEnvT (i + 1) :: EnvelopeT '[Char] Identity Int+-- >>> bindEnvT env2 f2 :: EnvelopeT '[String, Double, Char] Identity Int+-- EnvelopeT (Identity (ErrEnvelope (Identity "some err")))+--+-- >>> let env3 = pureSuccEnvT "hello" :: EnvelopeT '[Char] Identity String+-- >>> let f3 _ = throwErrEnvT 3.5 :: EnvelopeT '[(), Double] Identity Int+-- >>> bindEnvT env3 f3 :: EnvelopeT '[Char, (), Double] Identity Int+-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))+--+-- If both of the 'Envelope's is an 'ErrEnvelope', then short-circuit and only+-- return the first 'ErrEnvelope'.+--+-- >>> let env4 = throwErrEnvT 3.5 :: EnvelopeT '[(), Double] Maybe String+-- >>> let f4 _ = throwErrEnvT 'x' :: EnvelopeT '[Int, Char] Maybe String+-- >>> bindEnvT env4 f4 :: EnvelopeT '[Char, (), Double, Int] Maybe String+-- EnvelopeT (Just (ErrEnvelope (Identity 3.5)))+bindEnvT+  :: (Contains es1 fullEs, Contains es2 fullEs, Monad m)+  => EnvelopeT es1 m a+  -> (a -> EnvelopeT es2 m b)+  -> EnvelopeT fullEs m b+bindEnvT (EnvelopeT m) f =+  EnvelopeT $ do+    envel1 <- m+    case envel1 of+      SuccEnvelope a ->+        let x = f a+        in runEnvelopeT $ relaxEnvT x+      ErrEnvelope u ->+        let fullEs = relaxOpenUnion u+        in pure $ ErrEnvelope fullEs++-- | This function allows you to try to remove individual error types from an+-- 'EnvelopeT'.+--+-- This can be used to handle only certain error types in an 'Envelope',+-- instead of having to handle all of them at the same time.  This can be more+-- convenient than a function like 'catchesEnvT'.+--+-- ==== __Examples__+--+-- Pulling out an error in an 'EnvelopeT':+--+-- >>> let env1 = throwErrEnvT "hello" :: EnvelopeT '[String, Double] Identity Float+-- >>> envTRemove env1 :: EnvelopeT '[Double] Identity (Either Float String)+-- EnvelopeT (Identity (SuccEnvelope (Right "hello")))+--+-- Failing to pull out an error in an 'EnvelopeT':+--+-- >>> let env2 = throwErrEnvT (3.5 :: Double) :: EnvelopeT '[String, Double] Identity Float+-- >>> envTRemove env2 :: EnvelopeT '[Double] Identity (Either Float String)+-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))+--+-- Note that if you have an 'EnvelopeT' with multiple errors of the same type,+-- they will all be handled at the same time:+--+-- >>> let env3 = throwErrEnvT (3.5 :: Double) :: EnvelopeT '[String, Double, Char, Double] Identity Float+-- >>> envTRemove env3 :: EnvelopeT '[String, Char] Identity (Either Float Double)+-- EnvelopeT (Identity (SuccEnvelope (Right 3.5)))+--+-- 'SuccEnvelope' gets passed through as expected:+--+-- >>> let env4 = pureSuccEnvT 3.5 :: EnvelopeT '[String, Double] Identity Float+-- >>> envTRemove env4 :: EnvelopeT '[Double] Identity (Either Float String)+-- EnvelopeT (Identity (SuccEnvelope (Left 3.5)))+envTRemove+  :: forall e es m a+   . (ElemRemove e es, Functor m)+  => EnvelopeT es m a+  -> EnvelopeT (Remove e es) m (Either a e)+envTRemove (EnvelopeT m) = EnvelopeT $ fmap go m+  where+  go :: Envelope es a -> Envelope (Remove e es) (Either a e)+  go envel =+    case envelopeRemove envel of+      Right e -> SuccEnvelope (Right e)+      Left envel -> fmap Left envel