{-# LANGUAGE TemplateHaskell #-}
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, Star(..), Costar)
import qualified Data.Profunctor as Profunctor
import Data.Profunctor.Composition (Procompose(..))
import Data.Functor.Contravariant (Contravariant, contramap)
import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable, chosen)
import Control.Category (id)
import Control.Arrow (Arrow, (***), (<<<), arr, (&&&), ArrowChoice, (+++))
import Control.Applicative (Applicative, liftA2, pure, (<*>), Alternative, (<|>), (<$>))
import Data.Monoid (Monoid, mempty, (<>))
import Data.Tagged
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Joker
import Data.Bifunctor.Product
import Data.Bifunctor.Tannen
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)
(***$) :: ProductProfunctor p => (b -> c) -> p a b -> p a c
(***$) = Profunctor.rmap
instance ProductProfunctor (->) where
purePP = pure
(****) = (<*>)
instance Arrow arr => ProductProfunctor (WrappedArrow arr) where
empty = id
(***!) = (***)
instance ProductProfunctor Tagged where
purePP = pure
(****) = (<*>)
instance Applicative f => ProductProfunctor (Star f) where
purePP = pure
(****) = (<*>)
instance Functor f => ProductProfunctor (Costar f) where
purePP = pure
(****) = (<*>)
instance (ProductProfunctor p, ProductProfunctor q) => ProductProfunctor (Procompose p q) where
purePP a = Procompose (purePP a) (purePP ())
Procompose pf qf **** Procompose pa qa =
Procompose (lmap fst pf **** lmap snd pa) ((,) ***$ qf **** qa)
instance (Functor f, Applicative g, ProductProfunctor p) => ProductProfunctor (Biff p f g) where
purePP = Biff . purePP . pure
Biff abc **** Biff ab = Biff $ (<*>) ***$ abc **** ab
instance Applicative f => ProductProfunctor (Joker f) where
purePP = Joker . pure
Joker bc **** Joker b = Joker $ bc <*> b
instance Divisible f => ProductProfunctor (Clown f) where
purePP _ = Clown conquer
Clown l **** Clown r = Clown $ divide (\a -> (a, a)) l r
instance (ProductProfunctor p, ProductProfunctor q) => ProductProfunctor (Product p q) where
purePP a = Pair (purePP a) (purePP a)
Pair l1 l2 **** Pair r1 r2 = Pair (l1 **** r1) (l2 **** r2)
instance (Applicative f, ProductProfunctor p) => ProductProfunctor (Tannen f p) where
purePP = Tannen . pure . purePP
Tannen f **** Tannen a = Tannen $ liftA2 (****) f a
instance SumProfunctor (->) where
f +++! g = either (Left . f) (Right . g)
instance ArrowChoice arr => SumProfunctor (WrappedArrow arr) where
(+++!) = (+++)
instance Applicative f => SumProfunctor (Star f) where
Star f +++! Star g = Star $ either (fmap Left . f) (fmap Right . g)
instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Procompose p q) where
Procompose pa qa +++! Procompose pb qb = Procompose (pa +++! pb) (qa +++! qb)
instance Alternative f => SumProfunctor (Joker f) where
Joker f +++! Joker g = Joker $ Left <$> f <|> Right <$> g
instance Decidable f => SumProfunctor (Clown f) where
Clown f +++! Clown g = Clown $ chosen f g
instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Product p q) where
Pair l1 l2 +++! Pair r1 r2 = Pair (l1 +++! r1) (l2 +++! r2)
instance (Applicative f, SumProfunctor p) => SumProfunctor (Tannen f p) where
Tannen l +++! Tannen r = Tannen $ liftA2 (+++!) l r
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]
{-# DEPRECATED defaultEmpty "Use pure () instead" #-}
defaultEmpty :: Applicative (p ()) => p () ()
defaultEmpty = pure ()
{-# DEPRECATED defaultProfunctorProduct "Use \\p p' -> liftA2 (,) (lmap fst p) (lmap snd p') instead" #-}
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')
{-# DEPRECATED defaultPoint "Use mempty instead" #-}
defaultPoint :: Monoid (p ()) => p ()
defaultPoint = mempty