Variant.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 #-}

-- | Open sum type
module Haskus.Utils.Variant
   ( Variant
   , V
   , variantIndex
   -- * Patterns
   , pattern V
   , pattern VMaybe
   , (:<)
   , (:<?)
   -- * Operations by index
   , toVariantAt
   , toVariantHead
   , toVariantTail
   , fromVariantAt
   , popVariantAt
   , popVariantHead
   , updateVariantAt
   , foldMapVariantAt
   , foldMapVariantAtM
   -- * Operations by type
   , toVariant
   , Member
   , Filter
   , Popable
   , MaybePopable
   , popVariant
   , popVariantMaybe
   , fromVariant
   , fromVariantMaybe
   , fromVariantFirst
   , updateVariantFirst
   , updateVariantFirstM
   , MappableVariant
   , mapVariant
   , foldMapVariantFirst
   , foldMapVariantFirstM
   , foldMapVariant
   -- * Generic operations with type classes
   , AlterVariant
   , TraverseVariant
   , NoConstraint
   , alterVariant
   , traverseVariant
   , traverseVariant_
   -- * Conversions between variants
   , appendVariant
   , prependVariant
   , Liftable
   , liftVariant
   , nubVariant
   , productVariant
   , FlattenVariant
   , flattenVariant
   , ExtractMonad
   , joinVariant
   -- * Conversions to/from other data types
   , variantToValue
   , variantFromValue
   , variantToEither
   , variantFromEither
   , variantToHList
   , variantToTuple
   -- ** Continuations
   , ContVariant (..)
   , (>:>)
   , (>:^>)
   , (>#>)
   , (>#^>)
   , LiftCont (..)
   , ExtractRHS
   , ReplaceRHS
   , LiftContTuple
   -- ** Internals
   , pattern V'
   , liftVariant'
   , fromVariant'
   , popVariant'
   , toVariant'
   , LiftVariant
   , PopVariant
   )
where

import Unsafe.Coerce
import GHC.Exts (Any,Constraint)

import Haskus.Utils.Monad
import Haskus.Utils.Types
import Haskus.Utils.Tuple
import Haskus.Utils.HList
import Haskus.Utils.ContFlow
import Haskus.Utils.Types.List

-- | A variant contains a value whose type is at the given position in the type
-- list
data Variant (l :: [*]) = Variant {-# UNPACK #-} !Word Any

type V = Variant

-- Make GHC consider `l` as a representational parameter to make coercions
-- between Variant values unsafe
type role Variant representational

-- | Pattern synonym for Variant
--
-- Usage: case v of
--          V (x :: Int)    -> ...
--          V (x :: String) -> ...
pattern V :: forall c cs. Popable c cs => c -> Variant cs
pattern V x <- (fromVariant -> Just x)
   where
      V x = toVariant x

-- | Silent pattern synonym for Variant
--
-- Usage: case v of
--          V (x :: Int)    -> ...
--          V (x :: String) -> ...
pattern V' :: forall c cs.
   ( Member' c cs
   , PopVariant c cs
   ) => c -> Variant cs
pattern V' x <- (fromVariant' -> Just x)
   where
      V' x = toVariant' x

-- | Statically unchecked matching on a Variant
pattern VMaybe :: forall c cs. (MaybePopable c cs) => c -> Variant cs
pattern VMaybe x <- (fromVariantMaybe -> Just x)

instance Eq (Variant '[]) where
   (==) = error "Empty variant"

instance
   ( Eq (Variant xs)
   , Eq x
   ) => Eq (Variant (x ': xs))
   where
      {-# INLINE (==) #-}
      (==) v1@(Variant t1 _) v2@(Variant t2 _)
         | t1 /= t2  = False
         | otherwise = case (popVariantHead v1, popVariantHead v2) of
            (Right a, Right b) -> a == b
            (Left as, Left bs) -> as == bs
            _                  -> False

instance Ord (Variant '[]) where
   compare = error "Empty variant"

instance
   ( Ord (Variant xs)
   , Ord x
   ) => Ord (Variant (x ': xs))
   where
      compare v1 v2 = case (popVariantHead v1, popVariantHead v2) of
         (Right a, Right b) -> compare a b
         (Left as, Left bs) -> compare as bs
         (Right _, Left _)  -> LT
         (Left _, Right _)  -> GT

instance Show (Variant '[]) where
   show = error "Empty variant"

instance
   ( Show (Variant xs)
   , Show x
   ) => Show (Variant (x ': xs))
   where
      show v = case popVariantHead v of
         Right x -> show x
         Left xs -> show xs

-----------------------------------------------------------
-- Operations by index
-----------------------------------------------------------

-- | Get Variant index
variantIndex :: Variant a -> Word
variantIndex (Variant n _) = n

-- | Set the value with the given indexed type
toVariantAt :: forall (n :: Nat) (l :: [*]).
   ( KnownNat n
   ) => Index n l -> Variant l
{-# INLINE toVariantAt #-}
toVariantAt a = Variant (natValue' @n) (unsafeCoerce a)

-- | Set the first value
toVariantHead :: forall x xs. x -> Variant (x ': xs)
{-# INLINE toVariantHead #-}
toVariantHead a = Variant 0 (unsafeCoerce a)

-- | Set the tail
toVariantTail :: forall x xs. Variant xs -> Variant (x ': xs)
{-# INLINE toVariantTail #-}
toVariantTail (Variant t a) = Variant (t+1) a

-- | Get the value if it has the indexed type
fromVariantAt :: forall (n :: Nat) (l :: [*]).
   ( KnownNat n
   ) => Variant l -> Maybe (Index n l)
{-# INLINE fromVariantAt #-}
fromVariantAt (Variant t a) = do
   guard (t == natValue' @n)
   return (unsafeCoerce a) -- we know it is the effective type

-- | Pop a variant value by index, return either the value or the remaining
-- variant
popVariantAt :: forall (n :: Nat) l. 
   ( KnownNat n
   ) => Variant l -> Either (Variant (RemoveAt n l)) (Index n l)
{-# INLINE popVariantAt #-}
popVariantAt v@(Variant t a) = case fromVariantAt @n v of
   Just x  -> Right x
   Nothing -> Left $ if t > natValue' @n
      then Variant (t-1) a
      else Variant t a

-- | Pop the head of a variant value
popVariantHead :: forall x xs. Variant (x ': xs) -> Either (Variant xs) x
{-# INLINE popVariantHead #-}
popVariantHead v@(Variant t a) = case fromVariantAt @0 v of
   Just x  -> Right x
   Nothing -> Left $ Variant (t-1) a

-- | Update a variant value
updateVariantAt :: forall (n :: Nat) a b l.
   ( KnownNat n
   , a ~ Index n l
   ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l)
{-# INLINE updateVariantAt #-}
updateVariantAt f v@(Variant t a) =
   case fromVariantAt @n v of
      Nothing -> Variant t a
      Just x  -> Variant t (unsafeCoerce (f x))

-----------------------------------------------------------
-- Operations by type
-----------------------------------------------------------

-- | Put a value into a Variant
--
-- Use the first matching type index.
toVariant :: forall a l.
   ( Member a l
   ) => a -> Variant l
{-# INLINE toVariant #-}
toVariant = toVariantAt @(IndexOf a l)

-- | Put a value into a Variant (silent)
--
-- Use the first matching type index.
toVariant' :: forall a l.
   ( Member' a l
   ) => a -> Variant l
{-# INLINE toVariant' #-}
toVariant' = toVariantAt @(IndexOf a l)

class PopVariant a xs where
   -- | Remove a type from a variant
   popVariant' :: Variant xs -> Either (Variant (Filter a xs)) a

instance PopVariant a '[] where
   popVariant' _ = undefined

instance forall a xs n xs' y ys.
      ( PopVariant a xs'
      , n ~ MaybeIndexOf a xs
      , xs' ~ RemoveAt1 n xs
      , Filter a xs' ~ Filter a xs
      , KnownNat n
      , xs ~ (y ': ys)
      ) => PopVariant a (y ': ys)
   where
      {-# INLINE popVariant' #-}
      popVariant' (Variant t a)
         = case natValue' @n of
            0             -> Left (Variant t a) -- no 'a' left in xs
            n | n-1 == t  -> Right (unsafeCoerce a)
              | n-1 < t   -> popVariant' @a @xs' (Variant (t-1) a)
              | otherwise -> Left (Variant t a)

-- | a is popable in xs
type Popable a xs =
   ( Member a xs
   , PopVariant a xs
   )

-- | a may be popable in xs
type MaybePopable a xs =
   ( PopVariant a xs
   )

type (:<) a xs  = Popable a xs
type (:<?) a xs = MaybePopable a xs


-- | Extract a type from a variant. Return either the value of this type or the
-- remaining variant
popVariant :: forall a xs.
   ( Popable a xs
   ) => Variant xs -> Either (Variant (Filter a xs)) a
popVariant v = popVariant' @a v

-- | Extract a type from a variant. Return either the value of this type or the
-- remaining variant
popVariantMaybe :: forall a xs.
   ( MaybePopable a xs
   ) => Variant xs -> Either (Variant (Filter a xs)) a
popVariantMaybe v = popVariant' @a v

-- | Pick the first matching type of a Variant
--
-- fromVariantFirst @A (Variant 2 undefined :: Variant '[A,B,A]) == Nothing
fromVariantFirst :: forall a l.
   ( Member a l
   ) => Variant l -> Maybe a
{-# INLINE fromVariantFirst #-}
fromVariantFirst = fromVariantAt @(IndexOf a l)

-- | Try to a get a value of a given type from a Variant
fromVariant :: forall a xs.
   ( Popable a xs
   ) => Variant xs -> Maybe a
{-# INLINE fromVariant #-}
fromVariant v = case popVariant v of
   Right a -> Just a
   Left _  -> Nothing

-- | Try to a get a value of a given type from a Variant (silent)
fromVariant' :: forall a xs.
   ( PopVariant a xs
   ) => Variant xs -> Maybe a
{-# INLINE fromVariant' #-}
fromVariant' v = case popVariant' v of
   Right a -> Just a
   Left _  -> Nothing

-- | Try to a get a value of a given type from a Variant that may not even
-- support the given type.
fromVariantMaybe :: forall a xs.
   ( MaybePopable a xs
   ) => Variant xs -> Maybe a
{-# INLINE fromVariantMaybe #-}
fromVariantMaybe v = case popVariantMaybe v of
   Right a -> Just a
   Left _  -> Nothing

-- | Update a variant value
updateVariantFirst :: forall a b n l.
   ( Member a l
   , n ~ IndexOf a l
   ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l)
{-# INLINE updateVariantFirst #-}
updateVariantFirst f v = updateVariantAt @n f v

-- | Monadic update of the first matching variant value
updateVariantFirstM :: forall (n :: Nat) l l2 m .
   (KnownNat n, Monad m)
   => (Index n l -> m (Index n l2)) -> Variant l -> m (Variant l2)
{-# INLINE updateVariantFirstM #-}
updateVariantFirstM f v@(Variant t a) =
   case fromVariantAt @n v of
      Nothing -> return (Variant t a)
      Just x  -> Variant t <$> unsafeCoerce (f x)

class MapVariant a b cs (is :: [Nat]) where
   mapVariant' :: (a -> b) -> Variant cs -> Variant (ReplaceNS is b cs)

instance MapVariant a b '[] is where
   {-# INLINE mapVariant' #-}
   mapVariant' = undefined

instance MapVariant a b cs '[] where
   {-# INLINE mapVariant' #-}
   mapVariant' _ v = v

instance forall a b cs is i.
   ( MapVariant a b (ReplaceN i b cs) is
   , a ~ Index i cs
   , KnownNat i
   ) => MapVariant a b cs (i ': is) where
   {-# INLINE mapVariant' #-}
   mapVariant' f v = mapVariant' @a @b @(ReplaceN i b cs) @is f (updateVariantAt @i f v)

type MappableVariant a b cs =
   ( MapVariant a b cs (IndexesOf a cs)
   )

-- | Map the matching types of a variant
mapVariant :: forall a b cs.
   ( MappableVariant a b cs
   ) => (a -> b) -> Variant cs -> Variant (ReplaceNS (IndexesOf a cs) b cs)
mapVariant = mapVariant' @a @b @cs @(IndexesOf a cs)


-- | Update a variant value with a variant and fold the result
foldMapVariantAt :: forall (n :: Nat) l l2 .
   ( KnownNat n
   , KnownNat (Length l2)
   ) => (Index n l -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2)
foldMapVariantAt f v@(Variant t a) =
   case fromVariantAt @n v of
      Nothing ->
         -- we need to adapt the tag if new valid tags (from l2) are added before
         if t < n
            then Variant t a
            else Variant (t+nl2-1) a

      Just x  -> case f x of
         Variant t2 a2 -> Variant (t2+n) a2
   where
      n   = natValue' @n
      nl2 = natValue' @(Length l2)

-- | Update a variant value with a variant and fold the result
foldMapVariantAtM :: forall (n :: Nat) m l l2.
   ( KnownNat n
   , KnownNat (Length l2)
   , Monad m
   ) => (Index n l -> m (Variant l2)) -> Variant l -> m (Variant (ReplaceAt n l l2))
foldMapVariantAtM f v@(Variant t a) =
   case fromVariantAt @n v of
      Nothing ->
         -- we need to adapt the tag if new valid tags (from l2) are added before
         return $ if t < n
            then Variant t a
            else Variant (t+nl2-1) a

      Just x  -> do
         y <- f x
         case y of
            Variant t2 a2 -> return (Variant (t2+n) a2)
   where
      n   = natValue' @n
      nl2 = natValue' @(Length l2)

-- | Update a variant value with a variant and fold the result
foldMapVariantFirst :: forall a (n :: Nat) l l2 .
   ( KnownNat n
   , KnownNat (Length l2)
   , n ~ IndexOf a l
   , a ~ Index n l
   ) => (a -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2)
foldMapVariantFirst f v = foldMapVariantAt @n f v

-- | Update a variant value with a variant and fold the result
foldMapVariantFirstM :: forall a (n :: Nat) l l2 m.
   ( KnownNat n
   , KnownNat (Length l2)
   , n ~ IndexOf a l
   , a ~ Index n l
   , Monad m
   ) => (a -> m (V l2)) -> V l -> m (V (ReplaceAt n l l2))
foldMapVariantFirstM f v = foldMapVariantAtM @n f v



-- | Update a variant value with a variant and fold the result
foldMapVariant :: forall a cs ds i.
   ( i ~ IndexOf a cs
   , Popable a cs
   ) => (a -> V ds) -> V cs -> V (InsertAt i (Filter a cs) ds)
foldMapVariant f v = case popVariant v of
   Right a -> case f a of
      Variant t x -> Variant (i + t) x
   Left (Variant t x)
      | t < i     -> Variant t x
      | otherwise -> Variant (i+t) x
   where
      i = natValue' @i




-----------------------------------------------------------
-- Generic operations with type classes
-----------------------------------------------------------

class AlterVariant c (b :: [*]) where
   alterVariant' :: Alter c -> Word -> Any -> Any

instance AlterVariant c '[] where
   {-# INLINE alterVariant' #-}
   alterVariant' = undefined

instance
   ( AlterVariant c xs
   , c x
   ) => AlterVariant c (x ': xs)
   where
      {-# INLINE alterVariant' #-}
      alterVariant' m@(Alter f) t v =
         case t of
            0 -> unsafeCoerce (f (unsafeCoerce v :: x))
            n -> alterVariant' @c @xs m (n-1) v

-- | Wrap a function and its constraints
data Alter (c :: * -> Constraint) = Alter (forall a. c a => a -> a)

-- | Wrap a function and its constraints
data AlterM (c :: * -> Constraint) m = AlterM (forall a. (Monad m, c a) => a -> m a)

-- | Useful to specify a "* -> Constraint" function returning no constraint
class NoConstraint a
instance NoConstraint a

class TraverseVariant c (b :: [*]) m where
   traverseVariant' :: AlterM c m -> Word -> Any -> m Any

instance TraverseVariant c '[] m where
   {-# INLINE traverseVariant' #-}
   traverseVariant' = undefined

instance
   ( TraverseVariant c xs m
   , c x
   , Monad m
   ) => TraverseVariant c (x ': xs) m
   where
      {-# INLINE traverseVariant' #-}
      traverseVariant' m@(AlterM f) t v =
         case t of
            0 -> unsafeCoerce <$> f (unsafeCoerce v :: x)
            n -> traverseVariant' @c @xs m (n-1) v


-- | Alter a variant. You need to specify the constraints required by the
-- modifying function.
--
-- Usage:
--    alterVariant @NoConstraint id         v
--    alterVariant @Resizable    (resize 4) v
--
--    class (Ord a, Num a) => OrdNum a
--    instance (Ord a, Num a) => OrdNum a
--
{-# INLINE alterVariant #-}
alterVariant :: forall c (a :: [*]).
   ( AlterVariant c a
   ) => (forall x. c x => x -> x) -> Variant a  -> Variant a
alterVariant f (Variant t a) = 
   Variant t (alterVariant' @c @a (Alter @c f) t a)

-- | Traverse a variant. You need to specify the constraints required by the
-- modifying function.
{-# INLINE traverseVariant #-}
traverseVariant :: forall c (a :: [*]) m.
   ( TraverseVariant c a m
   , Monad m
   ) => (forall x. c x => x -> m x) -> Variant a  -> m (Variant a)
traverseVariant f (Variant t a) = 
   Variant t <$> traverseVariant' @c @a (AlterM @c @m f) t a

-- | Traverse a variant. You need to specify the constraints required by the
-- modifying function.
traverseVariant_ :: forall c (a :: [*]) m.
   ( TraverseVariant c a m
   , Monad m
   ) => (forall x. c x => x -> m ()) -> Variant a  -> m ()
traverseVariant_ f v = void (traverseVariant @c @a f' v)
   where
      f' :: forall x. c x => x -> m x
      f' x = f x >> return x

-----------------------------------------------------------
-- Conversions between variants
-----------------------------------------------------------

-- | Extend a variant by appending other possible values
appendVariant :: forall (ys :: [*]) (xs :: [*]). Variant xs -> Variant (Concat xs ys)
{-# INLINE appendVariant #-}
appendVariant (Variant t a) = Variant t a

-- | Extend a variant by prepending other possible values
prependVariant :: forall (ys :: [*]) (xs :: [*]).
   ( KnownNat (Length ys)
   ) => Variant xs -> Variant (Concat ys xs)
{-# INLINE prependVariant #-}
prependVariant (Variant t a) = Variant (n+t) a
   where
      n = natValue' @(Length ys)

-- | xs is liftable in ys
type Liftable xs ys =
   ( IsSubset xs ys ~ 'True
   , LiftVariant xs ys
   )

class LiftVariant xs ys where
   liftVariant' :: Variant xs -> Variant ys

instance LiftVariant '[] ys where
   liftVariant' = error "Lifting empty variant"

instance forall xs ys x.
      ( LiftVariant xs ys
      , KnownNat (IndexOf x ys)
      ) => LiftVariant (x ': xs) ys
   where
      {-# INLINE liftVariant' #-}
      liftVariant' (Variant t a)
         | t == 0    = Variant (natValue' @(IndexOf x ys)) a
         | otherwise = liftVariant' @xs (Variant (t-1) a)


-- | Lift a variant into another
--
-- Set values to the first matching type
liftVariant :: forall xs ys.
   ( Liftable xs ys
   ) => Variant xs -> Variant ys
{-# INLINE liftVariant #-}
liftVariant = liftVariant'

-- | Nub the type list
nubVariant :: (Liftable xs (Nub xs)) => V xs -> V (Nub xs)
nubVariant = liftVariant

-- | Product of two variants
productVariant :: forall xs ys.
   ( KnownNat (Length ys)
   ) => Variant xs -> Variant ys -> Variant (Product xs ys)
productVariant (Variant n1 a1) (Variant n2 a2)
   = Variant (n1 * natValue @(Length ys) + n2) (unsafeCoerce (a1,a2))

type family FlattenVariant (xs :: [*]) :: [*] where
   FlattenVariant '[]             = '[]
   FlattenVariant (Variant xs:ys) = Concat xs (FlattenVariant ys)
   FlattenVariant (y:ys)          = y ': FlattenVariant ys

class Flattenable a rs where
   toFlattenVariant :: Word -> a -> rs

instance Flattenable (Variant '[]) rs where
   {-# INLINE toFlattenVariant #-}
   toFlattenVariant _ _ = undefined

instance forall xs ys rs.
   ( Flattenable (Variant ys) (Variant rs)
   , KnownNat (Length xs)
   ) => Flattenable (Variant (Variant xs ': ys)) (Variant rs)
   where
   {-# INLINE toFlattenVariant #-}
   toFlattenVariant i v = case popVariantHead v of
      Right (Variant n a) -> Variant (i+n) a
      Left vys            -> toFlattenVariant (i+natValue @(Length xs)) vys

-- | Flatten variants in a variant
flattenVariant :: forall xs.
   ( Flattenable (Variant xs) (Variant (FlattenVariant xs))
   ) => Variant xs -> Variant (FlattenVariant xs)
flattenVariant v = toFlattenVariant 0 v

type family ExtractMonad m f where
   ExtractMonad m '[m x]      = '[x]
   ExtractMonad m (m x ': xs) = x ': ExtractMonad m xs

-- | Join on a variant
--
-- Transform a variant of applicatives as follow:
--    V'[m a, m b, m c] ===> m (V'[a,b,c])
--
joinVariant :: forall m xs ys.
   ( Applicative m
   , ys ~ ExtractMonad m xs
   ) => Variant xs -> m (Variant ys)
joinVariant (Variant t act) = Variant t <$> (unsafeCoerce act :: m Any)

-----------------------------------------------------------
-- Conversions to other data types
-----------------------------------------------------------

-- | Retrieve a single value
variantToValue :: Variant '[a] -> a
{-# INLINE variantToValue #-}
variantToValue (Variant _ a) = unsafeCoerce a

-- | Create a variant from a single value
variantFromValue :: a -> Variant '[a]
{-# INLINE variantFromValue #-}
variantFromValue a = Variant 0 (unsafeCoerce a)


-- | Convert a variant of two values in a Either
variantToEither :: forall a b. Variant '[a,b] -> Either b a
variantToEither (Variant 0 a) = Right (unsafeCoerce a)
variantToEither (Variant _ a) = Left (unsafeCoerce a)

class VariantToHList xs where
   -- | Convert a variant into a HList of Maybes
   variantToHList :: Variant xs -> HList (Map Maybe xs)

instance VariantToHList '[] where
   variantToHList _ = HNil

instance
   ( VariantToHList xs
   ) => VariantToHList (x ': xs)
   where
      variantToHList v@(Variant t a) =
            fromVariantAt @0 v `HCons` variantToHList v'
         where
            v' :: Variant xs
            v' = Variant (t-1) a

-- | Get variant possible values in a tuple of Maybe types
variantToTuple :: forall l t.
   ( VariantToHList l
   , HTuple' (Map Maybe l) t
   ) => Variant l -> t
variantToTuple = hToTuple' . variantToHList


-- | Lift an Either into a Variant (reversed order by convention)
variantFromEither :: Either a b -> Variant '[b,a]
{-# INLINE variantFromEither #-}
variantFromEither (Left a)  = toVariantAt @1 a
variantFromEither (Right b) = toVariantAt @0 b


class ContVariant xs where
   -- | Convert a variant into a multi-continuation
   variantToCont :: Variant xs -> ContFlow xs r

   -- | Convert a variant into a multi-continuation
   variantToContM :: Monad m => m (Variant xs) -> ContFlow xs (m r)

   -- | Convert a multi-continuation into a Variant
   contToVariant :: ContFlow xs (Variant xs) -> Variant xs

   -- | Convert a multi-continuation into a Variant
   contToVariantM :: Monad m => ContFlow xs (m (Variant xs)) -> m (Variant xs)

instance ContVariant '[a] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant _ a) = ContFlow $ \(Single f) ->
      f (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(Single f) -> do
      Variant _ a <- act
      f (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      Single (toVariantAt @0)

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      Single (return . toVariantAt @0)

instance ContVariant '[a,b] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         _ -> f2 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         _ -> f2 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      )

instance ContVariant '[a,b,c] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         _ -> f3 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         _ -> f3 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      )

instance ContVariant '[a,b,c,d] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         _ -> f4 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         _ -> f4 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      )

instance ContVariant '[a,b,c,d,e] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         _ -> f5 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         _ -> f5 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      )

instance ContVariant '[a,b,c,d,e,f] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         _ -> f6 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         _ -> f6 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      , toVariantAt @5
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      , return . toVariantAt @5
      )

instance ContVariant '[a,b,c,d,e,f,g] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         5 -> f6 (unsafeCoerce a)
         _ -> f7 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         5 -> f6 (unsafeCoerce a)
         _ -> f7 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      , toVariantAt @5
      , toVariantAt @6
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      , return . toVariantAt @5
      , return . toVariantAt @6
      )

instance ContVariant '[a,b,c,d,e,f,g,h] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         5 -> f6 (unsafeCoerce a)
         6 -> f7 (unsafeCoerce a)
         _ -> f8 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         5 -> f6 (unsafeCoerce a)
         6 -> f7 (unsafeCoerce a)
         _ -> f8 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      , toVariantAt @5
      , toVariantAt @6
      , toVariantAt @7
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      , return . toVariantAt @5
      , return . toVariantAt @6
      , return . toVariantAt @7
      )

instance ContVariant '[a,b,c,d,e,f,g,h,i] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9) ->
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         5 -> f6 (unsafeCoerce a)
         6 -> f7 (unsafeCoerce a)
         7 -> f8 (unsafeCoerce a)
         _ -> f9 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9) -> do
      Variant t a <- act
      case t of
         0 -> f1 (unsafeCoerce a)
         1 -> f2 (unsafeCoerce a)
         2 -> f3 (unsafeCoerce a)
         3 -> f4 (unsafeCoerce a)
         4 -> f5 (unsafeCoerce a)
         5 -> f6 (unsafeCoerce a)
         6 -> f7 (unsafeCoerce a)
         7 -> f8 (unsafeCoerce a)
         _ -> f9 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      , toVariantAt @5
      , toVariantAt @6
      , toVariantAt @7
      , toVariantAt @8
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      , return . toVariantAt @5
      , return . toVariantAt @6
      , return . toVariantAt @7
      , return . toVariantAt @8
      )

instance ContVariant '[a,b,c,d,e,f,g,h,i,j] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10) ->
      case t of
         0 -> f1  (unsafeCoerce a)
         1 -> f2  (unsafeCoerce a)
         2 -> f3  (unsafeCoerce a)
         3 -> f4  (unsafeCoerce a)
         4 -> f5  (unsafeCoerce a)
         5 -> f6  (unsafeCoerce a)
         6 -> f7  (unsafeCoerce a)
         7 -> f8  (unsafeCoerce a)
         8 -> f9  (unsafeCoerce a)
         _ -> f10 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10) -> do
      Variant t a <- act
      case t of
         0 -> f1  (unsafeCoerce a)
         1 -> f2  (unsafeCoerce a)
         2 -> f3  (unsafeCoerce a)
         3 -> f4  (unsafeCoerce a)
         4 -> f5  (unsafeCoerce a)
         5 -> f6  (unsafeCoerce a)
         6 -> f7  (unsafeCoerce a)
         7 -> f8  (unsafeCoerce a)
         8 -> f9  (unsafeCoerce a)
         _ -> f10 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      , toVariantAt @5
      , toVariantAt @6
      , toVariantAt @7
      , toVariantAt @8
      , toVariantAt @9
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      , return . toVariantAt @5
      , return . toVariantAt @6
      , return . toVariantAt @7
      , return . toVariantAt @8
      , return . toVariantAt @9
      )

instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11) ->
      case t of
         0 -> f1  (unsafeCoerce a)
         1 -> f2  (unsafeCoerce a)
         2 -> f3  (unsafeCoerce a)
         3 -> f4  (unsafeCoerce a)
         4 -> f5  (unsafeCoerce a)
         5 -> f6  (unsafeCoerce a)
         6 -> f7  (unsafeCoerce a)
         7 -> f8  (unsafeCoerce a)
         8 -> f9  (unsafeCoerce a)
         9 -> f10 (unsafeCoerce a)
         _ -> f11 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11) -> do
      Variant t a <- act
      case t of
         0 -> f1  (unsafeCoerce a)
         1 -> f2  (unsafeCoerce a)
         2 -> f3  (unsafeCoerce a)
         3 -> f4  (unsafeCoerce a)
         4 -> f5  (unsafeCoerce a)
         5 -> f6  (unsafeCoerce a)
         6 -> f7  (unsafeCoerce a)
         7 -> f8  (unsafeCoerce a)
         8 -> f9  (unsafeCoerce a)
         9 -> f10 (unsafeCoerce a)
         _ -> f11 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      , toVariantAt @5
      , toVariantAt @6
      , toVariantAt @7
      , toVariantAt @8
      , toVariantAt @9
      , toVariantAt @10
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      , return . toVariantAt @5
      , return . toVariantAt @6
      , return . toVariantAt @7
      , return . toVariantAt @8
      , return . toVariantAt @9
      , return . toVariantAt @10
      )

instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k,l] where
   {-# INLINE variantToCont #-}
   variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12) ->
      case t of
         0  -> f1  (unsafeCoerce a)
         1  -> f2  (unsafeCoerce a)
         2  -> f3  (unsafeCoerce a)
         3  -> f4  (unsafeCoerce a)
         4  -> f5  (unsafeCoerce a)
         5  -> f6  (unsafeCoerce a)
         6  -> f7  (unsafeCoerce a)
         7  -> f8  (unsafeCoerce a)
         8  -> f9  (unsafeCoerce a)
         9  -> f10 (unsafeCoerce a)
         10 -> f11 (unsafeCoerce a)
         _  -> f12 (unsafeCoerce a)

   {-# INLINE variantToContM #-}
   variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12) -> do
      Variant t a <- act
      case t of
         0  -> f1  (unsafeCoerce a)
         1  -> f2  (unsafeCoerce a)
         2  -> f3  (unsafeCoerce a)
         3  -> f4  (unsafeCoerce a)
         4  -> f5  (unsafeCoerce a)
         5  -> f6  (unsafeCoerce a)
         6  -> f7  (unsafeCoerce a)
         7  -> f8  (unsafeCoerce a)
         8  -> f9  (unsafeCoerce a)
         9  -> f10 (unsafeCoerce a)
         10 -> f11 (unsafeCoerce a)
         _  -> f12 (unsafeCoerce a)

   {-# INLINE contToVariant #-}
   contToVariant c = c >::>
      ( toVariantAt @0
      , toVariantAt @1
      , toVariantAt @2
      , toVariantAt @3
      , toVariantAt @4
      , toVariantAt @5
      , toVariantAt @6
      , toVariantAt @7
      , toVariantAt @8
      , toVariantAt @9
      , toVariantAt @10
      , toVariantAt @11
      )

   {-# INLINE contToVariantM #-}
   contToVariantM c = c >::>
      ( return . toVariantAt @0
      , return . toVariantAt @1
      , return . toVariantAt @2
      , return . toVariantAt @3
      , return . toVariantAt @4
      , return . toVariantAt @5
      , return . toVariantAt @6
      , return . toVariantAt @7
      , return . toVariantAt @8
      , return . toVariantAt @9
      , return . toVariantAt @10
      , return . toVariantAt @11
      )


type family ReplaceRHS f v where
   ReplaceRHS '[] _              = '[]
   ReplaceRHS ((x -> _) ': xs) v = (x -> v) ': ReplaceRHS xs v

type family ExtractRHS f where
   ExtractRHS '[]              = '[]
   ExtractRHS ((_ -> x) ': xs) = x ': ExtractRHS xs

type LiftContTuple x = ListToTuple (ReplaceRHS (TupleToList x) (Variant (ExtractRHS (TupleToList x))))

class LiftCont x where
   liftCont :: x -> LiftContTuple x

instance LiftCont (Single (a -> b)) where
   liftCont (Single a) = Single (V . a)

instance LiftCont (a->b,c->d) where
   liftCont (a,b) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      )

instance LiftCont (a->b,c->d,e->f) where
   liftCont (a,b,c) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      , toVariantAt @2 . c
      )

instance LiftCont (a->b,c->d,e->f,g->h) where
   liftCont (a,b,c,d) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      , toVariantAt @2 . c
      , toVariantAt @3 . d
      )

instance LiftCont (a->b,c->d,e->f,g->h,i->j) where
   liftCont (a,b,c,d,e) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      , toVariantAt @2 . c
      , toVariantAt @3 . d
      , toVariantAt @4 . e
      )

instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l) where
   liftCont (a,b,c,d,e,f) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      , toVariantAt @2 . c
      , toVariantAt @3 . d
      , toVariantAt @4 . e
      , toVariantAt @5 . f
      )

instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l,m->n) where
   liftCont (a,b,c,d,e,f,g) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      , toVariantAt @2 . c
      , toVariantAt @3 . d
      , toVariantAt @4 . e
      , toVariantAt @5 . f
      , toVariantAt @6 . g
      )

instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l,m->n,o->p) where
   liftCont (a,b,c,d,e,f,g,h) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      , toVariantAt @2 . c
      , toVariantAt @3 . d
      , toVariantAt @4 . e
      , toVariantAt @5 . f
      , toVariantAt @6 . g
      , toVariantAt @7 . h
      )

instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l,m->n,o->p,q->r) where
   liftCont (a,b,c,d,e,f,g,h,i) =
      ( toVariantAt @0 . a
      , toVariantAt @1 . b
      , toVariantAt @2 . c
      , toVariantAt @3 . d
      , toVariantAt @4 . e
      , toVariantAt @5 . f
      , toVariantAt @6 . g
      , toVariantAt @7 . h
      , toVariantAt @8 . i
      )

-- | Map functions on a variant and produce a resulting variant
--
-- @
--     > (V 'c' :: V '[Char,String]) >:> (ord,map toUpper)
--     V 99 :: V '[Int,String]
--
--     > (V "test" :: V '[Char,String]) >:> (ord,map toUpper)
--     V "TEST" :: V '[Int,String]
--
--     > (V "test" :: V '[Char,String]) >:> (ord,length)
--     V 4 :: V '[Int,Int]
-- @
--
(>:>) :: forall fs xs zs.
   ( LiftCont fs
   , zs ~ ExtractRHS (TupleToList fs)
   , LiftContTuple fs ~ ContListToTuple xs (Variant zs)
   , ContVariant xs
   ) => Variant xs -> fs -> Variant zs
(>:>) v fs = variantToCont v >::> liftCont fs

-- | Applicative version of (>:>)
(>:^>) :: forall m fs xs zs ks.
   ( LiftCont fs
   , zs ~ ExtractRHS (TupleToList fs)
   , LiftContTuple fs ~ ContListToTuple xs (Variant zs)
   , ContVariant xs
   , ks ~ ExtractMonad m zs
   , Applicative m
   ) => Variant xs -> fs -> m (Variant ks)
(>:^>) v fs = joinVariant (v >:> fs)

-- | Map functions returning a variant on a variant and produce a resulting
-- flattened and nub'ed variant
--
-- @
--     mapInt64 :: Int64 -> V '[Int16,Int32,Int64]
--     mapInt64 x
--        | x <= 0xffff     = toVariantAt @0 (fromIntegral x)
--        | x <= 0xffffffff = toVariantAt @1 (fromIntegral x)
--        | otherwise       = toVariantAt @2 x
--     
--     mapInt32 :: Int32 -> V '[Int16,Int32]
--     mapInt32 x
--        | x <= 0xffff     = toVariantAt @0 (fromIntegral x)
--        | otherwise       = toVariantAt @1 x
--     
--     > V @Int64 @'[Int64,Int32] 10 >#> (mapInt64,mapInt32)
--     V 10 :: Variant '[Int16, Int32, Int64]
-- @
--
(>#>) :: forall fs xs zs ys rs.
   ( LiftCont fs
   , zs ~ ExtractRHS (TupleToList fs)
   , LiftContTuple fs ~ ContListToTuple xs (Variant zs)
   , ContVariant xs
   , ys ~ FlattenVariant zs
   , Flattenable (Variant zs) (Variant ys)
   , Liftable ys (Nub ys)
   , rs ~ Nub ys
   ) => Variant xs -> fs -> Variant rs
(>#>) v fs = nubVariant (flattenVariant (v >:> fs))

-- | Applicative version of (>#>)
--
-- @
--    mapInt64 :: Int64 -> IO (V '[Int16,Int32,Int64])
--    mapInt64 x
--       | x <= 0xffff     = do
--          putStrLn "Found Int16!"
--          return (toVariantAt @0 (fromIntegral x))
--       | x <= 0xffffffff = do
--          putStrLn "Found Int32!"
--          return (toVariantAt @1 (fromIntegral x))
--       | otherwise       = do
--          putStrLn "Found Int64!"
--          return (toVariantAt @2 x)
--
--    mapInt32 :: Int32 -> IO (V '[Int16,Int32])
--    mapInt32 x
--       | x <= 0xffff     = do
--          putStrLn "Found Int16!"
--          return (toVariantAt @0 (fromIntegral x))
--       | otherwise       = do
--          putStrLn "Found Int32!"
--          return (toVariantAt @1 x)
--
--    v = V @Int64 @'[Int64,Int32] 10
--
--    > x <- v >:^> (mapInt64,mapInt32)
--    Found Int16!
--
--    > :t x
--    x :: V '[V '[Int16, Int32, Int64], V '[Int16, Int32]]
--
--    > x <- v >#^> (mapInt64,mapInt32)
--    Found Int16!
--
--    > :t x
--    x :: V '[Int16, Int32, Int64]
-- @
--
(>#^>) :: forall m fs xs zs ks ys rs.
   ( ContVariant xs
   , LiftCont fs
   , zs ~ ExtractRHS (TupleToList fs)
   , LiftContTuple fs ~ ContListToTuple xs (Variant zs)
   , ks ~ ExtractMonad m zs
   , ys ~ FlattenVariant ks
   , Flattenable (Variant ks) (Variant ys)
   , rs ~ Nub ys
   , Liftable ys rs
   , Applicative m
   ) => Variant xs -> fs -> m (Variant rs)
(>#^>) v fs = nubVariant <$> (flattenVariant <$> joinVariant (v >:> fs))