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