module Generics.Pointless.Bifunctors where
import Generics.Pointless.Combinators
import Generics.Pointless.Functors
newtype BId a x = BId {unBId :: x}
newtype BConst t a x = BConst {unBConst :: t}
newtype BPar a x = Par {unPar :: a}
infixr 5 :+|
data (g :+| h) a x = BInl (g a x) | BInr (h a x)
infixr 6 :*|
data (g :*| h) a x = BProd (g a x) (h a x)
infixr 9 :@|
newtype (g :@| h) a x = BComp {unBComp :: g a (h a x)}
newtype BFix f = BFix { unBFix :: f (BFix f) (BFix f) }
type family BF (f :: * -> *) :: * -> * -> *
type family BRep (f :: * -> * -> *) a :: (* -> *)
type instance Rep (BId a) x = x
type instance Rep ((BConst t) a) x = t
type instance Rep (BPar a) x = a
type instance Rep ((g :+| h) a) x = Rep (g a) x `Either` Rep (h a) x
type instance Rep ((g :*| h) a) x = (Rep (g a) x,Rep (h a) x)
type instance Rep ((g :@| h) a) x = Rep (g a) (Rep (h a) x)
type instance BRep BId a = Id
type instance BRep (BConst t) a = Const t
type instance BRep BPar a = Const a
type instance BRep (g :+| h) a = BRep g a :+: BRep h a
type instance BRep (g :*| h) a = BRep g a :*: BRep h a
type instance BRep (g :@| h) a = BRep g a :@: BRep h a
class Bifunctor (f :: * -> * -> *) where
bmap :: BFix f -> (a -> b) -> (x -> y) -> Rep (BRep f a) x -> Rep (BRep f b) y
instance Bifunctor BId where
bmap _ p f = f
instance Bifunctor (BConst t) where
bmap _ p f = id
instance Bifunctor BPar where
bmap _ p f = p
instance (Bifunctor g,Bifunctor h) => Bifunctor (g :+| h) where
bmap _ p f (Left x) = Left (bmap (_L :: BFix g) p f x)
bmap _ p f (Right x) = Right (bmap (_L :: BFix h) p f x)
instance (Bifunctor g,Bifunctor h) => Bifunctor (g :*| h) where
bmap _ p f (x,y) = (bmap (_L :: BFix g) p f x,bmap (_L :: BFix h) p f y)
instance (Bifunctor g,Bifunctor h) => Bifunctor (g :@| h) where
bmap _ p f x = bmap (_L :: BFix g) p (bmap (_L :: BFix h) p f) x
type B d a x = Rep (BRep (BF d) a) x
class Bimu d where
binn :: B d a (d a) -> d a
bout :: d a -> B d a (d a)
pbmap :: Bifunctor (BF d) => d a -> (a -> b) -> (x -> y) -> B d a x -> B d b y
pbmap (_::d a) p f = bmap (_L :: BFix (BF d)) p f
data BI x = FixBId
type instance BF BI = BId
instance Bimu BI where
binn = id
bout = id
data BK a x = FixBConst {unFixBConst :: a}
type instance BF (BK a) = BConst a
instance Bimu (BK a) where
binn = FixBConst
bout = unFixBConst
infixr 5 :+!|
data ((a :: * -> *) :+!| (b :: * -> *)) x = FixBSum {unFixBSum :: B (a :+!| b) x ((a :+!| b) x)}
type instance BF (a :+!| b) = BF a :+| BF b
instance Bimu (a :+!| b) where
binn = FixBSum
bout = unFixBSum
infixr 6 :*!|
data ((a :: * -> *) :*!| (b :: * -> *)) x = FixBProd {unFixBProd :: B (a :*!| b) x ((a :*!| b) x)}
type instance BF (a :*!| b) = BF a :*| BF b
instance Bimu (a :*!| b) where
binn = FixBProd
bout = unFixBProd
infixr 9 :@!|
data ((a :: * -> *) :@!| (b :: * -> *)) x = FixBComp {unFixBComp :: B (a :@!| b) x ((a :@!| b) x)}
type instance BF (a :@!| b) = BF a :@| BF b
instance Bimu (a :@!| b) where
binn = FixBComp
bout = unFixBComp
type instance BF [] = BConst One :+| BPar :*| BId
instance Bimu [] where
binn (Left _) = []
binn (Right (x,xs)) = x:xs
bout [] = Left _L
bout (x:xs) = Right (x,xs)