1{-# LANGUAGE CPP #-}
2{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FunctionalDependencies #-}
7#if __GLASGOW_HASKELL__ >= 707
8{-# LANGUAGE RoleAnnotations #-}
9#endif
10
11-----------------------------------------------------------------------------
12-- |
13-- Module      :  Control.Lens.Internal.Context
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.Context
22  ( IndexedFunctor(..)
23  , IndexedComonad(..)
24  , IndexedComonadStore(..)
25  , Sellable(..)
26  , Context(..), Context'
27  , Pretext(..), Pretext'
28  , PretextT(..), PretextT'
29  ) where
30
31import Prelude ()
32
33import Control.Arrow
34import qualified Control.Category as C
35import Control.Comonad
36import Control.Comonad.Store.Class
37import Control.Lens.Internal.Indexed
38import Control.Lens.Internal.Prelude
39import Data.Profunctor.Rep
40import Prelude hiding ((.),id)
41
42------------------------------------------------------------------------------
43-- IndexedFunctor
44------------------------------------------------------------------------------
45
46-- | This is a Bob Atkey -style 2-argument indexed functor.
47--
48-- It exists as a superclass for 'IndexedComonad' and expresses the functoriality
49-- of an 'IndexedComonad' in its third argument.
50class IndexedFunctor w where
51  ifmap :: (s -> t) -> w a b s -> w a b t
52
53------------------------------------------------------------------------------
54-- IndexedComonad
55------------------------------------------------------------------------------
56
57-- | This is a Bob Atkey -style 2-argument indexed comonad.
58--
59-- It exists as a superclass for 'IndexedComonad' and expresses the functoriality
60-- of an 'IndexedComonad' in its third argument.
61--
62-- The notion of indexed monads is covered in more depth in Bob Atkey's
63-- "Parameterized Notions of Computation" <http://bentnib.org/paramnotions-jfp.pdf>
64-- and that construction is dualized here.
65class IndexedFunctor w => IndexedComonad w where
66#if __GLASGOW_HASKELL__ >= 708
67  {-# MINIMAL iextract, (iduplicate | iextend) #-}
68#endif
69  -- | extract from an indexed comonadic value when the indices match.
70  iextract :: w a a t -> t
71
72  -- | duplicate an indexed comonadic value splitting the index.
73  iduplicate :: w a c t -> w a b (w b c t)
74  iduplicate = iextend id
75  {-# INLINE iduplicate #-}
76
77  -- | extend a indexed comonadic computation splitting the index.
78  iextend :: (w b c t -> r) -> w a c t -> w a b r
79  iextend f = ifmap f . iduplicate
80  {-# INLINE iextend #-}
81
82------------------------------------------------------------------------------
83-- IndexedComonadStore
84------------------------------------------------------------------------------
85
86-- | This is an indexed analogue to 'ComonadStore' for when you are working with an
87-- 'IndexedComonad'.
88class IndexedComonad w => IndexedComonadStore w where
89  -- | This is the generalization of 'pos' to an indexed comonad store.
90  ipos :: w a c t -> a
91
92  -- | This is the generalization of 'peek' to an indexed comonad store.
93  ipeek :: c  -> w a c t -> t
94  ipeek c = iextract . iseek c
95  {-# INLINE ipeek #-}
96
97  -- | This is the generalization of 'peeks' to an indexed comonad store.
98  ipeeks :: (a -> c) -> w a c t -> t
99  ipeeks f = iextract . iseeks f
100  {-# INLINE ipeeks #-}
101
102  -- | This is the generalization of 'seek' to an indexed comonad store.
103  iseek :: b  -> w a c t -> w b c t
104
105  -- | This is the generalization of 'seeks' to an indexed comonad store.
106  iseeks :: (a -> b) -> w a c t -> w b c t
107
108  -- | This is the generalization of 'experiment' to an indexed comonad store.
109  iexperiment :: Functor f => (b -> f c) -> w b c t -> f t
110  iexperiment bfc wbct = (`ipeek` wbct) <$> bfc (ipos wbct)
111  {-# INLINE iexperiment #-}
112
113  -- | We can always forget the rest of the structure of 'w' and obtain a simpler
114  -- indexed comonad store model called 'Context'.
115  context :: w a b t -> Context a b t
116  context wabt = Context (`ipeek` wabt) (ipos wabt)
117  {-# INLINE context #-}
118
119------------------------------------------------------------------------------
120-- Sellable
121------------------------------------------------------------------------------
122
123-- | This is used internally to construct a 'Control.Lens.Internal.Bazaar.Bazaar', 'Context' or 'Pretext'
124-- from a singleton value.
125class Corepresentable p => Sellable p w | w -> p where
126  sell :: p a (w a b b)
127
128------------------------------------------------------------------------------
129-- Context
130------------------------------------------------------------------------------
131
132-- | The indexed store can be used to characterize a 'Control.Lens.Lens.Lens'
133-- and is used by 'Control.Lens.Lens.cloneLens'.
134--
135-- @'Context' a b t@ is isomorphic to
136-- @newtype 'Context' a b t = 'Context' { runContext :: forall f. 'Functor' f => (a -> f b) -> f t }@,
137-- and to @exists s. (s, 'Control.Lens.Lens.Lens' s t a b)@.
138--
139-- A 'Context' is like a 'Control.Lens.Lens.Lens' that has already been applied to a some structure.
140data Context a b t = Context (b -> t) a
141-- type role Context representational representational representational
142
143instance IndexedFunctor Context where
144  ifmap f (Context g t) = Context (f . g) t
145  {-# INLINE ifmap #-}
146
147instance IndexedComonad Context where
148  iextract   (Context f a) = f a
149  {-# INLINE iextract #-}
150  iduplicate (Context f a) = Context (Context f) a
151  {-# INLINE iduplicate #-}
152  iextend g  (Context f a) = Context (g . Context f) a
153  {-# INLINE iextend #-}
154
155instance IndexedComonadStore Context where
156  ipos (Context _ a) = a
157  {-# INLINE ipos #-}
158  ipeek b (Context g _) = g b
159  {-# INLINE ipeek #-}
160  ipeeks f (Context g a) = g (f a)
161  {-# INLINE ipeeks #-}
162  iseek a (Context g _) = Context g a
163  {-# INLINE iseek #-}
164  iseeks f (Context g a) = Context g (f a)
165  {-# INLINE iseeks #-}
166  iexperiment f (Context g a) = g <$> f a
167  {-# INLINE iexperiment #-}
168  context = id
169  {-# INLINE context #-}
170
171instance Functor (Context a b) where
172  fmap f (Context g t) = Context (f . g) t
173  {-# INLINE fmap #-}
174
175instance a ~ b => Comonad (Context a b) where
176  extract   (Context f a) = f a
177  {-# INLINE extract #-}
178  duplicate (Context f a) = Context (Context f) a
179  {-# INLINE duplicate #-}
180  extend g  (Context f a) = Context (g . Context f) a
181  {-# INLINE extend #-}
182
183instance a ~ b => ComonadStore a (Context a b) where
184  pos = ipos
185  {-# INLINE pos #-}
186  peek = ipeek
187  {-# INLINE peek #-}
188  peeks = ipeeks
189  {-# INLINE peeks #-}
190  seek = iseek
191  {-# INLINE seek #-}
192  seeks = iseeks
193  {-# INLINE seeks #-}
194  experiment = iexperiment
195  {-# INLINE experiment #-}
196
197instance Sellable (->) Context where
198  sell = Context id
199  {-# INLINE sell #-}
200
201-- | @type 'Context'' a s = 'Context' a a s@
202type Context' a = Context a a
203
204------------------------------------------------------------------------------
205-- Pretext
206------------------------------------------------------------------------------
207
208-- | This is a generalized form of 'Context' that can be repeatedly cloned with less
209-- impact on its performance, and which permits the use of an arbitrary 'Conjoined'
210-- 'Profunctor'
211newtype Pretext p a b t = Pretext { runPretext :: forall f. Functor f => p a (f b) -> f t }
212-- type role Pretext representational nominal nominal nominal
213
214-- | @type 'Pretext'' p a s = 'Pretext' p a a s@
215type Pretext' p a = Pretext p a a
216
217instance IndexedFunctor (Pretext p) where
218  ifmap f (Pretext k) = Pretext (fmap f . k)
219  {-# INLINE ifmap #-}
220
221instance Functor (Pretext p a b) where
222  fmap = ifmap
223  {-# INLINE fmap #-}
224
225instance Conjoined p => IndexedComonad (Pretext p) where
226  iextract (Pretext m) = runIdentity $ m (arr Identity)
227  {-# INLINE iextract #-}
228  iduplicate (Pretext m) = getCompose $ m (Compose #. distrib sell C.. sell)
229  {-# INLINE iduplicate #-}
230
231instance (a ~ b, Conjoined p) => Comonad (Pretext p a b) where
232  extract = iextract
233  {-# INLINE extract #-}
234  duplicate = iduplicate
235  {-# INLINE duplicate #-}
236
237instance Conjoined p => IndexedComonadStore (Pretext p) where
238  ipos (Pretext m) = getConst $ coarr m $ arr Const
239  {-# INLINE ipos #-}
240  ipeek a (Pretext m) = runIdentity $ coarr m $ arr (\_ -> Identity a)
241  {-# INLINE ipeek #-}
242  ipeeks f (Pretext m) = runIdentity $ coarr m $ arr (Identity . f)
243  {-# INLINE ipeeks #-}
244  iseek a (Pretext m) = Pretext (lmap (lmap (const a)) m)
245  {-# INLINE iseek #-}
246  iseeks f (Pretext m) = Pretext (lmap (lmap f) m)
247  {-# INLINE iseeks #-}
248  iexperiment f (Pretext m) = coarr m (arr f)
249  {-# INLINE iexperiment #-}
250  context (Pretext m) = coarr m (arr sell)
251  {-# INLINE context #-}
252
253instance (a ~ b, Conjoined p) => ComonadStore a (Pretext p a b) where
254  pos = ipos
255  {-# INLINE pos #-}
256  peek = ipeek
257  {-# INLINE peek #-}
258  peeks = ipeeks
259  {-# INLINE peeks #-}
260  seek = iseek
261  {-# INLINE seek #-}
262  seeks = iseeks
263  {-# INLINE seeks #-}
264  experiment = iexperiment
265  {-# INLINE experiment #-}
266
267instance Corepresentable p => Sellable p (Pretext p) where
268  sell = cotabulate $ \ w -> Pretext (`cosieve` w)
269  {-# INLINE sell #-}
270
271------------------------------------------------------------------------------
272-- PretextT
273------------------------------------------------------------------------------
274
275
276
277-- | This is a generalized form of 'Context' that can be repeatedly cloned with less
278-- impact on its performance, and which permits the use of an arbitrary 'Conjoined'
279-- 'Profunctor'.
280--
281-- The extra phantom 'Functor' is used to let us lie and claim
282-- 'Control.Lens.Getter.Getter'-compatibility under limited circumstances.
283-- This is used internally to permit a number of combinators to gracefully
284-- degrade when applied to a 'Control.Lens.Fold.Fold' or
285-- 'Control.Lens.Getter.Getter'.
286newtype PretextT p (g :: * -> *) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t }
287
288#if __GLASGOW_HASKELL__ >= 707
289-- really we want PretextT p g a b t to permit the last 3 arguments to be representational iff p and f accept representational arguments
290-- but that isn't currently an option in GHC
291type role PretextT representational nominal nominal nominal nominal
292#endif
293
294-- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@
295type PretextT' p g a = PretextT p g a a
296
297instance IndexedFunctor (PretextT p g) where
298  ifmap f (PretextT k) = PretextT (fmap f . k)
299  {-# INLINE ifmap #-}
300
301instance Functor (PretextT p g a b) where
302  fmap = ifmap
303  {-# INLINE fmap #-}
304
305instance Conjoined p => IndexedComonad (PretextT p g) where
306  iextract (PretextT m) = runIdentity $ m (arr Identity)
307  {-# INLINE iextract #-}
308  iduplicate (PretextT m) = getCompose $ m (Compose #. distrib sell C.. sell)
309  {-# INLINE iduplicate #-}
310
311instance (a ~ b, Conjoined p) => Comonad (PretextT p g a b) where
312  extract = iextract
313  {-# INLINE extract #-}
314  duplicate = iduplicate
315  {-# INLINE duplicate #-}
316
317instance Conjoined p => IndexedComonadStore (PretextT p g) where
318  ipos (PretextT m) = getConst $ coarr m $ arr Const
319  {-# INLINE ipos #-}
320  ipeek a (PretextT m) = runIdentity $ coarr m $ arr (\_ -> Identity a)
321  {-# INLINE ipeek #-}
322  ipeeks f (PretextT m) = runIdentity $ coarr m $ arr (Identity . f)
323  {-# INLINE ipeeks #-}
324  iseek a (PretextT m) = PretextT (lmap (lmap (const a)) m)
325  {-# INLINE iseek #-}
326  iseeks f (PretextT m) = PretextT (lmap (lmap f) m)
327  {-# INLINE iseeks #-}
328  iexperiment f (PretextT m) = coarr m (arr f)
329  {-# INLINE iexperiment #-}
330  context (PretextT m) = coarr m (arr sell)
331  {-# INLINE context #-}
332
333instance (a ~ b, Conjoined p) => ComonadStore a (PretextT p g a b) where
334  pos = ipos
335  {-# INLINE pos #-}
336  peek = ipeek
337  {-# INLINE peek #-}
338  peeks = ipeeks
339  {-# INLINE peeks #-}
340  seek = iseek
341  {-# INLINE seek #-}
342  seeks = iseeks
343  {-# INLINE seeks #-}
344  experiment = iexperiment
345  {-# INLINE experiment #-}
346
347instance Corepresentable p => Sellable p (PretextT p g) where
348  sell = cotabulate $ \ w -> PretextT (`cosieve` w)
349  {-# INLINE sell #-}
350
351instance (Profunctor p, Contravariant g) => Contravariant (PretextT p g a b) where
352  contramap _ = (<$) (error "contramap: PretextT")
353  {-# INLINE contramap #-}
354
355------------------------------------------------------------------------------
356-- Utilities
357------------------------------------------------------------------------------
358
359-- | We can convert any 'Conjoined' 'Profunctor' to a function,
360-- possibly losing information about an index in the process.
361coarr :: (Representable q, Comonad (Rep q)) => q a b -> a -> b
362coarr qab = extract . sieve qab
363{-# INLINE coarr #-}
364