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