{-# LANGUAGE DerivingVia #-}
module Data.HBifunctor (
HBifunctor(..)
, WrappedHBifunctor(..)
, overHBifunctor
, LeftF(..)
, RightF(..)
) where
import Control.Natural.IsoF
import Data.Biapplicative
import Data.Bifunctor.TH
import Data.Data
import Data.Deriving
import Data.HFunctor
import Data.HFunctor.Internal
import Data.HFunctor.Interpret
import GHC.Generics
overHBifunctor
:: HBifunctor t
=> (f <~> f')
-> (g <~> g')
-> t f g <~> t f' g'
overHBifunctor f g =
isoF (hbimap (viewF f) (viewF g))
(hbimap (reviewF f) (reviewF g))
newtype LeftF f g a = LeftF { runLeftF :: f a }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''LeftF
deriveRead1 ''LeftF
deriveEq1 ''LeftF
deriveOrd1 ''LeftF
deriveBifunctor ''LeftF
deriveBifoldable ''LeftF
deriveBitraversable ''LeftF
instance Applicative f => Biapplicative (LeftF f) where
bipure _ y = LeftF (pure y)
LeftF x <<*>> LeftF y = LeftF (x <*> y)
instance HBifunctor LeftF where
hbimap f _ (LeftF x) = LeftF (f x)
deriving via (WrappedHBifunctor LeftF f)
instance HFunctor (LeftF f)
newtype RightF f g a = RightF { runRightF :: g a }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''RightF
deriveRead1 ''RightF
deriveEq1 ''RightF
deriveOrd1 ''RightF
instance HBifunctor RightF where
hbimap _ g (RightF x) = RightF (g x)
deriving via (WrappedHBifunctor RightF g)
instance HFunctor (RightF g)
instance HFunctor (RightF g) where
hmap f (RightF x) = RightF (f x)
instance Inject (RightF g) where
inject = RightF
instance HBind (RightF g) where
hbind f (RightF x) = f x
instance Interpret (RightF g) f where
retract (RightF x) = x
interpret f (RightF x) = f x