{-# LANGUAGE UndecidableInstances #-}

module Pandora.Paradigm.Primary.Transformer.Day where

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.Extendable (Extendable ((<<=)))
import Pandora.Pattern.Transformer.Lowerable (Lowerable (lower))
import Pandora.Pattern.Transformer.Hoistable (Hoistable ((/|\)))
import Pandora.Paradigm.Primary.Algebraic.Exponential ((!..), (-.#..-))

data Day t u a = forall b c . Day (t b) (u c) (b -> c -> a)

instance Covariant (Day t u) (->) (->) where
	a -> b
f -<$>- :: (a -> b) -> Day t u a -> Day t u b
-<$>- Day t b
tb u c
uc b -> c -> a
g = t b -> u c -> (b -> c -> b) -> Day t u b
forall (t :: * -> *) (u :: * -> *) a b c.
t b -> u c -> (b -> c -> a) -> Day t u a
Day t b
tb u c
uc ((b -> c -> b) -> Day t u b) -> (b -> c -> b) -> Day t u b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a -> b
f (a -> b) -> (b -> c -> a) -> b -> c -> b
forall (v :: * -> * -> *) a (target :: * -> * -> *) c d b.
(Covariant (v a) (->) target, Semigroupoid v) =>
v c d -> target (v a (v b c)) (v a (v b d))
-.#..- b -> c -> a
g

instance (Pointable t (->), Pointable u (->)) => Pointable (Day t u) (->) where
	point :: a -> Day t u a
point a
x = t () -> u () -> (() -> () -> a) -> Day t u a
forall (t :: * -> *) (u :: * -> *) a b c.
t b -> u c -> (b -> c -> a) -> Day t u a
Day (t () -> u () -> (() -> () -> a) -> Day t u a)
-> t () -> u () -> (() -> () -> a) -> Day t u a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# () -> t ()
forall (t :: * -> *) (source :: * -> * -> *) a.
Pointable t source =>
source a (t a)
point () (u () -> (() -> () -> a) -> Day t u a)
-> u () -> (() -> () -> a) -> Day t u a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# () -> u ()
forall (t :: * -> *) (source :: * -> * -> *) a.
Pointable t source =>
source a (t a)
point () ((() -> () -> a) -> Day t u a) -> (() -> () -> a) -> Day t u a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# (a
x a -> () -> () -> a
forall a b c. a -> b -> c -> a
!..)

instance (Extractable t (->), Extractable u (->)) => Extractable (Day t u) (->) where
	extract :: Day t u a -> a
extract (Day t b
tb u c
uc b -> c -> a
bcad) = b -> c -> a
bcad (b -> c -> a) -> b -> c -> a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# t b -> b
forall (t :: * -> *) (source :: * -> * -> *) a.
Extractable t source =>
source (t a) a
extract t b
tb (c -> a) -> c -> a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# u c -> c
forall (t :: * -> *) (source :: * -> * -> *) a.
Extractable t source =>
source (t a) a
extract u c
uc

instance (Extendable t (->), Extendable u (->)) => Extendable (Day t u) (->) where
	Day t u a -> b
f <<= :: (Day t u a -> b) -> Day t u a -> Day t u b
<<= day :: Day t u a
day@(Day t b
tb u c
uc b -> c -> a
_) = t b -> u c -> (b -> c -> b) -> Day t u b
forall (t :: * -> *) (u :: * -> *) a b c.
t b -> u c -> (b -> c -> a) -> Day t u a
Day t b
tb u c
uc (Day t u a -> b
f Day t u a
day b -> b -> c -> b
forall a b c. a -> b -> c -> a
!..)

instance Extractable t (->) => Lowerable (Day t) where
	lower :: Day t u ~> u
lower (Day t b
tb u c
uc b -> c -> a
bca) = b -> c -> a
bca (t b -> b
forall (t :: * -> *) (source :: * -> * -> *) a.
Extractable t source =>
source (t a) a
extract t b
tb) (c -> a) -> u c -> u a
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant t source target =>
source a b -> target (t a) (t b)
-<$>- u c
uc

instance Hoistable (Day t) where
	u ~> v
g /|\ :: (u ~> v) -> Day t u ~> Day t v
/|\ Day t b
tb u c
uc b -> c -> a
bca = t b -> v c -> (b -> c -> a) -> Day t v a
forall (t :: * -> *) (u :: * -> *) a b c.
t b -> u c -> (b -> c -> a) -> Day t u a
Day t b
tb (v c -> (b -> c -> a) -> Day t v a)
-> v c -> (b -> c -> a) -> Day t v a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# u c -> v c
u ~> v
g u c
uc ((b -> c -> a) -> Day t v a) -> (b -> c -> a) -> Day t v a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# b -> c -> a
bca

data Day_ category source target t u r = forall a b .
	Day_ (target (category (source a b) r) (target (t a) (u b)))