# LANGUAGE GeneralizedNewtypeDeriving #
{-# LANGUAGE PatternSynonyms            #-}
-- | Monad for validation
module Data.Validated (
    Validated(..)
  , validatedFromExceptT
  , validatedFromEither
  , validatedToEither
  , isValidated
  , addErrorDetail
  , validatedMapErrors
    -- * Convenience re-exports
  , MonadError(..)
  ) where

import           Control.Monad.Except
import           Formatting (bprint, build, (%))
import qualified Formatting.Buildable
import           Serokell.Util (listJson)
import           Universum

-- | Mark a value as validated or not
--
-- If not validated, we can include some arbitrary error message as well
-- as some additional text detail.
data Validated e a = Invalid [Text] e | Valid a

addErrorDetail :: Text -> Validated e a -> Validated e a
addErrorDetail d (Invalid ds e) = Invalid (d:ds) e
addErrorDetail _ (Valid      a) = Valid a

instance Functor (Validated e) where
    fmap = liftM
instance Applicative (Validated e) where
    pure = return
    (<*>) = ap
instance Monad (Validated e) where
    return = Valid
    Invalid ds e >>= _ = Invalid ds e
    Valid      a >>= f = f a
instance MonadError e (Validated e) where
    throwError = Invalid []
    Invalid _ e `catchError` f = f e
    Valid     a `catchError` _ = Valid a

validatedFromExceptT :: Monad m => ExceptT e m a -> m (Validated e a)
validatedFromExceptT = fmap validatedFromEither . runExceptT

validatedFromEither :: Either e a -> Validated e a
validatedFromEither (Left  e) = Invalid [] e
validatedFromEither (Right a) = Valid      a

validatedToEither :: Validated e a -> Either e a
validatedToEither (Invalid _ e) = Left  e
validatedToEither (Valid     a) = Right a

instance (Buildable e, Buildable a) => Buildable (Validated e a) where
  build (Invalid ds e) = bprint ("Invalid " % listJson % " " % build) ds e
  build (Valid      a) = bprint ("Valid "   % build) a

isValidated :: Validated e a -> Bool
isValidated (Invalid _ _) = False
isValidated (Valid     _) = True

validatedMapErrors :: (e -> e') -> Validated e a -> Validated e' a
validatedMapErrors f (Invalid ds e) = Invalid ds (f e)
validatedMapErrors _ (Valid a)      = Valid a

# LANGUAGE PatternSynonyms            #
 | Monad for validation
 * Convenience re-exports
 | Mark a value as validated or not

 If not validated, we can include some arbitrary error message as well
 as some additional text detail.
# LANGUAGE GeneralizedNewtypeDeriving #
module Data.Validated (
    Validated(..)
  , validatedFromExceptT
  , validatedFromEither
  , validatedToEither
  , isValidated
  , addErrorDetail
  , validatedMapErrors
  , MonadError(..)
  ) where

import           Control.Monad.Except
import           Formatting (bprint, build, (%))
import qualified Formatting.Buildable
import           Serokell.Util (listJson)
import           Universum

data Validated e a = Invalid [Text] e | Valid a

addErrorDetail :: Text -> Validated e a -> Validated e a
addErrorDetail d (Invalid ds e) = Invalid (d:ds) e
addErrorDetail _ (Valid      a) = Valid a

instance Functor (Validated e) where
    fmap = liftM
instance Applicative (Validated e) where
    pure = return
    (<*>) = ap
instance Monad (Validated e) where
    return = Valid
    Invalid ds e >>= _ = Invalid ds e
    Valid      a >>= f = f a
instance MonadError e (Validated e) where
    throwError = Invalid []
    Invalid _ e `catchError` f = f e
    Valid     a `catchError` _ = Valid a

validatedFromExceptT :: Monad m => ExceptT e m a -> m (Validated e a)
validatedFromExceptT = fmap validatedFromEither . runExceptT

validatedFromEither :: Either e a -> Validated e a
validatedFromEither (Left  e) = Invalid [] e
validatedFromEither (Right a) = Valid      a

validatedToEither :: Validated e a -> Either e a
validatedToEither (Invalid _ e) = Left  e
validatedToEither (Valid     a) = Right a

instance (Buildable e, Buildable a) => Buildable (Validated e a) where
  build (Invalid ds e) = bprint ("Invalid " % listJson % " " % build) ds e
  build (Valid      a) = bprint ("Valid "   % build) a

isValidated :: Validated e a -> Bool
isValidated (Invalid _ _) = False
isValidated (Valid     _) = True

validatedMapErrors :: (e -> e') -> Validated e a -> Validated e' a
validatedMapErrors f (Invalid ds e) = Invalid ds (f e)
validatedMapErrors _ (Valid a)      = Valid a
