module Pandora.Paradigm.Primary.Transformer.Day where import Pandora.Pattern ((.|..)) 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.Extendable (Extendable ((=>>))) import Pandora.Pattern.Transformer.Lowerable (Lowerable (lower)) import Pandora.Pattern.Transformer.Hoistable (Hoistable (hoist)) import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:))) 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 (a -> b f (a -> b) -> (b -> c -> a) -> b -> c -> b forall (v :: * -> * -> *) a c d b. (Category v, Covariant (v a)) => v c d -> ((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 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 forall (t :: * -> *) a. Pointable t => a |-> t point ()) (() |-> u forall (t :: * -> *) a. Pointable t => a |-> t point ()) ((() -> () -> a) -> Day t u a) -> (() -> () -> a) -> Day t u a forall (m :: * -> * -> *) a b. Category m => m a b -> m a b $ \() _ () _ -> a x instance (Applicative t, Applicative u) => Applicative (Day t u) where Day t b tb u c uc b -> c -> a -> b bcad <*> :: Day t u (a -> b) -> Day t u a -> Day t u b <*> Day t b vb u c wc b -> c -> a bca = t (Product b b) -> u (Product c c) -> (Product b b -> Product c c -> b) -> Day t u b forall (t :: * -> *) (u :: * -> *) a b c. t b -> u c -> (b -> c -> a) -> Day t u a Day (b -> b -> Product b b forall s a. s -> a -> Product s a (:*:) (b -> b -> Product b b) -> t b -> t (b -> Product b b) forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b <$> t b tb t (b -> Product b b) -> t b -> t (Product b b) forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b <*> t b vb) (c -> c -> Product c c forall s a. s -> a -> Product s a (:*:) (c -> c -> Product c c) -> u c -> u (c -> Product c c) forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b <$> u c uc u (c -> Product c c) -> u c -> u (Product c c) forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b <*> u c wc) ((Product b b -> Product c c -> b) -> Day t u b) -> (Product b b -> Product c c -> b) -> Day t u b forall (m :: * -> * -> *) a b. Category m => m a b -> m a b $ \(b b :*: b b') (c c :*: c c') -> b -> c -> a -> b bcad b b c c (a -> b) -> a -> b forall (m :: * -> * -> *) a b. Category m => m a b -> m a b $ b -> c -> a bca b b' c c' instance (Extractable t, Extractable u) => Extractable (Day t u) where extract :: a <-| Day t u extract (Day t b tb u c uc b -> c -> a bcad) = b -> c -> a bcad (b <-| t forall (t :: * -> *) a. Extractable t => a <-| t extract t b tb) (c <-| u forall (t :: * -> *) a. Extractable t => a <-| t extract u c uc) instance (Extendable t, Extendable u) => Extendable (Day t u) where day :: Day t u a day@(Day t b tb u c uc b -> c -> a _) =>> :: Day t u a -> (Day t u a -> b) -> Day t u b =>> Day t u a -> b f = 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 _ -> Day t u a -> b f Day t u a day) 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 (b <-| t forall (t :: * -> *) a. Extractable t => a <-| t extract t b tb) (c -> a) -> u c -> u a forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b <$> u c uc instance Hoistable (Day t) where hoist :: (u ~> v) -> Day t u ~> Day t v hoist u ~> v g (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 (u c -> v c u ~> v g u c uc) b -> c -> a bca