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