{-# OPTIONS_GHC -Wno-orphans #-}
module Data.HBifunctor.Tensor (
Tensor(..)
, rightIdentity
, leftIdentity
, sumLeftIdentity
, sumRightIdentity
, prodLeftIdentity
, prodRightIdentity
, MonoidIn(..)
, nilLB
, consLB
, unconsLB
, retractLB
, interpretLB
, inL
, inR
, outL
, outR
, prodOutL
, prodOutR
, WrapF(..)
, WrapLB(..)
, Matchable(..)
, splittingNE
, matchingLB
) where
import Control.Applicative.Free
import Control.Applicative.ListF
import Control.Applicative.Step
import Control.Monad.Freer.Church
import Control.Monad.Trans.Compose
import Control.Natural
import Control.Natural.IsoF
import Data.Coerce
import Data.Data
import Data.Function
import Data.Functor.Apply.Free
import Data.Functor.Bind
import Data.Functor.Classes
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Conclude
import Data.Functor.Contravariant.Decide
import Data.Functor.Contravariant.Divise
import Data.Functor.Contravariant.Divisible
import Data.Functor.Contravariant.Divisible.Free
import Data.Functor.Contravariant.Night (Night(..), Not(..))
import Data.Functor.Day (Day(..))
import Data.Functor.Identity
import Data.Functor.Invariant
import Data.Functor.Plus
import Data.Functor.Product
import Data.Functor.Sum
import Data.Functor.These
import Data.HBifunctor
import Data.HBifunctor.Associative
import Data.HBifunctor.Tensor.Internal
import Data.HFunctor
import Data.HFunctor.Chain.Internal
import Data.HFunctor.Internal
import Data.HFunctor.Interpret
import Data.List.NonEmpty (NonEmpty(..))
import Data.Void
import GHC.Generics
import qualified Data.Functor.Contravariant.Coyoneda as CCY
import qualified Data.Functor.Contravariant.Day as CD
import qualified Data.Functor.Contravariant.Night as N
import qualified Data.Functor.Day as D
import qualified Data.Functor.Invariant.Day as ID
import qualified Data.Functor.Invariant.Night as IN
import qualified Data.Map.NonEmpty as NEM
rightIdentity :: (Tensor t i, FunctorBy t f) => f <~> t f i
rightIdentity = isoF intro1 elim1
leftIdentity :: (Tensor t i, FunctorBy t g) => g <~> t i g
leftIdentity = isoF intro2 elim2
sumLeftIdentity :: f <~> V1 :+: f
sumLeftIdentity = isoF R1 (absurd1 !+! id)
sumRightIdentity :: f <~> f :+: V1
sumRightIdentity = isoF L1 (id !+! absurd1)
prodLeftIdentity :: f <~> Proxy :*: f
prodLeftIdentity = isoF (Proxy :*:) (\case _ :*: y -> y)
prodRightIdentity :: g <~> g :*: Proxy
prodRightIdentity = isoF (:*: Proxy) (\case x :*: _ -> x)
prodOutL :: f :*: g ~> f
prodOutL (x :*: _) = x
prodOutR :: f :*: g ~> g
prodOutR (_ :*: y) = y
class (Tensor t i, SemigroupIn t f) => MonoidIn t i f where
pureT :: i ~> f
default pureT :: Interpret (ListBy t) f => i ~> f
pureT = retract . reviewF (splittingLB @t) . L1
retractLB :: forall t i f. MonoidIn t i f => ListBy t f ~> f
retractLB = (pureT @t !*! biretract @t . hright (retractLB @t))
. unconsLB @t
interpretLB :: forall t i g f. MonoidIn t i f => (g ~> f) -> ListBy t g ~> f
interpretLB f = retractLB @t . hmap f
inL
:: forall t i f g. MonoidIn t i g
=> f ~> t f g
inL = hright (pureT @t) . intro1
inR
:: forall t i f g. MonoidIn t i f
=> g ~> t f g
inR = hleft (pureT @t) . intro2
outL
:: (Tensor t Proxy, FunctorBy t f)
=> t f g ~> f
outL = elim1 . hright absorb
outR
:: (Tensor t Proxy, FunctorBy t g)
=> t f g ~> g
outR = elim2 . hleft absorb
class Tensor t i => Matchable t i where
unsplitNE :: FunctorBy t f => t f (ListBy t f) ~> NonEmptyBy t f
matchLB :: FunctorBy t f => ListBy t f ~> i :+: NonEmptyBy t f
splittingNE
:: (Matchable t i, FunctorBy t f)
=> NonEmptyBy t f <~> t f (ListBy t f)
splittingNE = isoF splitNE unsplitNE
matchingLB
:: forall t i f. (Matchable t i, FunctorBy t f)
=> ListBy t f <~> i :+: NonEmptyBy t f
matchingLB = isoF (matchLB @t) (nilLB @t !*! fromNE @t)
instance Tensor (:*:) Proxy where
type ListBy (:*:) = ListF
intro1 = (:*: Proxy)
intro2 = (Proxy :*:)
elim1 (x :*: ~Proxy) = x
elim2 (~Proxy :*: y ) = y
appendLB (ListF xs :*: ListF ys) = ListF (xs ++ ys)
splitNE = nonEmptyProd
splittingLB = isoF to_ from_
where
to_ = \case
ListF [] -> L1 Proxy
ListF (x:xs) -> R1 (x :*: ListF xs)
from_ = \case
L1 ~Proxy -> ListF []
R1 (x :*: ListF xs) -> ListF (x:xs)
toListBy (x :*: y) = ListF [x, y]
instance Plus f => MonoidIn (:*:) Proxy f where
pureT _ = zero
instance Tensor Product Proxy where
type ListBy Product = ListF
intro1 = (`Pair` Proxy)
intro2 = (Proxy `Pair`)
elim1 (Pair x ~Proxy) = x
elim2 (Pair ~Proxy y) = y
appendLB (ListF xs `Pair` ListF ys) = ListF (xs ++ ys)
splitNE = viewF prodProd . nonEmptyProd
splittingLB = isoF to_ from_
where
to_ = \case
ListF [] -> L1 Proxy
ListF (x:xs) -> R1 (x `Pair` ListF xs)
from_ = \case
L1 ~Proxy -> ListF []
R1 (x `Pair` ListF xs) -> ListF (x:xs)
toListBy (Pair x y) = ListF [x, y]
instance Plus f => MonoidIn Product Proxy f where
pureT _ = zero
instance Tensor Day Identity where
type ListBy Day = Ap
intro1 = D.intro2
intro2 = D.intro1
elim1 = D.elim2
elim2 = D.elim1
appendLB (Day x y z) = z <$> x <*> y
splitNE = ap1Day
splittingLB = isoF to_ from_
where
to_ = \case
Pure x -> L1 (Identity x)
Ap x xs -> R1 (Day x xs (&))
from_ = \case
L1 (Identity x) -> Pure x
R1 (Day x xs f) -> Ap x (flip f <$> xs)
toListBy (Day x y z) = Ap x (Ap y (Pure (flip z)))
instance (Apply f, Applicative f) => MonoidIn Day Identity f where
pureT = generalize
instance Tensor CD.Day Proxy where
type ListBy CD.Day = Div
intro1 = CD.intro2
intro2 = CD.intro1
elim1 = CD.day1
elim2 = CD.day2
appendLB (CD.Day x y z) = divide z x y
splitNE = go . splitNE @(:*:) . NonEmptyF . unDiv1
where
go (CCY.Coyoneda f x :*: ListF xs) = CD.Day x (Div xs) (\y -> (f y, y))
splittingLB = isoF (ListF . unDiv) (Div . runListF) . splittingLB @(:*:) . isoF (hright to_) (hright from_)
where
to_ (CCY.Coyoneda f x :*: ListF xs) = CD.Day x (Div xs) (\y -> (f y, y))
from_ (CD.Day x (Div xs) f) = CCY.Coyoneda (fst . f) x :*: contramap (snd . f) (ListF xs)
toListBy (CD.Day x y f) = Div . runListF . toListBy $
CCY.Coyoneda (fst . f) x :*: CCY.Coyoneda (snd . f) y
instance (Divise f, Divisible f) => MonoidIn CD.Day Proxy f where
pureT _ = conquer
instance Tensor ID.Day Identity where
type ListBy ID.Day = DayChain
intro1 = ID.intro2
intro2 = ID.intro1
elim1 = ID.elim2
elim2 = ID.elim1
appendLB = coerce appendChain
splitNE = coerce splitChain1
splittingLB = coercedF . splittingChain . coercedF
toListBy = DayChain . More . hright (unDayChain . inject)
instance Matchable ID.Day Identity where
unsplitNE = coerce unsplitNEIDay_
matchLB = coerce matchLBIDay_
unsplitNEIDay_ :: Invariant f => ID.Day f (Chain ID.Day Identity f) ~> Chain1 ID.Day f
unsplitNEIDay_ (ID.Day x xs g f) = case xs of
Done (Identity r) -> Done1 $ invmap (`g` r) (fst . f) x
More ys -> More1 $ ID.Day x (unsplitNEIDay_ ys) g f
matchLBIDay_ :: Invariant f => Chain ID.Day Identity f ~> (Identity :+: Chain1 ID.Day f)
matchLBIDay_ = \case
Done x -> L1 x
More xs -> R1 $ unsplitNEIDay_ xs
instance Tensor IN.Night IN.Not where
type ListBy IN.Night = NightChain
intro1 = IN.intro2
intro2 = IN.intro1
elim1 = IN.elim2
elim2 = IN.elim1
appendLB = coerce appendChain
splitNE = coerce splitChain1
splittingLB = coercedF . splittingChain . coercedF
toListBy = NightChain . More . hright (unNightChain . inject)
instance Matchable IN.Night Not where
unsplitNE = coerce unsplitNEINight_
matchLB = coerce matchLBINight_
unsplitNEINight_ :: Invariant f => IN.Night f (Chain IN.Night Not f) ~> Chain1 IN.Night f
unsplitNEINight_ (IN.Night x xs f g h) = case xs of
Done r -> Done1 $ invmap g (either id (absurd . refute r) . f) x
More ys -> More1 $ IN.Night x (unsplitNEINight_ ys) f g h
matchLBINight_ :: Invariant f => Chain IN.Night Not f ~> (Not :+: Chain1 IN.Night f)
matchLBINight_ = \case
Done x -> L1 x
More xs -> R1 $ unsplitNEINight_ xs
instance Tensor Night Not where
type ListBy Night = Dec
intro1 = N.intro2
intro2 = N.intro1
elim1 = N.elim2
elim2 = N.elim1
appendLB (Night x y z) = decide z x y
splitNE (Dec1 f x xs) = Night x xs f
splittingLB = isoF to_ from_
where
to_ = \case
Lose f -> L1 (Not f)
Choose f x xs -> R1 (Night x xs f)
from_ = \case
L1 (Not f) -> Lose f
R1 (Night x xs f) -> Choose f x xs
toListBy (Night x y z) = Choose z x (inject y)
instance Conclude f => MonoidIn Night Not f where
pureT (Not x) = conclude x
instance Tensor (:+:) V1 where
type ListBy (:+:) = Step
intro1 = L1
intro2 = R1
elim1 = \case
L1 x -> x
R1 y -> absurd1 y
elim2 = \case
L1 x -> absurd1 x
R1 y -> y
appendLB = id !*! stepUp . R1
splitNE = stepDown
splittingLB = stepping . sumLeftIdentity
toListBy = \case
L1 x -> Step 0 x
R1 x -> Step 1 x
instance MonoidIn (:+:) V1 f where
pureT = absurd1
instance Tensor Sum V1 where
type ListBy Sum = Step
intro1 = InL
intro2 = InR
elim1 = \case
InL x -> x
InR y -> absurd1 y
elim2 = \case
InL x -> absurd1 x
InR y -> y
appendLB = id !*! stepUp . R1
splitNE = viewF sumSum . stepDown
splittingLB = stepping
. sumLeftIdentity
. overHBifunctor id sumSum
toListBy = \case
InL x -> Step 0 x
InR x -> Step 1 x
instance MonoidIn Sum V1 f where
pureT = absurd1
instance Tensor These1 V1 where
type ListBy These1 = Steps
intro1 = This1
intro2 = That1
elim1 = \case
This1 x -> x
That1 y -> absurd1 y
These1 _ y -> absurd1 y
elim2 = \case
This1 x -> absurd1 x
That1 y -> y
These1 x _ -> absurd1 x
appendLB = \case
This1 x -> x
That1 y -> stepsUp . That1 $ y
These1 x y -> x <> y
splitNE = stepsDown . flaggedVal . getComposeT
splittingLB = steppings . sumLeftIdentity
toListBy = \case
This1 x -> Steps $ NEM.singleton 0 x
That1 y -> Steps $ NEM.singleton 1 y
These1 x y -> Steps $ NEM.fromDistinctAscList ((0, x) :| [(1, y)])
instance Alt f => MonoidIn These1 V1 f where
pureT = absurd1
instance Tensor Comp Identity where
type ListBy Comp = Free
intro1 = (:>>= Identity)
intro2 = (Identity () :>>=) . const
elim1 (x :>>= y) = runIdentity . y <$> x
elim2 (x :>>= y) = y (runIdentity x)
appendLB (x :>>= y) = x >>= y
splitNE = free1Comp
splittingLB = isoF to_ from_
where
to_ :: Free f ~> Identity :+: Comp f (Free f)
to_ = foldFree' (L1 . Identity) $ \y n -> R1 $
y :>>= (from_ . n)
from_ :: Identity :+: Comp f (Free f) ~> Free f
from_ = generalize
!*! (\case x :>>= f -> liftFree x >>= f)
toListBy (x :>>= y) = liftFree x >>= (inject . y)
instance (Bind f, Monad f) => MonoidIn Comp Identity f where
pureT = generalize
instance Matchable (:*:) Proxy where
unsplitNE = ProdNonEmpty
matchLB = fromListF
instance Matchable Product Proxy where
unsplitNE = ProdNonEmpty . reviewF prodProd
matchLB = fromListF
instance Matchable Day Identity where
unsplitNE = DayAp1
matchLB = fromAp
instance Matchable CD.Day Proxy where
unsplitNE (CD.Day x (Div xs) f) = Div1 . runNonEmptyF . unsplitNE $
CCY.Coyoneda (fst . f) x :*: contramap (snd . f) (ListF xs)
matchLB = hright (Div1 . runNonEmptyF) . matchLB @(:*:) . ListF . unDiv
instance Matchable Night Not where
unsplitNE (Night x xs f) = Dec1 f x xs
matchLB = \case
Lose f -> L1 (Not f)
Choose f x xs -> R1 (Dec1 f x xs)
instance Matchable (:+:) V1 where
unsplitNE = stepUp
matchLB = R1
instance Matchable Sum V1 where
unsplitNE = stepUp . reviewF sumSum
matchLB = R1
newtype WrapF f a = WrapF { unwrapF :: f a }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
instance Show1 f => Show1 (WrapF f) where
liftShowsPrec sp sl d (WrapF x) = showsUnaryWith (liftShowsPrec sp sl) "WrapF" d x
instance Eq1 f => Eq1 (WrapF f) where
liftEq eq (WrapF x) (WrapF y) = liftEq eq x y
instance Ord1 f => Ord1 (WrapF f) where
liftCompare c (WrapF x) (WrapF y) = liftCompare c x y
instance Tensor t i => Tensor (WrapHBF t) (WrapF i) where
type ListBy (WrapHBF t) = ListBy t
intro1 = WrapHBF . hright WrapF . intro1
intro2 = WrapHBF . hleft WrapF . intro2
elim1 = elim1 . hright unwrapF . unwrapHBF
elim2 = elim2 . hleft unwrapF . unwrapHBF
appendLB = appendLB . unwrapHBF
splitNE = WrapHBF . splitNE
splittingLB = splittingLB @t
. overHBifunctor (isoF WrapF unwrapF) (isoF WrapHBF unwrapHBF)
toListBy = toListBy . unwrapHBF
fromNE = fromNE @t
newtype WrapLB t f a = WrapLB { unwrapLB :: ListBy t f a }
instance Functor (ListBy t f) => Functor (WrapLB t f) where
fmap f (WrapLB x) = WrapLB (fmap f x)
instance Contravariant (ListBy t f) => Contravariant (WrapLB t f) where
contramap f (WrapLB x) = WrapLB (contramap f x)
instance Invariant (ListBy t f) => Invariant (WrapLB t f) where
invmap f g (WrapLB x) = WrapLB (invmap f g x)
instance (Tensor t i, FunctorBy t f, FunctorBy t (WrapLB t f)) => SemigroupIn (WrapHBF t) (WrapLB t f) where
biretract = WrapLB . appendLB . hbimap unwrapLB unwrapLB . unwrapHBF
binterpret f g = biretract . hbimap f g
instance (Tensor t i, FunctorBy t f, FunctorBy t (WrapLB t f)) => MonoidIn (WrapHBF t) (WrapF i) (WrapLB t f) where
pureT = WrapLB . nilLB @t . unwrapF