{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module OptEnvConf.Validation where

import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State
import Control.Selective (Selective (..))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE

-- TODO define Validation in terms of ValidationT so we can use polymorphic functions?
newtype ValidationT e m a = ValidationT {forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
unValidationT :: m (Validation e a)}
  deriving ((forall a b. (a -> b) -> ValidationT e m a -> ValidationT e m b)
-> (forall a b. a -> ValidationT e m b -> ValidationT e m a)
-> Functor (ValidationT e m)
forall a b. a -> ValidationT e m b -> ValidationT e m a
forall a b. (a -> b) -> ValidationT e m a -> ValidationT e m b
forall e (m :: * -> *) a b.
Functor m =>
a -> ValidationT e m b -> ValidationT e m a
forall e (m :: * -> *) a b.
Functor m =>
(a -> b) -> ValidationT e m a -> ValidationT e m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall e (m :: * -> *) a b.
Functor m =>
(a -> b) -> ValidationT e m a -> ValidationT e m b
fmap :: forall a b. (a -> b) -> ValidationT e m a -> ValidationT e m b
$c<$ :: forall e (m :: * -> *) a b.
Functor m =>
a -> ValidationT e m b -> ValidationT e m a
<$ :: forall a b. a -> ValidationT e m b -> ValidationT e m a
Functor)

instance (Applicative m) => Applicative (ValidationT e m) where
  pure :: forall a. a -> ValidationT e m a
pure = m (Validation e a) -> ValidationT e m a
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e a) -> ValidationT e m a)
-> (a -> m (Validation e a)) -> a -> ValidationT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation e a -> m (Validation e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation e a -> m (Validation e a))
-> (a -> Validation e a) -> a -> m (Validation e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Validation e a
forall e a. a -> Validation e a
Success
  (ValidationT m (Validation e (a -> b))
m1) <*> :: forall a b.
ValidationT e m (a -> b) -> ValidationT e m a -> ValidationT e m b
<*> (ValidationT m (Validation e a)
m2) =
    m (Validation e b) -> ValidationT e m b
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e b) -> ValidationT e m b)
-> m (Validation e b) -> ValidationT e m b
forall a b. (a -> b) -> a -> b
$
      Validation e (a -> b) -> Validation e a -> Validation e b
forall a b.
Validation e (a -> b) -> Validation e a -> Validation e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (Validation e (a -> b) -> Validation e a -> Validation e b)
-> m (Validation e (a -> b))
-> m (Validation e a -> Validation e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Validation e (a -> b))
m1 m (Validation e a -> Validation e b)
-> m (Validation e a) -> m (Validation e b)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Validation e a)
m2

instance (Selective m) => Selective (ValidationT e m) where
  select :: forall a b.
ValidationT e m (Either a b)
-> ValidationT e m (a -> b) -> ValidationT e m b
select (ValidationT m (Validation e (Either a b))
fe) (ValidationT m (Validation e (a -> b))
ff) = m (Validation e b) -> ValidationT e m b
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e b) -> ValidationT e m b)
-> m (Validation e b) -> ValidationT e m b
forall a b. (a -> b) -> a -> b
$ Validation e (Either a b)
-> Validation e (a -> b) -> Validation e b
forall a b.
Validation e (Either a b)
-> Validation e (a -> b) -> Validation e b
forall (f :: * -> *) a b.
Selective f =>
f (Either a b) -> f (a -> b) -> f b
select (Validation e (Either a b)
 -> Validation e (a -> b) -> Validation e b)
-> m (Validation e (Either a b))
-> m (Validation e (a -> b) -> Validation e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Validation e (Either a b))
fe m (Validation e (a -> b) -> Validation e b)
-> m (Validation e (a -> b)) -> m (Validation e b)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Validation e (a -> b))
ff

instance (Monad m) => Monad (ValidationT e m) where
  (ValidationT m (Validation e a)
m) >>= :: forall a b.
ValidationT e m a -> (a -> ValidationT e m b) -> ValidationT e m b
>>= a -> ValidationT e m b
f = m (Validation e b) -> ValidationT e m b
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e b) -> ValidationT e m b)
-> m (Validation e b) -> ValidationT e m b
forall a b. (a -> b) -> a -> b
$ do
    Validation e a
va <- m (Validation e a)
m
    case Validation e a
va of
      Failure NonEmpty e
es -> Validation e b -> m (Validation e b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation e b -> m (Validation e b))
-> Validation e b -> m (Validation e b)
forall a b. (a -> b) -> a -> b
$ NonEmpty e -> Validation e b
forall e a. NonEmpty e -> Validation e a
Failure NonEmpty e
es
      Success a
a -> ValidationT e m b -> m (Validation e b)
forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
unValidationT (ValidationT e m b -> m (Validation e b))
-> ValidationT e m b -> m (Validation e b)
forall a b. (a -> b) -> a -> b
$ a -> ValidationT e m b
f a
a

instance MonadTrans (ValidationT e) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ValidationT e m a
lift m a
f = m (Validation e a) -> ValidationT e m a
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e a) -> ValidationT e m a)
-> m (Validation e a) -> ValidationT e m a
forall a b. (a -> b) -> a -> b
$ a -> Validation e a
forall e a. a -> Validation e a
Success (a -> Validation e a) -> m a -> m (Validation e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
f

instance (MonadReader env m) => MonadReader env (ValidationT err m) where
  ask :: ValidationT err m env
ask = m env -> ValidationT err m env
forall (m :: * -> *) a. Monad m => m a -> ValidationT err m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m env
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a.
(env -> env) -> ValidationT err m a -> ValidationT err m a
local env -> env
func = m (Validation err a) -> ValidationT err m a
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation err a) -> ValidationT err m a)
-> (ValidationT err m a -> m (Validation err a))
-> ValidationT err m a
-> ValidationT err m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (env -> env) -> m (Validation err a) -> m (Validation err a)
forall a. (env -> env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local env -> env
func (m (Validation err a) -> m (Validation err a))
-> (ValidationT err m a -> m (Validation err a))
-> ValidationT err m a
-> m (Validation err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationT err m a -> m (Validation err a)
forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
unValidationT

instance (MonadState state m) => MonadState state (ValidationT err m) where
  get :: ValidationT err m state
get = m state -> ValidationT err m state
forall (m :: * -> *) a. Monad m => m a -> ValidationT err m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m state
forall s (m :: * -> *). MonadState s m => m s
get
  put :: state -> ValidationT err m ()
put = m () -> ValidationT err m ()
forall (m :: * -> *) a. Monad m => m a -> ValidationT err m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ValidationT err m ())
-> (state -> m ()) -> state -> ValidationT err m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance (MonadIO m) => MonadIO (ValidationT e m) where
  liftIO :: forall a. IO a -> ValidationT e m a
liftIO IO a
io = m (Validation e a) -> ValidationT e m a
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e a) -> ValidationT e m a)
-> m (Validation e a) -> ValidationT e m a
forall a b. (a -> b) -> a -> b
$ a -> Validation e a
forall e a. a -> Validation e a
Success (a -> Validation e a) -> m a -> m (Validation e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io

runValidationT :: ValidationT e m a -> m (Validation e a)
runValidationT :: forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
runValidationT = ValidationT e m a -> m (Validation e a)
forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
unValidationT

validationTFailure :: (Applicative m) => e -> ValidationT e m a
validationTFailure :: forall (m :: * -> *) e a. Applicative m => e -> ValidationT e m a
validationTFailure = m (Validation e a) -> ValidationT e m a
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e a) -> ValidationT e m a)
-> (e -> m (Validation e a)) -> e -> ValidationT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation e a -> m (Validation e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation e a -> m (Validation e a))
-> (e -> Validation e a) -> e -> m (Validation e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Validation e a
forall e a. e -> Validation e a
validationFailure

mapValidationTFailure :: (Functor m) => (e1 -> e2) -> ValidationT e1 m a -> ValidationT e2 m a
mapValidationTFailure :: forall (m :: * -> *) e1 e2 a.
Functor m =>
(e1 -> e2) -> ValidationT e1 m a -> ValidationT e2 m a
mapValidationTFailure e1 -> e2
f = m (Validation e2 a) -> ValidationT e2 m a
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (m (Validation e2 a) -> ValidationT e2 m a)
-> (ValidationT e1 m a -> m (Validation e2 a))
-> ValidationT e1 m a
-> ValidationT e2 m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validation e1 a -> Validation e2 a)
-> m (Validation e1 a) -> m (Validation e2 a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e1 -> e2) -> Validation e1 a -> Validation e2 a
forall e1 e2 a. (e1 -> e2) -> Validation e1 a -> Validation e2 a
mapValidationFailure e1 -> e2
f) (m (Validation e1 a) -> m (Validation e2 a))
-> (ValidationT e1 m a -> m (Validation e1 a))
-> ValidationT e1 m a
-> m (Validation e2 a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationT e1 m a -> m (Validation e1 a)
forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
unValidationT

data Validation e a
  = Failure !(NonEmpty e)
  | Success !a

instance Functor (Validation e) where
  fmap :: forall a b. (a -> b) -> Validation e a -> Validation e b
fmap a -> b
_ (Failure NonEmpty e
e) = NonEmpty e -> Validation e b
forall e a. NonEmpty e -> Validation e a
Failure NonEmpty e
e
  fmap a -> b
f (Success a
a) = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
a)

instance Applicative (Validation e) where
  pure :: forall a. a -> Validation e a
pure = a -> Validation e a
forall e a. a -> Validation e a
Success
  Failure NonEmpty e
e1 <*> :: forall a b.
Validation e (a -> b) -> Validation e a -> Validation e b
<*> Validation e a
b = NonEmpty e -> Validation e b
forall e a. NonEmpty e -> Validation e a
Failure (NonEmpty e -> Validation e b) -> NonEmpty e -> Validation e b
forall a b. (a -> b) -> a -> b
$ case Validation e a
b of
    Failure NonEmpty e
e2 -> NonEmpty e
e1 NonEmpty e -> NonEmpty e -> NonEmpty e
forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
`NE.append` NonEmpty e
e2
    Success a
_ -> NonEmpty e
e1
  Success a -> b
_ <*> Failure NonEmpty e
e2 = NonEmpty e -> Validation e b
forall e a. NonEmpty e -> Validation e a
Failure NonEmpty e
e2
  Success a -> b
f <*> Success a
a = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
a)

instance Selective (Validation e) where
  select :: forall a b.
Validation e (Either a b)
-> Validation e (a -> b) -> Validation e b
select (Failure NonEmpty e
ne1) (Failure NonEmpty e
ne2) = NonEmpty e -> Validation e b
forall e a. NonEmpty e -> Validation e a
Failure (NonEmpty e
ne1 NonEmpty e -> NonEmpty e -> NonEmpty e
forall a. Semigroup a => a -> a -> a
<> NonEmpty e
ne2)
  select (Failure NonEmpty e
ne) (Success a -> b
_) = NonEmpty e -> Validation e b
forall e a. NonEmpty e -> Validation e a
Failure NonEmpty e
ne
  -- We could chose to skip the failures here if the first argument was a
  -- Right, but we'd prefer to see as many errors as possible.
  select (Success Either a b
_) (Failure NonEmpty e
ne) = NonEmpty e -> Validation e b
forall e a. NonEmpty e -> Validation e a
Failure NonEmpty e
ne
  select (Success Either a b
e) (Success a -> b
f) = b -> Validation e b
forall e a. a -> Validation e a
Success (b -> Validation e b) -> b -> Validation e b
forall a b. (a -> b) -> a -> b
$ case Either a b
e of
    Left a
a -> a -> b
f a
a
    Right b
b -> b
b

validationFailure :: e -> Validation e a
validationFailure :: forall e a. e -> Validation e a
validationFailure e
e = NonEmpty e -> Validation e a
forall e a. NonEmpty e -> Validation e a
Failure (e
e e -> [e] -> NonEmpty e
forall a. a -> [a] -> NonEmpty a
:| [])

mapValidationFailure :: (e1 -> e2) -> Validation e1 a -> Validation e2 a
mapValidationFailure :: forall e1 e2 a. (e1 -> e2) -> Validation e1 a -> Validation e2 a
mapValidationFailure e1 -> e2
f = \case
  Success a
a -> a -> Validation e2 a
forall e a. a -> Validation e a
Success a
a
  Failure NonEmpty e1
errs -> NonEmpty e2 -> Validation e2 a
forall e a. NonEmpty e -> Validation e a
Failure (NonEmpty e2 -> Validation e2 a) -> NonEmpty e2 -> Validation e2 a
forall a b. (a -> b) -> a -> b
$ (e1 -> e2) -> NonEmpty e1 -> NonEmpty e2
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map e1 -> e2
f NonEmpty e1
errs

validationToEither :: Validation e a -> Either (NonEmpty e) a
validationToEither :: forall e a. Validation e a -> Either (NonEmpty e) a
validationToEither = \case
  Success a
a -> a -> Either (NonEmpty e) a
forall a b. b -> Either a b
Right a
a
  Failure NonEmpty e
ne -> NonEmpty e -> Either (NonEmpty e) a
forall a b. a -> Either a b
Left NonEmpty e
ne