Add custom ExceptT (#37)

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

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

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

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

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

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)

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 ]