VEither.hs

{-# 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 VLeft xs <- ((popVariantHead . veitherToVariant) -> Left xs)
   where
      VLeft xs = VEither (toVariantTail xs)

-- | Right value
--
-- >>> VRight True :: VEither [String,Int] Bool
-- VRight True
pattern VRight :: forall x xs. x -> VEither xs x
pattern VRight x <- ((popVariantHead . veitherToVariant) -> Right x)
   where
      VRight x = VEither (toVariantHead 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 d v = showParen (d /= 0) $ case v of
      VLeft xs -> showString "VLeft "
                  . showsPrec 10 xs
      VRight x -> showString "VRight "
                  . showsPrec 10 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 = 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 (VEither x) = 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 = \case
   VLeft xs -> Left xs
   VRight x -> Right 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 = coerce (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 f g v = case v of
   VLeft xs -> VLeft (f xs)
   VRight x -> VRight (g 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 = veitherBimap liftVariant id

-- | Prepend errors to VEither
veitherPrepend :: forall ns es a.
   ( KnownNat (Length ns)
   ) => VEither es a -> VEither (Concat ns es) a
{-# INLINABLE veitherPrepend #-}
veitherPrepend = veitherBimap (prependVariant @ns) id

-- | Append errors to VEither
veitherAppend :: forall ns es a.
   VEither es a -> VEither (Concat es ns) a
{-# INLINABLE veitherAppend #-}
veitherAppend = veitherBimap (appendVariant @ns) id

-- | VEither continuations
veitherCont :: (V es -> u) -> (a -> u) -> VEither es a -> u
{-# INLINABLE veitherCont #-}
veitherCont f g v = case v of
   VLeft xs -> f xs
   VRight x -> g 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 (VEither x) (VEither y) = VEither (productVariant x 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 f (VEither v) = VEither (mapVariantAt @0 f 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 = VRight

   VRight f <*> VRight a = VRight (f a)
   VLeft v  <*> _        = VLeft v
   _        <*> VLeft v  = VLeft 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 >>= f = f a
   VLeft v  >>= _ = VLeft 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 f (VRight a) = f a
   foldMap _ (VLeft _)  = mempty

instance Traversable (VEither es) where
   traverse f (VRight a) = VRight <$> f a
   traverse _ (VLeft xs) = pure (VLeft xs)