1{-# LANGUAGE CPP #-} 2{-# LANGUAGE Rank2Types #-} 3{-# LANGUAGE TypeFamilies #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE FunctionalDependencies #-} 6{-# LANGUAGE RoleAnnotations #-} 7#if __GLASGOW_HASKELL__ >= 711 8{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 9#endif 10 11----------------------------------------------------------------------------- 12-- | 13-- Module : Control.Lens.Internal.Bazaar 14-- Copyright : (C) 2012-2016 Edward Kmett 15-- License : BSD-style (see the file LICENSE) 16-- Maintainer : Edward Kmett <ekmett@gmail.com> 17-- Stability : experimental 18-- Portability : non-portable 19-- 20---------------------------------------------------------------------------- 21module Control.Lens.Internal.Bazaar 22 ( Bizarre(..) 23 , Bazaar(..), Bazaar' 24 , BazaarT(..), BazaarT' 25 , Bizarre1(..) 26 , Bazaar1(..), Bazaar1' 27 , BazaarT1(..), BazaarT1' 28 ) where 29 30import Prelude () 31 32import Control.Arrow as Arrow 33import qualified Control.Category as C 34import Control.Comonad 35import Control.Lens.Internal.Prelude 36import Control.Lens.Internal.Context 37import Control.Lens.Internal.Indexed 38import Data.Functor.Apply 39import Data.Profunctor.Rep 40 41------------------------------------------------------------------------------ 42-- Bizarre 43------------------------------------------------------------------------------ 44 45-- | This class is used to run the various 'Bazaar' variants used in this 46-- library. 47class Profunctor p => Bizarre p w | w -> p where 48 bazaar :: Applicative f => p a (f b) -> w a b t -> f t 49 50------------------------------------------------------------------------------ 51-- Bazaar 52------------------------------------------------------------------------------ 53 54-- | This is used to characterize a 'Control.Lens.Traversal.Traversal'. 55-- 56-- a.k.a. indexed Cartesian store comonad, indexed Kleene store comonad, or an indexed 'FunList'. 57-- 58-- <http://twanvl.nl/blog/haskell/non-regular1> 59-- 60-- A 'Bazaar' is like a 'Control.Lens.Traversal.Traversal' that has already been applied to some structure. 61-- 62-- Where a @'Context' a b t@ holds an @a@ and a function from @b@ to 63-- @t@, a @'Bazaar' a b t@ holds @N@ @a@s and a function from @N@ 64-- @b@s to @t@, (where @N@ might be infinite). 65-- 66-- Mnemonically, a 'Bazaar' holds many stores and you can easily add more. 67-- 68-- This is a final encoding of 'Bazaar'. 69newtype Bazaar p a b t = Bazaar { runBazaar :: forall f. Applicative f => p a (f b) -> f t } 70-- type role Bazaar representatonal nominal nominal nominal 71 72-- | This alias is helpful when it comes to reducing repetition in type signatures. 73-- 74-- @ 75-- type 'Bazaar'' p a t = 'Bazaar' p a a t 76-- @ 77type Bazaar' p a = Bazaar p a a 78 79instance IndexedFunctor (Bazaar p) where 80 ifmap f (Bazaar k) = Bazaar (fmap f . k) 81 {-# INLINE ifmap #-} 82 83instance Conjoined p => IndexedComonad (Bazaar p) where 84 iextract (Bazaar m) = runIdentity $ m (arr Identity) 85 {-# INLINE iextract #-} 86 iduplicate (Bazaar m) = getCompose $ m (Compose #. distrib sell C.. sell) 87 {-# INLINE iduplicate #-} 88 89instance Corepresentable p => Sellable p (Bazaar p) where 90 sell = cotabulate $ \ w -> Bazaar $ tabulate $ \k -> pure (cosieve k w) 91 {-# INLINE sell #-} 92 93instance Profunctor p => Bizarre p (Bazaar p) where 94 bazaar g (Bazaar f) = f g 95 {-# INLINE bazaar #-} 96 97instance Functor (Bazaar p a b) where 98 fmap = ifmap 99 {-# INLINE fmap #-} 100 x <$ Bazaar k = Bazaar ( (x <$) . k ) 101 {-# INLINE (<$) #-} 102 103instance Apply (Bazaar p a b) where 104 (<.>) = (<*>) 105 {-# INLINE (<.>) #-} 106 (.>) = (*>) 107 {-# INLINE (.>) #-} 108 (<.) = (<*) 109 {-# INLINE (<.) #-} 110 111instance Applicative (Bazaar p a b) where 112 pure a = Bazaar $ \_ -> pure a 113 {-# INLINE pure #-} 114 Bazaar mf <*> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb 115 {-# INLINE (<*>) #-} 116#if MIN_VERSION_base(4,10,0) 117 liftA2 f (Bazaar mx) (Bazaar my) = Bazaar $ \pafb -> liftA2 f (mx pafb) (my pafb) 118 {-# INLINE liftA2 #-} 119#endif 120 Bazaar mx *> Bazaar my = Bazaar $ \pafb -> mx pafb *> my pafb 121 {-# INLINE (*>) #-} 122 Bazaar mx <* Bazaar my = Bazaar $ \pafb -> mx pafb <* my pafb 123 {-# INLINE (<*) #-} 124 125instance (a ~ b, Conjoined p) => Comonad (Bazaar p a b) where 126 extract = iextract 127 {-# INLINE extract #-} 128 duplicate = iduplicate 129 {-# INLINE duplicate #-} 130 131instance (a ~ b, Conjoined p) => ComonadApply (Bazaar p a b) where 132 (<@>) = (<*>) 133 {-# INLINE (<@>) #-} 134 (@>) = (*>) 135 {-# INLINE (@>) #-} 136 (<@) = (<*) 137 {-# INLINE (<@) #-} 138 139------------------------------------------------------------------------------ 140-- BazaarT 141------------------------------------------------------------------------------ 142 143-- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Contravariant' instance 144-- To protect this instance it relies on the soundness of another 'Contravariant' type, and usage conventions. 145-- 146-- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there 147-- must be a better way! 148newtype BazaarT p (g :: * -> *) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t } 149type role BazaarT representational nominal nominal nominal nominal 150 151-- | This alias is helpful when it comes to reducing repetition in type signatures. 152-- 153-- @ 154-- type 'BazaarT'' p g a t = 'BazaarT' p g a a t 155-- @ 156type BazaarT' p g a = BazaarT p g a a 157 158instance IndexedFunctor (BazaarT p g) where 159 ifmap f (BazaarT k) = BazaarT (fmap f . k) 160 {-# INLINE ifmap #-} 161 162instance Conjoined p => IndexedComonad (BazaarT p g) where 163 iextract (BazaarT m) = runIdentity $ m (arr Identity) 164 {-# INLINE iextract #-} 165 iduplicate (BazaarT m) = getCompose $ m (Compose #. distrib sell C.. sell) 166 {-# INLINE iduplicate #-} 167 168instance Corepresentable p => Sellable p (BazaarT p g) where 169 sell = cotabulate $ \ w -> BazaarT (`cosieve` w) 170 {-# INLINE sell #-} 171 172instance Profunctor p => Bizarre p (BazaarT p g) where 173 bazaar g (BazaarT f) = f g 174 {-# INLINE bazaar #-} 175 176instance Functor (BazaarT p g a b) where 177 fmap = ifmap 178 {-# INLINE fmap #-} 179 x <$ BazaarT k = BazaarT ( (x <$) . k ) 180 {-# INLINE (<$) #-} 181 182instance Apply (BazaarT p g a b) where 183 (<.>) = (<*>) 184 {-# INLINE (<.>) #-} 185 (.>) = (*>) 186 {-# INLINE (.>) #-} 187 (<.) = (<*) 188 {-# INLINE (<.) #-} 189 190instance Applicative (BazaarT p g a b) where 191 pure a = BazaarT $ tabulate $ \_ -> pure (pure a) 192 {-# INLINE pure #-} 193 BazaarT mf <*> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb 194 {-# INLINE (<*>) #-} 195#if MIN_VERSION_base(4,10,0) 196 liftA2 f (BazaarT mx) (BazaarT my) = BazaarT $ \pafb -> liftA2 f (mx pafb) (my pafb) 197 {-# INLINE liftA2 #-} 198#endif 199 BazaarT mf *> BazaarT ma = BazaarT $ \ pafb -> mf pafb *> ma pafb 200 {-# INLINE (*>) #-} 201 BazaarT mf <* BazaarT ma = BazaarT $ \ pafb -> mf pafb <* ma pafb 202 {-# INLINE (<*) #-} 203 204instance (a ~ b, Conjoined p) => Comonad (BazaarT p g a b) where 205 extract = iextract 206 {-# INLINE extract #-} 207 duplicate = iduplicate 208 {-# INLINE duplicate #-} 209 210instance (a ~ b, Conjoined p) => ComonadApply (BazaarT p g a b) where 211 (<@>) = (<*>) 212 {-# INLINE (<@>) #-} 213 (@>) = (*>) 214 {-# INLINE (@>) #-} 215 (<@) = (<*) 216 {-# INLINE (<@) #-} 217 218instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where 219 contramap _ = (<$) (error "contramap: BazaarT") 220 {-# INLINE contramap #-} 221 222instance Contravariant g => Semigroup (BazaarT p g a b t) where 223 BazaarT a <> BazaarT b = BazaarT $ \f -> a f <* b f 224 {-# INLINE (<>) #-} 225 226instance Contravariant g => Monoid (BazaarT p g a b t) where 227 mempty = BazaarT $ \_ -> pure (error "mempty: BazaarT") 228 {-# INLINE mempty #-} 229 BazaarT a `mappend` BazaarT b = BazaarT $ \f -> a f <* b f 230 {-# INLINE mappend #-} 231 232 233------------------------------------------------------------------------------ 234-- Bizarre1 235------------------------------------------------------------------------------ 236 237class Profunctor p => Bizarre1 p w | w -> p where 238 bazaar1 :: Apply f => p a (f b) -> w a b t -> f t 239 240------------------------------------------------------------------------------ 241-- Bazaar1 242------------------------------------------------------------------------------ 243 244-- | This is used to characterize a 'Control.Lens.Traversal.Traversal'. 245-- 246-- a.k.a. indexed Cartesian store comonad, indexed Kleene store comonad, or an indexed 'FunList'. 247-- 248-- <http://twanvl.nl/blog/haskell/non-regular1> 249-- 250-- A 'Bazaar1' is like a 'Control.Lens.Traversal.Traversal' that has already been applied to some structure. 251-- 252-- Where a @'Context' a b t@ holds an @a@ and a function from @b@ to 253-- @t@, a @'Bazaar1' a b t@ holds @N@ @a@s and a function from @N@ 254-- @b@s to @t@, (where @N@ might be infinite). 255-- 256-- Mnemonically, a 'Bazaar1' holds many stores and you can easily add more. 257-- 258-- This is a final encoding of 'Bazaar1'. 259newtype Bazaar1 p a b t = Bazaar1 { runBazaar1 :: forall f. Apply f => p a (f b) -> f t } 260-- type role Bazaar1 representatonal nominal nominal nominal 261 262-- | This alias is helpful when it comes to reducing repetition in type signatures. 263-- 264-- @ 265-- type 'Bazaar1'' p a t = 'Bazaar1' p a a t 266-- @ 267type Bazaar1' p a = Bazaar1 p a a 268 269instance IndexedFunctor (Bazaar1 p) where 270 ifmap f (Bazaar1 k) = Bazaar1 (fmap f . k) 271 {-# INLINE ifmap #-} 272 273instance Conjoined p => IndexedComonad (Bazaar1 p) where 274 iextract (Bazaar1 m) = runIdentity $ m (arr Identity) 275 {-# INLINE iextract #-} 276 iduplicate (Bazaar1 m) = getCompose $ m (Compose #. distrib sell C.. sell) 277 {-# INLINE iduplicate #-} 278 279instance Corepresentable p => Sellable p (Bazaar1 p) where 280 sell = cotabulate $ \ w -> Bazaar1 $ tabulate $ \k -> pure (cosieve k w) 281 {-# INLINE sell #-} 282 283instance Profunctor p => Bizarre1 p (Bazaar1 p) where 284 bazaar1 g (Bazaar1 f) = f g 285 {-# INLINE bazaar1 #-} 286 287instance Functor (Bazaar1 p a b) where 288 fmap = ifmap 289 {-# INLINE fmap #-} 290 x <$ Bazaar1 k = Bazaar1 ((x <$) . k) 291 {-# INLINE (<$) #-} 292 293instance Apply (Bazaar1 p a b) where 294 Bazaar1 mf <.> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb 295 {-# INLINE (<.>) #-} 296 Bazaar1 mf .> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb .> ma pafb 297 {-# INLINE (.>) #-} 298 Bazaar1 mf <. Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <. ma pafb 299 {-# INLINE (<.) #-} 300 301instance (a ~ b, Conjoined p) => Comonad (Bazaar1 p a b) where 302 extract = iextract 303 {-# INLINE extract #-} 304 duplicate = iduplicate 305 {-# INLINE duplicate #-} 306 307instance (a ~ b, Conjoined p) => ComonadApply (Bazaar1 p a b) where 308 (<@>) = (<.>) 309 {-# INLINE (<@>) #-} 310 (@>) = (.>) 311 {-# INLINE (@>) #-} 312 (<@) = (<.) 313 {-# INLINE (<@) #-} 314 315------------------------------------------------------------------------------ 316-- BazaarT1 317------------------------------------------------------------------------------ 318 319-- | 'BazaarT1' is like 'Bazaar1', except that it provides a questionable 'Contravariant' instance 320-- To protect this instance it relies on the soundness of another 'Contravariant' type, and usage conventions. 321-- 322-- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there 323-- must be a better way! 324newtype BazaarT1 p (g :: * -> *) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t } 325type role BazaarT1 representational nominal nominal nominal nominal 326 327-- | This alias is helpful when it comes to reducing repetition in type signatures. 328-- 329-- @ 330-- type 'BazaarT1'' p g a t = 'BazaarT1' p g a a t 331-- @ 332type BazaarT1' p g a = BazaarT1 p g a a 333 334instance IndexedFunctor (BazaarT1 p g) where 335 ifmap f (BazaarT1 k) = BazaarT1 (fmap f . k) 336 {-# INLINE ifmap #-} 337 338instance Conjoined p => IndexedComonad (BazaarT1 p g) where 339 iextract (BazaarT1 m) = runIdentity $ m (arr Identity) 340 {-# INLINE iextract #-} 341 iduplicate (BazaarT1 m) = getCompose $ m (Compose #. distrib sell C.. sell) 342 {-# INLINE iduplicate #-} 343 344instance Corepresentable p => Sellable p (BazaarT1 p g) where 345 sell = cotabulate $ \ w -> BazaarT1 (`cosieve` w) 346 {-# INLINE sell #-} 347 348instance Profunctor p => Bizarre1 p (BazaarT1 p g) where 349 bazaar1 g (BazaarT1 f) = f g 350 {-# INLINE bazaar1 #-} 351 352instance Functor (BazaarT1 p g a b) where 353 fmap = ifmap 354 {-# INLINE fmap #-} 355 x <$ BazaarT1 k = BazaarT1 ((x <$) . k) 356 {-# INLINE (<$) #-} 357 358instance Apply (BazaarT1 p g a b) where 359 BazaarT1 mf <.> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb 360 {-# INLINE (<.>) #-} 361 BazaarT1 mf .> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb .> ma pafb 362 {-# INLINE (.>) #-} 363 BazaarT1 mf <. BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <. ma pafb 364 {-# INLINE (<.) #-} 365 366instance (a ~ b, Conjoined p) => Comonad (BazaarT1 p g a b) where 367 extract = iextract 368 {-# INLINE extract #-} 369 duplicate = iduplicate 370 {-# INLINE duplicate #-} 371 372instance (a ~ b, Conjoined p) => ComonadApply (BazaarT1 p g a b) where 373 (<@>) = (<.>) 374 {-# INLINE (<@>) #-} 375 (@>) = (.>) 376 {-# INLINE (@>) #-} 377 (<@) = (<.) 378 {-# INLINE (<@) #-} 379 380instance (Profunctor p, Contravariant g) => Contravariant (BazaarT1 p g a b) where 381 contramap _ = (<$) (error "contramap: BazaarT1") 382 {-# INLINE contramap #-} 383 384instance Contravariant g => Semigroup (BazaarT1 p g a b t) where 385 BazaarT1 a <> BazaarT1 b = BazaarT1 $ \f -> a f <. b f 386 {-# INLINE (<>) #-} 387