diff --git a/selective.cabal b/selective.cabal index 37d1e72..c1aee3c 100644 --- a/selective.cabal +++ b/selective.cabal @@ -34,7 +34,8 @@ library Control.Selective.Free, Control.Selective.Multi, Control.Selective.Rigid.Free, - Control.Selective.Rigid.Freer + Control.Selective.Rigid.Freer, + Control.Selective.Trans.Except build-depends: base >= 4.9 && < 5, containers >= 0.5.5.1 && < 0.7, transformers >= 0.4.2.0 && < 0.7 diff --git a/src/Control/Selective.hs b/src/Control/Selective.hs index fedc19f..7e69fe8 100644 --- a/src/Control/Selective.hs +++ b/src/Control/Selective.hs @@ -35,7 +35,6 @@ import Control.Applicative.Lift import Control.Arrow import Control.Monad.ST import Control.Monad.Trans.Cont -import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader @@ -510,7 +509,6 @@ instance Selective (ST s) where select = selectM instance Selective STM where select = selectM instance Selective (ContT r m) where select = selectM -instance Monad m => Selective (ExceptT e m) where select = selectM instance Monad m => Selective (MaybeT m) where select = selectM instance (Monoid w, Monad m) => Selective (RWST r w s m) where select = selectM instance (Monoid w, Monad m) => Selective (S.RWST r w s m) where select = selectM diff --git a/src/Control/Selective/Rigid/Free.hs b/src/Control/Selective/Rigid/Free.hs index ad1d4c0..e74797e 100644 --- a/src/Control/Selective/Rigid/Free.hs +++ b/src/Control/Selective/Rigid/Free.hs @@ -30,7 +30,7 @@ module Control.Selective.Rigid.Free ( getPure, getEffects, getNecessaryEffect, runSelect, foldSelect ) where -import Control.Monad.Trans.Except +import Control.Selective.Trans.Except import Control.Selective import Data.Bifunctor import Data.Functor diff --git a/src/Control/Selective/Rigid/Freer.hs b/src/Control/Selective/Rigid/Freer.hs index 2c18ad5..fcf2a82 100644 --- a/src/Control/Selective/Rigid/Freer.hs +++ b/src/Control/Selective/Rigid/Freer.hs @@ -26,7 +26,7 @@ module Control.Selective.Rigid.Freer ( getPure, getEffects, getNecessaryEffect, runSelect, foldSelect ) where -import Control.Monad.Trans.Except +import Control.Selective.Trans.Except import Control.Selective import Data.Bifunctor import Data.Function diff --git a/src/Control/Selective/Trans/Except.hs b/src/Control/Selective/Trans/Except.hs new file mode 100644 index 0000000..eb0a0fe --- /dev/null +++ b/src/Control/Selective/Trans/Except.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- | A newtype around @transformers@ 'ExceptT' with less restrictive 'Applicative', 'Selective', and 'Alternative' implementations. + +Supplies an @instance 'Selective' f => 'Selective' ('ExceptT' e f)@. +In other words, 'ExceptT' is a bona-fide 'Selective' transformer. + +This tries to copy verbatim the API from @transformers@, +so it can be used as a drop-in replacement. +The documentation can be found in the [@transformers@](https://hackage.haskell.org/package/transformers/docs/Control-Monad-Trans-Except.html) package. +-} +module Control.Selective.Trans.Except where + +import Control.Applicative (Alternative (empty, (<|>))) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Zip (MonadZip) +import Data.Functor.Classes +import Data.Functor.Identity +#if MIN_VERSION_base(4,13,0) +-- MonadFail is imported already +#else +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail +#endif +#endif +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant (Contravariant) +#endif + +import qualified Control.Monad.Trans.Except as Transformers +import Control.Monad.Trans.Class + +import Control.Selective +import Control.Monad.Signatures + +-- | A newtype around @transformers@' 'Transformers.ExceptT'. +newtype ExceptT e m a = ExceptT + { toTransformers :: Transformers.ExceptT e m a } + deriving + ( Functor, Monad, MonadTrans, MonadFix, Foldable, Eq1, Ord1, Read1, Show1, MonadZip, MonadIO, MonadPlus, Eq, Ord, Read, Show +#if MIN_VERSION_base(4,9,0) + , MonadFail +#endif +#if MIN_VERSION_base(4,12,0) + , Contravariant +#endif + ) + +instance Traversable f => Traversable (ExceptT e f) where + traverse f (ExceptT efa)= ExceptT <$> traverse f efa + +-- | No @'Monad' f@ constraint is needed. +-- If the first argument to '<*>' results in `Left e`, +-- the second argument is not executed. +instance Selective f => Applicative (ExceptT e f) where + pure = ExceptT . Transformers.ExceptT . pure . pure + ExceptT (Transformers.ExceptT f) <*> ExceptT (Transformers.ExceptT m) = ExceptT $ Transformers.ExceptT + $ either (Right . Left) Left <$> f + <*? (flip fmap <$> m) + +-- | No @'Monad' f@ constraint is needed. +instance Selective f => Selective (ExceptT e f) where + select (ExceptT (Transformers.ExceptT meab)) (ExceptT (Transformers.ExceptT mef)) = ExceptT $ Transformers.ExceptT + $ commute <$> meab + <*? (swapFunctionEither <$> mef) + where + commute :: Either e (Either a b) -> Either a (Either e b) + commute (Left e) = Right (Left e) + commute (Right (Left a)) = Left a + commute (Right (Right b)) = Right (Right b) + + swapFunctionEither :: Either e (a -> b) -> a -> Either e b + swapFunctionEither (Left e) _ = Left e + swapFunctionEither (Right fab) a = Right (fab a) + +-- | No @'Monad' f@ constraint is needed. +instance (Selective f, Monoid e) => Alternative (ExceptT e f) where + empty = ExceptT $ Transformers.ExceptT $ pure $ Left mempty + ExceptT (Transformers.ExceptT mx) <|> ExceptT (Transformers.ExceptT my) + = ExceptT $ Transformers.ExceptT + $ fmap Right <$> mx + <*? ( either ((Left .) . mappend) (flip (const Right)) <$> my) + +-- | Convert back to the newtype. +fromTransformers :: Transformers.ExceptT e m a -> ExceptT e m a +fromTransformers = ExceptT + +type Except e = ExceptT e Identity + +#if MIN_VERSION_transformers(0,5,6) +except :: Monad m => Either e a -> ExceptT e m a +#else +except :: Either e a -> Except e a +#endif +except = ExceptT . Transformers.except + +runExcept :: Except e a -> Either e a +runExcept = Transformers.runExcept . toTransformers + +mapExcept :: (Either e a -> Either e' b) -> Except e a -> Except e' b +mapExcept f = ExceptT . Transformers.mapExcept f . toTransformers + +withExcept :: (e -> e') -> Except e a -> Except e' a +withExcept f = ExceptT . Transformers.withExcept f . toTransformers + +runExceptT :: ExceptT e m a -> m (Either e a) +runExceptT = Transformers.runExceptT . toTransformers + +mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b +mapExceptT f = ExceptT . Transformers.mapExceptT f . toTransformers + +withExceptT :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a +withExceptT f = ExceptT . Transformers.withExceptT f . toTransformers + +throwE :: Monad m => e -> ExceptT e m a +throwE = ExceptT . Transformers.throwE + +catchE :: Monad m => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a +catchE action continuation = ExceptT $ Transformers.catchE (toTransformers action) (toTransformers . continuation) + +liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b +liftCallCC callCC caller = ExceptT $ Transformers.liftCallCC callCC (toTransformers . caller . (ExceptT .)) + +liftListen :: Monad m => Listen w m (Either e a) -> Listen w (ExceptT e m) a +liftListen listen (ExceptT action) = ExceptT $ Transformers.liftListen listen action + +liftPass :: Monad m => Pass w m (Either e a) -> Pass w (ExceptT e m) a +liftPass pass (ExceptT action) = ExceptT $ Transformers.liftPass pass action diff --git a/test/Laws.hs b/test/Laws.hs index 06cc087..ba1d1f3 100644 --- a/test/Laws.hs +++ b/test/Laws.hs @@ -1,10 +1,14 @@ {-# LANGUAGE FlexibleInstances, TupleSections, TypeApplications #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Laws where import Control.Arrow hiding (first, second) +import qualified Control.Monad.Trans.Except as Transformers import Control.Monad.Trans.Writer import Control.Selective +import Control.Selective.Trans.Except import Data.Bifunctor (bimap, first, second) import Data.Function import Data.Functor.Identity @@ -146,3 +150,6 @@ propertyPureRightIdentity = quickCheck (propertyPureRight @Identity @Int @Int) instance (Arbitrary w, Arbitrary a) => Arbitrary (Writer w a) where arbitrary = curry writer <$> arbitrary <*> arbitrary + +deriving instance (Arbitrary e, Arbitrary a) => Arbitrary (Transformers.Except e a) +deriving instance (Arbitrary e, Arbitrary a) => Arbitrary (Except e a) diff --git a/test/Main.hs b/test/Main.hs index da3cfe1..ad91b43 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,7 @@ import Control.Arrow (ArrowMonad) import Control.Monad.Trans.Writer hiding (writer) +import Control.Selective.Trans.Except hiding (except) import Control.Selective import Data.Functor.Identity import Data.Maybe hiding (maybe) @@ -28,7 +29,9 @@ main = runTests $ testGroup "Tests" , arrowMonad , maybe , identity - , writer ] + , writer + , except + ] -------------------------------------------------------------------------------- ------------------------ Ping-pong---------------------------------------------- @@ -386,3 +389,48 @@ writerProperties = testGroup "Properties" \x -> propertyPureRight @MyWriter @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @MyWriter @Int @Int x ] + +-------------------------------------------------------------------------------- +------------------------ Except ------------------------------------------------ +-------------------------------------------------------------------------------- + +except :: Tests +except = testGroup "Except" + [ exceptLaws + , exceptTheorems + , exceptProperties ] + +type MyExcept = Except [Int] + +exceptLaws :: Tests +exceptLaws = testGroup "Laws" + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ + \x -> lawIdentity @MyExcept @Int x + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + \x -> lawDistributivity @MyExcept @Int @Int x + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ + \x -> lawAssociativity @MyExcept @Int @Int @Int x + , expectSuccess "select == selectM" $ + \x -> lawMonad @MyExcept @Int @Int x ] + +exceptTheorems :: Tests +exceptTheorems = testGroup "Theorems" + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + \x -> theorem1 @MyExcept @Int @Int @Int x + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + \x -> theorem2 @MyExcept @Int @Int @Int x + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + \x -> theorem3 @MyExcept @Int @Int @Int x + , expectSuccess "Generalised Identity: (x <*? pure y) == (either y id <$> x)" $ + \x -> theorem4 @MyExcept @Int @Int x + , expectSuccess "(f <*> g) == (f `apS` g)" $ + \x -> theorem5 @MyExcept @Int @Int x + , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + \x -> theorem6 @MyExcept @Int @Int @Int x ] + +exceptProperties :: Tests +exceptProperties = testGroup "Properties" + [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ + \x -> propertyPureRight @MyExcept @Int @Int x + , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + \x -> propertyPureLeft @MyExcept @Int @Int x ]