{-# 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
--
-- This allows definition of common type classes (Functor, etc.) that can't  be
-- provided for Variant
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)