-
Notifications
You must be signed in to change notification settings - Fork 272
/
Indexed.hs
322 lines (278 loc) · 11.6 KB
/
Indexed.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Internal.Indexed
-- Copyright : (C) 2012-2013 Edward Kmett
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : experimental
-- Portability : non-portable
--
-- Internal implementation details for 'Indexed' lens-likes
----------------------------------------------------------------------------
module Control.Lens.Internal.Indexed
(
-- * An Indexed Profunctor
Indexed(..)
-- * Classes
, Conjoined(..)
, Indexable(..)
-- * Indexing
, Indexing(..)
, indexing
-- * 64-bit Indexing
, Indexing64(..)
, indexing64
) where
import Control.Applicative
import Control.Arrow as Arrow
import Control.Category
import Control.Comonad
import Control.Lens.Internal.Instances ()
import Control.Monad
import Control.Monad.Fix
import Data.Distributive
import Data.Functor.Bind
import Data.Functor.Contravariant
import Data.Int
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Unsafe
import Data.Traversable
import Prelude hiding ((.),id)
#ifndef SAFE
import Unsafe.Coerce
#endif
------------------------------------------------------------------------------
-- Conjoined
------------------------------------------------------------------------------
-- | This is a 'Profunctor' that is both 'Corepresentable' by @f@ and 'Representable' by @g@ such
-- that @f@ is left adjoint to @g@. From this you can derive a lot of structure due
-- to the preservation of limits and colimits.
class
( Choice p, Corepresentable p, Comonad (Corep p), Traversable (Corep p)
, Strong p, Representable p, Monad (Rep p), MonadFix (Rep p), Distributive (Rep p)
, ArrowLoop p, ArrowApply p, ArrowChoice p
) => Conjoined p where
-- | 'Conjoined' is strong enough to let us distribute every 'Conjoined'
-- 'Profunctor' over every Haskell 'Functor'. This is effectively a
-- generalization of 'fmap'.
distrib :: Functor f => p a b -> p (f a) (f b)
distrib = tabulate . collect . rep
{-# INLINE distrib #-}
-- | This permits us to make a decision at an outermost point about whether or not we use an index.
--
-- Ideally any use of this function should be done in such a way so that you compute the same answer,
-- but this cannot be enforced at the type level.
conjoined :: ((p ~ (->)) => q (a -> b) r) -> q (p a b) r -> q (p a b) r
conjoined _ r = r
{-# INLINE [0] conjoined #-}
#ifdef USE_RULES
{-# RULES "conjoined/fun" [1] forall f g. conjoined f g = f #-}
#endif
instance Conjoined (->) where
distrib = fmap
{-# INLINE distrib #-}
conjoined l _ = l
{-# INLINE conjoined #-}
----------------------------------------------------------------------------
-- Indexable
----------------------------------------------------------------------------
-- | This class permits overloading of function application for things that
-- also admit a notion of a key or index.
class Conjoined p => Indexable i p where
-- | Build a function from an 'indexed' function.
indexed :: p a b -> i -> a -> b
instance Indexable i (->) where
indexed = const
{-# INLINE indexed #-}
-----------------------------------------------------------------------------
-- Indexed Internals
-----------------------------------------------------------------------------
-- | A function with access to a index. This constructor may be useful when you need to store
-- an 'Indexable' in a container to avoid @ImpredicativeTypes@.
--
-- @index :: Indexed i a b -> i -> a -> b@
newtype Indexed i a b = Indexed { runIndexed :: i -> a -> b }
instance Functor (Indexed i a) where
fmap g (Indexed f) = Indexed $ \i a -> g (f i a)
{-# INLINE fmap #-}
instance Apply (Indexed i a) where
Indexed f <.> Indexed g = Indexed $ \i a -> f i a (g i a)
{-# INLINE (<.>) #-}
instance Applicative (Indexed i a) where
pure b = Indexed $ \_ _ -> b
{-# INLINE pure #-}
Indexed f <*> Indexed g = Indexed $ \i a -> f i a (g i a)
{-# INLINE (<*>) #-}
instance Bind (Indexed i a) where
Indexed f >>- k = Indexed $ \i a -> runIndexed (k (f i a)) i a
{-# INLINE (>>-) #-}
instance Monad (Indexed i a) where
return b = Indexed $ \_ _ -> b
{-# INLINE return #-}
Indexed f >>= k = Indexed $ \i a -> runIndexed (k (f i a)) i a
{-# INLINE (>>=) #-}
instance MonadFix (Indexed i a) where
mfix f = Indexed $ \ i a -> let o = runIndexed (f o) i a in o
{-# INLINE mfix #-}
instance Profunctor (Indexed i) where
dimap ab cd ibc = Indexed $ \i -> cd . runIndexed ibc i . ab
{-# INLINE dimap #-}
lmap ab ibc = Indexed $ \i -> runIndexed ibc i . ab
{-# INLINE lmap #-}
rmap bc iab = Indexed $ \i -> bc . runIndexed iab i
{-# INLINE rmap #-}
( .# ) ibc _ = unsafeCoerce ibc
{-# INLINE ( .# ) #-}
( #. ) _ = unsafeCoerce
{-# INLINE ( #. ) #-}
instance Corepresentable (Indexed i) where
type Corep (Indexed i) = (,) i
cotabulate = Indexed . curry
{-# INLINE cotabulate #-}
corep = uncurry . runIndexed
{-# INLINE corep #-}
instance Representable (Indexed i) where
type Rep (Indexed i) = (->) i
tabulate = Indexed . flip
{-# INLINE tabulate #-}
rep = flip . runIndexed
{-# INLINE rep #-}
instance Choice (Indexed i) where
right' = right
{-# INLINE right' #-}
instance Strong (Indexed i) where
second' = second
{-# INLINE second' #-}
instance Category (Indexed i) where
id = Indexed (const id)
{-# INLINE id #-}
Indexed f . Indexed g = Indexed $ \i -> f i . g i
{-# INLINE (.) #-}
instance Arrow (Indexed i) where
arr f = Indexed (\_ -> f)
{-# INLINE arr #-}
first f = Indexed (Arrow.first . runIndexed f)
{-# INLINE first #-}
second f = Indexed (Arrow.second . runIndexed f)
{-# INLINE second #-}
Indexed f *** Indexed g = Indexed $ \i -> f i *** g i
{-# INLINE (***) #-}
Indexed f &&& Indexed g = Indexed $ \i -> f i &&& g i
{-# INLINE (&&&) #-}
instance ArrowChoice (Indexed i) where
left f = Indexed (left . runIndexed f)
{-# INLINE left #-}
right f = Indexed (right . runIndexed f)
{-# INLINE right #-}
Indexed f +++ Indexed g = Indexed $ \i -> f i +++ g i
{-# INLINE (+++) #-}
Indexed f ||| Indexed g = Indexed $ \i -> f i ||| g i
{-# INLINE (|||) #-}
instance ArrowApply (Indexed i) where
app = Indexed $ \ i (f, b) -> runIndexed f i b
{-# INLINE app #-}
instance ArrowLoop (Indexed i) where
loop (Indexed f) = Indexed $ \i b -> let (c,d) = f i (b, d) in c
{-# INLINE loop #-}
instance Conjoined (Indexed i) where
distrib (Indexed iab) = Indexed $ \i fa -> iab i <$> fa
{-# INLINE distrib #-}
instance i ~ j => Indexable i (Indexed j) where
indexed = runIndexed
{-# INLINE indexed #-}
------------------------------------------------------------------------------
-- Indexing
------------------------------------------------------------------------------
-- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used
-- by 'Control.Lens.Indexed.indexed'.
newtype Indexing f a = Indexing { runIndexing :: Int -> (Int, f a) }
instance Functor f => Functor (Indexing f) where
fmap f (Indexing m) = Indexing $ \i -> case m i of
(j, x) -> (j, fmap f x)
{-# INLINE fmap #-}
instance Apply f => Apply (Indexing f) where
Indexing mf <.> Indexing ma = Indexing $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <.> fa)
{-# INLINE (<.>) #-}
instance Applicative f => Applicative (Indexing f) where
pure x = Indexing $ \i -> (i, pure x)
{-# INLINE pure #-}
Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <*> fa)
{-# INLINE (<*>) #-}
instance Contravariant f => Contravariant (Indexing f) where
contramap f (Indexing m) = Indexing $ \i -> case m i of
(j, ff) -> (j, contramap f ff)
{-# INLINE contramap #-}
-- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or
-- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc.
--
-- @
-- 'indexing' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int' s t a b
-- 'indexing' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int' s t a b
-- 'indexing' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int' s t a b
-- 'indexing' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int' s t a b
-- 'indexing' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.IndexedFold' 'Int' s a
-- 'indexing' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.IndexedGetter' 'Int' s a
-- @
--
-- @'indexing' :: 'Indexable' 'Int' p => 'Control.Lens.Type.LensLike' ('Indexing' f) s t a b -> 'Control.Lens.Type.Overloading' p (->) f s t a b@
indexing :: Indexable Int p => ((a -> Indexing f b) -> s -> Indexing f t) -> p a (f b) -> s -> f t
indexing l iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0
{-# INLINE indexing #-}
------------------------------------------------------------------------------
-- Indexing64
------------------------------------------------------------------------------
-- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int64'@ with a 'Functor', used
-- by 'Control.Lens.Indexed.indexed64'.
newtype Indexing64 f a = Indexing64 { runIndexing64 :: Int64 -> (Int64, f a) }
instance Functor f => Functor (Indexing64 f) where
fmap f (Indexing64 m) = Indexing64 $ \i -> case m i of
(j, x) -> (j, fmap f x)
{-# INLINE fmap #-}
instance Apply f => Apply (Indexing64 f) where
Indexing64 mf <.> Indexing64 ma = Indexing64 $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <.> fa)
{-# INLINE (<.>) #-}
instance Applicative f => Applicative (Indexing64 f) where
pure x = Indexing64 $ \i -> (i, pure x)
{-# INLINE pure #-}
Indexing64 mf <*> Indexing64 ma = Indexing64 $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <*> fa)
{-# INLINE (<*>) #-}
instance Contravariant f => Contravariant (Indexing64 f) where
contramap f (Indexing64 m) = Indexing64 $ \i -> case m i of
(j, ff) -> (j, contramap f ff)
{-# INLINE contramap #-}
-- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or
-- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc.
--
-- This combinator is like 'indexing' except that it handles large traversals and folds gracefully.
--
-- @
-- 'indexing64' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int64' s t a b
-- 'indexing64' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int64' s t a b
-- 'indexing64' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int64' s t a b
-- 'indexing64' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int64' s t a b
-- 'indexing64' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.IndexedFold' 'Int64' s a
-- 'indexing64' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.IndexedGetter' 'Int64' s a
-- @
--
-- @'indexing64' :: 'Indexable' 'Int64' p => 'Control.Lens.Type.LensLike' ('Indexing64' f) s t a b -> 'Control.Lens.Type.Overloading' p (->) f s t a b@
indexing64 :: Indexable Int64 p => ((a -> Indexing64 f b) -> s -> Indexing64 f t) -> p a (f b) -> s -> f t
indexing64 l iafb s = snd $ runIndexing64 (l (\a -> Indexing64 (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0
{-# INLINE indexing64 #-}