Dev maybe t

selective.cabal

@@ -35,7 +35,8 @@ library
                         Control.Selective.Multi,
                         Control.Selective.Rigid.Free,
                         Control.Selective.Rigid.Freer,
-                        Control.Selective.Trans.Except
+                        Control.Selective.Trans.Except,
+                        Control.Selective.Trans.Maybe
     build-depends:      base         >= 4.9     && < 5,
                         containers   >= 0.5.5.1 && < 0.7,
                         transformers >= 0.4.2.0 && < 0.7

src/Control/Selective.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE CPP, LambdaCase, TupleSections, DeriveTraversable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingVia #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module     : Control.Selective
@@ -27,7 +29,7 @@ module Control.Selective (
     SelectA (..), SelectM (..), Over (..), Under (..), Validation (..),
 
     -- * Miscellaneous
-    swapEither, ComposeEither (..)
+    swapEither, ComposeEither (..), ComposeTraversable (..)
     ) where
 
 import Control.Applicative
@@ -491,6 +493,20 @@ and 'Nothing' which corresponds to the behaviour of 'selectA'.
 
 -}
 
+{- | Compose a 'Selective' (outside) with a 'Traversable' (inside) to get a 'Selective'.
+
+The composed functor 'ComposeTraversable f g' will traverse each @g@ structure and short-circuit when encountering a 'Left e'.
+Then the outer @f@ will 'select' which actions to run.
+-}
+newtype ComposeTraversable f g a = ComposeTraversable
+    { getComposeTraversable :: f (g a) }
+    deriving (Functor)
+
+deriving via (Compose f g) instance (Applicative f, Applicative g) => Applicative (ComposeTraversable f g)
+
+instance (Traversable g, Applicative g, Selective f) => Selective (ComposeTraversable f g) where
+    select (ComposeTraversable eab) (ComposeTraversable fab) = ComposeTraversable $ select (sequenceA <$> eab) (sequenceA <$> fab)
+
 -- Monad instances
 
 -- As a quick experiment, try: ifS (pure True) (print 1) (print 2)

src/Control/Selective/Trans/Except.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingVia #-}
 {- | A newtype around @transformers@ 'ExceptT' with less restrictive 'Applicative', 'Selective', and 'Alternative' implementations.
 
 Supplies an @instance 'Selective' f => 'Selective' ('ExceptT' e f)@.
@@ -61,19 +63,7 @@ instance Selective f => Applicative (ExceptT e f) where
       <*? (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)
+deriving via (ComposeTraversable f (Either e)) instance Selective f => Selective (ExceptT e f)
 
 -- | No @'Monad' f@ constraint is needed.
 instance (Selective f, Monoid e) => Alternative (ExceptT e f) where

src/Control/Selective/Trans/Maybe.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingVia #-}
+{- | A newtype around @transformers@ 'MaybeT' with less restrictive 'Applicative', 'Selective', and 'Alternative' implementations.
+
+Supplies an @instance 'Selective' f => 'Selective' ('MaybeT' e f)@.
+In other words, 'MaybeT' 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-Maybe.html) package.
+-}
+module Control.Selective.Trans.Maybe 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
+#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.Maybe as Transformers
+import Control.Monad.Trans.Class
+
+import Control.Selective
+import Control.Monad.Signatures
+import Control.Selective.Trans.Except (ExceptT)
+import qualified Control.Selective.Trans.Except as SelectiveExcept
+
+-- | A newtype around @transformers@' 'Transformers.MaybeT'.
+newtype MaybeT m a = MaybeT
+    { toTransformers :: Transformers.MaybeT 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 (MaybeT f) where
+    traverse f (MaybeT efa)= MaybeT <$> 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 (MaybeT f) where
+    pure = MaybeT . Transformers.MaybeT . pure . pure
+    MaybeT (Transformers.MaybeT f) <*> MaybeT (Transformers.MaybeT m) = MaybeT $ Transformers.MaybeT
+      $ maybe (Right Nothing) Left <$> f
+      <*? (flip fmap <$> m)
+
+-- | No @'Monad' f@ constraint is needed.
+deriving via ComposeTraversable f Maybe instance Selective f => Selective (MaybeT f)
+
+-- | No @'Monad' f@ constraint is needed.
+instance Selective f => Alternative (MaybeT f) where
+    empty = MaybeT $ Transformers.MaybeT $ pure Nothing
+    MaybeT (Transformers.MaybeT mx) <|> MaybeT (Transformers.MaybeT my)
+        = MaybeT $ Transformers.MaybeT
+        $ Right <$> mx
+        <*? (const <$> my)
+
+-- | Convert back to the newtype.
+fromTransformers :: Transformers.MaybeT m a -> MaybeT m a
+fromTransformers = MaybeT
+
+runMaybeT :: MaybeT m a -> m (Maybe a)
+runMaybeT = Transformers.runMaybeT . toTransformers
+
+mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
+mapMaybeT f = MaybeT . Transformers.mapMaybeT f . toTransformers
+
+#if MIN_VERSION_transformers(0,6,0)
+hoistMaybe :: Applicative m => Maybe b -> MaybeT m b
+hoistMaybe = fromTransformers . Transformers.hoistMaybe
+#endif
+
+maybeToExceptT :: Functor m => e -> MaybeT m a -> ExceptT e m a
+maybeToExceptT e = SelectiveExcept.fromTransformers . Transformers.maybeToExceptT e . toTransformers
+
+exceptToMaybeT :: Functor m => ExceptT e m a -> MaybeT m a
+exceptToMaybeT = fromTransformers . Transformers.exceptToMaybeT . SelectiveExcept.toTransformers
+
+
+liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b
+liftCallCC callCC caller = MaybeT $ Transformers.liftCallCC callCC (toTransformers . caller . (MaybeT .))
+
+liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a
+liftCatch f m h = MaybeT $ Transformers.liftCatch f (toTransformers m) (toTransformers . h)
+
+liftListen :: Monad m => Listen w m (Maybe a) -> Listen w (MaybeT m) a
+liftListen listen (MaybeT action) = MaybeT $ Transformers.liftListen listen action
+
+liftPass :: Monad m => Pass w m (Maybe a) -> Pass w (MaybeT m) a
+liftPass pass (MaybeT action) = MaybeT $ Transformers.liftPass pass action