From bbf731349ce0c1ad35c55fd91b4cd5a02b0a7401 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Mon, 5 Jul 2021 13:02:14 +0200
Subject: [PATCH 1/5] Add ExceptT selective transformer (#37)

This implementation of ExceptT has an Applicative instance
that does not need a Monad constraint of the underlying context.
---
 selective.cabal                       |   3 +-
 src/Control/Selective.hs              |   2 -
 src/Control/Selective/Rigid/Free.hs   |   2 +-
 src/Control/Selective/Rigid/Freer.hs  |   2 +-
 src/Control/Selective/Trans/Except.hs | 107 ++++++++++++++++++++++++++
 test/Laws.hs                          |   7 ++
 test/Main.hs                          |  50 +++++++++++-
 7 files changed, 167 insertions(+), 6 deletions(-)
 create mode 100644 src/Control/Selective/Trans/Except.hs

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..7d1404f
--- /dev/null
+++ b/src/Control/Selective/Trans/Except.hs
@@ -0,0 +1,107 @@
+{-# 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
+
+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)
+
+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
+
+except :: Monad m => Either e a -> ExceptT e m a
+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 ]

From 5211adbd1cdc5a800f2d8b20301542d1e39b8c47 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <m.baerenz@sonnen.de>
Date: Wed, 15 Jun 2022 14:53:51 +0200
Subject: [PATCH 2/5] Backwards compatibility for older transformers versions

---
 src/Control/Selective/Trans/Except.hs | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/src/Control/Selective/Trans/Except.hs b/src/Control/Selective/Trans/Except.hs
index 7d1404f..d96d0d7 100644
--- a/src/Control/Selective/Trans/Except.hs
+++ b/src/Control/Selective/Trans/Except.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {- | A newtype around @transformers@ 'ExceptT' with less restrictive 'Applicative', 'Selective', and 'Alternative' implementations.
 
@@ -70,7 +71,11 @@ 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

From fd33e89e9102b035290f6eb7e96a88aedd65a154 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <m.baerenz@sonnen.de>
Date: Wed, 15 Jun 2022 15:55:51 +0200
Subject: [PATCH 3/5] FIXUP? monad fail

---
 src/Control/Selective/Trans/Except.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/src/Control/Selective/Trans/Except.hs b/src/Control/Selective/Trans/Except.hs
index d96d0d7..7220825 100644
--- a/src/Control/Selective/Trans/Except.hs
+++ b/src/Control/Selective/Trans/Except.hs
@@ -18,6 +18,10 @@ import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Zip (MonadZip)
 import Data.Functor.Classes
 import Data.Functor.Identity
+#if MIN_VERSION_base(4,9,0)
+import Control.Monad.Fail
+import Data.Functor.Contravariant (Contravariant)
+#endif
 
 import qualified Control.Monad.Trans.Except as Transformers
 import Control.Monad.Trans.Class
@@ -28,7 +32,12 @@ 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)
+    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, Contravariant
+#endif
+        )
 
 instance Traversable f => Traversable (ExceptT e f) where
     traverse f (ExceptT efa)= ExceptT <$> traverse f efa

From 1216cd1ff75a885d19313d92ef7bc5f0f0be1b4b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <m.baerenz@sonnen.de>
Date: Wed, 15 Jun 2022 16:09:02 +0200
Subject: [PATCH 4/5] FIXUP

---
 src/Control/Selective/Trans/Except.hs | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/src/Control/Selective/Trans/Except.hs b/src/Control/Selective/Trans/Except.hs
index 7220825..9131be7 100644
--- a/src/Control/Selective/Trans/Except.hs
+++ b/src/Control/Selective/Trans/Except.hs
@@ -20,6 +20,8 @@ import Data.Functor.Classes
 import Data.Functor.Identity
 #if MIN_VERSION_base(4,9,0)
 import Control.Monad.Fail
+#endif
+#if MIN_VERSION_base(4,12,0)
 import Data.Functor.Contravariant (Contravariant)
 #endif
 
@@ -35,7 +37,10 @@ newtype ExceptT e m a = ExceptT
     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, Contravariant
+        , MonadFail
+#endif
+#if MIN_VERSION_base(4,12,0)
+        , Contravariant
 #endif
         )
 

From 5963f9232c8879fc9196339e9206c47697d59bb3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <m.baerenz@sonnen.de>
Date: Fri, 17 Jun 2022 11:31:41 +0200
Subject: [PATCH 5/5] FIXUP

---
 src/Control/Selective/Trans/Except.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/Control/Selective/Trans/Except.hs b/src/Control/Selective/Trans/Except.hs
index 9131be7..eb0a0fe 100644
--- a/src/Control/Selective/Trans/Except.hs
+++ b/src/Control/Selective/Trans/Except.hs
@@ -18,9 +18,13 @@ 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