{-# LANGUAGE DerivingVia #-}
module Data.HBifunctor.Associative (
Associative(..)
, assoc
, disassoc
, SemigroupIn(..)
, matchingNE
, retractNE
, interpretNE
, biget
, bicollect
, (!*!)
, (!$!)
, (!+!)
, WrapHBF(..)
, WrapNE(..)
) where
import Control.Applicative
import Control.Applicative.ListF
import Control.Applicative.Step
import Control.Monad.Freer.Church
import Control.Monad.Trans.Compose
import Control.Monad.Trans.Identity
import Control.Natural
import Control.Natural.IsoF
import Data.Bifunctor.Joker
import Data.Coerce
import Data.Data
import Data.Foldable
import Data.Functor.Apply.Free
import Data.Functor.Bind
import Data.Functor.Classes
import Data.Functor.Day (Day(..))
import Data.Functor.Identity
import Data.Functor.Plus
import Data.Functor.Product
import Data.Functor.Sum
import Data.Functor.These
import Data.HBifunctor
import Data.HFunctor
import Data.HFunctor.Internal
import Data.HFunctor.Interpret
import Data.Kind
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Generics
import qualified Data.Functor.Day as D
import qualified Data.Map.NonEmpty as NEM
class (HBifunctor t, Inject (NonEmptyBy t)) => Associative t where
type NonEmptyBy t :: (Type -> Type) -> Type -> Type
associating
:: (Functor f, Functor g, Functor h)
=> t f (t g h) <~> t (t f g) h
appendNE :: t (NonEmptyBy t f) (NonEmptyBy t f) ~> NonEmptyBy t f
matchNE :: Functor f => NonEmptyBy t f ~> f :+: t f (NonEmptyBy t f)
consNE :: t f (NonEmptyBy t f) ~> NonEmptyBy t f
consNE = appendNE . hleft inject
toNonEmptyBy :: t f f ~> NonEmptyBy t f
toNonEmptyBy = consNE . hright inject
{-# MINIMAL associating, appendNE, matchNE #-}
assoc
:: (Associative t, Functor f, Functor g, Functor h)
=> t f (t g h)
~> t (t f g) h
assoc = viewF associating
disassoc
:: (Associative t, Functor f, Functor g, Functor h)
=> t (t f g) h
~> t f (t g h)
disassoc = reviewF associating
class Associative t => SemigroupIn t f where
biretract :: t f f ~> f
default biretract :: Interpret (NonEmptyBy t) f => t f f ~> f
biretract = retract . consNE . hright inject
binterpret
:: g ~> f
-> h ~> f
-> t g h ~> f
default binterpret :: Interpret (NonEmptyBy t) f => (g ~> f) -> (h ~> f) -> t g h ~> f
binterpret f g = retract . toNonEmptyBy . hbimap f g
retractNE :: forall t f. (SemigroupIn t f, Functor f) => NonEmptyBy t f ~> f
retractNE = (id !*! biretract @t . hright (retractNE @t))
. matchNE @t
interpretNE :: forall t g f. (SemigroupIn t f, Functor f) => (g ~> f) -> NonEmptyBy t g ~> f
interpretNE f = retractNE @t . hmap f
matchingNE :: (Associative t, Functor f) => NonEmptyBy t f <~> f :+: t f (NonEmptyBy t f)
matchingNE = isoF matchNE (inject !*! consNE)
biget
:: SemigroupIn t (Const b)
=> (forall x. f x -> b)
-> (forall x. g x -> b)
-> t f g a
-> b
biget f g = getConst . binterpret (Const . f) (Const . g)
(!$!)
:: SemigroupIn t (Const b)
=> (forall x. f x -> b)
-> (forall x. g x -> b)
-> t f g a
-> b
(!$!) = biget
infixr 5 !$!
(!*!)
:: SemigroupIn t h
=> (f ~> h)
-> (g ~> h)
-> t f g
~> h
(!*!) = binterpret
infixr 5 !*!
(!+!)
:: (f ~> h)
-> (g ~> h)
-> (f :+: g)
~> h
(!+!) f g = \case
L1 x -> f x
R1 y -> g y
infixr 5 !+!
bicollect
:: SemigroupIn t (Const [b])
=> (forall x. f x -> b)
-> (forall x. g x -> b)
-> t f g a
-> [b]
bicollect f g = biget ((:[]) . f) ((:[]) . g)
instance Associative (:*:) where
type NonEmptyBy (:*:) = NonEmptyF
associating = isoF to_ from_
where
to_ (x :*: (y :*: z)) = (x :*: y) :*: z
from_ ((x :*: y) :*: z) = x :*: (y :*: z)
appendNE (NonEmptyF xs :*: NonEmptyF ys) = NonEmptyF (xs <> ys)
matchNE x = case ys of
L1 ~Proxy -> L1 y
R1 zs -> R1 $ y :*: zs
where
y :*: ys = fromListF `hright` nonEmptyProd x
consNE (x :*: NonEmptyF xs) = NonEmptyF $ x :| toList xs
toNonEmptyBy (x :*: y ) = NonEmptyF $ x :| [y]
instance Alt f => SemigroupIn (:*:) f where
biretract (x :*: y) = x <!> y
binterpret f g (x :*: y) = f x <!> g y
instance Associative Product where
type NonEmptyBy Product = NonEmptyF
associating = isoF to_ from_
where
to_ (Pair x (Pair y z)) = Pair (Pair x y) z
from_ (Pair (Pair x y) z) = Pair x (Pair y z)
appendNE (NonEmptyF xs `Pair` NonEmptyF ys) = NonEmptyF (xs <> ys)
matchNE x = case ys of
L1 ~Proxy -> L1 y
R1 zs -> R1 $ Pair y zs
where
y :*: ys = fromListF `hright` nonEmptyProd x
consNE (x `Pair` NonEmptyF xs) = NonEmptyF $ x :| toList xs
toNonEmptyBy (x `Pair` y ) = NonEmptyF $ x :| [y]
instance Alt f => SemigroupIn Product f where
biretract (Pair x y) = x <!> y
binterpret f g (Pair x y) = f x <!> g y
instance Associative Day where
type NonEmptyBy Day = Ap1
associating = isoF D.assoc D.disassoc
appendNE (Day x y z) = z <$> x <.> y
matchNE a = case fromAp `hright` ap1Day a of
Day x y z -> case y of
L1 (Identity y') -> L1 $ (`z` y') <$> x
R1 ys -> R1 $ Day x ys z
consNE (Day x y z) = Ap1 x $ flip z <$> toAp y
toNonEmptyBy (Day x y z) = z <$> inject x <.> inject y
instance Apply f => SemigroupIn Day f where
biretract (Day x y z) = z <$> x <.> y
binterpret f g (Day x y z) = z <$> f x <.> g y
instance Associative (:+:) where
type NonEmptyBy (:+:) = Step
associating = isoF to_ from_
where
to_ = \case
L1 x -> L1 (L1 x)
R1 (L1 y) -> L1 (R1 y)
R1 (R1 z) -> R1 z
from_ = \case
L1 (L1 x) -> L1 x
L1 (R1 y) -> R1 (L1 y)
R1 z -> R1 (R1 z)
appendNE = \case
L1 (Step i x) -> Step (i + 1) x
R1 (Step i y) -> Step (i + 2) y
matchNE = hright stepDown . stepDown
consNE = stepUp . R1 . stepUp
toNonEmptyBy = \case
L1 x -> Step 1 x
R1 y -> Step 2 y
instance SemigroupIn (:+:) f where
biretract = \case
L1 x -> x
R1 y -> y
binterpret f g = \case
L1 x -> f x
R1 y -> g y
instance Associative Sum where
type NonEmptyBy Sum = Step
associating = isoF to_ from_
where
to_ = \case
InL x -> InL (InL x)
InR (InL y) -> InL (InR y)
InR (InR z) -> InR z
from_ = \case
InL (InL x) -> InL x
InL (InR y) -> InR (InL y)
InR z -> InR (InR z)
appendNE = \case
InL (Step i x) -> Step (i + 1) x
InR (Step i y) -> Step (i + 2) y
matchNE = hright (viewF sumSum . stepDown) . stepDown
consNE = stepUp . R1 . stepUp . reviewF sumSum
toNonEmptyBy = \case
InL x -> Step 1 x
InR y -> Step 2 y
instance SemigroupIn Sum f where
biretract = \case
InR x -> x
InL y -> y
binterpret f g = \case
InL x -> f x
InR y -> g y
instance Associative These1 where
type NonEmptyBy These1 = ComposeT Flagged Steps
associating = isoF to_ from_
where
to_ = \case
This1 x -> This1 (This1 x )
That1 (This1 y ) -> This1 (That1 y)
That1 (That1 z) -> That1 z
That1 (These1 y z) -> These1 (That1 y) z
These1 x (This1 y ) -> This1 (These1 x y)
These1 x (That1 z) -> These1 (This1 x ) z
These1 x (These1 y z) -> These1 (These1 x y) z
from_ = \case
This1 (This1 x ) -> This1 x
This1 (That1 y) -> That1 (This1 y )
This1 (These1 x y) -> These1 x (This1 y )
That1 z -> That1 (That1 z)
These1 (This1 x ) z -> These1 x (That1 z)
These1 (That1 y) z -> That1 (These1 y z)
These1 (These1 x y) z -> These1 x (These1 y z)
appendNE s = ComposeT $ case s of
This1 (ComposeT (Flagged _ q)) ->
Flagged True q
That1 (ComposeT (Flagged b q)) ->
Flagged b (stepsUp (That1 q))
These1 (ComposeT (Flagged a q)) (ComposeT (Flagged b r)) ->
Flagged (a || b) (q <> r)
matchNE (ComposeT (Flagged isImpure q)) = case stepsDown q of
This1 x
| isImpure -> R1 $ This1 x
| otherwise -> L1 x
That1 y -> R1 . That1 . ComposeT $ Flagged isImpure y
These1 x y -> R1 . These1 x . ComposeT $ Flagged isImpure y
consNE s = ComposeT $ case s of
This1 x -> Flagged True (inject x)
That1 (ComposeT (Flagged b y)) -> Flagged b (stepsUp (That1 y))
These1 x (ComposeT (Flagged b y)) -> Flagged b (stepsUp (These1 x y))
toNonEmptyBy s = ComposeT $ case s of
This1 x -> Flagged True . Steps $ NEM.singleton 0 x
That1 y -> Flagged False . Steps $ NEM.singleton 1 y
These1 x y -> Flagged False . Steps $ NEM.fromDistinctAscList $ (0, x) :| [(1, y)]
instance Alt f => SemigroupIn These1 f where
biretract = \case
This1 x -> x
That1 y -> y
These1 x y -> x <!> y
binterpret f g = \case
This1 x -> f x
That1 y -> g y
These1 x y -> f x <!> g y
instance Associative Void3 where
type NonEmptyBy Void3 = IdentityT
associating = isoF coerce coerce
appendNE = \case {}
matchNE = L1 . runIdentityT
consNE = \case {}
toNonEmptyBy = \case {}
instance SemigroupIn Void3 f where
biretract = \case {}
binterpret _ _ = \case {}
instance Associative Comp where
type NonEmptyBy Comp = Free1
associating = isoF to_ from_
where
to_ (x :>>= y) = (x :>>= (unComp . y)) :>>= id
from_ ((x :>>= y) :>>= z) = x :>>= ((:>>= z) . y)
appendNE (x :>>= y) = x >>- y
matchNE = matchFree1
consNE (x :>>= y) = liftFree1 x >>- y
toNonEmptyBy (x :>>= g) = liftFree1 x >>- inject . g
instance Bind f => SemigroupIn Comp f where
biretract (x :>>= y) = x >>- y
binterpret f g (x :>>= y) = f x >>- (g . y)
instance Associative Joker where
type NonEmptyBy Joker = Flagged
associating = isoF (Joker . Joker . runJoker)
(Joker . runJoker . runJoker)
appendNE (Joker (Flagged _ x)) = Flagged True x
matchNE (Flagged False x) = L1 x
matchNE (Flagged True x) = R1 $ Joker x
instance SemigroupIn Joker f where
biretract = runJoker
binterpret f _ = f . runJoker
instance Associative LeftF where
type NonEmptyBy LeftF = Flagged
associating = isoF (LeftF . LeftF . runLeftF)
(LeftF . runLeftF . runLeftF)
appendNE = hbind (Flagged True) . runLeftF
matchNE (Flagged False x) = L1 x
matchNE (Flagged True x) = R1 $ LeftF x
consNE = Flagged True . runLeftF
toNonEmptyBy = Flagged True . runLeftF
instance SemigroupIn LeftF f where
biretract = runLeftF
binterpret f _ = f . runLeftF
instance Associative RightF where
type NonEmptyBy RightF = Step
associating = isoF (RightF . runRightF . runRightF)
(RightF . RightF . runRightF)
appendNE = stepUp . R1 . runRightF
matchNE = hright RightF . stepDown
consNE = stepUp . R1 . runRightF
toNonEmptyBy = Step 1 . runRightF
instance SemigroupIn RightF f where
biretract = runRightF
binterpret _ g = g . runRightF
newtype WrapHBF t f g a = WrapHBF { unwrapHBF :: t f g a }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
instance Show1 (t f g) => Show1 (WrapHBF t f g) where
liftShowsPrec sp sl d (WrapHBF x) = showsUnaryWith (liftShowsPrec sp sl) "WrapHBF" d x
instance Eq1 (t f g) => Eq1 (WrapHBF t f g) where
liftEq eq (WrapHBF x) (WrapHBF y) = liftEq eq x y
instance Ord1 (t f g) => Ord1 (WrapHBF t f g) where
liftCompare c (WrapHBF x) (WrapHBF y) = liftCompare c x y
instance HBifunctor t => HBifunctor (WrapHBF t) where
hbimap f g (WrapHBF x) = WrapHBF (hbimap f g x)
hleft f (WrapHBF x) = WrapHBF (hleft f x)
hright g (WrapHBF x) = WrapHBF (hright g x)
deriving via (WrappedHBifunctor (WrapHBF t) f)
instance HBifunctor t => HFunctor (WrapHBF t f)
instance Associative t => Associative (WrapHBF t) where
type NonEmptyBy (WrapHBF t) = NonEmptyBy t
associating = isoF (hright unwrapHBF . unwrapHBF) (WrapHBF . hright WrapHBF)
. associating @t
. isoF (WrapHBF . hleft WrapHBF) (hleft unwrapHBF . unwrapHBF)
appendNE = appendNE . unwrapHBF
matchNE = hright WrapHBF . matchNE
consNE = consNE . unwrapHBF
toNonEmptyBy = toNonEmptyBy . unwrapHBF
newtype WrapNE t f a = WrapNE { unwrapNE :: NonEmptyBy t f a }
instance Associative t => SemigroupIn (WrapHBF t) (WrapNE t f) where
biretract = WrapNE . appendNE . hbimap unwrapNE unwrapNE . unwrapHBF
binterpret f g = biretract . hbimap f g