{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE RoleAnnotations #-}
#endif
#if __GLASGOW_HASKELL__ >= 711
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Control.Lens.Internal.Bazaar
( Bizarre(..)
, Bazaar(..), Bazaar'
, BazaarT(..), BazaarT'
, Bizarre1(..)
, Bazaar1(..), Bazaar1'
, BazaarT1(..), BazaarT1'
) where
import Control.Applicative
import Control.Arrow as Arrow
import Control.Category
import Control.Comonad
import Control.Lens.Internal.Context
import Control.Lens.Internal.Indexed
import Data.Functor.Apply
import Data.Functor.Compose
import Data.Functor.Contravariant
import Data.Functor.Identity
import Data.Semigroup
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Data.Profunctor.Unsafe
import Prelude hiding ((.),id)
class Profunctor p => Bizarre p w | w -> p where
bazaar :: Applicative f => p a (f b) -> w a b t -> f t
newtype Bazaar p a b t = Bazaar { runBazaar :: forall f. Applicative f => p a (f b) -> f t }
type Bazaar' p a = Bazaar p a a
instance IndexedFunctor (Bazaar p) where
ifmap f (Bazaar k) = Bazaar (fmap f . k)
{-# INLINE ifmap #-}
instance Conjoined p => IndexedComonad (Bazaar p) where
iextract (Bazaar m) = runIdentity $ m (arr Identity)
{-# INLINE iextract #-}
iduplicate (Bazaar m) = getCompose $ m (Compose #. distrib sell . sell)
{-# INLINE iduplicate #-}
instance Corepresentable p => Sellable p (Bazaar p) where
sell = cotabulate $ \ w -> Bazaar $ tabulate $ \k -> pure (cosieve k w)
{-# INLINE sell #-}
instance Profunctor p => Bizarre p (Bazaar p) where
bazaar g (Bazaar f) = f g
{-# INLINE bazaar #-}
instance Functor (Bazaar p a b) where
fmap = ifmap
{-# INLINE fmap #-}
instance Apply (Bazaar p a b) where
Bazaar mf <.> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb
{-# INLINE (<.>) #-}
instance Applicative (Bazaar p a b) where
pure a = Bazaar $ \_ -> pure a
{-# INLINE pure #-}
Bazaar mf <*> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb
{-# INLINE (<*>) #-}
instance (a ~ b, Conjoined p) => Comonad (Bazaar p a b) where
extract = iextract
{-# INLINE extract #-}
duplicate = iduplicate
{-# INLINE duplicate #-}
instance (a ~ b, Conjoined p) => ComonadApply (Bazaar p a b) where
(<@>) = (<*>)
{-# INLINE (<@>) #-}
newtype BazaarT p (g :: * -> *) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t }
#if __GLASGOW_HASKELL__ >= 707
type role BazaarT representational nominal nominal nominal nominal
#endif
type BazaarT' p g a = BazaarT p g a a
instance IndexedFunctor (BazaarT p g) where
ifmap f (BazaarT k) = BazaarT (fmap f . k)
{-# INLINE ifmap #-}
instance Conjoined p => IndexedComonad (BazaarT p g) where
iextract (BazaarT m) = runIdentity $ m (arr Identity)
{-# INLINE iextract #-}
iduplicate (BazaarT m) = getCompose $ m (Compose #. distrib sell . sell)
{-# INLINE iduplicate #-}
instance Corepresentable p => Sellable p (BazaarT p g) where
sell = cotabulate $ \ w -> BazaarT (`cosieve` w)
{-# INLINE sell #-}
instance Profunctor p => Bizarre p (BazaarT p g) where
bazaar g (BazaarT f) = f g
{-# INLINE bazaar #-}
instance Functor (BazaarT p g a b) where
fmap = ifmap
{-# INLINE fmap #-}
instance Apply (BazaarT p g a b) where
BazaarT mf <.> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb
{-# INLINE (<.>) #-}
instance Applicative (BazaarT p g a b) where
pure a = BazaarT $ tabulate $ \_ -> pure (pure a)
{-# INLINE pure #-}
BazaarT mf <*> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb
{-# INLINE (<*>) #-}
instance (a ~ b, Conjoined p) => Comonad (BazaarT p g a b) where
extract = iextract
{-# INLINE extract #-}
duplicate = iduplicate
{-# INLINE duplicate #-}
instance (a ~ b, Conjoined p) => ComonadApply (BazaarT p g a b) where
(<@>) = (<*>)
{-# INLINE (<@>) #-}
instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where
contramap _ = (<$) (error "contramap: BazaarT")
{-# INLINE contramap #-}
instance Contravariant g => Semigroup (BazaarT p g a b t) where
BazaarT a <> BazaarT b = BazaarT $ \f -> a f <* b f
{-# INLINE (<>) #-}
instance Contravariant g => Monoid (BazaarT p g a b t) where
mempty = BazaarT $ \_ -> pure (error "mempty: BazaarT")
{-# INLINE mempty #-}
BazaarT a `mappend` BazaarT b = BazaarT $ \f -> a f <* b f
{-# INLINE mappend #-}
class Profunctor p => Bizarre1 p w | w -> p where
bazaar1 :: Apply f => p a (f b) -> w a b t -> f t
newtype Bazaar1 p a b t = Bazaar1 { runBazaar1 :: forall f. Apply f => p a (f b) -> f t }
type Bazaar1' p a = Bazaar1 p a a
instance IndexedFunctor (Bazaar1 p) where
ifmap f (Bazaar1 k) = Bazaar1 (fmap f . k)
{-# INLINE ifmap #-}
instance Conjoined p => IndexedComonad (Bazaar1 p) where
iextract (Bazaar1 m) = runIdentity $ m (arr Identity)
{-# INLINE iextract #-}
iduplicate (Bazaar1 m) = getCompose $ m (Compose #. distrib sell . sell)
{-# INLINE iduplicate #-}
instance Corepresentable p => Sellable p (Bazaar1 p) where
sell = cotabulate $ \ w -> Bazaar1 $ tabulate $ \k -> pure (cosieve k w)
{-# INLINE sell #-}
instance Profunctor p => Bizarre1 p (Bazaar1 p) where
bazaar1 g (Bazaar1 f) = f g
{-# INLINE bazaar1 #-}
instance Functor (Bazaar1 p a b) where
fmap = ifmap
{-# INLINE fmap #-}
instance Apply (Bazaar1 p a b) where
Bazaar1 mf <.> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb
{-# INLINE (<.>) #-}
instance (a ~ b, Conjoined p) => Comonad (Bazaar1 p a b) where
extract = iextract
{-# INLINE extract #-}
duplicate = iduplicate
{-# INLINE duplicate #-}
instance (a ~ b, Conjoined p) => ComonadApply (Bazaar1 p a b) where
Bazaar1 mf <@> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb
{-# INLINE (<@>) #-}
newtype BazaarT1 p (g :: * -> *) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t }
#if __GLASGOW_HASKELL__ >= 707
type role BazaarT1 representational nominal nominal nominal nominal
#endif
type BazaarT1' p g a = BazaarT1 p g a a
instance IndexedFunctor (BazaarT1 p g) where
ifmap f (BazaarT1 k) = BazaarT1 (fmap f . k)
{-# INLINE ifmap #-}
instance Conjoined p => IndexedComonad (BazaarT1 p g) where
iextract (BazaarT1 m) = runIdentity $ m (arr Identity)
{-# INLINE iextract #-}
iduplicate (BazaarT1 m) = getCompose $ m (Compose #. distrib sell . sell)
{-# INLINE iduplicate #-}
instance Corepresentable p => Sellable p (BazaarT1 p g) where
sell = cotabulate $ \ w -> BazaarT1 (`cosieve` w)
{-# INLINE sell #-}
instance Profunctor p => Bizarre1 p (BazaarT1 p g) where
bazaar1 g (BazaarT1 f) = f g
{-# INLINE bazaar1 #-}
instance Functor (BazaarT1 p g a b) where
fmap = ifmap
{-# INLINE fmap #-}
instance Apply (BazaarT1 p g a b) where
BazaarT1 mf <.> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb
{-# INLINE (<.>) #-}
instance (a ~ b, Conjoined p) => Comonad (BazaarT1 p g a b) where
extract = iextract
{-# INLINE extract #-}
duplicate = iduplicate
{-# INLINE duplicate #-}
instance (a ~ b, Conjoined p) => ComonadApply (BazaarT1 p g a b) where
BazaarT1 mf <@> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb
{-# INLINE (<@>) #-}
instance (Profunctor p, Contravariant g) => Contravariant (BazaarT1 p g a b) where
contramap _ = (<$) (error "contramap: BazaarT1")
{-# INLINE contramap #-}
instance Contravariant g => Semigroup (BazaarT1 p g a b t) where
BazaarT1 a <> BazaarT1 b = BazaarT1 $ \f -> a f <. b f
{-# INLINE (<>) #-}