module Data.Profunctor.Product (module Data.Profunctor.Product.Class,
module Data.Profunctor.Product.Newtype,
module Data.Profunctor.Product) where
import Prelude hiding (id)
import Data.Profunctor (Profunctor, dimap, lmap, WrappedArrow)
import qualified Data.Profunctor as Profunctor
import Data.Functor.Contravariant (Contravariant, contramap)
import Control.Category (id)
import Control.Arrow (Arrow, (***), (<<<), arr, (&&&))
import Control.Applicative (Applicative, liftA2, pure)
import Data.Monoid (Monoid, mempty, (<>))
import Data.Profunctor.Product.Newtype
import Data.Profunctor.Product.Class
import Data.Profunctor.Product.Flatten
import Data.Profunctor.Product.Tuples
import Data.Profunctor.Product.Tuples.TH (pTns, maxTupleSize, pNs)
class Contravariant f => ProductContravariant f where
point :: f ()
(***<) :: f a -> f b -> f (a, b)
(****) :: ProductProfunctor p => p a (b -> c) -> p a b -> p a c
(****) f x = Profunctor.dimap dup (uncurry ($)) (f ***! x)
where dup y = (y, y)
(***$) :: ProductProfunctor p => (b -> c) -> p a b -> p a c
(***$) = Profunctor.rmap
defaultEmpty :: Applicative (p ()) => p () ()
defaultEmpty = pure ()
defaultProfunctorProduct :: (Applicative (p (a, a')), Profunctor p)
=> p a b -> p a' b' -> p (a, a') (b, b')
defaultProfunctorProduct p p' = liftA2 (,) (lmap fst p) (lmap snd p')
defaultPoint :: Monoid (p ()) => p ()
defaultPoint = mempty
defaultContravariantProduct :: (Contravariant f, Monoid (f (a, b)))
=> f a -> f b -> f (a, b)
defaultContravariantProduct p p' = contramap fst p <> contramap snd p'
newtype PPOfContravariant f a b = PPOfContravariant (f a)
unPPOfContravariant :: PPOfContravariant c a a -> c a
unPPOfContravariant (PPOfContravariant pp) = pp
instance Contravariant f => Profunctor (PPOfContravariant f) where
dimap f _ (PPOfContravariant p) = PPOfContravariant (contramap f p)
instance ProductContravariant f => ProductProfunctor (PPOfContravariant f) where
empty = PPOfContravariant point
PPOfContravariant f ***! PPOfContravariant f' = PPOfContravariant (f ***< f')
instance ProductProfunctor (->) where
empty = id
(***!) = (***)
instance Arrow arr => ProductProfunctor (WrappedArrow arr) where
empty = id
(***!) = (***)
data AndArrow arr z a b = AndArrow { runAndArrow :: arr z b }
instance Arrow arr => Profunctor (AndArrow arr z) where
dimap _ f (AndArrow g) = AndArrow (arr f <<< g)
instance Arrow arr => ProductProfunctor (AndArrow arr z) where
empty = AndArrow (arr (const ()))
(AndArrow f) ***! (AndArrow f') = AndArrow (f &&& f')
class Profunctor p => SumProfunctor p where
(+++!) :: p a b -> p a' b' -> p (Either a a') (Either b b')
instance SumProfunctor (->) where
f +++! g = either (Left . f) (Right . g)
list :: (ProductProfunctor p, SumProfunctor p) => p a b -> p [a] [b]
list p = Profunctor.dimap fromList toList (empty +++! (p ***! list p))
where toList :: Either () (a, [a]) -> [a]
toList = either (const []) (uncurry (:))
fromList :: [a] -> Either () (a, [a])
fromList [] = Left ()
fromList (a:as) = Right (a, as)
pTns [0..maxTupleSize]
pNs [0..maxTupleSize]