diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/servant-checked-exceptions-core.cabal b/servant-checked-exceptions-core.cabal --- a/servant-checked-exceptions-core.cabal +++ b/servant-checked-exceptions-core.cabal @@ -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 . 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 diff --git a/src/Servant/Checked/Exceptions.hs b/src/Servant/Checked/Exceptions.hs --- a/src/Servant/Checked/Exceptions.hs +++ b/src/Servant/Checked/Exceptions.hs @@ -86,6 +86,14 @@ . The 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: + + + -} 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 diff --git a/src/Servant/Checked/Exceptions/Envelope.hs b/src/Servant/Checked/Exceptions/Envelope.hs --- a/src/Servant/Checked/Exceptions/Envelope.hs +++ b/src/Servant/Checked/Exceptions/Envelope.hs @@ -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 diff --git a/src/Servant/Checked/Exceptions/Internal.hs b/src/Servant/Checked/Exceptions/Internal.hs --- a/src/Servant/Checked/Exceptions/Internal.hs +++ b/src/Servant/Checked/Exceptions/Internal.hs @@ -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 diff --git a/src/Servant/Checked/Exceptions/Internal/Envelope.hs b/src/Servant/Checked/Exceptions/Internal/Envelope.hs --- a/src/Servant/Checked/Exceptions/Internal/Envelope.hs +++ b/src/Servant/Checked/Exceptions/Internal/Envelope.hs @@ -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 diff --git a/src/Servant/Checked/Exceptions/Internal/EnvelopeT.hs b/src/Servant/Checked/Exceptions/Internal/EnvelopeT.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/EnvelopeT.hs @@ -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