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

-- | VariantF functor
module Haskus.Utils.VariantF
   ( VariantF (..)
   , ApplyAll
   , pattern FV
   , appendVariantF
   , prependVariantF
   , toVariantFHead
   , toVariantFTail
   , popVariantFHead
   , variantFToValue
   , MapVariantF
   , mapVariantF
   , PopVariantF
   , popVariantF
   , LiftVariantF
   , liftVariantF
   , SplitVariantF
   , splitVariantF
   , variantFToCont
   , variantFToContM
   , contToVariantF
   , contToVariantFM
   -- * Algebras
   , BottomUpF
   , BottomUp (..)
   , BottomUpOrig (..)
   , BottomUpOrigF
   , TopDownStop (..)
   , TopDownStopF
   -- * Reexport
   , NoConstraint
   , module Haskus.Utils.Functor
   )
where

import Haskus.Utils.Variant
import Haskus.Utils.Functor
import Haskus.Utils.Types.List
import Haskus.Utils.Types.Constraint
import Haskus.Utils.ContFlow
import Haskus.Utils.Types

import Data.Bifunctor
import Control.DeepSeq

-- $setup
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XFlexibleContexts
-- >>> :set -XTypeFamilies
-- >>> :set -XPatternSynonyms
-- >>> :set -XDeriveFunctor
-- >>> import Data.Functor.Classes
-- >>>
-- >>> data ConsF a e = ConsF a e deriving (Functor)
-- >>> data NilF    e = NilF      deriving (Functor)
-- >>> type ListF   a = VariantF '[NilF,ConsF a]
-- >>>
-- >>> instance Eq a => Eq1 (ConsF a) where liftEq cmp (ConsF a e1) (ConsF b e2) = a == b && cmp e1 e2
-- >>> instance Eq1 NilF where liftEq _ _ _ = True
-- >>>
-- >>> instance Ord a => Ord1 (ConsF a) where liftCompare cmp (ConsF a e1) (ConsF b e2) = compare a b <> cmp e1 e2
-- >>> instance Ord1 NilF where liftCompare _ _ _ = EQ
-- >>>
-- >>> instance Show a => Show1 (ConsF a) where liftShowsPrec shw _ p (ConsF a e) = showString "ConsF " . showsPrec 10 a . showString " " . shw 10 e
-- >>> instance Show1 NilF where liftShowsPrec _ _ _ _ = showString "NilF"
-- >>>
-- >>> liftEq (==) NilF (NilF :: NilF Int)
-- True
-- >>> liftEq (==) (ConsF 10 "Test") (ConsF 10 "Test" :: ConsF Int String)
-- True
-- >>> liftEq (==) (ConsF 10 "Test") (ConsF 8 "Test" :: ConsF Int String)
-- False
-- >>> liftEq (==) (ConsF 10 "Test") (ConsF 10 "XXX" :: ConsF Int String)
-- False

-- | Recursive Functor-like Variant
newtype VariantF (xs :: [t -> Type]) (e :: t)
   = VariantF (V (ApplyAll e xs))

-- | Apply its first argument to every element of the 2nd arg list
--
-- > ApplyAll e '[f,g,h] ==> '[f e, g e, h e]
--
type family ApplyAll (e :: t) (xs :: [t -> k]) :: [k] where
   ApplyAll e '[]       = '[]
   ApplyAll e (f ': fs) = f e ': ApplyAll e fs

type instance Base (VariantF xs a) = VariantF xs

-- | Eq instance for VariantF
--
-- >>> let a = FV (ConsF 'a' "Test") :: VariantF '[ConsF Char,NilF] String
-- >>> let a' = FV (ConsF 'a' "XXX") :: VariantF '[ConsF Char,NilF] String
-- >>> let b = FV (ConsF 'b' "Test") :: VariantF '[ConsF Char,NilF] String
-- >>> a == a
-- True
-- >>> a == a'
-- False
-- >>> a == b
-- False
--
-- >>> let c = FV (ConsF 'c' b) :: VariantF '[ConsF Char,NilF] (VariantF '[ConsF Char, NilF] String)
-- >>> c == c
-- True
--
-- >>> let n1 = FV (NilF :: NilF ()) :: VariantF '[ConsF Char,NilF] ()
-- >>> let n2 = FV (NilF :: NilF ()) :: VariantF '[ConsF Char,NilF] ()
-- >>> n1 == n2
-- True
--
instance
   ( Eq1 (VariantF xs)
   , ConstraintAll1 Eq1 xs
   , Eq e
   ) => Eq (VariantF xs e)
   where
   == :: VariantF xs e -> VariantF xs e -> Bool
(==) = VariantF xs e -> VariantF xs e -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

-- | Ord instance for VariantF
--
-- >>> let a = FV (ConsF 'a' "Test") :: VariantF '[ConsF Char,NilF] String
-- >>> let a' = FV (ConsF 'a' "XXX") :: VariantF '[ConsF Char,NilF] String
-- >>> let b = FV (ConsF 'b' "Test") :: VariantF '[ConsF Char,NilF] String
-- >>> compare a a
-- EQ
-- >>> compare a a'
-- LT
-- >>> compare a b
-- LT
instance
   ( Ord1 (VariantF xs)
   , ConstraintAll1 Ord1 xs
   , ConstraintAll1 Eq1 xs
   , Ord e
   ) => Ord (VariantF xs e)
   where
   compare :: VariantF xs e -> VariantF xs e -> Ordering
compare = VariantF xs e -> VariantF xs e -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1


instance Eq1 (VariantF '[]) where
   liftEq :: (a -> b -> Bool) -> VariantF '[] a -> VariantF '[] b -> Bool
liftEq = (a -> b -> Bool) -> VariantF '[] a -> VariantF '[] b -> Bool
forall a. HasCallStack => a
undefined

instance
   ( Eq1 f
   , Eq1 (VariantF fs)
   ) => Eq1 (VariantF (f:fs)) where
   liftEq :: (a -> b -> Bool)
-> VariantF (f : fs) a -> VariantF (f : fs) b -> Bool
liftEq a -> b -> Bool
cmp VariantF (f : fs) a
x VariantF (f : fs) b
y = case (VariantF (f : fs) a -> Either (VariantF fs a) (f a)
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) a
x, VariantF (f : fs) b -> Either (VariantF fs b) (f b)
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) b
y) of
      (Right f a
a, Right f b
b) -> (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
cmp f a
a f b
b
      (Left VariantF fs a
a, Left VariantF fs b
b)   -> (a -> b -> Bool) -> VariantF fs a -> VariantF fs b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
cmp VariantF fs a
a VariantF fs b
b
      (Either (VariantF fs a) (f a), Either (VariantF fs b) (f b))
_                  -> Bool
False

instance Ord1 (VariantF '[]) where
   liftCompare :: (a -> b -> Ordering)
-> VariantF '[] a -> VariantF '[] b -> Ordering
liftCompare = (a -> b -> Ordering)
-> VariantF '[] a -> VariantF '[] b -> Ordering
forall a. HasCallStack => a
undefined

instance
   ( Ord1 f
   , Ord1 (VariantF fs)
   ) => Ord1 (VariantF (f:fs)) where
   liftCompare :: (a -> b -> Ordering)
-> VariantF (f : fs) a -> VariantF (f : fs) b -> Ordering
liftCompare a -> b -> Ordering
cmp x :: VariantF (f : fs) a
x@(VariantF V (ApplyAll a (f : fs))
v1) y :: VariantF (f : fs) b
y@(VariantF V (ApplyAll b (f : fs))
v2) =
      case (VariantF (f : fs) a -> Either (VariantF fs a) (f a)
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) a
x, VariantF (f : fs) b -> Either (VariantF fs b) (f b)
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) b
y) of
         (Right f a
a, Right f b
b) -> (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp f a
a f b
b
         (Left  VariantF fs a
a, Left  VariantF fs b
b) -> (a -> b -> Ordering) -> VariantF fs a -> VariantF fs b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp VariantF fs a
a VariantF fs b
b
         (Either (VariantF fs a) (f a), Either (VariantF fs b) (f b))
_                  -> Word -> Word -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (V (f a : ApplyAll a fs) -> Word
forall (a :: [*]). V a -> Word
variantIndex V (f a : ApplyAll a fs)
V (ApplyAll a (f : fs))
v1) (V (f b : ApplyAll b fs) -> Word
forall (a :: [*]). V a -> Word
variantIndex V (f b : ApplyAll b fs)
V (ApplyAll b (f : fs))
v2)


instance Show1 (VariantF '[]) where
   liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> VariantF '[] a -> ShowS
liftShowsPrec = (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> VariantF '[] a -> ShowS
forall a. HasCallStack => a
undefined

instance
   ( Show1 f
   , Show1 (VariantF fs)
   ) => Show1 (VariantF (f:fs)) where
   liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> VariantF (f : fs) a -> ShowS
liftShowsPrec Int -> a -> ShowS
shw [a] -> ShowS
shwl Int
p VariantF (f : fs) a
x = case VariantF (f : fs) a -> Either (VariantF fs a) (f a)
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) a
x of
         Right f a
a -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
shw [a] -> ShowS
shwl Int
p f a
a
         Left  VariantF fs a
a -> (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> VariantF fs a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
shw [a] -> ShowS
shwl Int
p VariantF fs a
a

-- | Show instance for VariantF
--
-- >>> let a = FV (ConsF 'a' "Test") :: VariantF '[ConsF Char,NilF] String
-- >>> let b = FV (NilF :: NilF String) :: VariantF '[ConsF Char,NilF] String
-- >>> print a
-- ConsF 'a' "Test"
-- >>> print b
-- NilF
instance
   ( Show1 (VariantF xs)
   , ConstraintAll1 Show1 xs
   , Show e
   ) => Show (VariantF xs e)
   where
   showsPrec :: Int -> VariantF xs e -> ShowS
showsPrec = Int -> VariantF xs e -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance Functor (VariantF '[]) where
   fmap :: (a -> b) -> VariantF '[] a -> VariantF '[] b
fmap a -> b
_ = VariantF '[] a -> VariantF '[] b
forall a. HasCallStack => a
undefined

instance (Functor (VariantF fs), Functor f) => Functor (VariantF (f ': fs)) where
   fmap :: (a -> b) -> VariantF (f : fs) a -> VariantF (f : fs) b
fmap a -> b
f (VariantF V (ApplyAll a (f : fs))
v) = case V (f a : ApplyAll a fs) -> Either (V (ApplyAll a fs)) (f a)
forall x (xs :: [*]). V (x : xs) -> Either (V xs) x
popVariantHead V (f a : ApplyAll a fs)
V (ApplyAll a (f : fs))
v of
      Right f a
x -> f b -> VariantF (f : fs) b
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
x e -> VariantF (x : xs) e
toVariantFHead ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x)
      Left V (ApplyAll a fs)
xs -> VariantF fs b -> VariantF (f : fs) b
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF xs e -> VariantF (x : xs) e
toVariantFTail ((a -> b) -> VariantF fs a -> VariantF fs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (V (ApplyAll a fs) -> VariantF fs a
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF V (ApplyAll a fs)
xs))



-- | Pattern-match in a VariantF
--
-- >>> FV (NilF :: NilF String) :: VariantF '[ConsF Char,NilF] String
-- NilF
pattern FV :: forall c cs e. c :< (ApplyAll e cs) => c -> VariantF cs e
pattern $bFV :: c -> VariantF cs e
$mFV :: forall r t c (cs :: [t -> *]) (e :: t).
(c :< ApplyAll e cs) =>
VariantF cs e -> (c -> r) -> (Void# -> r) -> r
FV x = VariantF (V x)

-- | Retrieve a single value
variantFToValue :: VariantF '[f] e -> f e
variantFToValue :: VariantF '[f] e -> f e
variantFToValue (VariantF V (ApplyAll e '[f])
v) = V '[f e] -> f e
forall a. V '[a] -> a
variantToValue V '[f e]
V (ApplyAll e '[f])
v

appendVariantF :: forall (ys :: [Type -> Type]) (xs :: [Type -> Type]) e.
   ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys)
   ) => VariantF xs e -> VariantF (Concat xs ys) e
appendVariantF :: VariantF xs e -> VariantF (Concat xs ys) e
appendVariantF (VariantF V (ApplyAll e xs)
v) = V (ApplyAll e (Concat xs ys)) -> VariantF (Concat xs ys) e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (V (ApplyAll e xs) -> V (Concat (ApplyAll e xs) (ApplyAll e ys))
forall (ys :: [*]) (xs :: [*]). V xs -> V (Concat xs ys)
appendVariant @(ApplyAll e ys) V (ApplyAll e xs)
v)

prependVariantF :: forall (xs :: [Type -> Type]) (ys :: [Type -> Type]) e.
   ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys)
   , KnownNat (Length (ApplyAll e xs))
   ) => VariantF ys e -> VariantF (Concat xs ys) e
prependVariantF :: VariantF ys e -> VariantF (Concat xs ys) e
prependVariantF (VariantF V (ApplyAll e ys)
v) = V (ApplyAll e (Concat xs ys)) -> VariantF (Concat xs ys) e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (V (ApplyAll e ys) -> V (Concat (ApplyAll e xs) (ApplyAll e ys))
forall (ys :: [*]) (xs :: [*]).
KnownNat (Length ys) =>
V xs -> V (Concat ys xs)
prependVariant @(ApplyAll e xs) V (ApplyAll e ys)
v)


-- | Set the first value
toVariantFHead :: forall x xs e. x e -> VariantF (x ': xs) e
{-# INLINABLE toVariantFHead #-}
toVariantFHead :: x e -> VariantF (x : xs) e
toVariantFHead x e
v = V (ApplyAll e (x : xs)) -> VariantF (x : xs) e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (x e -> V (x e : ApplyAll e xs)
forall x (xs :: [*]). x -> V (x : xs)
toVariantHead @(x e) @(ApplyAll e xs) x e
v)

-- | Set the tail
toVariantFTail :: forall x xs e. VariantF xs e -> VariantF (x ': xs) e
{-# INLINABLE toVariantFTail #-}
toVariantFTail :: VariantF xs e -> VariantF (x : xs) e
toVariantFTail (VariantF V (ApplyAll e xs)
v) = V (ApplyAll e (x : xs)) -> VariantF (x : xs) e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (V (ApplyAll e xs) -> V (x e : ApplyAll e xs)
forall x (xs :: [*]). V xs -> V (x : xs)
toVariantTail @(x e) @(ApplyAll e xs) V (ApplyAll e xs)
v)

-- | Pop VariantF head
popVariantFHead :: forall x xs e. VariantF (x ': xs) e -> Either (VariantF xs e) (x e)
{-# INLINABLE popVariantFHead #-}
popVariantFHead :: VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead (VariantF V (ApplyAll e (x : xs))
v) = case V (x e : ApplyAll e xs) -> Either (V (ApplyAll e xs)) (x e)
forall x (xs :: [*]). V (x : xs) -> Either (V xs) x
popVariantHead V (x e : ApplyAll e xs)
V (ApplyAll e (x : xs))
v of
   Right x e
x -> x e -> Either (VariantF xs e) (x e)
forall a b. b -> Either a b
Right x e
x
   Left V (ApplyAll e xs)
xs -> VariantF xs e -> Either (VariantF xs e) (x e)
forall a b. a -> Either a b
Left (V (ApplyAll e xs) -> VariantF xs e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF V (ApplyAll e xs)
xs)

type PopVariantF x xs e =
   ( x e :< ApplyAll e xs
   , Remove (x e) (ApplyAll e xs) ~ ApplyAll e (Remove x xs)
   )

-- | Pop VariantF
popVariantF :: forall x xs e.
   ( PopVariantF x xs e
   ) => VariantF xs e -> Either (VariantF (Remove x xs) e) (x e)
{-# INLINABLE popVariantF #-}
popVariantF :: VariantF xs e -> Either (VariantF (Remove x xs) e) (x e)
popVariantF (VariantF V (ApplyAll e xs)
v) = case V (ApplyAll e xs)
-> Either (V (Remove (x e) (ApplyAll e xs))) (x e)
forall a (xs :: [*]).
(a :< xs) =>
V xs -> Either (V (Remove a xs)) a
popVariant V (ApplyAll e xs)
v of
   Right x e
x -> x e -> Either (VariantF (Remove x xs) e) (x e)
forall a b. b -> Either a b
Right x e
x
   Left V (Remove (x e) (ApplyAll e xs))
xs -> VariantF (Remove x xs) e -> Either (VariantF (Remove x xs) e) (x e)
forall a b. a -> Either a b
Left (V (ApplyAll e (Remove x xs)) -> VariantF (Remove x xs) e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF V (Remove (x e) (ApplyAll e xs))
V (ApplyAll e (Remove x xs))
xs)

type MapVariantF a b cs ds e =
   ( MapVariant (a e) (b e) (ApplyAll e cs)
   , ds ~ ReplaceNS (IndexesOf a cs) b cs
   , ApplyAll e ds ~ ReplaceNS (IndexesOf (a e) (ApplyAll e cs)) (b e) (ApplyAll e cs)
   )

-- | Map the matching types of a variant
mapVariantF :: forall a b cs ds e.
   ( MapVariantF a b cs ds e
   ) => (a e -> b e) -> VariantF cs e -> VariantF ds e
mapVariantF :: (a e -> b e) -> VariantF cs e -> VariantF ds e
mapVariantF a e -> b e
f (VariantF V (ApplyAll e cs)
v) = V (ApplyAll e ds) -> VariantF ds e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF ((a e -> b e)
-> V (ApplyAll e cs) -> V (ReplaceAll (a e) (b e) (ApplyAll e cs))
forall a b (cs :: [*]).
MapVariant a b cs =>
(a -> b) -> V cs -> V (ReplaceAll a b cs)
mapVariant @(a e) @(b e) @(ApplyAll e cs) a e -> b e
f V (ApplyAll e cs)
v)

-- | xs is liftable in ys
type LiftVariantF xs ys e =
   ( LiftVariant (ApplyAll e xs) (ApplyAll e ys)
   )

-- | Lift a VariantF into another
liftVariantF :: forall as bs e.
   ( LiftVariantF as bs e
   ) => VariantF as e -> VariantF bs e
liftVariantF :: VariantF as e -> VariantF bs e
liftVariantF (VariantF V (ApplyAll e as)
v) = V (ApplyAll e bs) -> VariantF bs e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (V (ApplyAll e as) -> V (ApplyAll e bs)
forall (xs :: [*]) (ys :: [*]). LiftVariant' xs ys => V xs -> V ys
liftVariant' V (ApplyAll e as)
v)

type SplitVariantF as xs e =
   ( Complement (ApplyAll e xs) (ApplyAll e as) ~ ApplyAll e (Complement xs as)
   , SplitVariant (ApplyAll e as) (ApplyAll e (Complement xs as)) (ApplyAll e xs)
   )

-- | Split a VariantF in two
splitVariantF :: forall as xs e.
   ( SplitVariantF as xs e
   ) => VariantF xs e
     -> Either (VariantF (Complement xs as) e) (VariantF as e)
splitVariantF :: VariantF xs e
-> Either (VariantF (Complement xs as) e) (VariantF as e)
splitVariantF (VariantF V (ApplyAll e xs)
v) = (V (ApplyAll e (Complement xs as))
 -> VariantF (Complement xs as) e)
-> (V (ApplyAll e as) -> VariantF as e)
-> Either (V (ApplyAll e (Complement xs as))) (V (ApplyAll e as))
-> Either (VariantF (Complement xs as) e) (VariantF as e)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap V (ApplyAll e (Complement xs as)) -> VariantF (Complement xs as) e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF V (ApplyAll e as) -> VariantF as e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (V (ApplyAll e xs)
-> Either
     (V (Complement (ApplyAll e xs) (ApplyAll e as)))
     (V (ApplyAll e as))
forall (as :: [*]) (xs :: [*]).
SplitVariant as (Complement xs as) xs =>
V xs -> Either (V (Complement xs as)) (V as)
splitVariant V (ApplyAll e xs)
v)

-- | Convert a VariantF into a multi-continuation
variantFToCont :: ContVariant (ApplyAll e xs)
   => VariantF xs e -> ContFlow (ApplyAll e xs) r
variantFToCont :: VariantF xs e -> ContFlow (ApplyAll e xs) r
variantFToCont (VariantF V (ApplyAll e xs)
v) = V (ApplyAll e xs) -> ContFlow (ApplyAll e xs) r
forall (xs :: [*]) r. ContVariant xs => V xs -> ContFlow xs r
variantToCont V (ApplyAll e xs)
v

-- | Convert a VariantF into a multi-continuation
variantFToContM ::
   ( ContVariant (ApplyAll e xs)
   , Monad m
   ) => m (VariantF xs e) -> ContFlow (ApplyAll e xs) (m r)
variantFToContM :: m (VariantF xs e) -> ContFlow (ApplyAll e xs) (m r)
variantFToContM m (VariantF xs e)
f = m (V (ApplyAll e xs)) -> ContFlow (ApplyAll e xs) (m r)
forall (xs :: [*]) (m :: * -> *) r.
(ContVariant xs, Monad m) =>
m (V xs) -> ContFlow xs (m r)
variantToContM (VariantF xs e -> V (ApplyAll e xs)
forall t (xs :: [t -> *]) (e :: t).
VariantF xs e -> V (ApplyAll e xs)
unvariantF (VariantF xs e -> V (ApplyAll e xs))
-> m (VariantF xs e) -> m (V (ApplyAll e xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (VariantF xs e)
f)
   where
      unvariantF :: VariantF xs e -> V (ApplyAll e xs)
unvariantF (VariantF V (ApplyAll e xs)
v) = V (ApplyAll e xs)
v

-- | Convert a multi-continuation into a VariantF
contToVariantF :: forall xs e.
   ( ContVariant (ApplyAll e xs)
   ) => ContFlow (ApplyAll e xs) (V (ApplyAll e xs)) -> VariantF xs e
contToVariantF :: ContFlow (ApplyAll e xs) (V (ApplyAll e xs)) -> VariantF xs e
contToVariantF ContFlow (ApplyAll e xs) (V (ApplyAll e xs))
c = V (ApplyAll e xs) -> VariantF xs e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (ContFlow (ApplyAll e xs) (V (ApplyAll e xs)) -> V (ApplyAll e xs)
forall (xs :: [*]). ContVariant xs => ContFlow xs (V xs) -> V xs
contToVariant ContFlow (ApplyAll e xs) (V (ApplyAll e xs))
c)

-- | Convert a multi-continuation into a VariantF
contToVariantFM :: forall xs e m.
   ( ContVariant (ApplyAll e xs)
   , Monad m
   ) => ContFlow (ApplyAll e xs) (m (V (ApplyAll e xs))) -> m (VariantF xs e)
contToVariantFM :: ContFlow (ApplyAll e xs) (m (V (ApplyAll e xs)))
-> m (VariantF xs e)
contToVariantFM ContFlow (ApplyAll e xs) (m (V (ApplyAll e xs)))
f = V (ApplyAll e xs) -> VariantF xs e
forall t (xs :: [t -> *]) (e :: t).
V (ApplyAll e xs) -> VariantF xs e
VariantF (V (ApplyAll e xs) -> VariantF xs e)
-> m (V (ApplyAll e xs)) -> m (VariantF xs e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContFlow (ApplyAll e xs) (m (V (ApplyAll e xs)))
-> m (V (ApplyAll e xs))
forall (xs :: [*]) (m :: * -> *).
(ContVariant xs, Monad m) =>
ContFlow xs (m (V xs)) -> m (V xs)
contToVariantM ContFlow (ApplyAll e xs) (m (V (ApplyAll e xs)))
f

instance ContVariant (ApplyAll e xs) => MultiCont (VariantF xs e) where
   type MultiContTypes (VariantF xs e) = ApplyAll e xs
   toCont :: VariantF xs e -> ContFlow (MultiContTypes (VariantF xs e)) r
toCont  = VariantF xs e -> ContFlow (MultiContTypes (VariantF xs e)) r
forall t (e :: t) (xs :: [t -> *]) r.
ContVariant (ApplyAll e xs) =>
VariantF xs e -> ContFlow (ApplyAll e xs) r
variantFToCont
   toContM :: m (VariantF xs e)
-> ContFlow (MultiContTypes (VariantF xs e)) (m r)
toContM = m (VariantF xs e)
-> ContFlow (MultiContTypes (VariantF xs e)) (m r)
forall t (e :: t) (xs :: [t -> *]) (m :: * -> *) r.
(ContVariant (ApplyAll e xs), Monad m) =>
m (VariantF xs e) -> ContFlow (ApplyAll e xs) (m r)
variantFToContM

deriving newtype instance (NFData (V (ApplyAll e xs))) => NFData (VariantF xs e)

----------------------------------------
-- BottomUp
----------------------------------------

type family BottomUpF c fs :: Constraint where
   BottomUpF c fs = (Functor (VariantF fs), BottomUp c fs)

class BottomUp c fs where
   toBottomUp :: (forall f. c f => f a -> b) -> (VariantF fs a -> b)

instance BottomUp c '[] where
   {-# INLINABLE toBottomUp #-}
   toBottomUp :: (forall (f :: t -> *). c f => f a -> b) -> VariantF '[] a -> b
toBottomUp forall (f :: t -> *). c f => f a -> b
_f = VariantF '[] a -> b
forall a. HasCallStack => a
undefined

instance forall c fs f.
   ( BottomUp c fs
   , c f
   ) => BottomUp c (f ':fs) where
   {-# INLINABLE toBottomUp #-}
   toBottomUp :: (forall (f :: t -> *). c f => f a -> b) -> VariantF (f : fs) a -> b
toBottomUp forall (f :: t -> *). c f => f a -> b
f VariantF (f : fs) a
v = case VariantF (f : fs) a -> Either (VariantF fs a) (f a)
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) a
v of
      Right f a
x -> f a -> b
forall (f :: t -> *). c f => f a -> b
f f a
x
      Left VariantF fs a
xs -> (forall (f :: t -> *). c f => f a -> b) -> VariantF fs a -> b
forall t (c :: (t -> *) -> Constraint) (fs :: [t -> *]) (a :: t) b.
BottomUp c fs =>
(forall (f :: t -> *). c f => f a -> b) -> VariantF fs a -> b
toBottomUp @c forall (f :: t -> *). c f => f a -> b
f VariantF fs a
xs

----------------------------------------
-- BottomUpOrig
----------------------------------------

type family BottomUpOrigF c fs :: Constraint where
   BottomUpOrigF c fs = (Functor (VariantF fs), BottomUpOrig c fs)

class BottomUpOrig c fs where
   toBottomUpOrig :: (forall f. c f => f (t,a) -> b) -> (VariantF fs (t,a) -> b)

instance BottomUpOrig c '[] where
   {-# INLINABLE toBottomUpOrig #-}
   toBottomUpOrig :: (forall (f :: * -> *). c f => f (t, a) -> b)
-> VariantF '[] (t, a) -> b
toBottomUpOrig forall (f :: * -> *). c f => f (t, a) -> b
_f = VariantF '[] (t, a) -> b
forall a. HasCallStack => a
undefined

instance forall c fs f.
   ( BottomUpOrig c fs
   , c f
   ) => BottomUpOrig c (f ': fs) where
   {-# INLINABLE toBottomUpOrig #-}
   toBottomUpOrig :: (forall (f :: * -> *). c f => f (t, a) -> b)
-> VariantF (f : fs) (t, a) -> b
toBottomUpOrig forall (f :: * -> *). c f => f (t, a) -> b
f VariantF (f : fs) (t, a)
v = case VariantF (f : fs) (t, a) -> Either (VariantF fs (t, a)) (f (t, a))
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) (t, a)
v of
      Right f (t, a)
x -> f (t, a) -> b
forall (f :: * -> *). c f => f (t, a) -> b
f f (t, a)
x
      Left VariantF fs (t, a)
xs -> (forall (f :: * -> *). c f => f (t, a) -> b)
-> VariantF fs (t, a) -> b
forall (c :: (* -> *) -> Constraint) (fs :: [* -> *]) t a b.
BottomUpOrig c fs =>
(forall (f :: * -> *). c f => f (t, a) -> b)
-> VariantF fs (t, a) -> b
toBottomUpOrig @c forall (f :: * -> *). c f => f (t, a) -> b
f VariantF fs (t, a)
xs


----------------------------------------
-- TopDownStop
----------------------------------------

type family TopDownStopF c fs :: Constraint where
   TopDownStopF c fs = (Functor (VariantF fs), TopDownStop c fs)

class TopDownStop c fs where
   toTopDownStop :: (forall f. c f => TopDownStopT a f) -> TopDownStopT a (VariantF fs)

instance TopDownStop c '[] where
   {-# INLINABLE toTopDownStop #-}
   toTopDownStop :: (forall (f :: * -> *). c f => TopDownStopT a f)
-> TopDownStopT a (VariantF '[])
toTopDownStop forall (f :: * -> *). c f => TopDownStopT a f
_f = TopDownStopT a (VariantF '[])
forall a. HasCallStack => a
undefined

instance forall c fs f.
   ( TopDownStop c fs
   , Functor f
   , c f
   ) => TopDownStop c (f ':fs) where
   {-# INLINABLE toTopDownStop #-}
   toTopDownStop :: (forall (f :: * -> *). c f => TopDownStopT a f)
-> TopDownStopT a (VariantF (f : fs))
toTopDownStop forall (f :: * -> *). c f => TopDownStopT a f
f VariantF (f : fs) a
v = case VariantF (f : fs) a -> Either (VariantF fs a) (f a)
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
VariantF (x : xs) e -> Either (VariantF xs e) (x e)
popVariantFHead VariantF (f : fs) a
v of
      Right f a
x -> (f a -> VariantF (f : fs) a)
-> Either (f a) a -> Either (VariantF (f : fs) a) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first f a -> VariantF (f : fs) a
forall t (x :: t -> *) (xs :: [t -> *]) (e :: t).
x e -> VariantF (x : xs) e
toVariantFHead (TopDownStopT a f
forall (f :: * -> *). c f => TopDownStopT a f
f f a
x)
      Left VariantF fs a
xs -> (VariantF fs a -> VariantF (f : fs) a)
-> Either (VariantF fs a) a -> Either (VariantF (f : fs) a) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (xs :: [* -> *]) (ys :: [* -> *]) e.
(ApplyAll e (Concat xs ys)
 ~ Concat (ApplyAll e xs) (ApplyAll e ys),
 KnownNat (Length (ApplyAll e xs))) =>
VariantF ys e -> VariantF (Concat xs ys) e
forall (ys :: [* -> *]) e.
(ApplyAll e (Concat '[f] ys)
 ~ Concat (ApplyAll e '[f]) (ApplyAll e ys),
 KnownNat (Length (ApplyAll e '[f]))) =>
VariantF ys e -> VariantF (Concat '[f] ys) e
prependVariantF @'[f]) ((forall (f :: * -> *). c f => TopDownStopT a f)
-> TopDownStopT a (VariantF fs)
forall (c :: (* -> *) -> Constraint) (fs :: [* -> *]) a.
TopDownStop c fs =>
(forall (f :: * -> *). c f => TopDownStopT a f)
-> TopDownStopT a (VariantF fs)
toTopDownStop @c forall (f :: * -> *). c f => TopDownStopT a f
f VariantF fs a
xs)