{-# LANGUAGE UndecidableInstances #-}

module Pandora.Paradigm.Controlflow.Effect.Transformer.Monadic (Monadic (..), (:>) (..)) where

import Pandora.Core.Functor (type (~>))
import Pandora.Pattern.Category ((.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Pointable (Pointable (point))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Applicative (Applicative ((<*>)))
import Pandora.Pattern.Functor.Alternative (Alternative ((<+>)))
import Pandora.Pattern.Functor.Avoidable (Avoidable (empty))
import Pandora.Pattern.Functor.Distributive (Distributive ((>>-)))
import Pandora.Pattern.Functor.Traversable (Traversable ((->>)))
import Pandora.Pattern.Functor.Bindable (Bindable ((>>=)))
import Pandora.Pattern.Functor.Extendable (Extendable ((=>>)))
import Pandora.Pattern.Functor.Monad (Monad)
import Pandora.Pattern.Transformer.Liftable (Liftable (lift))
import Pandora.Pattern.Transformer.Hoistable (Hoistable (hoist))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Schematic, Interpreted (Primary, run, unite))

class Interpreted t => Monadic t where
	{-# MINIMAL wrap #-}
	wrap :: Pointable u => t ~> t :> u

infixr 3 :>
newtype (:>) t u a = TM { (:>) t u a -> Schematic Monad t u a
tm :: Schematic Monad t u a }

instance Covariant (Schematic Monad t u) => Covariant (t :> u) where
	a -> b
f <$> :: (a -> b) -> (:>) t u a -> (:>) t u b
<$> TM Schematic Monad t u a
x = Schematic Monad t u b -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u b -> (:>) t u b)
-> Schematic Monad t u b -> (:>) t u b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a -> b
f (a -> b) -> Schematic Monad t u a -> Schematic Monad t u b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> Schematic Monad t u a
x

instance Pointable (Schematic Monad t u) => Pointable (t :> u) where
	point :: a |-> (t :> u)
point = Schematic Monad t u a -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u a -> (:>) t u a)
-> (a -> Schematic Monad t u a) -> a |-> (t :> u)
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> Schematic Monad t u a
forall (t :: * -> *) a. Pointable t => a |-> t
point

instance Extractable (Schematic Monad t u) => Extractable (t :> u) where
	extract :: a <-| (t :> u)
extract = a <-| Schematic Monad t u
forall (t :: * -> *) a. Extractable t => a <-| t
extract (a <-| Schematic Monad t u)
-> ((:>) t u a -> Schematic Monad t u a) -> a <-| (t :> u)
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (:>) t u a -> Schematic Monad t u a
forall (t :: * -> *) (u :: * -> *) a.
(:>) t u a -> Schematic Monad t u a
tm

instance Applicative (Schematic Monad t u) => Applicative (t :> u) where
	TM Schematic Monad t u (a -> b)
f <*> :: (:>) t u (a -> b) -> (:>) t u a -> (:>) t u b
<*> TM Schematic Monad t u a
x = Schematic Monad t u b -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u b -> (:>) t u b)
-> Schematic Monad t u b -> (:>) t u b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Schematic Monad t u (a -> b)
f Schematic Monad t u (a -> b)
-> Schematic Monad t u a -> Schematic Monad t u b
forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b
<*> Schematic Monad t u a
x

instance Alternative (Schematic Monad t u) => Alternative (t :> u) where
	TM Schematic Monad t u a
x <+> :: (:>) t u a -> (:>) t u a -> (:>) t u a
<+> TM Schematic Monad t u a
y = Schematic Monad t u a -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u a -> (:>) t u a)
-> Schematic Monad t u a -> (:>) t u a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Schematic Monad t u a
x Schematic Monad t u a
-> Schematic Monad t u a -> Schematic Monad t u a
forall (t :: * -> *) a. Alternative t => t a -> t a -> t a
<+> Schematic Monad t u a
y

instance Avoidable (Schematic Monad t u) => Avoidable (t :> u) where
	empty :: (:>) t u a
empty = Schematic Monad t u a -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM Schematic Monad t u a
forall (t :: * -> *) a. Avoidable t => t a
empty

instance Traversable (Schematic Monad t u) => Traversable (t :> u) where
	TM Schematic Monad t u a
x ->> :: (:>) t u a -> (a -> u b) -> (u :. (t :> u)) := b
->> a -> u b
f = Schematic Monad t u b -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u b -> (:>) t u b)
-> u (Schematic Monad t u b) -> (u :. (t :> u)) := b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> (Schematic Monad t u a
x Schematic Monad t u a -> (a -> u b) -> u (Schematic Monad t u b)
forall (t :: * -> *) (u :: * -> *) a b.
(Traversable t, Pointable u, Applicative u) =>
t a -> (a -> u b) -> (u :. t) := b
->> a -> u b
f)

instance Distributive (Schematic Monad t u) => Distributive (t :> u) where
	u a
x >>- :: u a -> (a -> (:>) t u b) -> ((t :> u) :. u) := b
>>- a -> (:>) t u b
f = Schematic Monad t u (u b) -> ((t :> u) :. u) := b
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u (u b) -> ((t :> u) :. u) := b)
-> Schematic Monad t u (u b) -> ((t :> u) :. u) := b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ u a
x u a -> (a -> Schematic Monad t u b) -> Schematic Monad t u (u b)
forall (t :: * -> *) (u :: * -> *) a b.
(Distributive t, Covariant u) =>
u a -> (a -> t b) -> (t :. u) := b
>>- (:>) t u b -> Schematic Monad t u b
forall (t :: * -> *) (u :: * -> *) a.
(:>) t u a -> Schematic Monad t u a
tm ((:>) t u b -> Schematic Monad t u b)
-> (a -> (:>) t u b) -> a -> Schematic Monad t u b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> (:>) t u b
f

instance Bindable (Schematic Monad t u) => Bindable (t :> u) where
	TM Schematic Monad t u a
x >>= :: (:>) t u a -> (a -> (:>) t u b) -> (:>) t u b
>>= a -> (:>) t u b
f = Schematic Monad t u b -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u b -> (:>) t u b)
-> Schematic Monad t u b -> (:>) t u b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Schematic Monad t u a
x Schematic Monad t u a
-> (a -> Schematic Monad t u b) -> Schematic Monad t u b
forall (t :: * -> *) a b. Bindable t => t a -> (a -> t b) -> t b
>>= (:>) t u b -> Schematic Monad t u b
forall (t :: * -> *) (u :: * -> *) a.
(:>) t u a -> Schematic Monad t u a
tm ((:>) t u b -> Schematic Monad t u b)
-> (a -> (:>) t u b) -> a -> Schematic Monad t u b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> (:>) t u b
f

instance Extendable (Schematic Monad t u) => Extendable (t :> u) where
	TM Schematic Monad t u a
x =>> :: (:>) t u a -> ((:>) t u a -> b) -> (:>) t u b
=>> (:>) t u a -> b
f = Schematic Monad t u b -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u b -> (:>) t u b)
-> Schematic Monad t u b -> (:>) t u b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Schematic Monad t u a
x Schematic Monad t u a
-> (Schematic Monad t u a -> b) -> Schematic Monad t u b
forall (t :: * -> *) a b. Extendable t => t a -> (t a -> b) -> t b
=>> (:>) t u a -> b
f ((:>) t u a -> b)
-> (Schematic Monad t u a -> (:>) t u a)
-> Schematic Monad t u a
-> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Schematic Monad t u a -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM

instance (Pointable (t :> u), Bindable (t :> u)) => Monad (t :> u) where

instance Liftable (Schematic Monad t) => Liftable ((:>) t) where
	lift :: u ~> (t :> u)
lift = Schematic Monad t u a -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u a -> (:>) t u a)
-> (u a -> Schematic Monad t u a) -> u a -> (:>) t u a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. u a -> Schematic Monad t u a
forall (t :: (* -> *) -> * -> *) (u :: * -> *).
(Liftable t, Covariant u) =>
u ~> t u
lift

instance Hoistable (Schematic Monad t) => Hoistable ((:>) t) where
	hoist :: (u ~> v) -> (t :> u) ~> (t :> v)
hoist u ~> v
f (TM Schematic Monad t u a
x) = Schematic Monad t v a -> (:>) t v a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t v a -> (:>) t v a)
-> Schematic Monad t v a -> (:>) t v a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ (u ~> v) -> Schematic Monad t u a -> Schematic Monad t v a
forall k (t :: (* -> *) -> k -> *) (u :: * -> *) (v :: * -> *).
(Hoistable t, Covariant u) =>
(u ~> v) -> t u ~> t v
hoist u ~> v
f Schematic Monad t u a
x

instance (Interpreted (Schematic Monad t u)) => Interpreted (t :> u) where
	type Primary (t :> u) a = Primary (Schematic Monad t u) a
	run :: (:>) t u a -> Primary (t :> u) a
run ~(TM Schematic Monad t u a
x) = Schematic Monad t u a -> Primary (Schematic Monad t u) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Schematic Monad t u a
x
	unite :: Primary (t :> u) a -> (:>) t u a
unite = Schematic Monad t u a -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM (Schematic Monad t u a -> (:>) t u a)
-> (Primary (Schematic Monad t u) a -> Schematic Monad t u a)
-> Primary (Schematic Monad t u) a
-> (:>) t u a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Primary (Schematic Monad t u) a -> Schematic Monad t u a
forall (t :: * -> *) a. Interpreted t => Primary t a -> t a
unite