Valid.hs

{-|
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 (Eq, Show, Ord)

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

instance Bifunctor Valid where
    bimap f g = valid (Invalid . f) (Valid . g)
    {-# INLINABLE bimap #-}

instance Functor (Valid e) where
    fmap = second
    {-# INLINE fmap #-}

instance Semigroup e => Applicative (Valid e) where
    pure = Valid

    Valid   fn  <*> Valid   x     = Valid (fn x)
    Invalid lhs <*> Invalid rhs   = Invalid (lhs <> rhs)
    Invalid lhs <*> _             = Invalid lhs
    _           <*> Invalid rhs   = Invalid rhs

instance Monoid e => Alternative (Valid e) where
    empty = Invalid mempty

    lhs@Valid{} <|> _           = lhs
    Invalid lhs <|> Invalid rhs = Invalid (lhs <> rhs)
    Invalid{}   <|> rhs         = rhs

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

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

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