module Pandora.Paradigm.Primary.Transformer.Tap where

import Pandora.Core.Morphism ((%))
import Pandora.Pattern.Category ((.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Avoidable (Avoidable (empty))
import Pandora.Pattern.Functor.Pointable (Pointable (point))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Alternative (Alternative ((<+>)))
import Pandora.Pattern.Functor.Applicative (Applicative ((<*>)))
import Pandora.Pattern.Functor.Traversable (Traversable ((->>)))
import Pandora.Pattern.Functor.Extendable (Extendable ((=>>)))
import Pandora.Pattern.Functor.Bindable (Bindable ((>>=)))
import Pandora.Pattern.Transformer.Lowerable (Lowerable (lower))
import Pandora.Pattern.Transformer.Hoistable (Hoistable (hoist))

data Tap t a = Tap a (t a)

instance Covariant t => Covariant (Tap t) where
	a -> b
f <$> :: (a -> b) -> Tap t a -> Tap t b
<$> Tap a
x t a
xs = b -> t b -> Tap t b
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap (a -> b
f a
x) (t b -> Tap t b) -> t b -> Tap t b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a -> b
f (a -> b) -> t a -> t b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> t a
xs

instance Avoidable t => Pointable (Tap t) where
	point :: a |-> Tap t
point = a -> t a -> Tap t a
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap (a -> t a -> Tap t a) -> t a -> a |-> Tap t
forall a b c. (a -> b -> c) -> b -> a -> c
% t a
forall (t :: * -> *) a. Avoidable t => t a
empty

instance Covariant t => Extractable (Tap t) where
	extract :: a <-| Tap t
extract (Tap a
x t a
_) = a
x

instance Applicative t => Applicative (Tap t) where
	Tap a -> b
f t (a -> b)
fs <*> :: Tap t (a -> b) -> Tap t a -> Tap t b
<*> Tap a
x t a
xs = b -> t b -> Tap t b
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap (a -> b
f a
x) (t b -> Tap t b) -> t b -> Tap t b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ t (a -> b)
fs t (a -> b) -> t a -> t b
forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b
<*> t a
xs

instance Traversable t => Traversable (Tap t) where
	Tap a
x t a
xs ->> :: Tap t a -> (a -> u b) -> (u :. Tap t) := b
->> a -> u b
f = b -> t b -> Tap t b
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap (b -> t b -> Tap t b) -> u b -> u (t b -> Tap t b)
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> a -> u b
f a
x u (t b -> Tap t b) -> u (t b) -> (u :. Tap t) := b
forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b
<*> (t a
xs t a -> (a -> u b) -> u (t 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 (Extractable t, Alternative t, Bindable t) => Bindable (Tap t) where
	Tap a
x t a
xs >>= :: Tap t a -> (a -> Tap t b) -> Tap t b
>>= a -> Tap t b
f = case a -> Tap t b
f a
x of ~(Tap b
y t b
ys) -> b -> t b -> Tap t b
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap b
y (t b -> Tap t b) -> t b -> Tap t b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ t b
ys t b -> t b -> t b
forall (t :: * -> *) a. Alternative t => t a -> t a -> t a
<+> (t a
xs t a -> (a -> t b) -> t b
forall (t :: * -> *) a b. Bindable t => t a -> (a -> t b) -> t b
>>= Tap t b -> t b
forall (t :: (* -> *) -> * -> *) (u :: * -> *).
(Lowerable t, Covariant u) =>
t u ~> u
lower (Tap t b -> t b) -> (a -> Tap t b) -> a -> t b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> Tap t b
f)

instance Extendable t => Extendable (Tap t) where
	Tap t a
x =>> :: Tap t a -> (Tap t a -> b) -> Tap t b
=>> Tap t a -> b
f = b -> t b -> Tap t b
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap (Tap t a -> b
f Tap t a
x) (t b -> Tap t b) -> t b -> Tap t b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Tap t a -> t a
forall (t :: (* -> *) -> * -> *) (u :: * -> *).
(Lowerable t, Covariant u) =>
t u ~> u
lower Tap t a
x t a -> (t a -> b) -> t b
forall (t :: * -> *) a b. Extendable t => t a -> (t a -> b) -> t b
=>> Tap t a -> b
f (Tap t a -> b) -> (t a -> Tap t a) -> t a -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> t a -> Tap t a
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap (a <-| Tap t
forall (t :: * -> *) a. Extractable t => a <-| t
extract Tap t a
x)

instance Lowerable Tap where
	lower :: Tap u ~> u
lower (Tap a
_ u a
xs) = u a
xs

instance Hoistable Tap where
	hoist :: (u ~> v) -> Tap u ~> Tap v
hoist u ~> v
f (Tap a
x u a
xs) = a -> v a -> Tap v a
forall (t :: * -> *) a. a -> t a -> Tap t a
Tap a
x (v a -> Tap v a) -> v a -> Tap v a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ u a -> v a
u ~> v
f u a
xs