{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{- | Variant biased towards one type

Variants have types like @V [W,X,Y,Z]@. This is great when all the inner types
play the same role. However in some cases we want one type to be the main one
and the other ones to be secondaries.

For instance we could have @V [Result,ErrorA,ErrorB,ErrorC]@ to represent the
result of a function. In this case, the first type is the main one and it would
be great to be able to define the common type-classes ('Functor', 'Monad',
etc.) so that we have easy access to it.

'VEither' is a 'V' wrapper that does exactly this:

> newtype VEither es a = VEither (V (a : es))

It is isomorphic to @Either (V es) a@. The difference is in the runtime
representation: @VEither es a@ has one less indirection than @Either (V es) a@
(it uses only one tag value).

== Pattern matching (VRight and VLeft)

'VEither' values can be created and matched on with the 'VRight' and 'VLeft'
patterns (just as if we had the @Either (V es) a@ type).

> >>> VRight True :: VEither [String,Int] Bool
> VRight True
>
> >>> VLeft (V "failed" :: V [String,Int]) :: VEither [String,Int] Bool
> VLeft "failed"

== Common instances

The main advantage of @VEither es a@ over @V (a ': es)@ is that we can define
instances for common type-classes such as 'Functor', 'Applicative', 'Monad',
'Foldable', etc.:

> > let x = VRight True :: VEither [Int,Float] Bool
> > fmap (\b -> if b then "Success" else "Failure") x
> VRight "Success"
>
> > let x = VRight True  :: VEither [Int,Float] Bool
> > let y = VRight False :: VEither [Int,Float] Bool
> > (&&) \<$> x \<*> y
> VRight False
>
> > let x   = VRight True    :: VEither [Int,Float] Bool
> > let f v = VRight (not v) :: VEither [Int,Float] Bool
> > x >>= f
> VRight False
>
> > let x = VRight True :: VEither [Int,Float] Bool
> > let y = VLeft (V "failed" :: V [String,Int]) :: VEither [String,Int] Bool
> > forM_ x print
> True
> > forM_ y print

== See also

* "Data.Variant.Excepts" — multi-exception monad transformer wrapping 'VEither'
* "Data.Variant" — the underlying 'V' type

-}
module Data.Variant.VEither
   ( VEither
   , pattern VLeft
   , pattern VRight
   , veitherFromVariant
   , veitherToVariant
   , veitherToValue
   , veitherBimap
   , VEitherLift
   , veitherLift
   , veitherAppend
   , veitherPrepend
   , veitherCont
   , veitherToEither
   , veitherProduct
   , module Data.Variant
   )
where

import Data.Variant
import Data.Variant.Types

import Data.Coerce
import GHC.TypeLits

-- $setup
-- >>> :seti -XDataKinds
-- >>> :seti -XTypeApplications
-- >>> :seti -XFlexibleContexts
-- >>> :seti -XTypeFamilies
-- >>> import Data.Foldable


-- | Variant biased towards one type
newtype VEither es a
   = VEither (V (a ': es))


----------------------
-- Patterns
----------------------

-- | Left value
--
-- >>> VLeft (V "failed" :: V [String,Int]) :: VEither [String,Int] Bool
-- VLeft "failed"
--
pattern VLeft :: forall x xs. V xs -> VEither xs x
pattern $mVLeft :: forall {r} {x} {xs :: [*]}.
VEither xs x -> (V xs -> r) -> ((# #) -> r) -> r
$bVLeft :: forall x (xs :: [*]). V xs -> VEither xs x
VLeft xs <- ((popVariantHead . veitherToVariant) -> Left xs)
   where
      VLeft V xs
xs = V (x : xs) -> VEither xs x
forall (es :: [*]) a. V (a : es) -> VEither es a
VEither (V xs -> V (x : xs)
forall x (xs :: [*]). V xs -> V (x : xs)
toVariantTail V xs
xs)

-- | Right value
--
-- >>> VRight True :: VEither [String,Int] Bool
-- VRight True
pattern VRight :: forall x xs. x -> VEither xs x
pattern $mVRight :: forall {r} {x} {xs :: [*]}.
VEither xs x -> (x -> r) -> ((# #) -> r) -> r
$bVRight :: forall x (xs :: [*]). x -> VEither xs x
VRight x <- ((popVariantHead . veitherToVariant) -> Right x)
   where
      VRight x
x = V (x : xs) -> VEither xs x
forall (es :: [*]) a. V (a : es) -> VEither es a
VEither (x -> V (x : xs)
forall x (xs :: [*]). x -> V (x : xs)
toVariantHead x
x)

{-# COMPLETE VLeft,VRight #-}

----------------------
-- Eq instance
----------------------

-- | Check VEithers for equality
--
-- >>> let a = VRight "Foo" :: VEither [Int,Double] String
-- >>> let b = VRight "Foo" :: VEither [Int,Double] String
-- >>> let c = VRight "Bar" :: VEither [Int,Double] String
-- >>> let d = VLeft (V (1::Int) :: V [Int, Double]) :: VEither [Int,Double] String
-- >>> a == b
-- True
-- >>> a == c
-- False
-- >>> a == d
-- False
--
deriving newtype instance (Eq (V (a ': es))) => Eq (VEither es a)


----------------------
-- Ord instance
----------------------

-- | Compare VEithers
--
-- >>> let a = VRight "Foo" :: VEither [Int,Double] String
-- >>> let b = VRight "Bar" :: VEither [Int,Double] String
-- >>> a < b
-- False
-- >>> a > b
-- True
--
deriving newtype instance (Ord (V (a ': es))) => Ord (VEither es a)


----------------------
-- Show instance
----------------------

instance
   ( Show a
   , Show (V es)
   ) => Show (VEither es a) where
   showsPrec :: Int -> VEither es a -> ShowS
showsPrec Int
d VEither es a
v = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ case VEither es a
v of
      VLeft V es
xs -> String -> ShowS
showString String
"VLeft "
                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> V es -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
10 V es
xs
      VRight a
x -> String -> ShowS
showString String
"VRight "
                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
10 a
x


-- | Convert a Variant into a VEither
--
-- >>> let x = V "Test" :: V [Int,String,Double]
-- >>> veitherFromVariant x
-- VLeft "Test"
--
veitherFromVariant :: V (a ': es) -> VEither es a
{-# INLINABLE veitherFromVariant #-}
veitherFromVariant :: forall a (es :: [*]). V (a : es) -> VEither es a
veitherFromVariant = V (a : es) -> VEither es a
forall (es :: [*]) a. V (a : es) -> VEither es a
VEither

-- | Convert a VEither into a Variant
--
-- >>> let x = VRight True :: VEither [Int,Float] Bool
-- >>> veitherToVariant x
-- True
--
veitherToVariant :: VEither es a -> V (a ': es)
{-# INLINABLE veitherToVariant #-}
veitherToVariant :: forall (es :: [*]) a. VEither es a -> V (a : es)
veitherToVariant (VEither V (a : es)
x) = V (a : es)
x

-- | Convert a VEither into an Either
--
-- >>> let x = VRight True :: VEither [Int,Float] Bool
-- >>> veitherToEither x
-- Right True
--
veitherToEither :: VEither es a -> Either (V es) a
{-# INLINABLE veitherToEither #-}
veitherToEither :: forall (es :: [*]) a. VEither es a -> Either (V es) a
veitherToEither = \case
   VLeft V es
xs -> V es -> Either (V es) a
forall a b. a -> Either a b
Left V es
xs
   VRight a
x -> a -> Either (V es) a
forall a b. b -> Either a b
Right a
x

-- | Extract from a VEither without left types
--
-- >>> let x = VRight True :: VEither '[] Bool
-- >>> veitherToValue x
-- True
veitherToValue :: forall a. VEither '[] a -> a
{-# INLINABLE veitherToValue #-}
veitherToValue :: forall a. VEither '[] a -> a
veitherToValue = (V '[a] -> a) -> VEither '[] a -> a
forall a b. Coercible a b => a -> b
coerce (forall a. V '[a] -> a
variantToValue @a)

-- | Bimap for VEither
--
-- >>> let x = VRight True :: VEither [Int,Float] Bool
-- >>> veitherBimap id not x
-- VRight False
--
veitherBimap :: (V es -> V fs) -> (a -> b) ->  VEither es a -> VEither fs b
{-# INLINABLE veitherBimap #-}
veitherBimap :: forall (es :: [*]) (fs :: [*]) a b.
(V es -> V fs) -> (a -> b) -> VEither es a -> VEither fs b
veitherBimap V es -> V fs
f a -> b
g VEither es a
v = case VEither es a
v of
   VLeft V es
xs -> V fs -> VEither fs b
forall x (xs :: [*]). V xs -> VEither xs x
VLeft (V es -> V fs
f V es
xs)
   VRight a
x -> b -> VEither fs b
forall x (xs :: [*]). x -> VEither xs x
VRight (a -> b
g a
x)


type VEitherLift es es' =
   ( LiftVariant es es'
   )

-- | Lift a VEither into another
veitherLift :: forall es' es a.
   ( VEitherLift es es'
   ) => VEither es a -> VEither es' a
{-# INLINABLE veitherLift #-}
veitherLift :: forall (es' :: [*]) (es :: [*]) a.
VEitherLift es es' =>
VEither es a -> VEither es' a
veitherLift = (V es -> V es') -> (a -> a) -> VEither es a -> VEither es' a
forall (es :: [*]) (fs :: [*]) a b.
(V es -> V fs) -> (a -> b) -> VEither es a -> VEither fs b
veitherBimap V es -> V es'
forall (ys :: [*]) (xs :: [*]). LiftVariant xs ys => V xs -> V ys
liftVariant a -> a
forall a. a -> a
id

-- | Prepend errors to VEither
veitherPrepend :: forall ns es a.
   ( KnownNat (Length ns)
   ) => VEither es a -> VEither (Concat ns es) a
{-# INLINABLE veitherPrepend #-}
veitherPrepend :: forall (ns :: [*]) (es :: [*]) a.
KnownNat (Length ns) =>
VEither es a -> VEither (Concat ns es) a
veitherPrepend = (V es -> V (Concat ns es))
-> (a -> a) -> VEither es a -> VEither (Concat ns es) a
forall (es :: [*]) (fs :: [*]) a b.
(V es -> V fs) -> (a -> b) -> VEither es a -> VEither fs b
veitherBimap (forall (ys :: [*]) (xs :: [*]).
KnownNat (Length ys) =>
V xs -> V (Concat ys xs)
prependVariant @ns) a -> a
forall a. a -> a
id

-- | Append errors to VEither
veitherAppend :: forall ns es a.
   VEither es a -> VEither (Concat es ns) a
{-# INLINABLE veitherAppend #-}
veitherAppend :: forall (ns :: [*]) (es :: [*]) a.
VEither es a -> VEither (Concat es ns) a
veitherAppend = (V es -> V (Concat es ns))
-> (a -> a) -> VEither es a -> VEither (Concat es ns) a
forall (es :: [*]) (fs :: [*]) a b.
(V es -> V fs) -> (a -> b) -> VEither es a -> VEither fs b
veitherBimap (forall (ys :: [*]) (xs :: [*]). V xs -> V (Concat xs ys)
appendVariant @ns) a -> a
forall a. a -> a
id

-- | VEither continuations
veitherCont :: (V es -> u) -> (a -> u) -> VEither es a -> u
{-# INLINABLE veitherCont #-}
veitherCont :: forall (es :: [*]) u a.
(V es -> u) -> (a -> u) -> VEither es a -> u
veitherCont V es -> u
f a -> u
g VEither es a
v = case VEither es a
v of
   VLeft V es
xs -> V es -> u
f V es
xs
   VRight a
x -> a -> u
g a
x

-- | Product of two VEither
veitherProduct :: KnownNat (Length (b:e2)) => VEither e1 a -> VEither e2 b -> VEither (Tail (Product (a:e1) (b:e2))) (a,b)
veitherProduct :: forall b (e2 :: [*]) (e1 :: [*]) a.
KnownNat (Length (b : e2)) =>
VEither e1 a
-> VEither e2 b
-> VEither (Tail (Product (a : e1) (b : e2))) (a, b)
veitherProduct (VEither V (a : e1)
x) (VEither V (b : e2)
y) = V ((a, b) : Concat (Product' a e2) (Product e1 (b : e2)))
-> VEither (Concat (Product' a e2) (Product e1 (b : e2))) (a, b)
forall (es :: [*]) a. V (a : es) -> VEither es a
VEither (V (a : e1) -> V (b : e2) -> V (Product (a : e1) (b : e2))
forall (xs :: [*]) (ys :: [*]).
KnownNat (Length ys) =>
V xs -> V ys -> V (Product xs ys)
productVariant V (a : e1)
x V (b : e2)
y)

-- | Functor instance for VEither
--
-- >>> let x = VRight True :: VEither [Int,Float] Bool
-- >>> fmap (\b -> if b then "Success" else "Failure") x
-- VRight "Success"
--
instance Functor (VEither es) where
   {-# INLINABLE fmap #-}
   fmap :: forall a b. (a -> b) -> VEither es a -> VEither es b
fmap a -> b
f (VEither V (a : es)
v) = V (b : es) -> VEither es b
forall (es :: [*]) a. V (a : es) -> VEither es a
VEither (forall (n :: Nat) a b (l :: [*]).
(KnownNat n, a ~ Index n l) =>
(a -> b) -> V l -> V (ReplaceN n b l)
mapVariantAt @0 a -> b
f V (a : es)
v)

-- | Applicative instance for VEither
--
-- >>> let x = VRight True  :: VEither [Int,Float] Bool
-- >>> let y = VRight False :: VEither [Int,Float] Bool
-- >>> (&&) <$> x <*> y
-- VRight False
-- >>> (||) <$> x <*> y
-- VRight True
--
instance Applicative (VEither es) where
   pure :: forall a. a -> VEither es a
pure = a -> VEither es a
forall x (xs :: [*]). x -> VEither xs x
VRight

   VRight a -> b
f <*> :: forall a b. VEither es (a -> b) -> VEither es a -> VEither es b
<*> VRight a
a = b -> VEither es b
forall x (xs :: [*]). x -> VEither xs x
VRight (a -> b
f a
a)
   VLeft V es
v  <*> VEither es a
_        = V es -> VEither es b
forall x (xs :: [*]). V xs -> VEither xs x
VLeft V es
v
   VEither es (a -> b)
_        <*> VLeft V es
v  = V es -> VEither es b
forall x (xs :: [*]). V xs -> VEither xs x
VLeft V es
v

-- | Monad instance for VEither
--
-- >>> let x   = VRight True    :: VEither [Int,Float] Bool
-- >>> let f v = VRight (not v) :: VEither [Int,Float] Bool
-- >>> x >>= f
-- VRight False
--
instance Monad (VEither es) where
   VRight a
a >>= :: forall a b. VEither es a -> (a -> VEither es b) -> VEither es b
>>= a -> VEither es b
f = a -> VEither es b
f a
a
   VLeft V es
v  >>= a -> VEither es b
_ = V es -> VEither es b
forall x (xs :: [*]). V xs -> VEither xs x
VLeft V es
v

-- | Foldable instance for VEither
--
-- >>> let x   = VRight True    :: VEither [Int,Float] Bool
-- >>> let y   = VLeft (V "failed" :: V [String,Int]) :: VEither [String,Int] Bool
-- >>> forM_ x print
-- True
-- >>> forM_ y print
--
instance Foldable (VEither es) where
   foldMap :: forall m a. Monoid m => (a -> m) -> VEither es a -> m
foldMap a -> m
f (VRight a
a) = a -> m
f a
a
   foldMap a -> m
_ (VLeft V es
_)  = m
forall a. Monoid a => a
mempty

instance Traversable (VEither es) where
   traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> VEither es a -> f (VEither es b)
traverse a -> f b
f (VRight a
a) = b -> VEither es b
forall x (xs :: [*]). x -> VEither xs x
VRight (b -> VEither es b) -> f b -> f (VEither es b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
   traverse a -> f b
_ (VLeft V es
xs) = VEither es b -> f (VEither es b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (V es -> VEither es b
forall x (xs :: [*]). V xs -> VEither xs x
VLeft V es
xs)