validation

validationt.hs

{-# LANGUAGE GeneralizedNewtypeDeriving  #-}
module ValidationT where
import Data.Validation
import Data.Functor.Compose
import Control.Monad.IO.Class
import qualified Data.DList as DList
import Control.Monad.Except
import Data.These

-- | Applicative only validation transformer
newtype ValidationT e m a =
  ValidationT (Compose m (Validation (DList.DList e)) a)
  deriving (Functor, Applicative)

-- | Reporting monad transformer, which allows for collecting errors
newtype ReportT e m a =
  ReportT { reportThese :: m (These (DList.DList e) a) }

instance Functor m => Functor (ReportT e m) where
  fmap f (ReportT m) = ReportT $ fmap (fmap f) m

instance Monad m => Applicative (ReportT e m) where
  pure x = ReportT $ pure (pure x)
  (<*>) = ap

instance Monad m => Monad (ReportT e m) where
  return = pure
  m >>= f = ReportT $ do
    x <- reportThese m
    case x of
      This e -> pure $ This e
      That a -> reportThese $ f a
      These e a -> do y <- reportThese $ f a
                      case y of
                        That b -> pure $ These e b
                        This e2 -> pure $ This $ e <> e2
                        These e2 b -> pure $ These (e <> e2) b

-- | return the validation result, or the collected errors.
runValidation :: Functor m => ValidationT e m a -> m (Either [e] a)
runValidation (ValidationT (Compose m)) =
  validation (Left . DList.toList) Right <$> m

-- | make a validation from a report
validateReport :: Monad m => ReportT e m a -> ValidationT e m a
validateReport (ReportT m) =
  ValidationT $ Compose $
  do x <- m
     case x of
       This e -> pure $ Failure e
       That a -> pure $ Success a
       These e _ -> pure $ Failure e
  
-- | fail a validation always
invalid :: Monad m => e -> ValidationT e m a
invalid e = ValidationT $ Compose $ pure $ Failure $ DList.singleton e

-- | lift a computation which always succeeds
valid :: Monad m => m a -> ValidationT e m a
valid m = ValidationT $ Compose $ pure <$> m

-- | lift an io which always succeeds
validIO :: MonadIO m => IO a -> ValidationT e m a 
validIO = valid . liftIO

-- | report an error, but continue the computation
report :: Monad m => e -> ReportT e m ()
report e = ReportT $ pure $ These (DList.singleton e) ()

-- | abort the computation with an error
abort :: Monad m => e -> ReportT e m a
abort e = ReportT $ pure $ This $ DList.singleton e