either-n-0.1.0.0: src/Data/Either3/Either3.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}

-- | A data type similar to @Data.Either@ with three constructors.
module Data.Either3.Either3 (
  -- * Data type
  Either3 (..),

  -- * Catamorphism
  foldEither3,

  -- * Isomorphisms
  either3ACB,
  either3BAC,
  either3BCA,
  either3CAB,
  either3CBA,

  -- * Optics

  -- ** Classy lenses
  GetEither3 (..),
  HasEither3 (..),

  -- ** Classy prisms
  ReviewEither3 (..),
  AsEither3 (..),
) where

import Control.DeepSeq (NFData)
import Control.Lens (Each (..), FoldableWithIndex (..), FunctorWithIndex (..), Getter, Iso, Lens', Prism', Review, TraversableWithIndex (..), iso, lens, prism', review, unto, view)
import Control.Monad.Zip (MonadZip (..))
import Control.Selective (Selective (..), selectM)
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bifunctor.Swap (Swap (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Data (Data)
import Data.Functor.Alt (Alt (..))
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind (Bind (..))
import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..), showsUnaryWith)
import Data.Functor.Extend (Extend (..))
import Data.Lens.Injection.Injection1 (Injection1)
import Data.Lens.Injection.Injection2 (Injection2)
import Data.Lens.Injection.Injection3 (Injection3)
import GHC.Generics (Generic, Generic1)

{- $setup
>>> import Control.Lens((^?), (#), over, view, review, toListOf, imap)
>>> import Control.DeepSeq(rnf)
>>> import Data.Data(toConstr)
>>> import GHC.Generics(from, to)
>>> import Control.Monad.Zip(mzip)
>>> import Control.Selective(select)
>>> import Data.Bifunctor(bimap)
>>> import Data.Bifoldable(bifoldMap)
>>> import Data.Bitraversable(bitraverse)
>>> import Data.Bifunctor.Swap(swap)
>>> import Data.Functor.Alt((<!>))
>>> import Data.Functor.Apply((<.>))
>>> import Data.Functor.Bind((>>-))
>>> import Data.Functor.Classes(liftEq, liftCompare)
>>> import Data.Functor.Extend(duplicated)
>>> import Data.Lens.Injection.Injection1(Injection1(..))
>>> import Data.Lens.Injection.Injection2(Injection2(..))
>>> import Data.Lens.Injection.Injection3(Injection3(..))
-}

{- | A value of one of three types, similar to 'Either'.

The 'Functor', 'Applicative' and 'Monad' instances act on the third type
parameter, so 'First3' and 'Second3' short-circuit, in the same way 'Left'
does for 'Either'.

>>> toConstr (Second3 True :: Either3 String Bool Int)
Second3

>>> to (from (Third3 1 :: Either3 String Bool Int)) :: Either3 String Bool Int
Third3 1
-}
data Either3 a b c
  = First3 a
  | Second3 b
  | Third3 c
  deriving stock (Data, Eq, Generic, Generic1, Ord, Show)
  deriving anyclass (NFData)

{- | Case analysis for 'Either3'.

>>> foldEither3 length fromEnum (+ 1) (First3 "abc" :: Either3 String Bool Int)
3

>>> foldEither3 length (const 0) (+ 1) (Third3 1 :: Either3 String Bool Int)
2
-}
foldEither3 :: (a -> x) -> (b -> x) -> (c -> x) -> Either3 a b c -> x
foldEither3 f _ _ (First3 a) =
  f a
foldEither3 _ g _ (Second3 b) =
  g b
foldEither3 _ _ h (Third3 c) =
  h c
{-# INLINE foldEither3 #-}

{- | Reorder the type parameters of 'Either3' to @a c b@.

>>> view either3ACB (Second3 True :: Either3 String Bool Int)
Third3 True

>>> view either3ACB (Third3 1 :: Either3 String Bool Int)
Second3 1

>>> over either3ACB (bimap show not) (Second3 True :: Either3 String Bool Int)
Second3 False
-}
either3ACB :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 a c b) (Either3 a' c' b')
either3ACB =
  iso (foldEither3 First3 Third3 Second3) (foldEither3 First3 Third3 Second3)
{-# INLINE either3ACB #-}

{- | Reorder the type parameters of 'Either3' to @b a c@.

>>> view either3BAC (First3 "x" :: Either3 String Bool Int)
Second3 "x"

>>> view either3BAC (Second3 True :: Either3 String Bool Int)
First3 True
-}
either3BAC :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 b a c) (Either3 b' a' c')
either3BAC =
  iso (foldEither3 Second3 First3 Third3) (foldEither3 Second3 First3 Third3)
{-# INLINE either3BAC #-}

{- | Reorder the type parameters of 'Either3' to @b c a@.

>>> view either3BCA (First3 "x" :: Either3 String Bool Int)
Third3 "x"

>>> view either3BCA (Second3 True :: Either3 String Bool Int)
First3 True

>>> review either3BCA (First3 True :: Either3 Bool Int String)
Second3 True
-}
either3BCA :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 b c a) (Either3 b' c' a')
either3BCA =
  iso (foldEither3 Third3 First3 Second3) (foldEither3 Second3 Third3 First3)
{-# INLINE either3BCA #-}

{- | Reorder the type parameters of 'Either3' to @c a b@.

>>> view either3CAB (First3 "x" :: Either3 String Bool Int)
Second3 "x"

>>> view either3CAB (Third3 1 :: Either3 String Bool Int)
First3 1

>>> review either3CAB (First3 1 :: Either3 Int String Bool)
Third3 1
-}
either3CAB :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 c a b) (Either3 c' a' b')
either3CAB =
  iso (foldEither3 Second3 Third3 First3) (foldEither3 Third3 First3 Second3)
{-# INLINE either3CAB #-}

{- | Reorder the type parameters of 'Either3' to @c b a@.

>>> view either3CBA (First3 "x" :: Either3 String Bool Int)
Third3 "x"

>>> view either3CBA (Second3 True :: Either3 String Bool Int)
Second3 True
-}
either3CBA :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 c b a) (Either3 c' b' a')
either3CBA =
  iso (foldEither3 Third3 Second3 First3) (foldEither3 Third3 Second3 First3)
{-# INLINE either3CBA #-}

{- |
>>> fmap (+ 1) (Third3 1 :: Either3 String Bool Int)
Third3 2

>>> fmap (+ 1) (Second3 True :: Either3 String Bool Int)
Second3 True
-}
instance Functor (Either3 a b) where
  fmap =
    mapEither3
  {-# INLINE fmap #-}

{- |
>>> sum (Third3 1 :: Either3 String Bool Int)
1

>>> length (First3 "x" :: Either3 String Bool Int)
0
-}
instance Foldable (Either3 a b) where
  foldMap =
    foldMapEither3
  {-# INLINE foldMap #-}
  foldr =
    foldrEither3
  {-# INLINE foldr #-}

{- |
>>> traverse (\x -> [x, x + 1]) (Third3 1 :: Either3 String Bool Int)
[Third3 1,Third3 2]

>>> traverse (\x -> [x, x + 1]) (Second3 True :: Either3 String Bool Int)
[Second3 True]
-}
instance Traversable (Either3 a b) where
  traverse =
    traverseEither3
  {-# INLINE traverse #-}

{- Fusion

The 'Functor', 'Foldable', 'Traversable', 'Bifunctor', 'Bifoldable' and
'Bitraversable' methods delegate to the functions below, which are not
inlined before phase 1, so that the rewrite rules, which are active before
phase 1, can fuse compositions of them. Each rule is an instance of the functor law
@fmap f . fmap g = fmap (f . g)@, or of the corresponding law for
'bimap', 'foldMap', 'traverse', 'bifoldMap' or 'bitraverse'.
-}

mapEither3 :: (c -> d) -> Either3 a b c -> Either3 a b d
mapEither3 f =
  foldEither3 First3 Second3 (Third3 . f)
{-# NOINLINE [1] mapEither3 #-}

bimapEither3 :: (b -> b') -> (c -> c') -> Either3 a b c -> Either3 a b' c'
bimapEither3 f g =
  foldEither3 First3 (Second3 . f) (Third3 . g)
{-# NOINLINE [1] bimapEither3 #-}

foldMapEither3 :: (Monoid m) => (c -> m) -> Either3 a b c -> m
foldMapEither3 =
  foldEither3 (const mempty) (const mempty)
{-# NOINLINE [1] foldMapEither3 #-}

foldrEither3 :: (c -> x -> x) -> x -> Either3 a b c -> x
foldrEither3 f z =
  foldEither3 (const z) (const z) (`f` z)
{-# NOINLINE [1] foldrEither3 #-}

traverseEither3 :: (Applicative g) => (c -> g d) -> Either3 a b c -> g (Either3 a b d)
traverseEither3 f =
  foldEither3 (pure . First3) (pure . Second3) (fmap Third3 . f)
{-# NOINLINE [1] traverseEither3 #-}

bifoldMapEither3 :: (Monoid m) => (b -> m) -> (c -> m) -> Either3 a b c -> m
bifoldMapEither3 =
  foldEither3 (const mempty)
{-# NOINLINE [1] bifoldMapEither3 #-}

bitraverseEither3 :: (Applicative g) => (b -> g b') -> (c -> g c') -> Either3 a b c -> g (Either3 a b' c')
bitraverseEither3 f g =
  foldEither3 (pure . First3) (fmap Second3 . f) (fmap Third3 . g)
{-# NOINLINE [1] bitraverseEither3 #-}

{-# RULES
"Either3 fmap/fmap" [~1] forall f g x.
  mapEither3 f (mapEither3 g x) =
    mapEither3 (f . g) x
"Either3 bimap/bimap" [~1] forall f g h k x.
  bimapEither3 f g (bimapEither3 h k x) =
    bimapEither3 (f . h) (g . k) x
"Either3 fmap/bimap" [~1] forall f g h x.
  mapEither3 f (bimapEither3 g h x) =
    bimapEither3 g (f . h) x
"Either3 bimap/fmap" [~1] forall f g h x.
  bimapEither3 f g (mapEither3 h x) =
    bimapEither3 f (g . h) x
"Either3 foldMap/fmap" [~1] forall f g x.
  foldMapEither3 f (mapEither3 g x) =
    foldMapEither3 (f . g) x
"Either3 foldr/fmap" [~1] forall f g z x.
  foldrEither3 f z (mapEither3 g x) =
    foldrEither3 (f . g) z x
"Either3 traverse/fmap" [~1] forall f g x.
  traverseEither3 f (mapEither3 g x) =
    traverseEither3 (f . g) x
"Either3 bifoldMap/bimap" [~1] forall f g h k x.
  bifoldMapEither3 f g (bimapEither3 h k x) =
    bifoldMapEither3 (f . h) (g . k) x
"Either3 bitraverse/bimap" [~1] forall f g h k x.
  bitraverseEither3 f g (bimapEither3 h k x) =
    bitraverseEither3 (f . h) (g . k) x
  #-}

{- |
>>> liftEq2 (==) (==) (Second3 1 :: Either3 String Int Int) (Second3 1)
True

>>> liftEq2 (==) (==) (Second3 1 :: Either3 String Int Int) (Third3 1)
False
-}
instance (Eq a) => Eq2 (Either3 a) where
  liftEq2 _ _ (First3 x) (First3 y) = x == y
  liftEq2 f _ (Second3 x) (Second3 y) = f x y
  liftEq2 _ g (Third3 x) (Third3 y) = g x y
  liftEq2 _ _ _ _ = False
  {-# INLINE liftEq2 #-}

{- |
>>> liftEq (==) (Third3 1 :: Either3 String Bool Int) (Third3 1)
True
-}
instance (Eq a, Eq b) => Eq1 (Either3 a b) where
  liftEq = liftEq2 (==)
  {-# INLINE liftEq #-}

{- | Orders 'First3' before 'Second3' before 'Third3', as the derived 'Ord' does.

>>> liftCompare2 compare compare (First3 "x" :: Either3 String Int Int) (Third3 1)
LT

>>> liftCompare2 compare compare (Third3 2 :: Either3 String Int Int) (Third3 1)
GT
-}
instance (Ord a) => Ord2 (Either3 a) where
  liftCompare2 _ _ (First3 x) (First3 y) = compare x y
  liftCompare2 _ _ (First3 _) _ = LT
  liftCompare2 _ _ _ (First3 _) = GT
  liftCompare2 f _ (Second3 x) (Second3 y) = f x y
  liftCompare2 _ _ (Second3 _) (Third3 _) = LT
  liftCompare2 _ _ (Third3 _) (Second3 _) = GT
  liftCompare2 _ g (Third3 x) (Third3 y) = g x y
  {-# INLINE liftCompare2 #-}

{- |
>>> liftCompare compare (Second3 True :: Either3 String Bool Int) (Third3 1)
LT
-}
instance (Ord a, Ord b) => Ord1 (Either3 a b) where
  liftCompare = liftCompare2 compare
  {-# INLINE liftCompare #-}

instance (Show a) => Show2 (Either3 a) where
  liftShowsPrec2 _ _ _ _ d (First3 x) = showsUnaryWith showsPrec "First3" d x
  liftShowsPrec2 sp1 _ _ _ d (Second3 x) = showsUnaryWith sp1 "Second3" d x
  liftShowsPrec2 _ _ sp2 _ d (Third3 x) = showsUnaryWith sp2 "Third3" d x
  {-# INLINE liftShowsPrec2 #-}

instance (Show a, Show b) => Show1 (Either3 a b) where
  liftShowsPrec = liftShowsPrec2 showsPrec showList
  {-# INLINE liftShowsPrec #-}

{- | The first 'Third3' wins, otherwise the second value, like 'Either'.

>>> First3 "x" <> Third3 1 :: Either3 String Bool Int
Third3 1

>>> Third3 1 <> Third3 2 :: Either3 String Bool Int
Third3 1

>>> First3 "x" <> Second3 True :: Either3 String Bool Int
Second3 True
-}
instance Semigroup (Either3 a b c) where
  (<>) =
    (<!>)
  {-# INLINE (<>) #-}

{- |
>>> Third3 (+ 1) <.> Third3 1 :: Either3 String Bool Int
Third3 2

>>> First3 "x" <.> Second3 True :: Either3 String Bool Int
First3 "x"
-}
instance Apply (Either3 a b) where
  First3 a <.> _ =
    First3 a
  Second3 b <.> _ =
    Second3 b
  Third3 f <.> e =
    fmap f e
  {-# INLINE (<.>) #-}

{- |
>>> pure 1 :: Either3 String Bool Int
Third3 1

>>> Third3 (+ 1) <*> Second3 True :: Either3 String Bool Int
Second3 True
-}
instance Applicative (Either3 a b) where
  pure =
    Third3
  {-# INLINE pure #-}
  (<*>) =
    (<.>)
  {-# INLINE (<*>) #-}

{- |
>>> Third3 1 >>- (\x -> Third3 (x + 1)) :: Either3 String Bool Int
Third3 2
-}
instance Bind (Either3 a b) where
  (>>-) =
    (>>=)
  {-# INLINE (>>-) #-}

{- |
>>> Third3 1 >>= (\x -> if x > 0 then Third3 (x + 1) else Second3 False) :: Either3 String Bool Int
Third3 2

>>> Second3 True >>= (\x -> Third3 (x + 1)) :: Either3 String Bool Int
Second3 True
-}
instance Monad (Either3 a b) where
  First3 a >>= _ =
    First3 a
  Second3 b >>= _ =
    Second3 b
  Third3 c >>= f =
    f c
  {-# INLINE (>>=) #-}

{- | Combines two 'Third3' values, otherwise the first 'First3' or 'Second3', as 'Control.Applicative.liftA2' does.

>>> mzip (Third3 1) (Third3 True) :: Either3 String Bool (Int, Bool)
Third3 (1,True)

>>> mzip (Second3 False) (First3 "x") :: Either3 String Bool (Int, Bool)
Second3 False
-}
instance MonadZip (Either3 a b) where
  mzipWith =
    liftA2
  {-# INLINE mzipWith #-}

{- | The first 'Third3' wins, otherwise the second value, like 'Either'.

>>> First3 "x" <!> Third3 1 :: Either3 String Bool Int
Third3 1

>>> Second3 True <!> First3 "x" :: Either3 String Bool Int
First3 "x"
-}
instance Alt (Either3 a b) where
  Third3 c <!> _ =
    Third3 c
  _ <!> e =
    e
  {-# INLINE (<!>) #-}

{- |
>>> duplicated (Third3 1 :: Either3 String Bool Int)
Third3 (Third3 1)

>>> duplicated (Second3 True :: Either3 String Bool Int)
Second3 True
-}
instance Extend (Either3 a b) where
  duplicated (First3 a) =
    First3 a
  duplicated (Second3 b) =
    Second3 b
  duplicated w@(Third3 _) =
    Third3 w
  {-# INLINE duplicated #-}

{- |
>>> select (Third3 (Left 1)) (Third3 (+ 1)) :: Either3 String Bool Int
Third3 2

>>> select (Third3 (Right 1)) (Second3 True) :: Either3 String Bool Int
Third3 1
-}
instance Selective (Either3 a b) where
  select =
    selectM
  {-# INLINE select #-}

{- | Maps the second and third type parameters.

>>> bimap not (+ 1) (Second3 True :: Either3 String Bool Int)
Second3 False

>>> bimap not (+ 1) (Third3 1 :: Either3 String Bool Int)
Third3 2
-}
instance Bifunctor (Either3 a) where
  bimap =
    bimapEither3
  {-# INLINE bimap #-}

{- |
>>> bifoldMap show show (Second3 True :: Either3 String Bool Int)
"True"

>>> bifoldMap show show (First3 "x" :: Either3 String Bool Int)
""
-}
instance Bifoldable (Either3 a) where
  bifoldMap =
    bifoldMapEither3
  {-# INLINE bifoldMap #-}

{- |
>>> bitraverse (\b -> [b, not b]) (\c -> [c]) (Second3 True :: Either3 String Bool Int)
[Second3 True,Second3 False]
-}
instance Bitraversable (Either3 a) where
  bitraverse =
    bitraverseEither3
  {-# INLINE bitraverse #-}

{- | Swaps the second and third type parameters.

>>> swap (Second3 True :: Either3 String Bool Int)
Third3 True

>>> swap (First3 "x" :: Either3 String Bool Int)
First3 "x"
-}
instance Swap (Either3 a) where
  swap (First3 a) =
    First3 a
  swap (Second3 b) =
    Third3 b
  swap (Third3 c) =
    Second3 c
  {-# INLINE swap #-}

{- | The index is always @()@, as for 'Maybe'.

>>> imap (\() x -> x + 1) (Third3 1 :: Either3 String Bool Int)
Third3 2
-}
instance FunctorWithIndex () (Either3 a b) where
  imap f =
    fmap (f ())
  {-# INLINE imap #-}

instance FoldableWithIndex () (Either3 a b) where
  ifoldMap f =
    foldMap (f ())
  {-# INLINE ifoldMap #-}

instance TraversableWithIndex () (Either3 a b) where
  itraverse f =
    traverse (f ())
  {-# INLINE itraverse #-}

{- | Traverses the single value, like the 'Each' instance for @Either a a@.

>>> over each (+ 1) (Second3 1 :: Either3 Int Int Int)
Second3 2

>>> toListOf each (First3 1 :: Either3 Int Int Int)
[1]
-}
instance Each (Either3 a a a) (Either3 b b b) a b where
  each f (First3 a) =
    First3 <$> f a
  each f (Second3 a) =
    Second3 <$> f a
  each f (Third3 a) =
    Third3 <$> f a
  {-# INLINE each #-}

{- |
>>> (First3 1 :: Either3 Int Bool String) ^? _I1
Just 1

>>> over _I1 show (First3 1 :: Either3 Int Bool String)
First3 "1"
-}
instance Injection1 (Either3 a b c) (Either3 a' b c) a a'

{- |
>>> (Second3 True :: Either3 Int Bool String) ^? _I2
Just True

>>> _I2 # True :: Either3 Int Bool String
Second3 True
-}
instance Injection2 (Either3 a b c) (Either3 a b' c) b b'

{- |
>>> (Third3 "x" :: Either3 Int Bool String) ^? _I3
Just "x"

>>> (First3 1 :: Either3 Int Bool String) ^? _I3
Nothing
-}
instance Injection3 (Either3 a b c) (Either3 a b c') c c'

{- | Class for types that can be viewed as an 'Either3'.

>>> view getEither3 (Third3 1 :: Either3 String Bool Int)
Third3 1
-}
class GetEither3 s a b c | s -> a b c where
  getEither3 :: Getter s (Either3 a b c)

instance GetEither3 (Either3 a b c) a b c where
  getEither3 = id
  {-# INLINE getEither3 #-}

{- | Class for types that have a 'Lens'' to an 'Either3'. Instances define
'setEither3'; the lens 'either3' follows from it and from 'getEither3'.

>>> setEither3 (Second3 True) (Third3 1 :: Either3 String Bool Int)
Second3 True

>>> over either3 (fmap (+ 1)) (Third3 1 :: Either3 String Bool Int)
Third3 2
-}
class (GetEither3 s a b c) => HasEither3 s a b c | s -> a b c where
  {-# MINIMAL setEither3 #-}

  setEither3 :: Either3 a b c -> s -> s

  either3 :: Lens' s (Either3 a b c)
  either3 = lens (view getEither3) (flip setEither3)
  {-# INLINE either3 #-}

instance HasEither3 (Either3 a b c) a b c where
  setEither3 = const
  {-# INLINE setEither3 #-}

{- | Class for types that can be constructed from an 'Either3'.

>>> review reviewEither3 (First3 "x") :: Either3 String Bool Int
First3 "x"
-}
class ReviewEither3 t a b c | t -> a b c where
  reviewEither3 :: Review t (Either3 a b c)

instance ReviewEither3 (Either3 a b c) a b c where
  reviewEither3 = unto id
  {-# INLINE reviewEither3 #-}

{- | Class for types that have a 'Prism'' to an 'Either3'. Instances define
'matchEither3'; the prism '_Either3' follows from it and from 'reviewEither3'.

>>> matchEither3 (Third3 1 :: Either3 String Bool Int)
Just (Third3 1)

>>> (Third3 1 :: Either3 String Bool Int) ^? _Either3
Just (Third3 1)
-}
class (ReviewEither3 t a b c) => AsEither3 t a b c | t -> a b c where
  {-# MINIMAL matchEither3 #-}

  matchEither3 :: t -> Maybe (Either3 a b c)

  _Either3 :: Prism' t (Either3 a b c)
  _Either3 = prism' (review reviewEither3) matchEither3
  {-# INLINE _Either3 #-}

instance AsEither3 (Either3 a b c) a b c where
  matchEither3 = Just
  {-# INLINE matchEither3 #-}