diff --git a/CHANGES.md b/CHANGES.md index d6269d6..eca0c80 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ ## 0.6 +* Make the `Applicative` instance of `ComposeEither` more interesting by relying + on the `Selective f` constraint. See #64. * Make the `Lift` instance lazier. See #63. * Stop supporting GHC <= 8.6. See #62. * Add `Control.Selective.Trans.Except` transformer. See #39. diff --git a/src/Control/Selective.hs b/src/Control/Selective.hs index 63dc399..18cc870 100644 --- a/src/Control/Selective.hs +++ b/src/Control/Selective.hs @@ -520,9 +520,32 @@ toArrow :: Arrow a => ArrowMonad a (i -> o) -> a i o toArrow (ArrowMonad f) = arr ((),) >>> first f >>> arr (uncurry ($)) ---------------------------------- Alternative --------------------------------- --- | Composition of a functor @f@ with the 'Either' monad. +-- | Composition of a selective functor @f@ with the 'Either' monad. newtype ComposeEither f e a = ComposeEither (f (Either e a)) - deriving (Functor, Applicative) via Compose f (Either e) + deriving Functor via Compose f (Either e) + +instance Selective f => Applicative (ComposeEither f e) where + pure = ComposeEither . pure . Right + + ComposeEither f <*> ComposeEither a = ComposeEither $ + select (prepare <$> f) (combine <$> a) + where + prepare :: Either e (a -> b) -> Either (a -> b) (Either e b) + prepare = either (Right . Left) Left + + combine :: Either e a -> (a -> b) -> Either e b + combine = flip fmap + +instance Selective f => Selective (ComposeEither f e) where + select (ComposeEither x) (ComposeEither f) = ComposeEither $ + select (prepare <$> x) (combine <$> f) + where + prepare :: Either e (Either a b) -> Either a (Either e b) + prepare = either (Right . Left) (fmap Right) + + combine :: Either e (a -> b) -> a -> Either e b + combine (Left e) _ = Left e + combine (Right f) a = Right (f a) instance (Selective f, Monoid e) => Alternative (ComposeEither f e) where empty = ComposeEither (pure $ Left mempty) diff --git a/src/Control/Selective/Trans/Except.hs b/src/Control/Selective/Trans/Except.hs index 3a6bc80..5b58701 100644 --- a/src/Control/Selective/Trans/Except.hs +++ b/src/Control/Selective/Trans/Except.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveTraversable, DerivingVia #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Trans.Except @@ -23,7 +23,7 @@ ----------------------------------------------------------------------------- module Control.Selective.Trans.Except where -import Control.Applicative (Alternative (empty, (<|>))) +import Control.Applicative (Alternative) import Control.Monad (MonadPlus) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO) @@ -43,47 +43,14 @@ import Control.Monad.Trans.Class import Control.Selective import Control.Monad.Signatures --- | A newtype around 'T.ExceptT' from @transformers@. -newtype ExceptT e m a = ExceptT { unwrap :: T.ExceptT e m a } +-- | A newtype wrapper around 'T.ExceptT' from @transformers@ that provides less +-- restrictive 'Applicative', 'Selective' and 'Alternative' instances. +newtype ExceptT e f a = ExceptT { unwrap :: T.ExceptT e f a } deriving - ( Functor, Monad, MonadTrans, MonadFix, MonadFail, Foldable, Eq1, Ord1, Read1 - , Show1, MonadZip, MonadIO, MonadPlus, Eq, Ord, Read, Show, Contravariant ) - -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 a @Left e@, the second argument is not executed. -instance Selective f => Applicative (ExceptT e f) where - pure = ExceptT . T.ExceptT . pure . Right - - ExceptT (T.ExceptT f) <*> ExceptT (T.ExceptT a) = - ExceptT $ T.ExceptT $ select (prepare <$> f) (combine <$> a) - where - prepare :: Either e (a -> b) -> Either (a -> b) (Either e b) - prepare = either (Right . Left) Left - - combine :: Either e a -> (a -> b) -> Either e b - combine = flip fmap - --- | No @'Monad' f@ constraint is needed. -instance Selective f => Selective (ExceptT e f) where - select (ExceptT (T.ExceptT x)) (ExceptT (T.ExceptT f)) = - ExceptT $ T.ExceptT $ select (prepare <$> x) (combine <$> f) - where - prepare :: Either e (Either a b) -> Either a (Either e b) - prepare = either (Right . Left) (fmap Right) - - combine :: Either e (a -> b) -> a -> Either e b - combine (Left e) _ = Left e - combine (Right f) a = Right (f a) - --- | No @'Monad' f@ constraint is needed. -instance (Selective f, Monoid e) => Alternative (ExceptT e f) where - empty = ExceptT $ T.ExceptT $ pure $ Left mempty - - ExceptT (T.ExceptT x) <|> ExceptT (T.ExceptT y) = - ExceptT $ T.ExceptT $ orElse x y + ( Functor, Foldable, Traversable, Monad, Contravariant, Eq, Ord, Read, Show + , MonadTrans, MonadFix, MonadFail, MonadZip, MonadIO, MonadPlus, Eq1, Ord1 + , Read1, Show1 ) + deriving (Applicative, Selective, Alternative) via (ComposeEither f e) -- | Inject an 'T.ExceptT' value into the newtype wrapper. wrap :: T.ExceptT e m a -> ExceptT e m a