{-|
Module      : Data.Either.Valid
Description : 'Either', but accumulates its errors.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE LambdaCase #-}
module Data.Either.Valid 
  ( Valid(..)
  , fromEither
  , toEither
  , valid
  ) where

import Data.Bifunctor (Bifunctor(..))
import Control.Applicative (Alternative(..))

-- | Like the 'Either' type, but its instances accumulates its errors. As such,
-- there is no 'Monad' instance for 'Valid'.
--
-- The 'Invalid' constructor takes precedence over 'Valid' when used with
-- classes that combine two values.
--
-- Note: There are a /lot/ of packages that implement this data type, but
-- finding a well-maintained one with minimal dependencies proved difficult.
data Valid e a =
    Invalid !e
  | Valid   !a
  deriving (Valid e a -> Valid e a -> Bool
(Valid e a -> Valid e a -> Bool)
-> (Valid e a -> Valid e a -> Bool) -> Eq (Valid e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall e a. (Eq e, Eq a) => Valid e a -> Valid e a -> Bool
/= :: Valid e a -> Valid e a -> Bool
$c/= :: forall e a. (Eq e, Eq a) => Valid e a -> Valid e a -> Bool
== :: Valid e a -> Valid e a -> Bool
$c== :: forall e a. (Eq e, Eq a) => Valid e a -> Valid e a -> Bool
Eq, Int -> Valid e a -> ShowS
[Valid e a] -> ShowS
Valid e a -> String
(Int -> Valid e a -> ShowS)
-> (Valid e a -> String)
-> ([Valid e a] -> ShowS)
-> Show (Valid e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show e, Show a) => Int -> Valid e a -> ShowS
forall e a. (Show e, Show a) => [Valid e a] -> ShowS
forall e a. (Show e, Show a) => Valid e a -> String
showList :: [Valid e a] -> ShowS
$cshowList :: forall e a. (Show e, Show a) => [Valid e a] -> ShowS
show :: Valid e a -> String
$cshow :: forall e a. (Show e, Show a) => Valid e a -> String
showsPrec :: Int -> Valid e a -> ShowS
$cshowsPrec :: forall e a. (Show e, Show a) => Int -> Valid e a -> ShowS
Show, Eq (Valid e a)
Eq (Valid e a) =>
(Valid e a -> Valid e a -> Ordering)
-> (Valid e a -> Valid e a -> Bool)
-> (Valid e a -> Valid e a -> Bool)
-> (Valid e a -> Valid e a -> Bool)
-> (Valid e a -> Valid e a -> Bool)
-> (Valid e a -> Valid e a -> Valid e a)
-> (Valid e a -> Valid e a -> Valid e a)
-> Ord (Valid e a)
Valid e a -> Valid e a -> Bool
Valid e a -> Valid e a -> Ordering
Valid e a -> Valid e a -> Valid e a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall e a. (Ord e, Ord a) => Eq (Valid e a)
forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Bool
forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Ordering
forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Valid e a
min :: Valid e a -> Valid e a -> Valid e a
$cmin :: forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Valid e a
max :: Valid e a -> Valid e a -> Valid e a
$cmax :: forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Valid e a
>= :: Valid e a -> Valid e a -> Bool
$c>= :: forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Bool
> :: Valid e a -> Valid e a -> Bool
$c> :: forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Bool
<= :: Valid e a -> Valid e a -> Bool
$c<= :: forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Bool
< :: Valid e a -> Valid e a -> Bool
$c< :: forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Bool
compare :: Valid e a -> Valid e a -> Ordering
$ccompare :: forall e a. (Ord e, Ord a) => Valid e a -> Valid e a -> Ordering
$cp1Ord :: forall e a. (Ord e, Ord a) => Eq (Valid e a)
Ord)

instance (Semigroup e, Semigroup a) => Semigroup (Valid e a) where
    Valid   lhs :: a
lhs   <> :: Valid e a -> Valid e a -> Valid e a
<> Valid   rhs :: a
rhs = a -> Valid e a
forall e a. a -> Valid e a
Valid   (a
lhs a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
rhs)
    Invalid lhs :: e
lhs   <> Invalid rhs :: e
rhs = e -> Valid e a
forall e a. e -> Valid e a
Invalid (e
lhs e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
rhs)
    lhs :: Valid e a
lhs@Invalid{} <> _           = Valid e a
lhs
    _             <> rhs :: Valid e a
rhs         = Valid e a
rhs
    
instance (Semigroup e, Monoid a) => Monoid (Valid e a) where
    mempty :: Valid e a
mempty = a -> Valid e a
forall e a. a -> Valid e a
Valid a
forall a. Monoid a => a
mempty

instance Bifunctor Valid where
    bimap :: (a -> b) -> (c -> d) -> Valid a c -> Valid b d
bimap f :: a -> b
f g :: c -> d
g = (a -> Valid b d) -> (c -> Valid b d) -> Valid a c -> Valid b d
forall e r a. (e -> r) -> (a -> r) -> Valid e a -> r
valid (b -> Valid b d
forall e a. e -> Valid e a
Invalid (b -> Valid b d) -> (a -> b) -> a -> Valid b d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (d -> Valid b d
forall e a. a -> Valid e a
Valid (d -> Valid b d) -> (c -> d) -> c -> Valid b d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> d
g)
    {-# INLINABLE bimap #-}

instance Functor (Valid e) where
    fmap :: (a -> b) -> Valid e a -> Valid e b
fmap = (a -> b) -> Valid e a -> Valid e b
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second
    {-# INLINE fmap #-}

instance Semigroup e => Applicative (Valid e) where
    pure :: a -> Valid e a
pure = a -> Valid e a
forall e a. a -> Valid e a
Valid

    Valid   fn :: a -> b
fn  <*> :: Valid e (a -> b) -> Valid e a -> Valid e b
<*> Valid   x :: a
x     = b -> Valid e b
forall e a. a -> Valid e a
Valid (a -> b
fn a
x)
    Invalid lhs :: e
lhs <*> Invalid rhs :: e
rhs   = e -> Valid e b
forall e a. e -> Valid e a
Invalid (e
lhs e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
rhs)
    Invalid lhs :: e
lhs <*> _             = e -> Valid e b
forall e a. e -> Valid e a
Invalid e
lhs
    _           <*> Invalid rhs :: e
rhs   = e -> Valid e b
forall e a. e -> Valid e a
Invalid e
rhs

instance Monoid e => Alternative (Valid e) where
    empty :: Valid e a
empty = e -> Valid e a
forall e a. e -> Valid e a
Invalid e
forall a. Monoid a => a
mempty

    lhs :: Valid e a
lhs@Valid{} <|> :: Valid e a -> Valid e a -> Valid e a
<|> _           = Valid e a
lhs
    Invalid lhs :: e
lhs <|> Invalid rhs :: e
rhs = e -> Valid e a
forall e a. e -> Valid e a
Invalid (e
lhs e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
rhs)
    Invalid{}   <|> rhs :: Valid e a
rhs         = Valid e a
rhs

-- | Convert an 'Either' value to 'Valid'.
fromEither :: Either e a -> Valid e a
fromEither :: Either e a -> Valid e a
fromEither = (e -> Valid e a) -> (a -> Valid e a) -> Either e a -> Valid e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> Valid e a
forall e a. e -> Valid e a
Invalid a -> Valid e a
forall e a. a -> Valid e a
Valid
{-# INLINE fromEither #-}

-- | Convert a 'Valid' value to 'Either'.
toEither :: Valid e a -> Either e a
toEither :: Valid e a -> Either e a
toEither = (e -> Either e a) -> (a -> Either e a) -> Valid e a -> Either e a
forall e r a. (e -> r) -> (a -> r) -> Valid e a -> r
valid e -> Either e a
forall a b. a -> Either a b
Left a -> Either e a
forall a b. b -> Either a b
Right
{-# INLINE toEither #-}

-- | Consume a 'Valid' by handling errors and valid values.
valid :: (e -> r) -> (a -> r) -> Valid e a -> r
valid :: (e -> r) -> (a -> r) -> Valid e a -> r
valid l :: e -> r
l r :: a -> r
r = \case
    Invalid e :: e
e -> e -> r
l e
e
    Valid   a :: a
a -> a -> r
r a
a
{-# INLINE valid #-}