From f5e9e7b5e4963c1ae6018516554bd9d0e1f07e13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Thu, 23 Jun 2022 11:04:12 +0200 Subject: [PATCH 1/3] Add ComposeTraversable --- src/Control/Selective.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Control/Selective.hs b/src/Control/Selective.hs index 7e69fe8..4c432aa 100644 --- a/src/Control/Selective.hs +++ b/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) From a18830c8cae00e731d49e998ada176b99625a154 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Thu, 23 Jun 2022 11:04:33 +0200 Subject: [PATCH 2/3] Use ComposeTraversable to define ExceptT instance --- src/Control/Selective/Trans/Except.hs | 16 +++------------- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/src/Control/Selective/Trans/Except.hs b/src/Control/Selective/Trans/Except.hs index eb0a0fe..b7dede2 100644 --- a/src/Control/Selective/Trans/Except.hs +++ b/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 From a8befe598ca772f4777148ba92a08ea44ff0e1fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Thu, 23 Jun 2022 11:04:51 +0200 Subject: [PATCH 3/3] Add MaybeT --- selective.cabal | 3 +- src/Control/Selective/Trans/Maybe.hs | 109 +++++++++++++++++++++++++++ 2 files changed, 111 insertions(+), 1 deletion(-) create mode 100644 src/Control/Selective/Trans/Maybe.hs diff --git a/selective.cabal b/selective.cabal index 7a3ae5f..f1c665a 100644 --- a/selective.cabal +++ b/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 diff --git a/src/Control/Selective/Trans/Maybe.hs b/src/Control/Selective/Trans/Maybe.hs new file mode 100644 index 0000000..475c35e --- /dev/null +++ b/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