diff --git a/selective.cabal b/selective.cabal index 7a3ae5f..520db00 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.Validation 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 352dcb3..2cc8866 100644 --- a/src/Control/Selective.hs +++ b/src/Control/Selective.hs @@ -54,6 +54,8 @@ import GHC.Conc (STM) import qualified Control.Monad.Trans.RWS.Strict as S import qualified Control.Monad.Trans.State.Strict as S import qualified Control.Monad.Trans.Writer.Strict as S +import Control.Monad.Trans.Except (ExceptT) +import qualified Control.Monad.Trans.Except -- | Selective applicative functors. You can think of 'select' as a selective -- function application: when given a value of type 'Left' @a@, you __must apply__ @@ -428,7 +430,16 @@ instance Selective ZipList where select = selectA -- | Selective instance for the standard applicative functor Validation. This is -- a good example of a non-trivial selective functor which is not a monad. -data Validation e a = Failure e | Success a deriving (Eq, Functor, Ord, Show) +data Validation e a = Failure e | Success a + deriving (Eq, Functor, Ord, Show, Foldable, Traversable) + +-- instance Foldable (Validation e) where +-- foldMap _ (Failure _) = mempty +-- foldMap f (Success a) = f a + +-- instance Traversable (Validation e) where +-- traverse _ (Failure e) = pure $ Failure e +-- traverse f (Success a) = Success <$> f a instance Semigroup e => Applicative (Validation e) where pure = Success @@ -509,6 +520,9 @@ instance Selective (ST s) where select = selectM instance Selective STM where select = selectM instance Selective (ContT r m) where select = selectM +-- | Note that there is an instance for an isomorphic functor 'Control.Selective.Trans.Except' +-- which does not need the 'Monad m' constraint. +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/Trans/Validation.hs b/src/Control/Selective/Trans/Validation.hs new file mode 100644 index 0000000..67064cc --- /dev/null +++ b/src/Control/Selective/Trans/Validation.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +{- | +FIXME some inspiration/guidance needed here +-} +module Control.Selective.Trans.Validation where + +import Data.Functor.Compose +#if MIN_VERSION_base(4,12,0) +#endif + +import Control.Monad.Trans.Class + +import Control.Selective + +-- | A newtype around @transformers@' 'Transformers.ValidationT'. +newtype ValidationT e m a = ValidationT + { runValidationT :: m (Validation e a) } + deriving + ( Functor, Foldable, Traversable + ) + + +-- TODO +#if MIN_VERSION_base(4,12,0) + --, Contravariant +#endif + +-- Eq1, Ord1, Read1, Show1, +--, Eq, Ord, Read, Show + +#if MIN_VERSION_base(4,9,0) +-- , MonadFail +#endif +-- MonadZip, MonadIO, MonadPlus, -- alternative versions? +-- Monad, MonadTrans, MonadFix, + +instance MonadTrans (ValidationT e) where + lift = ValidationT . fmap Success + +deriving via Compose f (Validation e) instance (Applicative f, Semigroup e) => Applicative (ValidationT e f) + +-- TODO want: +-- deriving via ComposeTraversable +-- See https://github.com/snowleopard/selective/pull/52/ +instance (Selective f, Semigroup e) => Selective (ValidationT e f) where + select eab fab = ValidationT $ select (sequenceA <$> runValidationT eab) (sequenceA <$> runValidationT fab) + +-- TODO reproduce API of Validation