Dev validation 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.Validation
     build-depends:      base         >= 4.9     && < 5,
                         containers   >= 0.5.5.1 && < 0.7,
                         transformers >= 0.4.2.0 && < 0.7

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

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