WIP ValidationT

Author: turion

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

@@ -430,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

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