module Pandora.Paradigm.Primary.Functor.Tagged where

import Pandora.Core.Functor (type (:=>), type (~>))
import Pandora.Pattern.Category ((.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Pointable (Pointable (point))
import Pandora.Pattern.Functor.Applicative (Applicative ((<*>)))
import Pandora.Pattern.Functor.Traversable (Traversable ((->>)))
import Pandora.Pattern.Functor.Distributive (Distributive ((>>-)))
import Pandora.Pattern.Functor.Bindable (Bindable ((>>=)))
import Pandora.Pattern.Functor.Extendable (Extendable ((=>>)))
import Pandora.Pattern.Functor.Monad (Monad)
import Pandora.Pattern.Functor.Comonad (Comonad)
import Pandora.Pattern.Functor.Bivariant (Bivariant ((<->)))
import Pandora.Pattern.Object.Setoid (Setoid ((==)))
import Pandora.Pattern.Object.Chain (Chain ((<=>)))
import Pandora.Pattern.Object.Semigroup (Semigroup ((+)))
import Pandora.Pattern.Object.Monoid (Monoid (zero))
import Pandora.Pattern.Object.Ringoid (Ringoid ((*)))
import Pandora.Pattern.Object.Quasiring (Quasiring (one))
import Pandora.Pattern.Object.Semilattice (Infimum ((/\)), Supremum ((\/)))
import Pandora.Pattern.Object.Lattice (Lattice)
import Pandora.Pattern.Object.Group (Group (invert))

newtype Tagged tag a = Tag a

infixr 0 :#
type (:#) tag = Tagged tag

instance Covariant (Tagged tag) where
	a -> b
f <$> :: (a -> b) -> Tagged tag a -> Tagged tag b
<$> Tag a
x = b -> Tagged tag b
forall k (tag :: k) a. a -> Tagged tag a
Tag (b -> Tagged tag b) -> b -> Tagged tag b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a -> b
f a
x

instance Pointable (Tagged tag) where
	point :: a :=> Tagged tag
point = a :=> Tagged tag
forall k (tag :: k) a. a -> Tagged tag a
Tag

instance Extractable (Tagged tag) where
	extract :: a <:= Tagged tag
extract (Tag a
x) = a
x

instance Applicative (Tagged tag) where
	Tag a -> b
f <*> :: Tagged tag (a -> b) -> Tagged tag a -> Tagged tag b
<*> Tag a
x = b -> Tagged tag b
forall k (tag :: k) a. a -> Tagged tag a
Tag (b -> Tagged tag b) -> b -> Tagged tag b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a -> b
f a
x

instance Traversable (Tagged tag) where
	Tag a
x ->> :: Tagged tag a -> (a -> u b) -> (u :. Tagged tag) := b
->> a -> u b
f = b -> Tagged tag b
forall k (tag :: k) a. a -> Tagged tag a
Tag (b -> Tagged tag b) -> u b -> (u :. Tagged tag) := b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> a -> u b
f a
x

instance Distributive (Tagged tag) where
	u a
x >>- :: u a -> (a -> Tagged tag b) -> (Tagged tag :. u) := b
>>- a -> Tagged tag b
f = u b -> (Tagged tag :. u) := b
forall k (tag :: k) a. a -> Tagged tag a
Tag (u b -> (Tagged tag :. u) := b) -> u b -> (Tagged tag :. u) := b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ b <:= Tagged tag
forall (t :: * -> *) a. Extractable t => a <:= t
extract (b <:= Tagged tag) -> (a -> Tagged tag b) -> a -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> Tagged tag b
f (a -> b) -> u a -> u b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> u a
x

instance Bindable (Tagged tag) where
	Tag a
x >>= :: Tagged tag a -> (a -> Tagged tag b) -> Tagged tag b
>>= a -> Tagged tag b
f = a -> Tagged tag b
f a
x

instance Monad (Tagged tag)

instance Extendable (Tagged tag) where
	Tagged tag a
x =>> :: Tagged tag a -> (Tagged tag a -> b) -> Tagged tag b
=>> Tagged tag a -> b
f = b -> Tagged tag b
forall k (tag :: k) a. a -> Tagged tag a
Tag (b -> Tagged tag b)
-> (Tagged tag a -> b) -> Tagged tag a -> Tagged tag b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Tagged tag a -> b
f (Tagged tag a -> Tagged tag b) -> Tagged tag a -> Tagged tag b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Tagged tag a
x

instance Comonad (Tagged tag)

instance Bivariant Tagged where
	a -> b
_ <-> :: (a -> b) -> (c -> d) -> Tagged a c -> Tagged b d
<-> c -> d
g = \(Tag c
x) -> d -> Tagged b d
forall k (tag :: k) a. a -> Tagged tag a
Tag (d -> Tagged b d) -> d -> Tagged b d
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ c -> d
g c
x

instance Setoid a => Setoid (Tagged tag a) where
	Tag a
x == :: Tagged tag a -> Tagged tag a -> Boolean
== Tag a
y = a
x a -> a -> Boolean
forall a. Setoid a => a -> a -> Boolean
== a
y

instance Chain a => Chain (Tagged tag a) where
	Tag a
x <=> :: Tagged tag a -> Tagged tag a -> Ordering
<=> Tag a
y = a
x a -> a -> Ordering
forall a. Chain a => a -> a -> Ordering
<=> a
y

instance Semigroup a => Semigroup (Tagged tag a) where
	Tag a
x + :: Tagged tag a -> Tagged tag a -> Tagged tag a
+ Tag a
y = a -> Tagged tag a
forall k (tag :: k) a. a -> Tagged tag a
Tag (a -> Tagged tag a) -> a -> Tagged tag a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
y

instance Monoid a => Monoid (Tagged tag a) where
	 zero :: Tagged tag a
zero = a -> Tagged tag a
forall k (tag :: k) a. a -> Tagged tag a
Tag a
forall a. Monoid a => a
zero

instance Ringoid a => Ringoid (Tagged tag a) where
	Tag a
x * :: Tagged tag a -> Tagged tag a -> Tagged tag a
* Tag a
y = a -> Tagged tag a
forall k (tag :: k) a. a -> Tagged tag a
Tag (a -> Tagged tag a) -> a -> Tagged tag a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a
x a -> a -> a
forall a. Ringoid a => a -> a -> a
* a
y

instance Quasiring a => Quasiring (Tagged tag a) where
	one :: Tagged tag a
one = a -> Tagged tag a
forall k (tag :: k) a. a -> Tagged tag a
Tag a
forall a. Quasiring a => a
one

instance Infimum a => Infimum (Tagged tag a) where
	Tag a
x /\ :: Tagged tag a -> Tagged tag a -> Tagged tag a
/\ Tag a
y = a -> Tagged tag a
forall k (tag :: k) a. a -> Tagged tag a
Tag (a -> Tagged tag a) -> a -> Tagged tag a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a
x a -> a -> a
forall a. Infimum a => a -> a -> a
/\ a
y

instance Supremum a => Supremum (Tagged tag a) where
	Tag a
x \/ :: Tagged tag a -> Tagged tag a -> Tagged tag a
\/ Tag a
y = a -> Tagged tag a
forall k (tag :: k) a. a -> Tagged tag a
Tag (a -> Tagged tag a) -> a -> Tagged tag a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a
x a -> a -> a
forall a. Supremum a => a -> a -> a
\/ a
y

instance Lattice a => Lattice (Tagged tag a) where

instance Group a => Group (Tagged tag a) where
	invert :: Tagged tag a -> Tagged tag a
invert (Tag a
x) = a -> Tagged tag a
forall k (tag :: k) a. a -> Tagged tag a
Tag (a -> Tagged tag a) -> a -> Tagged tag a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a -> a
forall a. Group a => a -> a
invert a
x

retag :: forall new old . Tagged old ~> Tagged new
retag :: Tagged old a -> Tagged new a
retag (Tag a
x) = a -> Tagged new a
forall k (tag :: k) a. a -> Tagged tag a
Tag a
x

tagself :: a :=> Tagged a
tagself :: a :=> Tagged a
tagself = a :=> Tagged a
forall k (tag :: k) a. a -> Tagged tag a
Tag