{-# LANGUAGE UndecidableInstances #-}
module Pandora.Paradigm.Controlflow.Effect.Adaptable where

import Pandora.Core.Functor (type (#))
import Pandora.Pattern.Semigroupoid (Semigroupoid ((.)))
import Pandora.Pattern.Category (Category (identity))
import Pandora.Pattern.Functor.Covariant (Covariant)
import Pandora.Pattern.Functor.Monoidal (Monoidal)
import Pandora.Pattern.Transformer (Liftable (lift))
import Pandora.Paradigm.Primary.Algebraic.Exponential (type (-->))
import Pandora.Paradigm.Primary.Algebraic.Product ((:*:))
import Pandora.Paradigm.Primary.Algebraic (Pointable, extract, point)
import Pandora.Paradigm.Primary.Functor.Identity (Identity)
import Pandora.Paradigm.Controlflow.Effect.Transformer (Monadic, wrap, (:>))

class Adaptable u m t where
	{-# MINIMAL adapt #-}
	adapt :: m (t a) (u a)

instance Category m => Adaptable t m t where
	adapt :: m (t a) (t a)
adapt = forall a. Category m => m a a
forall (m :: * -> * -> *) a. Category m => m a a
identity @m

instance {-# OVERLAPS #-} Monoidal (-->) (-->) (:*:) (:*:) u => Adaptable u (->) Identity where
	adapt :: Identity a -> u a
adapt = a -> u a
forall (t :: * -> *) a. Pointable t => a -> t a
point (a -> u a) -> (Identity a -> a) -> Identity a -> u a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. Identity a -> a
forall (t :: * -> *) a. Extractable t => t a -> a
extract

class Effectful m v t u where
	effect :: m (v a) (t :> u # a)

instance (Pointable u, Monadic m t) => Effectful m t t u where
	effect :: m (t a) ((t :> u) # a)
effect = m (t a) ((t :> u) # a)
forall (m :: * -> * -> *) (t :: * -> *) (u :: * -> *) a.
(Monadic m t, Pointable u) =>
m (t a) ((:>) t u a)
wrap

instance (Covariant m m u, Liftable m ((:>) t)) => Effectful m u t u where
	effect :: m (u a) ((t :> u) # a)
effect = m (u a) ((t :> u) # a)
forall (cat :: * -> * -> *) (t :: (* -> *) -> * -> *) (u :: * -> *)
       a.
(Liftable cat t, Covariant cat cat u) =>
cat (u a) (t u a)
lift

instance {-# OVERLAPS #-} (Semigroupoid m, Effectful m u t u, Adaptable u m v) => Effectful m v t u where
	effect :: m (v a) ((t :> u) # a)
effect = forall a. Effectful m u t u => m (u a) ((t :> u) # a)
forall k (m :: k -> * -> *) (v :: * -> k) (t :: * -> *)
       (u :: * -> *) a.
Effectful m v t u =>
m (v a) ((t :> u) # a)
effect @m @u @t @u m (u a) ((t :> u) # a) -> m (v a) (u a) -> m (v a) ((t :> u) # a)
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. forall a. Adaptable u m v => m (v a) (u a)
forall k k k (u :: k -> k) (m :: k -> k -> *) (t :: k -> k)
       (a :: k).
Adaptable u m t =>
m (t a) (u a)
adapt @u @m @v

instance Effectful m v t u => Adaptable (t :> u) m v where
	adapt :: m (v a) ((:>) t u a)
adapt = forall a. Effectful m v t u => m (v a) ((:>) t u a)
forall k (m :: k -> * -> *) (v :: * -> k) (t :: * -> *)
       (u :: * -> *) a.
Effectful m v t u =>
m (v a) ((t :> u) # a)
effect @m @v @t @u