module Pandora.Paradigm.Primary.Transformer.Outline where

import Pandora.Core.Morphism ((%))
import Pandora.Pattern.Category (identity, (.), ($))
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.Transformer.Liftable (Liftable (lift))
import Pandora.Pattern.Transformer.Hoistable (Hoistable (hoist))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Interpreted (Primary, run, unite))

data Outline t a where
	Line :: a -> Outline t a
	Outlined :: t a -> Outline t (a -> b) -> Outline t b

instance Covariant (Outline t) where
	a -> b
f <$> :: (a -> b) -> Outline t a -> Outline t b
<$> Line a
a = b -> Outline t b
forall a (t :: * -> *). a -> Outline t a
Line (b -> Outline t b) -> b -> Outline t b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a -> b
f a
a
	a -> b
f <$> Outlined t a
x Outline t (a -> a)
y = t a -> Outline t (a -> b) -> Outline t b
forall (t :: * -> *) a b. t a -> Outline t (a -> b) -> Outline t b
Outlined t a
x ((a -> b) -> (a -> a) -> a -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
(.) a -> b
f ((a -> a) -> a -> b) -> Outline t (a -> a) -> Outline t (a -> b)
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> Outline t (a -> a)
y)

instance Pointable (Outline t) where
	point :: a |-> Outline t
point = a |-> Outline t
forall a (t :: * -> *). a -> Outline t a
Line

instance Extractable t => Extractable (Outline t) where
	extract :: a <-| Outline t
extract (Line a
x) = a
x
	extract (Outlined t a
x Outline t (a -> a)
y) = (a -> a) <-| Outline t
forall (t :: * -> *) a. Extractable t => a <-| t
extract Outline t (a -> a)
y (a -> a) -> a -> a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a <-| t
forall (t :: * -> *) a. Extractable t => a <-| t
extract t a
x

instance Applicative (Outline f) where
	Line a -> b
f <*> :: Outline f (a -> b) -> Outline f a -> Outline f b
<*> Outline f a
y = a -> b
f (a -> b) -> Outline f a -> Outline f b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> Outline f a
y
	Outlined f a
x Outline f (a -> a -> b)
y <*> Outline f a
z = f a -> Outline f (a -> b) -> Outline f b
forall (t :: * -> *) a b. t a -> Outline t (a -> b) -> Outline t b
Outlined f a
x ((a -> a -> b) -> a -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
(%) ((a -> a -> b) -> a -> a -> b)
-> Outline f (a -> a -> b) -> Outline f (a -> a -> b)
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> Outline f (a -> a -> b)
y Outline f (a -> a -> b) -> Outline f a -> Outline f (a -> b)
forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b
<*> Outline f a
z)

instance Liftable Outline where
	lift :: u ~> Outline u
lift u a
t = u a -> Outline u (a -> a) -> Outline u a
forall (t :: * -> *) a b. t a -> Outline t (a -> b) -> Outline t b
Outlined u a
t ((a -> a) -> Outline u (a -> a)
forall a (t :: * -> *). a -> Outline t a
Line a -> a
forall (m :: * -> * -> *) a. Category m => m a a
identity)

instance Hoistable Outline where
	hoist :: (u ~> v) -> Outline u ~> Outline v
hoist u ~> v
_ (Line a
x) = a -> Outline v a
forall a (t :: * -> *). a -> Outline t a
Line a
x
	hoist u ~> v
f (Outlined u a
x Outline u (a -> a)
y) = v a -> Outline v (a -> a) -> Outline v a
forall (t :: * -> *) a b. t a -> Outline t (a -> b) -> Outline t b
Outlined (u a -> v a
u ~> v
f u a
x) ((u ~> v) -> Outline u (a -> a) -> Outline v (a -> a)
forall k (t :: (* -> *) -> k -> *) (u :: * -> *) (v :: * -> *).
(Hoistable t, Covariant u) =>
(u ~> v) -> t u ~> t v
hoist u ~> v
f Outline u (a -> a)
y)

instance (Extractable t, Pointable t, Applicative t) => Interpreted (Outline t) where
	type Primary (Outline t) a = t a
	run :: Outline t a -> Primary (Outline t) a
run (Line a
x) = a |-> t
forall (t :: * -> *) a. Pointable t => a |-> t
point a
x
	run (Outlined t a
t Outline t (a -> a)
f) = Outline t (a -> a) -> Primary (Outline t) (a -> a)
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Outline t (a -> a)
f t (a -> a) -> t a -> t a
forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b
<*> t a
t
	unite :: Primary (Outline t) a -> Outline t a
unite = a -> Outline t a
forall a (t :: * -> *). a -> Outline t a
Line (a -> Outline t a) -> (t a -> a) -> t a -> Outline t a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. t a -> a
forall (t :: * -> *) a. Extractable t => a <-| t
extract