Validation Monad, with default value on validation fail

ValidationDef.hs

-- Validation monad that requires a defaul value on validation failure
--  This allows the code to run as far as possible and accumulate more
--  validation errors.
-- Also since there is always a valid value (the original or the default)
--  it means that we can make   <*> = ap   unlike the usual validation monads

-- | Validation
--              +---- Type to accumulate errors in e.g. []
--              |
--              | +------ Invalid type, i.e. type of error to accumulate
--              | |
--              | | +-------- Value type
--              | | |
--              v v v
data Validation t i v = Valid v          -- ^ Validation success
                      | Invalid (t i) v  -- ^ Validation failure, with default value so the code can continue
                      deriving (Eq, Show)


-- | Functor
instance Functor (Validation t i) where
  fmap f (Valid v) = Valid (f v)            -- ^ Valid case is simple
  fmap f (Invalid es v) = Invalid es (f v)  -- ^ Invalid case, apply function, keep errors


-- | Semigroup
instance (Semigroup (t i)) => Applicative (Validation t i) where
  pure = Valid
  (<*>) = ap  -- ^ Use ap. honour the monad laws. See below for explicit version of this
 

-- | Monad
instance (Semigroup (t i)) => Monad (Validation t i) where
  Valid v >>= f = f v -- ^ Valid case is once again simple
  Invalid es v >>= f = case f v of
                         -- | Left was invalid, so result is invalid
                         Valid v' -> Invalid es v' 

                         -- | Left was invalid, so result is invalid, accumulate errors
                         Invalid es' v' -> Invalid (es <> es') v'
  

-- | Helper so that you don't need to e.g. log [i] every time
invalid :: (Applicative t) => i -> v -> Validation t i v
invalid = Invalid . pure

-- | Convert to an Either. Left throws away the default value 
asEither :: Validation t i v -> Either (t i) v
asEither (Valid v) = Right v
asEither (Invalid es _) = Left es


-- | Example
main :: IO ()
main = do
  print test
  print . asEither $ test
  
  where
    test :: Validation [] Text Int
    test = do
      x <- pure 2
      y <- Invalid ["no"] 0
      z <- pure 3
      zz <- invalid "more" 0
      pure $ x + y + z + zz



{- Example of Applicative without using `ap`
instance (Semigroup (t i)) => Applicative (Validation t i) where
  pure = Valid

  Valid f <*> Valid v = Valid $ f v
  Valid f <*> Invalid es v = Invalid es (f v)
  Invalid es1 f <*> Invalid es2 v = Invalid (es2 <> es1) (f v)
  Invalid es1 f <*> Valid v = Invalid es1 (f v)
-}




-----------------------------------------------------------------------------------------------------------------------
-- | Monad transformer
newtype ValidationT t i m v = ValidationT { runValidationT :: m (Validation t i v) }

instance (Monad m) => Functor (ValidationT t i m) where
  fmap f x = ValidationT $ f <<$>> runValidationT x

instance (Monad m, Semigroup (t i)) => Applicative (ValidationT t i m) where
  (<*>) = ap
  pure = ValidationT . pure . Valid

instance (Monad m, Semigroup (t i)) => Monad (ValidationT t i m) where
  return = pure
  x >>= f = ValidationT $
    runValidationT x >>= \case
      (Valid v) -> runValidationT (f v)
      (Invalid es1 v1) ->
        runValidationT (f v1) >>= \case
          (Valid v2) -> pure $ Invalid es1 v2
          (Invalid es2 v2) -> pure $ Invalid (es1 <> es2) v2

instance Mt.MonadTrans (ValidationT t i) where
  lift = ValidationT . liftM Valid
-----------------------------------------------------------------------------------------------------------------------



{- eg

test2 :: IO ()
test2 = do
  r <- runValidationT go
  print r

  where
    go :: ValidationT [] Text IO Int
    go = do
      a <- pure 1
      b <- ValidationT . pure $ Invalid ["no"] 0
      lift $ putText "123"
      c <- pure 3
      pure $ a + b + c

-}