{-# LANGUAGE UndecidableInstances #-}

module Pandora.Paradigm.Primary.Transformer.Jack where

import Pandora.Pattern.Semigroupoid ((.))
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.Traversable (Traversable ((<<-)))
import Pandora.Pattern.Functor.Bindable (Bindable ((=<<)))
import Pandora.Pattern.Functor.Extendable (Extendable ((<<=)))
import Pandora.Pattern.Transformer.Liftable (Liftable (lift))
import Pandora.Pattern.Transformer.Hoistable (Hoistable ((/|\)))
import Pandora.Pattern.Object.Setoid (Setoid ((==)))
import Pandora.Pattern.Object.Chain (Chain ((<=>)))
import Pandora.Paradigm.Primary.Algebraic.Exponential ()
import Pandora.Paradigm.Primary.Object.Boolean (Boolean (False))
import Pandora.Paradigm.Primary.Object.Ordering (Ordering (Less, Greater))

data Jack t a = It a | Other (t a)

instance Covariant t (->) (->) => Covariant (Jack t) (->) (->) where
	a -> b
f -<$>- :: (a -> b) -> Jack t a -> Jack t b
-<$>- It a
x = b -> Jack t b
forall (t :: * -> *) a. a -> Jack t a
It (b -> Jack t b) -> b -> Jack t b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ a -> b
f a
x
	a -> b
f -<$>- Other t a
y = t b -> Jack t b
forall (t :: * -> *) a. t a -> Jack t a
Other (t b -> Jack t b) -> t b -> Jack t b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ a -> b
f (a -> b) -> t a -> t b
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant t source target =>
source a b -> target (t a) (t b)
-<$>- t a
y

instance Covariant t (->) (->) => Pointable (Jack t) (->) where
	point :: a -> Jack t a
point = a -> Jack t a
forall (t :: * -> *) a. a -> Jack t a
It

instance Extractable t (->) => Extractable (Jack t) (->) where
	extract :: Jack t a -> a
extract (It a
x) = a
x
	extract (Other t a
y) = t a -> a
forall (t :: * -> *) (source :: * -> * -> *) a.
Extractable t source =>
source (t a) a
extract t a
y

instance Traversable t (->) (->) => Traversable (Jack t) (->) (->) where
	a -> u b
f <<- :: (a -> u b) -> Jack t a -> u (Jack t b)
<<- It a
x = b -> Jack t b
forall (t :: * -> *) a. a -> Jack t a
It (b -> Jack t b) -> u b -> u (Jack t b)
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant t source target =>
source a b -> target (t a) (t b)
-<$>- a -> u b
f a
x
	a -> u b
f <<- Other t a
y = t b -> Jack t b
forall (t :: * -> *) a. t a -> Jack t a
Other (t b -> Jack t b) -> u (t b) -> u (Jack t b)
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant t source target =>
source a b -> target (t a) (t b)
-<$>- a -> u b
f (a -> u b) -> t a -> u (t b)
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) (u :: * -> *) a b.
(Traversable t source target, Covariant u source target,
 Pointable u target, Semimonoidal u target (:*:) (:*:)) =>
source a (u b) -> target (t a) (u (t b))
<<- t a
y

instance (Pointable t (->), Bindable t (->)) => Bindable (Jack t) (->) where
	a -> Jack t b
f =<< :: (a -> Jack t b) -> Jack t a -> Jack t b
=<< It a
x = a -> Jack t b
f a
x
	a -> Jack t b
f =<< Other t a
x = t b -> Jack t b
forall (t :: * -> *) a. t a -> Jack t a
Other (t b -> Jack t b) -> t b -> Jack t b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (b -> t b) -> (t b -> t b) -> Jack t b -> t b
forall a r (t :: * -> *). (a -> r) -> (t a -> r) -> Jack t a -> r
jack b -> t b
forall (t :: * -> *) (source :: * -> * -> *) a.
Pointable t source =>
source a (t a)
point t b -> t b
forall (m :: * -> * -> *) a. Category m => m a a
identity (Jack t b -> t b) -> (a -> Jack t b) -> a -> t b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. a -> Jack t b
f (a -> t b) -> t a -> t b
forall (t :: * -> *) (source :: * -> * -> *) a b.
Bindable t source =>
source a (t b) -> source (t a) (t b)
=<< t a
x

instance Extendable t (->) => Extendable (Jack t) (->) where
	Jack t a -> b
f <<= :: (Jack t a -> b) -> Jack t a -> Jack t b
<<= It a
x = b -> Jack t b
forall (t :: * -> *) a. a -> Jack t a
It (b -> Jack t b) -> (Jack t a -> b) -> Jack t a -> Jack t b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. Jack t a -> b
f (Jack t a -> Jack t b) -> Jack t a -> Jack t b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ a -> Jack t a
forall (t :: * -> *) a. a -> Jack t a
It a
x
	Jack t a -> b
f <<= Other t a
x = t b -> Jack t b
forall (t :: * -> *) a. t a -> Jack t a
Other (t b -> Jack t b) -> t b -> Jack t b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ Jack t a -> b
f (Jack t a -> b) -> (t a -> Jack t a) -> t a -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. t a -> Jack t a
forall (t :: * -> *) a. t a -> Jack t a
Other (t a -> b) -> t a -> t b
forall (t :: * -> *) (source :: * -> * -> *) a b.
Extendable t source =>
source (t a) b -> source (t a) (t b)
<<= t a
x

instance Liftable Jack where
	lift :: u ~> Jack u
lift = u a -> Jack u a
forall (t :: * -> *) a. t a -> Jack t a
Other

instance Hoistable Jack where
	u ~> v
_ /|\ :: (u ~> v) -> Jack u ~> Jack v
/|\ It a
x = a -> Jack v a
forall (t :: * -> *) a. a -> Jack t a
It a
x
	u ~> v
f /|\ Other u a
x = v a -> Jack v a
forall (t :: * -> *) a. t a -> Jack t a
Other (v a -> Jack v a) -> v a -> Jack v a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ u a -> v a
u ~> v
f u a
x

instance (Setoid a, Setoid (t a)) => Setoid (Jack t a) where
	It a
x == :: Jack t a -> Jack t a -> Boolean
== It a
y = a
x a -> a -> Boolean
forall a. Setoid a => a -> a -> Boolean
== a
y
	Other t a
x == Other t a
y = t a
x t a -> t a -> Boolean
forall a. Setoid a => a -> a -> Boolean
== t a
y
	Jack t a
_ == Jack t a
_ = Boolean
False

instance (Chain a, Chain (t a)) => Chain (Jack t a) where
	It a
_ <=> :: Jack t a -> Jack t a -> Ordering
<=> Other t a
_ = Ordering
Less
	Other t a
_ <=> It a
_ = Ordering
Greater
	It a
x <=> It a
y = a
x a -> a -> Ordering
forall a. Chain a => a -> a -> Ordering
<=> a
y
	Other t a
x <=> Other t a
y = t a
x t a -> t a -> Ordering
forall a. Chain a => a -> a -> Ordering
<=> t a
y

jack :: (a -> r) -> (t a -> r) -> Jack t a -> r
jack :: (a -> r) -> (t a -> r) -> Jack t a -> r
jack a -> r
f t a -> r
_ (It a
x) = a -> r
f a
x
jack a -> r
_ t a -> r
g (Other t a
y) = t a -> r
g t a
y