git.iko.soy/generic-lens
on master help sign in
Clean up
commit6a82eaf0d93fab600e01bf9d107a8409e4ca2a5a authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateWed 17 Jan 2018, 18:33 (9 years ago) parent3283578
9 files changed+10−1291
compare with master
unifiedsplit
generic-lens.cabal−4 src/Boggle.hs−533 src/Data/Generics/Internal/Lens.hs+10−16 src/Data/Generics/Product/Boggle.hs−83 src/Data/Generics/Product/Internal/Types.hs−4 src/Data/Generics/Product/Types.hs−4 src/Data/Generics/Sum/Constructors.hs−1 src/Data/Profunctor/Extra.hs−645 test/Spec.hs−1
generic-lens.cabal−4
@@ -27,9 +27,6 @@ library
2727 , Data.Generics.Product.Typed
2828 , Data.Generics.Labels
2929 , Data.Generics.Product.Types
30− , Data.Generics.Product.Boggle
31−
32− , Boggle
3330
3431 , Data.Generics.Sum
3532 , Data.Generics.Sum.Any
@@ -54,7 +51,6 @@ library
5451 , Data.Generics.Product.Internal.Subtype
5552 , Data.Generics.Product.Internal.Typed
5653 , Data.Generics.Product.Internal.Types
57− , Data.Profunctor.Extra
5854
5955 build-depends: base >= 4.9 && <= 5.0
6056 , profunctors >= 5.0 && <= 6.0
src/Boggle.hsdeleted−533
@@ -1,533 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−
3−-- | This module implements the 'Boggle' type which exists for its
4−-- 'Applicative' instance that takes advantage of the laws of the
5−-- 'Applicative' class to rearrange the applications of the underlying
6−-- type's 'Applicative' instance. These transformations collect all of
7−-- the pure values using in 'pure' and 'fmap' calls into a single place
8−-- which enables GHC to aggressively optimize them.
9−--
10−-- == Optimization Goals
11−--
12−-- The goal for rewriting values defined in terms of 'Applicative' operations
13−-- will be to normalize them into a form that gives GHC the most opportunity
14−-- to simply the resulting expression as possible without knowing anything
15−-- about the particular 'Applicative' instance that that it satisfies the class
16−-- laws.
17−--
18−-- The following type characterizes our desired normal form.
19−--
20−-- > data Normal :: (* -> *) -> * -> * where
21−-- > Pure :: a -> Normal f a
22−-- > Normal1 :: Normal1 f a -> Normal f a
23−--
24−-- > data Normal1 :: (* -> *) -> * -> * where
25−-- > Ap :: Normal1 f (a -> b) -> f a -> Normal1 f b
26−-- > Normal2 :: Normal2 f a -> Normal1 f a
27−--
28−-- > data Normal2 :: (* -> *) -> * -> * where
29−-- > Fmap :: (a -> b) -> f a -> Normal2 f b -- function ≠ 'id'
30−-- > Lift :: f a -> Normal2 f a
31−--
32−-- While this type on its own is simpler than some of the types that follow,
33−-- implementing '<$>' and '<*>' for this type would require recusion to deal
34−-- with the left-recursion found in this type:
35−--
36−-- > f <$> Ap mg mx = Ap ((f .) <$> mg) mx
37−-- > f <$> Normal2 mx = Normal2 (f <$> x)
38−--
39−-- == Optimization Techniques
40−--
41−-- This transformation uses four primary techniques to achieve optimization.
42−--
43−-- [/avoid recursion/]
44−--
45−-- Recursive functions interfere with GHC's ability to inline and optimize
46−-- function applications. Each of the following transformations will need
47−-- to be written in a way that enables GHC to inline all of the definitions
48−-- and optimize away all of the intermediate structures. If the
49−-- intermediate structures or the operations on them were written
50−-- recursively this would not be possible.
51−--
52−-- [/multiple equivalent representations/]
53−--
54−-- There are cases where we don't know what the optimal representation for
55−-- a value will be until that value is actually used. In the following code
56−-- we see this happen with 'MapK1' and 'ApK1'. Due to inlining and
57−-- optimization the representation that was not needed can be eliminated
58−-- at use time.
59−--
60−-- [/free structures/]
61−--
62−-- In order to optimize values according to laws that they satisfy, we'll
63−-- need the structures that these laws operate over to be explicit. This
64−-- will enable the operations to determine when a transformation is
65−-- appropriate and apply it.
66−--
67−-- 'MapK' tracks the eventual argument to 'fmap'. 'ApK' tracks the eventual
68−-- left-most argument to '<.>'. 'PureK' tracks uses of 'pure'.
69−--
70−-- [/typed tagless final encodings/]
71−--
72−-- The /typed tagless final/ approach for writing a computation involves
73−-- defining the signature of the operations that a compution can be
74−-- constructed from and then defining values completely within that
75−-- signature. This technique will specifically apply to computations
76−-- written generically in terms of the 'Applicative' signature.
77−--
78−-- Because the 'Applicative' signature carries a number of laws that
79−-- any interpretation of it must satisfy, we are able to write our
80−-- own interpretations in terms of existing interpretations but which
81−-- use the laws that these existing interpretations must satisfy.
82−--
83−-- It happens that it is now quite common to define computations in this
84−-- style with classes like 'Functor' and 'Applicative' due to the
85−-- popularlity of the @lens@ package and it's heavy use of this pattern.
86−module Boggle
87− ( Boggle(..)
88− , boggling
89− , test
90− , liftBoggle, lowerBoggle
91− -- * Abstractions
92− , Traversal(..)
93− , Apply(..)
94− , ApWrap(..), liftApWrap, lowerApWrap
95− -- * fmap fusion
96− , MapK(..), (<<$>), liftMapK, lowerMapK
97− -- * fmap fusion with fmap id law
98− , MapK1(..), liftMapK1, lowerMapK1
99− -- * '<*>' reassociation
100− , ApK(..), (<<.>), liftApK, lowerApK
101− -- * '<.>' reassociation
102− , ApK1(..), liftApK1, lowerApK1
103− -- * pure elminination
104− , PureK(..), liftPureK, lowerPureK
105− -- * '>>=' reassociation
106− , BindK(..), liftBindK, lowerBindK, liftBindK1, liftBindK2
107− ) where
108−
109−import Control.Applicative
110−import Control.Monad
111−import GHC.Exts ( inline )
112−
113−infixl 4 <<$>, <<.>, <.>
114−
115−type LensLike f s t a b = (a -> f b) -> (s -> f t)
116−type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
117−type Traversal' s a = Traversal s s a a
118−
119−-- | This class is a mid-point between 'Functor' and 'Applicative'
120−-- for types that support the '<*>' operation but not 'pure'
121−--
122−-- It provides an operation for lifted function application ('<.>')
123−--
124−-- Implementations of this class must follow these laws:
125−--
126−-- [/composition/]
127−--
128−-- * @(\\f g x -> f (g x)) '<$>' mf '<.>' mg '<.>' mx = mf '<.>' (mg '<.>' mx)@
129−--
130−-- [/interchange/]
131−--
132−-- * @(\\g x -> f (g x)) '<$>' mg '<.>' mx = f '<$>' (mg '<.>' mx)@
133−-- * @(\\g x -> g (f x)) '<$>' mg '<.>' mx = mg '<.>' (f '<$>' mx)@
134−--
135−-- If @f@ is an 'Applicative', it should satisfy
136−--
137−-- * @'<.>' = '<*>'@
138−class Functor f => Apply f where
139− -- | Lifted application
140− (<.>) :: f (a -> b) -> f a -> f b
141− {-# MINIMAL (<.>) #-}
142−
143−------------------------------------------------------------------------
144−
145−-- | 'ApWrap' provides an 'Apply' instance in terms of an underlying
146−-- 'Applicative' instance.
147−newtype ApWrap f a = ApWrap (f a)
148−
149−liftApWrap :: f a -> ApWrap f a
150−liftApWrap = ApWrap
151−
152−lowerApWrap :: ApWrap f a -> f a
153−lowerApWrap (ApWrap fa) = fa
154−
155−instance Functor f => Functor (ApWrap f) where
156− fmap f (ApWrap x) = ApWrap (f <$> x)
157−
158−-- | @('<.>') = ('<*>')@
159−instance Applicative f => Apply (ApWrap f) where
160− ApWrap f <.> ApWrap x = ApWrap (f <*> x)
161−
162−
163−------------------------------------------------------------------------
164−
165−-- | This type fuses all uses of 'fmap' into a single use of 'fmap' on
166−-- the underlying 'Functor' @f@.
167−--
168−-- There is a natural isomorphism between @f@ and @'MapK' f@ witnessed by
169−-- 'liftMapK' and 'lowerMapK' which is respected by the 'Functor' instance
170−-- of @'MapK' f@.
171−newtype MapK f a = MapK (forall b. (a -> b) -> f b)
172−
173−liftMapK :: Functor f => f a -> MapK f a
174−liftMapK fa = MapK (<$> fa)
175−
176−lowerMapK :: MapK f a -> f a
177−lowerMapK fa = id <<$> fa
178−
179−-- | Like '<$>' but removes the 'MapK'
180−(<<$>) :: (a -> b) -> MapK f a -> f b
181−f <<$> MapK x = x f
182−
183−-- | Note: no underlying 'Functor' required
184−instance Functor (MapK f) where
185− fmap f x = MapK (\z -> (z . f) <<$> x)
186−
187−------------------------------------------------------------------------
188−
189−-- | 'MapK1' extends 'MapK' to detect when a lift is immediately followed
190−-- by a lower. In this case no 'fmap' will be used at all!
191−--
192−-- There is a natural isomorphism between @f@ and @'MapK1' f@ witnessed by
193−-- 'liftMapK1' and 'lowerMapK1' which is respected by the 'Functor' and
194−-- 'Apply' instance of @'MapK1' f@.
195−data MapK1 f a = MapK1 (f a) (MapK f a)
196− -- ^ Invariant: @(x :: f a) == 'lowerMapK' (y :: 'MapK' f a)
197−
198−liftMapK1 :: Functor f => f a -> MapK1 f a
199−liftMapK1 fa = MapK1 fa (liftMapK fa)
200−
201−lowerMapK1 :: MapK1 f a -> f a
202−lowerMapK1 (MapK1 fa _) = fa
203−
204−-- | Note: no underlying 'Functor' required
205−instance Functor (MapK1 f) where
206− fmap f (MapK1 _ g) = MapK1 (f <<$> g) (f <$> g)
207−
208−instance Apply f => Apply (MapK1 f) where
209− MapK1 f g <.> MapK1 x _ =
210− MapK1 (f <.> x) (MapK (\k -> (\a b -> k (a b)) <<$> g <.> x))
211−
212−------------------------------------------------------------------------
213−
214−-- | 'ApK' provides an 'Apply' instance in terms of the underlying @f@'s
215−-- 'Apply' instance, but left-associates all '<.>'. Lowering this type
216−-- requires an 'Applicative' instance.
217−--
218−-- There is a natural isomorphism between @f@ and @'ApK' f@ witnessed by
219−-- 'liftApK' and 'lowerApK' which is respected by the 'Functor' and
220−-- 'Apply' instance of @'ApK' f@.
221−newtype ApK f a = ApK (forall b. f (a -> b) -> f b)
222−
223−liftApK :: Apply f => f a -> ApK f a
224−liftApK fa = ApK (<.> fa)
225−
226−lowerApK :: Applicative f => ApK f a -> f a
227−lowerApK fa = pure id <<.> fa
228−
229−-- | Like '<.>' but removes 'ApK'
230−(<<.>) :: f (a -> b) -> ApK f a -> f b
231−fa <<.> ApK k = k fa
232−
233−instance Functor f => Functor (ApK f) where
234− fmap f x = ApK (\g -> (\a b -> a (f b)) <$> g <<.> x)
235−
236−-- | Note that this 'Apply' instance only uses the underlying 'Functor'
237−instance Functor f => Apply (ApK f) where
238− f <.> x = ApK (\g -> (.) <$> g <<.> f <<.> x)
239−
240−------------------------------------------------------------------------
241−
242−-- | This type provides an 'Apply' instance in terms of the underlying @f@
243−-- type's 'Apply' instance, but it left-associates all uses of '<.>'
244−--
245−-- There is a natural isomorphism between @f@ and @'ApK1' f@ witnessed by
246−-- 'liftApK1' and 'lowerApK1' which is respected by the 'Functor' and
247−-- 'Apply' instance of @'ApK1' f@.
248−data ApK1 f a = ApK1 (f a) (ApK f a)
249− -- ^ Invariant: @(x :: f a) == 'lowerApK' (y :: 'ApK' f a)@
250−
251−instance Functor f => Functor (ApK1 f) where
252− fmap f (ApK1 x y) = ApK1 (f <$> x) (f <$> y)
253−
254−-- | Note that this 'Apply' instance only uses the underlying 'Functor'
255−instance Functor f => Apply (ApK1 f) where
256− ApK1 fl fr <.> ApK1 _ x = ApK1 (fl <<.> x) (fr <.> x)
257−
258−liftApK1 :: Apply f => f a -> ApK1 f a
259−liftApK1 fa = ApK1 fa (liftApK fa)
260−
261−lowerApK1 :: ApK1 f a -> f a
262−lowerApK1 (ApK1 fa _) = fa
263−
264−------------------------------------------------------------------------
265−
266−-- | 'PureK' lifts a type @f@ having an 'Apply' instance to a type
267−-- having an 'Applicative' instance. The 'Applicative' laws for 'pure'
268−-- are used to rewrite all uses of pure into either a single 'pure' or
269−-- into uses of 'fmap' where possible.
270−--
271−-- There is a natural isomorphism between @f@ and @'PureK' f@ witnessed by
272−-- 'liftPureK' and 'lowerPureK' which is respected by the 'Functor',
273−-- 'Apply', and 'Applicative' instance of @'PureK' f@.
274−data PureK f a = Pure a | Dirty (f a)
275−
276−lowerPureK :: Applicative f => PureK f a -> f a
277−lowerPureK (Pure a) = pure a
278−lowerPureK (Dirty fa) = fa
279−
280−liftPureK :: f a -> PureK f a
281−liftPureK = Dirty
282−
283−instance Functor f => Functor (PureK f) where
284− fmap f (Pure x) = Pure (f x)
285− fmap f (Dirty x) = Dirty (f <$> x)
286−
287−instance Apply f => Apply (PureK f) where
288− Dirty f <.> Dirty x = Dirty (f <.> x)
289− Pure f <.> x = f <$> x
290− f <.> Pure x = ($ x) <$> f
291−
292−-- Note that this 'Applicative' instance only uses the underlying 'Apply'
293−instance Apply f => Applicative (PureK f) where
294− pure = Pure
295− (<*>) = (<.>)
296−
297−-- | Transform the underlying type.
298−natPureK :: (f a -> g a) -> PureK f a -> PureK g a
299−natPureK f (Dirty fa) = Dirty (f fa)
300−natPureK _ (Pure a) = Pure a
301−
302−------------------------------------------------------------------------
303−
304−-- | @'Boggle' f@ is isomorphic to @f@ up to the 'Applicative' laws.
305−-- Uses of '<$>' on this type are combined into a single use of '<$>'
306−-- on the underlying @f@ type. Uses of 'pure' are combined and transformed
307−-- to '<$>' where possible. Uses of '<*>' are reassociated to the left.
308−--
309−-- 'PureK' is on the outside because any use of 'pure' is immediately
310−-- intercepted and translated into 'fmap' when needed. 'ApK1' doesn't
311−-- even have/need an 'Applicative' instance.
312−--
313−-- 'ApK1' is next because it uses the 'Functor' instance from its underlying
314−-- type and we want the 'MapK' layer to intercept and fuse all of those 'fmap'
315−-- uses.
316−--
317−-- 'MapK1' is down toward the bottom of the stack to be able to fuse the uses
318−-- of 'fmap' from all the previous layers into one single use.
319−--
320−-- 'ApWrap' is at the very bottom. It only exists to provide an 'Apply'
321−-- instance to the underlying type @f@.
322−--
323−-- There is a natural isomorphism between @f@ and @'Boggle' f@ witnessed by
324−-- 'liftBoggle' and 'lowerBoggle' which is respected by the 'Functor',
325−-- 'Apply', and 'Applicative' instance of @'Boggle' f@.
326−newtype Boggle f a = Boggle (PureK (ApK1 (MapK1 (ApWrap f))) a)
327−
328−instance Functor (Boggle f) where
329− fmap f (Boggle x) = Boggle (f <$> x)
330− {-# INLINE fmap #-}
331−
332−instance Applicative (Boggle f) where
333− pure x = Boggle (pure x)
334− {-# INLINE pure #-}
335− Boggle x <*> Boggle y = Boggle (x <*> y)
336− {-# INLINE (<*>) #-}
337−
338−liftBoggle :: Applicative f => f a -> Boggle f a
339−liftBoggle = Boggle . liftPureK . liftApK1 . liftMapK1 . liftApWrap
340−{-# INLINE[1] liftBoggle #-}
341−
342−-- | 'lowerBoggle' lowers the 'ApK1' and 'MapK' layers first before lowering
343−-- the 'PureK' layer. This ensures that any 'fmap' uses in the 'PureK' layer
344−-- are intercepted by the 'MapK' layer, but the final (possible) use of 'pure'
345−-- in the case that 'pure' is going to be used will happen in the underlying
346−-- @f@ type!
347−lowerBoggle :: Applicative f => Boggle f a -> f a
348−lowerBoggle
349− = lowerPureK . natPureK (lowerApWrap . lowerMapK1 . lowerApK1) . (\(Boggle b) -> b)
350−{-# INLINE lowerBoggle #-}
351−
352−-- | Optimize a 'Traversal' by fusing the '<$>'s and left-associating the '<*>'s
353−--
354−-- This function will only work well on non-recursive traversals. For an example
355−-- of using this technique on recursive cases see "Data.Traversable.Generic".
356−boggling :: Applicative f => LensLike (Boggle f) s t a b -> LensLike f s t a b
357−boggling l = \f x -> lowerBoggle (l (\x -> (liftBoggle (f x))) x)
358−{-# INLINE boggling #-}
359−
360−
361−------------------------------------------------------------------------
362−
363−-- | Local implementation of @Codensity@ type from @kan-extensions@.
364−-- This type captures the concept of a partially applied '>>=' function.
365−newtype BindK f a = BindK { runBindK :: forall b. (a -> f b) -> f b }
366−
367−instance Functor (BindK f) where
368− fmap = liftM
369−
370−instance Applicative (BindK f) where
371− pure x = BindK $ \k -> k x
372− (<*>) = ap
373−
374−instance Alternative f => Alternative (BindK f) where
375− empty = BindK $ \_ -> empty
376− (<|>) = liftBindK2 (<|>)
377− {-# INLINE (<|>) #-}
378−
379−instance Monad (BindK f) where
380− BindK m >>= f = BindK $ \k -> m $ \a -> runBindK (f a) k
381−
382−instance Alternative f => MonadPlus (BindK f)
383−
384−-- | Run a @'BindK' f@ computation with 'pure' as the final continuation.
385−lowerBindK :: Applicative f => BindK f a -> f a
386−lowerBindK (BindK k) = k pure
387−
388−liftBindK :: Monad f => f a -> BindK f a
389−liftBindK fa = BindK (fa >>=)
390−
391−liftBindK1 :: (forall a. f a -> f a) -> BindK f b -> BindK f b
392−liftBindK1 f (BindK k) = BindK (f . k)
393−
394−liftBindK2 :: (forall a. f a -> f a -> f a) -> BindK f b -> BindK f b -> BindK f b
395−liftBindK2 f (BindK m) (BindK n) = BindK (\k -> f (m k) (n k))
396−
397−traversePair f (a, b) = (,) <$> f a <*> f b
398−
399−test :: Applicative f => (a -> f a) -> (a, a) -> f (a, a)
400−test = boggling traversePair
401−
402−{- example
403−-
404−
405−liftBoggle fa <*> (pure (5+) <*> liftBoggle fb)
406−=
407−((Boggle . liftPureK . liftApK1 . liftMapK1 . liftApWrap) fa)
408− <*>
409− (pure (5+) <*> (Boggle . liftPureK . liftApK1 . liftMapK1 . liftApWrap) fb)
410−=
411− Boggle (
412− Dirty (
413− ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))))))
414− <*>
415− ( Boggle (Pure (5+))
416− <*>
417− Boggle (
418− Dirty (
419− ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))))
420−= Boggle (
421− (Dirty (
422− ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))))))
423− <*> (Pure (5+) <*>
424− (Dirty (
425− ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))))
426−= {- PureK <$> -}
427− Boggle (
428− (Dirty (
429− ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))))))
430− <.>
431− (Dirty ((+5) <$>
432− ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))))
433−= {- PureK <.> -}
434− Boggle (
435− (Dirty
436− (
437− ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))))))
438− <.>
439− ((+5) <$>
440− ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))
441−= {- ApK1 <$> -}
442− Boggle (
443− (Dirty
444− (
445− ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))))))
446− <.>
447− (
448− ApK1 ((+5) <$> MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) ((+5) <$> liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))
449−= {- ApK1 <.> -}
450−
451− Boggle (
452− (Dirty
453− (ApK1
454−
455− (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
456− <<.> ((+5) <$> liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))))
457− -- This isn't going to be evaluated
458− ((liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))))))
459− <.> ((+5) <$> liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))
460−= {- Remove unevaled term -}
461− Boggle (
462− (Dirty
463− (ApK1
464− (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
465− <<.> ((+5) <$> liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))))
466− <uneval>
467−= {- liftMapK defn -}
468− Boggle (
469− (Dirty
470− (ApK1
471− (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
472− <<.> ((+5) <$> liftApK (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))
473− <uneval>
474−= {- liftApK defn -}
475− Boggle (
476− (Dirty
477− (ApK1
478− (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
479− <<.> ((+5) <$> ApK (<.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))
480−= {- <$> ApK -}
481− Boggle (
482− (Dirty
483− (ApK1
484− (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
485− <<.> (ApK (\g -> (\a b -> a (5 + b)) <$> g <<.>
486− (ApK (<.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb)))))
487−= {- <<.> defn -}
488− Boggle (
489− (Dirty
490− (ApK1
491− (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
492− <<.> (ApK (\g -> (\a b -> a (5 + b)) <$>
493− (g <.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))))
494−= {- <<.> defn -}
495− Boggle (
496− (Dirty
497− (ApK1
498− (\a b -> a (5 + b)) <$> (
499− (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
500− <.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))))
501−= {- MapK1 <.> -}
502− Boggle (
503− (Dirty
504− (ApK1
505− (\a b -> a (5 + b)) <$> (
506− (MapK1 (ApWrap fa <.> ApWrap fb)
507− (\k -> (\a b -> k (a b)) <<$> (MapK (<$> (ApWrap fa)))))
508− <.> (ApWrap fb)))))
509−= {- <<$> defn -}
510− Boggle (
511− (Dirty
512− (ApK1
513− (\a b -> a (5 + b)) <$> (
514− (MapK1 (ApWrap fa <.> ApWrap fb)
515− (ApWrap ((\k -> (\a b -> k (a b))) <$> fa <*> fb))))
516−=
517− {- <$> -}
518− Boggle (
519− (Dirty
520− (ApK1
521− MapK1 (
522− (\a b -> a (5 + b)) <$> ApWrap fa <.> ApWrap fb))))
523−-}
524−
525−
526−
527−
528−
529−
530−
531−
532−
533−
src/Data/Generics/Internal/Lens.hs+10−16
@@ -20,13 +20,10 @@ module Data.Generics.Internal.Lens where
2020import Control.Applicative (Const(..))
2121import Data.Functor.Identity (Identity(..))
2222import Data.Monoid (First (..))
23−import Data.Profunctor (Choice(right'), Profunctor(dimap, rmap))
24−import Data.Profunctor.Extra
23+import Data.Profunctor (Choice(right'), Profunctor(dimap))
2524import Data.Profunctor.Unsafe ((#.), (.#))
2625import Data.Tagged
2726import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
28−import Boggle hiding (Dirty)
29−import Debug.Trace
3027
3128-- | Type alias for lens
3229type Lens' s a
@@ -39,6 +36,9 @@ type Lens s t a b
3936type Traversal' s a
4037 = forall f. Applicative f => (a -> f a) -> s -> f s
4138
39+type Traversal s t a b
40+ = forall f. Applicative f => (a -> f b) -> s -> f t
41+
4242-- | Type alias for prism
4343type Prism s t a b
4444 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
@@ -55,11 +55,8 @@ type Iso' s a
5555type Iso s t a b
5656 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
5757
58−type IsoE s t a b
59− = forall p f. (MProfunctor p) => p a b -> p s t
60−
6158type IsoP s t a b
62− = forall p f. (Profunctor p) => p a b -> p s t
59+ = forall p. (Profunctor p) => p a b -> p s t
6360
6461-- | Getting
6562(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
@@ -122,6 +119,11 @@ prismP :: (b -> t) -> (s -> Either t a) -> PrismP s t a b
122119prismP bt seta eta = dimap seta (either id bt) (right' eta)
123120{-# INLINE prismP #-}
124121
122+plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
123+plus f _ (Left x) = Left (f x)
124+plus _ g (Right y) = Right (g y)
125+
126+
125127-- | A type and its generic representation are isomorphic
126128repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
127129repIso = dimap from (fmap to)
@@ -284,14 +286,6 @@ instance Choice (Market a b) where
284286 Right a -> Right a
285287 {-# INLINE right' #-}
286288
287−instance MProfunctor (Market a b) where
288− mdimap f g m = dimap (lowerFun f) (lowerFun g) m
289− {-# INLINE mdimap #-}
290−
291−instance MRight (Market a b) where
292− mright m = right' m
293− {-# INLINE mright #-}
294−
295289prism2prismp :: Market a b s t -> PrismP s t a b
296290prism2prismp (Market bt seta) = prismP bt seta
297291
src/Data/Generics/Product/Boggle.hsdeleted−83
@@ -1,83 +0,0 @@
1−{-# LANGUAGE TypeOperators #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−
4−-- |
5−-- This module generates implementations of the 'traverse' operation which
6−-- make it possible for GHC to optimize away the GHC.Generics value
7−-- representation.
8−module Data.Generics.Product.Boggle
9− (
10− -- * Generic operations
11− genericTraverse,
12− -- * Implementation details
13− GTraversable(gtraverse)
14− ) where
15−
16−import Boggle
17−import Data.Generics.Internal.Lens
18−import GHC.Generics (Generic1, Rep1, to1, from1, (:*:)(..), (:+:)(..),
19− (:.:)(..),
20− M1(..), K1(..), Rec1(..), Par1(..), U1(..), V1)
21−import GHC.Exts (inline)
22−
23−-- NOTE: genericTraversal an gtraverse must be explicitly marked
24−-- for inlining as they need to inline across module boundaries
25−-- for GHC to optimize away the generics representation. The other
26−-- functions don't *need* to be marked for inlining because GHC
27−-- does figure it out, but it's better to be explicit about our
28−-- intention here than to rely on the optimizer any more than
29−-- we already are.
30−
31−-- | Implementation of 'traverse' for any instance of 'Generic1'.
32−genericTraverse ::
33− (Generic1 t, GTraversable (Rep1 t)) => Traversal (t a) (t b) a b
34−genericTraverse f x = lowerBoggle (to1 <$> gtraverse f (from1 x))
35−{-# INLINE genericTraverse #-}
36−
37−-- | The 'GTraversable' class has a method for traversing a generic
38−-- structure. This function is not quite the same as 'traverse' because
39−-- it uses a particular transformation on the underlying applicative functor.
40−class GTraversable t where
41− gtraverse :: Applicative f => (a -> f b) -> t a -> Boggle f (t b)
42−
43−instance GTraversable f => GTraversable (M1 i c f) where
44− gtraverse f (M1 x) = M1 <$> gtraverse f x
45− {-# INLINE gtraverse #-}
46−
47−instance (GTraversable f, GTraversable g) => GTraversable (f :+: g) where
48− gtraverse f (L1 x) = L1 <$> gtraverse f x
49− gtraverse f (R1 x) = R1 <$> gtraverse f x
50− {-# INLINE gtraverse #-}
51−
52−instance (GTraversable f, GTraversable g) => GTraversable (f :*: g) where
53− gtraverse f (x :*: y) = (:*:) <$> gtraverse f x <*> gtraverse f y
54− {-# INLINE gtraverse #-}
55−
56−instance (Traversable f, GTraversable g) => GTraversable (f :.: g) where
57− gtraverse f (Comp1 x) = Comp1 <$> inline traverse (gtraverse f) x
58− {-# INLINE gtraverse #-}
59−
60−instance GTraversable U1 where
61− gtraverse _ _ = pure U1
62− {-# INLINE gtraverse #-}
63−
64−instance GTraversable V1 where
65− gtraverse _ v = v `seq` error "GTraversal/V1: gtraverse"
66− {-# INLINE gtraverse #-}
67−
68−instance GTraversable (K1 i a) where
69− gtraverse _ (K1 x) = pure (K1 x)
70− {-# INLINE gtraverse #-}
71−
72−instance GTraversable Par1 where
73− gtraverse f (Par1 x) = Par1 <$> liftBoggle (f x)
74− {-# INLINE gtraverse #-}
75−
76−instance Traversable t => GTraversable (Rec1 t) where
77− gtraverse f (Rec1 x) = Rec1 <$> liftBoggle (traverse f x)
78− {-# INLINE gtraverse #-}
79−
80−
81−-------------------------------------------------------------------------------
82−
83−
src/Data/Generics/Product/Internal/Types.hs−4
@@ -27,12 +27,8 @@ module Data.Generics.Product.Internal.Types
2727 ( GHasTypes (..)
2828 ) where
2929
30−--import Data.Generics.Internal.Families
31−import Data.Generics.Internal.Lens
32−
3330import Data.Kind (Type)
3431import GHC.Generics
35−import Boggle
3632
3733-- |As 'HasTypes' but over generic representations as defined by
3834-- "GHC.Generics".
src/Data/Generics/Product/Types.hs−4
@@ -30,14 +30,10 @@ module Data.Generics.Product.Types
3030 HasTypes (..)
3131 ) where
3232
33−--import Data.Generics.Internal.Families
3433import Data.Generics.Internal.Lens
3534import Data.Generics.Product.Internal.Types
3635
37−--import Data.Kind (Constraint, Type)
3836import GHC.Generics (Generic (Rep), from, to)
39−import Boggle
40−--import GHC.TypeLits (TypeError, ErrorMessage (..))
4137
4238class HasTypes a s where
4339 types :: Traversal' s a
src/Data/Generics/Sum/Constructors.hs−1
@@ -40,7 +40,6 @@ import Data.Generics.Sum.Internal.Constructors
4040import Data.Kind (Constraint, Type)
4141import GHC.Generics (Generic (Rep))
4242import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
43−import Data.Profunctor.Extra
4443
4544-- $setup
4645-- == /Running example:/
src/Data/Profunctor/Extra.hsdeleted−645
@@ -1,645 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE DeriveGeneric #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# OPTIONS_GHC -funfolding-creation-threshold=100000 #-}
8−module Data.Profunctor.Extra where
9−
10−import Data.Profunctor
11−import GHC.Generics
12−import Debug.Trace
13−import Boggle hiding ((<.>))
14−
15−
16−-- Pull dimaps to left and rights to right
17−{-
18−data Boggle p a b where
19− DRight :: (p x y) -> Boggle p (Either z x) (Either z y)
20− DMap :: (c -> a) -> (b -> d) -> (p a b) -> Boggle p c d
21− Dirty :: p a b -> Boggle p a b
22−
23−instance Choice p => Profunctor (Boggle p) where
24− dimap f g (Dirty pab) = DMap f g pab
25− dimap f g (DMap f' g' pab) = DMap (f' . f) (g . g') pab
26− dimap f g (DRight pab) = DMap f g (right' pab)
27−
28−instance Choice p => Choice (Boggle p) where
29− right' (Dirty pab) = DRight pab
30− right' (DMap f g pab) = DMap (fmap f) (fmap g) (right' pab)
31− right' (DRight pab) = DRight (right' pab)
32−
33−lift :: p a b -> Boggle p a b
34−lift pab = Dirty pab
35−
36−
37−lower :: Choice p => Boggle p a b -> p a b
38−lower (Dirty pab) = pab
39−lower (DMap f g pab) = dimap f g pab
40−lower (DRight pab) = right' pab
41−
42−test1 :: Choice p => p Int Int -> p (Either z Int) (Either z Int)
43−test1 pab = right' (dimap (+1) (subtract 1) pab)
44−
45−test1spec :: Choice p => p Int Int -> p (Either z Int) (Either z Int)
46−test1spec = lower . test1 . lift
47−-}
48−
49−
50−------------------------------------------------------------------------------
51−
52−--- This type fuses together uses of `dimap` we want to do this last
53−-- as we first need to rearrange the "Eithers"
54−newtype DimapK p b c = DimapK (forall a d . (Fun a b -> Fun c d -> p a d))
55−
56−liftDimapK :: MProfunctor p => p a b -> DimapK p a b
57−liftDimapK pa = DimapK (\f g -> mdimap f g pa)
58−
59−lowerDimapK :: DimapK p a b -> p a b
60−lowerDimapK (DimapK pa) = pa (liftFun id) (liftFun id)
61−
62−-- Note that here because we use (<.>) we potentially flatten "either"
63−instance MProfunctor (DimapK p) where
64− mdimap f g (DimapK x) = DimapK (\y z -> x (f <.> y) (z <.> g))
65− {-# INLINE mdimap #-}
66−
67−fmdimap :: Fun a b -> Fun c d -> DimapK p b c -> p a d
68−fmdimap f g (DimapK x) = x f g
69−
70−------------------------------------------------------------------------------
71−-- Wrapper to ensure that a liftDimapK followed by lowerDimapK doesn't
72−-- introduce a dimap.
73−
74−data DimapK1 p b c = DimapK1 (p b c) (DimapK p b c)
75− | DirtyDimapK1 (p b c)
76−
77−liftDimapK1 :: MProfunctor p => p a b -> DimapK1 p a b
78−liftDimapK1 pab = DimapK1 pab (liftDimapK pab)
79−
80−lowerDimapK1 :: DimapK1 p a b -> p a b
81−lowerDimapK1 (DimapK1 pab _) = pab
82−lowerDimapK1 (DirtyDimapK1 pab) = pab
83−
84−instance MProfunctor p => MProfunctor (DimapK1 p) where
85− mdimap f g (DimapK1 _ d) = DimapK1 (fmdimap f g d) (mdimap f g d)
86− mdimap f g (DirtyDimapK1 pab) = DimapK1 (mdimap f g pab) (mdimap f g (liftDimapK pab))
87− {-# INLINE mdimap #-}
88−
89−--instance MRight p => MRight (DiMapK1 p) where
90−-- mright (DimapK1
91−instance MRight p => MRight (DimapK1 p) where
92− mright (DimapK1 f g) = DirtyDimapK1 (mright f)
93− mright (DirtyDimapK1 pab) = DirtyDimapK1 (mright pab)
94− {-# INLINE mright #-}
95−
96−-- Should be the identity, works
97−testDimapK1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
98−testDimapK1 pab = lowerDimapK1 (liftDimapK1 pab)
99−
100−a, b :: Fun Int Int
101−a = liftFun id
102−b = liftFun id
103−
104−-- Should observe one dimap in the specialised version
105−testDimapK1A :: (MProfunctor p) => p Int Int -> p Int Int
106−testDimapK1A pab = mdimap a b (mdimap a b pab)
107−
108−ravelDimapK1 :: (MProfunctor p)
109− => (DimapK1 p a b -> DimapK1 p c d)
110− -> p a b -> p c d
111−ravelDimapK1 l pab = lowerDimapK1 (l (liftDimapK1 pab))
112−
113−-- As expected
114−specDimapK1A :: (MProfunctor p) => p Int Int -> p Int Int
115−specDimapK1A = ravelDimapK1 testDimapK1A
116−
117−
118−
119−
120−-------------------------------------------------------------------------------
121−-- Pull Dimaps to the left
122−
123−data DimapSyntax p c d where
124− DMSMap :: Fun c a -> Fun b d -> p a b -> DimapSyntax p c d
125− DMSDirty :: p a b -> DimapSyntax p a b
126−
127−liftDimapSyntax :: p a b -> DimapSyntax p a b
128−liftDimapSyntax pab = DMSDirty pab
129−
130−lowerDimapSyntax :: MProfunctor p => DimapSyntax p a b -> p a b
131−lowerDimapSyntax (DMSDirty pab) = pab
132−lowerDimapSyntax (DMSMap pca pbd pab) = mdimap pca pbd pab
133−
134−instance MRight p => MRight (DimapSyntax p) where
135− mright (DMSDirty pab) = DMSDirty (mright pab)
136− mright (DMSMap fca fbd pab) = DMSMap (femap fca) (femap fbd) (mright pab)
137− {-# INLINE mright #-}
138−
139−-- Don't fuse here, we do that in DimapK1 at the end
140−instance MProfunctor p => MProfunctor (DimapSyntax p) where
141− mdimap f g (DMSDirty p) = DMSMap f g p
142− mdimap f g (DMSMap f' g' p) = DMSMap (f' <.> f) (g <.> g') p
143− {-# INLINE mdimap #-}
144−
145−f :: Fun Int (Either Int Int)
146−f = undefined
147−g :: Fun (Either Int Int) Int
148−g = undefined
149−
150−
151−testDimapSyntax :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
152−testDimapSyntax pab = mdimap f g (mright (mdimap f g (mright pab)))
153−
154−ravelDimapSyntax :: (MProfunctor p, MRight p) =>
155− (DimapSyntax p a b -> DimapSyntax p s t)
156− -> p a b -> p s t
157−ravelDimapSyntax l pab = lowerDimapSyntax (l (liftDimapSyntax pab))
158−
159−ravelDimapSyntaxFF :: (MProfunctor p, MRight p) =>
160− (DimapSyntax (RightFuse (RightFreeTheorem p)) a b -> DimapSyntax (RightFuse (RightFreeTheorem p)) s t)
161− -> p a b -> p s t
162−ravelDimapSyntaxFF l pab = lowerRightFreeTheorem (lowerRightFuse (lowerDimapSyntax (l (liftDimapSyntax (liftRightFuse (liftRightFreeTheorem pab))))))
163−
164−-- Works
165−specDimapSyntax :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
166−specDimapSyntax = ravelDimapSyntax testDimapSyntax
167−
168−
169−-------------------------------------------------------------------------------
170−-- Fuse together rights
171−{-
172−data RightSyntax p c d where
173− RSRight :: Fun c a -> Fun b d -> p a b -> DimapSyntax p c d
174− RSDirty :: p a b -> DimapSyntax p a b
175−
176−liftRightSyntax :: p a b -> RightSyntax p a b
177−liftRightSyntax pab = RSDirty pab
178−
179−lowerRightSyntax :: MRight p => RightSyntax p a b -> p a b
180−lowerRightSyntax (RSDirty pab) = pab
181−lowerRightSyntax (RSRight paa) = mright pa
182−
183−instance MRight p => MRight (DimapSyntax p) where
184− mright (DMSDirty pab) = DMSDirty (mright pab)
185− mright (DMSMap fca fbd pab) = DMSMap (ffmap fca) (ffmap fbd) (mright pab)
186−
187−-- Don't fuse here, we do that in DimapK1 at the end
188−instance MProfunctor p => MProfunctor (DimapSyntax p) where
189− mdimap f g (DMSDirty p) = DMSMap f g p
190− mdimap f g (DMSMap f' g' p) = DMSMap f g (mdimap f' g' p)
191− -}
192−-- We always want to ensure that "RightFuse p b c ~ p b c" So after
193−-- applying the "RightFuse" constructor when we encounter a right, we need
194−-- to ensure the type is "p (Either z b) (Either z c) as that's the type of
195−-- applying right
196−data RightFuse p b c where
197− RightFuse :: (forall a d z . Fun a (Either z b) -> Fun (Either z c) d -> p a d) -> RightFuse p (Either z b) (Either z c)
198− DirtyRightFuse :: p b c -> RightFuse p b c
199−
200−initRightFuse :: (MRight p, MProfunctor p) => p a b -> RightFuse p (Either z a) (Either z b)
201−initRightFuse pa = RightFuse (\f g -> mdimap f g (mright pa))
202−
203−liftRightFuse :: p a b -> RightFuse p a b
204−liftRightFuse pa = DirtyRightFuse pa
205−
206−lowerRightFuse :: RightFuse p a b -> p a b
207−lowerRightFuse (DirtyRightFuse pa) = pa
208−lowerRightFuse (RightFuse pa) = pa (liftFun id) (liftFun id)
209−
210−instance (MProfunctor p, MRight p) => MRight (RightFuse p) where
211− -- Both these work but this version maintains the EitherFun invariant
212− mright (RightFuse r) = RightFuse (\f1 f2 -> r (assocNew <.> f1) (f2 <.> assoc'New))
213−-- mright (RightFuse r) = RightFuse (\f1 f2 -> r (assoc <.> f1) (f2 <.> assoc'))
214− mright (DirtyRightFuse pab) = initRightFuse pab
215− {-# INLINE mright #-}
216−
217−-- Once we encounter a dimap we're done. As expressions are already in
218−-- a normal form. | We are here
219−-- |
220−-- dimap . dimap . dimap . <-| right . right . right
221−instance MProfunctor p => MProfunctor (RightFuse p) where
222− mdimap f g (RightFuse p) = DirtyRightFuse (p f g)
223−-- RightFuse (\aezb ezcd -> p (EitherFun Left (Right . lowerFun f) <.> aezb)
224−-- (ezcd <.> EitherFun Left (Right . lowerFun g)))
225−
226− -- We apply this adapther after floating all dimaps to the left so that
227− -- this should never happen
228− mdimap f g (DirtyRightFuse p) = DirtyRightFuse (mdimap f g p)
229− {-# INLINE mdimap #-}
230−
231−-- These are assoc and assoc' but with the free theorem applied
232−assocNew = WrappedFun (plus assocg id) <.> assoc
233−assoc'New = EitherFun id (\c -> Right (Right c))
234−
235−assocg = (\eab -> case eab of
236− Left a -> Left a
237− Right b -> Right (Left b))
238−
239−assoc :: Fun (Either a (Either b c)) (Either (Either a b) c)
240−assoc = EitherFun (\a -> Left (Left a))
241− (\ebc ->
242− case ebc of
243− Left b -> Left (Right b)
244− Right c -> Right c)
245−
246−assoc' :: Fun (Either (Either a b) c) (Either a (Either b c))
247−assoc' = EitherFun
248− (\eab -> case eab of
249− Left a -> Left a
250− Right b -> Right (Left b))
251− (\c -> Right (Right c) )
252−
253−-- Want to only have one mright
254−testRightFuse :: (MProfunctor p, MRight p) => p Int Int -> p (Either z2 (Either z (Either z1 Int))) (Either z2 ((Either z (Either z1 Int))))
255−testRightFuse pab = mright (mright (mright pab))
256−
257−ravelRightFuse :: (MProfunctor p, MRight p) =>
258− (RightFuse p a b -> RightFuse p s t)
259− -> p a b -> p s t
260−ravelRightFuse l pab = lowerRightFuse (l (liftRightFuse pab))
261−
262−-- Works
263−specRightFuse :: (MProfunctor p, MRight p) => p Int Int -> p (Either z2 (Either z (Either z1 Int))) (Either z2 ((Either z (Either z1 Int))))
264−specRightFuse = ravelRightFuse testRightFuse
265−
266−------------------------------------------------------------------------------
267−-- Then only start after a right
268−-- Don't think this is needed actually
269−{-
270−
271−data RightFuse1 p b c where
272− RightFuse1 :: p (Either z b) (Either z c) -> (RightFuse p (Either z b) (Either z c)) -> RightFuse1 p (Either z b) (Either z c)
273− DirtyRightFuse1 :: (p b c) -> RightFuse1 p b c
274−
275−initRightFuse1 :: (MRight p, MProfunctor p) => p a b -> RightFuse1 p (Either z a) (Either z b)
276−initRightFuse1 pab = RightFuse1 (mright pab) (initRightFuse pab)
277−
278−liftRightFuse1 = DirtyRightFuse1
279−
280−lowerRightFuse1 :: RightFuse1 p a b -> p a b
281−lowerRightFuse1 (RightFuse1 pab _) = pab
282−lowerRightFuse1 (DirtyRightFuse1 pbc) = pbc
283−
284−rfdimap :: Fun c a -> Fun b d -> RightFuse p a b -> p c d
285−rfdimap f g (RightFuse rf) = rf f g
286−
287−-- Once we see a dimap, it's over, remember the normal form invariant
288−instance MProfunctor p => MProfunctor (RightFuse1 p) where
289− mdimap f g (RightFuse1 _ d) = DirtyRightFuse1 (rfdimap f g d) -- RightFuse1 (rfdimap f g d) (mdimap f g d)
290− mdimap f g (DirtyRightFuse1 pbc) = DirtyRightFuse1 (mdimap f g pbc)
291−
292−instance (MProfunctor p, MRight p) => MRight (RightFuse1 p) where
293− mright (DirtyRightFuse1 pbc) = initRightFuse1 pbc
294− mright (RightFuse1 _ d) = RightFuse1 (mright (lowerRightFuse d)) (mright d)
295−
296−-- Want to only have one mright
297−testRightFuse1 :: (MProfunctor p, MRight p) => p Int Int -> p (Either z (Either z1 Int)) ((Either z (Either z1 Int)))
298−testRightFuse1 pab = mright (mright pab)
299−
300−ravelRightFuse1 :: (MProfunctor p, MRight p) =>
301− (RightFuse1 p a b -> RightFuse1 p s t)
302− -> p a b -> p s t
303−ravelRightFuse1 l pab = lowerRightFuse1 (l (liftRightFuse1 pab))
304−
305−-- Fails
306−specRightFuse1 :: (MProfunctor p, MRight p) => p Int Int -> p (Either z (Either z1 Int)) ((Either z (Either z1 Int)))
307−specRightFuse1 = ravelRightFuse1 testRightFuse1
308−-}
309−------------------------------------------------------------------------------
310−-- Now apply a specialised version of the free theorem, do this before
311−-- fusing anything or we risk losing information
312−-- dimap f (either g h) (right p) = dimap (either g f) (either id h) (right p)
313−
314−data RightFreeTheorem p a b where
315− RFRight :: p a b -> RightFreeTheorem p (Either z a) (Either z b)
316−-- RFDMap :: Fun c a -> Fun b d -> p a b -> RightFreeTheorem p c d
317− RFDirty :: p a b -> RightFreeTheorem p a b
318−
319−liftRightFreeTheorem :: p a b -> RightFreeTheorem p a b
320−liftRightFreeTheorem = RFDirty
321−
322−lowerRightFreeTheorem :: (MProfunctor p, MRight p) => RightFreeTheorem p a b -> p a b
323−lowerRightFreeTheorem (RFDirty pab) = pab
324−--lowerRightFreeTheorem (RFDMap fa fb pab) = mdimap fa fb pab
325−lowerRightFreeTheorem (RFRight pab) = mright pab
326−
327−instance (MRight p, MProfunctor p) => MProfunctor (RightFreeTheorem p) where
328− -- We are interested in dimap ... (right so dimap after a dirty is
329− -- pointless so just delegate
330− mdimap f g (RFDirty pab) = RFDirty (mdimap f g pab)
331− -- Actually I we need to do fusion in the same pass otherwise we just do
332− -- this for dimaps immediately next to a right BUT we do a partial fusion
333− -- pass first which spots these opporunities
334− mdimap f (EitherFun g h) (RFRight pab) = RFDirty (mdimap (liftFun (plus g id) <.> f) (EitherFun id h) (mright pab))
335− mdimap f g (RFRight pab) = RFDirty (mdimap f g (mright pab))
336− {-# INLINE mdimap #-}
337−
338−instance MRight p => MRight (RightFreeTheorem p) where
339− mright (RFDirty pab) = RFRight pab
340− mright (RFRight pab) = RFRight (mright pab)
341− {-# INLINE mright #-}
342−
343−
344−plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
345−plus f g (Left x) = Left (f x)
346−plus f g (Right x) = Right (g x)
347−
348−
349−-- Want to only have one mright
350−testRightFreeTheorem :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
351−testRightFreeTheorem pab = mdimap f g (mright (mdimap f g (mright pab)))
352− where
353− f :: Fun Int (Either Int Int)
354− f = liftFun Left
355−
356− g :: Fun (Either Int Int) Int
357− g = EitherFun (const 0) (const 0)
358−
359−ravelRightFreeTheorem :: (MProfunctor p, MRight p) =>
360− (RightFreeTheorem p a b -> RightFreeTheorem p s t)
361− -> p a b -> p s t
362−ravelRightFreeTheorem l pab = lowerRightFreeTheorem (l (liftRightFreeTheorem pab))
363−
364−-- Works
365−specRightFreeTheorem :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
366−specRightFreeTheorem = ravelRightFreeTheorem testRightFreeTheorem
367−
368−------------------------------------------------------------------------------
369−-- A partial dimap fusion pass which only fuses functions such that
370−-- we still have an EitherFun in the 2nd argument of dimap.
371−{-
372−data PartialFusion p a b where
373− PFDMap :: Fun c a -> Fun b d -> p a b -> PartialFusion p c d
374− PFDirty :: p a b -> PartialFusion p a b
375−
376−liftPartialFusion :: p a b -> PartialFusion p a b
377−liftPartialFusion = PFDirty
378−
379−lowerPartialFusion :: MProfunctor p => PartialFusion p a b -> p a b
380−lowerPartialFusion (PFDirty pab) = pab
381−lowerPartialFusion (PFDMap fca fbd pcd) = mdimap fca fbd pcd
382−
383−instance (MRight p, MProfunctor p) => MProfunctor (PartialFusion p) where
384− mdimap f g (PFDirty pab) = PFDMap f g pab
385− mdimap f g (PFDMap f' (EitherFun l r) pab) = PFDMap (f' <.> f) (EitherFun ((lowerFun g) . l) ((lowerFun g) . r)) pab
386− mdimap f g (PFDMap f' g' pab) = PFDMap f g (mdimap f' g' pab)
387−
388−instance (MProfunctor p, MRight p) => MRight (PartialFusion p) where
389− mright pab = PFDirty (mright (lowerPartialFusion pab))
390−
391−
392−-- We want g and g' to fuse but not the innermost dimap so we are left with
393−-- two dimaps
394−testPartialFusion :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
395−testPartialFusion pab = (mdimap id' g (mdimap (WrappedFun Left) g' (mdimap id' id' (mright pab))))
396− where
397− id' = WrappedFun id
398−
399− g' :: Fun (Either Int Int) Int
400− g' = EitherFun (const 0) (const 0)
401−
402− g :: Fun Int Int
403− g = WrappedFun (const 2)
404−
405−
406−ravelPartialFusion :: (MProfunctor p, MRight p) =>
407− (PartialFusion p a b -> PartialFusion p s t)
408− -> p a b -> p s t
409−ravelPartialFusion l pab = lowerPartialFusion (l (liftPartialFusion pab))
410−
411−-- Works
412−specPartialFusion :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
413−specPartialFusion = ravelPartialFusion testPartialFusion
414−-}
415−------------------------------------------------------------------------------
416−-- We also lift the function space so that we can rewrite
417−-- dimap f (either g h) (right r) = dimap (either g f) (either id h) (right r)
418−--
419−data Fun a b where
420− WrappedFun :: (a -> b) -> Fun a b
421−-- PlusFun :: (x1 -> x2) -> (y1 -> y2) -> Fun (Either x1 y1) (Either x2 y2)
422− EitherFun :: (x1 -> z) -> (x2 -> z) -> Fun (Either x1 x2) z
423−
424−lowerFun :: Fun a b -> a -> b
425−lowerFun (WrappedFun f) = f
426−lowerFun (EitherFun l r) = either l r
427−
428−liftFun :: (a -> b) -> Fun a b
429−liftFun = WrappedFun
430−
431−ffmap :: Functor f => Fun a b -> Fun (f a) (f b)
432−ffmap fab = liftFun (fmap (lowerFun fab))
433−
434−ddimap :: MProfunctor p => (c -> a) -> (b -> d) -> p a b -> p c d
435−ddimap f g = mdimap (liftFun f) (liftFun g)
436−
437−femap :: Fun a b -> Fun (Either z a) (Either z b)
438−femap f = EitherFun (Left . id) (Right . lowerFun f)
439−
440−-- Note that (<.>) never destroys an inner EitherFun, that is good
441−-- for the free theorem as it means we are free to fuse dimaps whenever
442−-- we like without fear of destroying this chance. For if we had the chance
443−-- before, we still will afterwards.
444−(<.>) :: Fun b c -> Fun a b -> Fun a c
445−(<.>) cb (EitherFun l r) = EitherFun (lowerFun cb . l) (lowerFun cb . r)
446−(<.>) f g = liftFun (lowerFun f . lowerFun g)
447−
448−(<.) :: Fun b c -> (a -> b) -> Fun a c
449−(<.) f g = f <.> liftFun g
450−
451−(.>) :: (b -> c) -> Fun a b -> Fun a c
452−(.>) f g = liftFun f <.> g
453−
454−-------------------------------------------------------------------------------
455−
456−class MProfunctor p where
457− mdimap :: Fun c a -> Fun b d -> p a b -> p c d
458−
459−class MRight p where
460− mright :: p x y -> p (Either z x) (Either z y)
461−
462−
463−-------------------------------------------------------------------------------
464−-- Note [Optimisating Prisms Plan]
465−-- We want to write prisms in a normal form of
466−-- dimap f (EitherFun id g) . right
467−--
468−-- To that end, the optimisation plan is
469−--
470−-- 1. Float dimaps to the left and rights to the right, fusing together
471−-- dimaps as we go.
472−-- 2. Fuse together rights (taking care not to introduce EitherFun with
473−-- non-id first argument
474−-- 3. Apply the right free theorem to replace EitherFun f g with EitherFun
475−-- id g
476−--
477−-- There are three different adapters for this purpose
478−--
479−-- 1. DimapSyntax
480−-- 2. RightFuse
481−-- 3. RightFreeTheorem
482−--
483−-------------------------------------------------------------------------------
484−-- Debugging help
485−
486−-- Run each stage individually
487−
488−stage1, stage3, stage4, stage5 :: (MProfunctor p, MRight p) => (forall p . (MProfunctor p, MRight p) => p a b) -> p a b
489−stage1 = lowerDimapSyntax
490−--stage2 = lowerPartialFusion
491−stage3 = lowerRightFreeTheorem
492−stage4 = lowerRightFuse
493−stage5 = lowerDimapK1
494−
495−ravelStage1, ravelStage3, ravelStage4, ravelStage5, ravelStage3a
496− :: (MProfunctor p, MRight p)
497− => (forall p . (MProfunctor p, MRight p) => p a b -> p s t) ->
498− p a b -> p s t
499−
500−ravelStage1 = ravelDimapSyntax
501−--ravelStage2 = ravelPartialFusion
502−ravelStage3 = ravelRightFreeTheorem
503−ravelStage3a = ravelDimapSyntaxFF
504−ravelStage4 = ravelRightFuse
505−ravelStage5 = ravelDimapK1
506−
507−newtype FusionStack p a b =
508− FusionStack { getFusionStack :: (DimapSyntax (RightFuse (RightFreeTheorem p)) a b) }
509−
510−instance (MRight p, MProfunctor p) => MProfunctor (FusionStack p) where
511− mdimap f g pab = FusionStack (mdimap f g (getFusionStack pab))
512− {-# INLINE mdimap #-}
513−
514−instance (MProfunctor p, MRight p) => MRight (FusionStack p) where
515− mright pab = FusionStack (mright (getFusionStack pab))
516− {-# INLINE mright #-}
517−
518−liftFusionStack :: MProfunctor p => p a b -> FusionStack p a b
519−liftFusionStack = FusionStack . liftDimapSyntax . liftRightFuse . liftRightFreeTheorem
520−
521−lowerFusionStack :: (MProfunctor p, MRight p) => FusionStack p a b -> p a b
522−lowerFusionStack = lowerRightFreeTheorem . lowerRightFuse . lowerDimapSyntax . getFusionStack
523−{-# INLINE lowerFusionStack #-}
524−
525−ravelFusionStack :: (MProfunctor p, MRight p) =>
526− (FusionStack p a b -> FusionStack p s t)
527− -> p a b -> p s t
528−ravelFusionStack l pab = lowerFusionStack (l (liftFusionStack pab))
529−{-# INLINE ravelFusionStack #-}
530−
531−{- This is morally correct but it doesn't optimise well,
532−- it is also pointless doing it like this as it introduces a lot of
533−- unecessary fmaps which we have to fuse together
534−ravelVLFusionStack :: (MProfunctor p, MRight p, Applicative f) =>
535− ((WrappedVLProfunctor (Boggle f) (FusionStack p)) a b
536− -> ((WrappedVLProfunctor (Boggle f) (FusionStack p)) s t))
537− -> p a (f b) -> p s (f t)
538−ravelVLFusionStack l pab =
539− (lowerFusionStack (ddimap id lowerBoggle (wrappedVLProfunctor (
540− (l (WrappedVLProfunctor (ddimap id liftBoggle (liftFusionStack pab))))))))
541−{-# INLINE ravelVLFusionStack #-}
542−-}
543−
544−-- Works
545−--specFusionStack1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
546−--specFusionStack1 pab = ravelFusionStack testPartialFusion pab
547−
548−specFusionStack2 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
549−specFusionStack2 pab = ravelFusionStack testRightFreeTheorem pab
550−
551−-------------------------------------------------------------------------------
552−-- A wrapped profunctor which we can make an instance of our classes.
553−--
554−
555−-- Use this adapter to get a profunctor lens
556−newtype WrappedProfunctor p a b = WrappedProfunctor { wrappedProfunctor :: (p a b) }
557−
558−instance Profunctor p => MProfunctor (WrappedProfunctor p) where
559− mdimap f g (WrappedProfunctor p) = WrappedProfunctor (dimap (lowerFun f) (lowerFun g) p)
560− {-# INLINE mdimap #-}
561−
562−instance Choice p => MRight (WrappedProfunctor p) where
563− mright (WrappedProfunctor p) = WrappedProfunctor (right' p)
564− {-# INLINE mright #-}
565−
566−-- | Use this adapter to get a VL lens
567−newtype WrappedVLMProfunctor f p a b
568− = WrappedVLMProfunctor { wrappedVLMProfunctor :: p a (f b) }
569−
570−instance (Functor f, MProfunctor p) => MProfunctor (WrappedVLMProfunctor f p) where
571− mdimap f g (WrappedVLMProfunctor pafb)
572− = WrappedVLMProfunctor (mdimap f (ffmap g) pafb)
573− {-# INLINE mdimap #-}
574−
575−instance (Applicative f, MRight p, MProfunctor p) => MRight (WrappedVLMProfunctor f p) where
576− mright (WrappedVLMProfunctor pafb)
577− = WrappedVLMProfunctor (mdimap (liftFun id) (EitherFun (pure . Left) (fmap Right)) (mright pafb))
578− {-# INLINE mright #-}
579−
580−{-
581−-- | Use this adapter to get a VL lens
582−newtype WrappedVLMProfunctor f p a b
583− = WrappedVLMProfunctor { wrappedVLProfunctor :: p a (f b) }
584−
585−instance (Functor f, MProfunctor p) => MProfunctor (WrappedVLMProfunctor f p) where
586− mdimap f g (WrappedVLProfunctor pafb)
587− = WrappedVLProfunctor (mdimap f (ffmap g) pafb)
588− {-# INLINE mdimap #-}
589−
590−instance (Applicative f, MRight p, MProfunctor p) => MRight (WrappedVLMProfunctor f p) where
591− mright (WrappedVLMProfunctor pafb)
592− = WrappedVLMProfunctor (ddimap id (either (pure . Left) (fmap Right)) (mright pafb))
593− {-# INLINE mright #-}
594− -}
595−
596−
597−
598−{-
599−instance MoreProfunctor p => MoreProfunctor (MoreBoggle p) where
600− mdimap f g (MDirty pab) = MDMap f g pab
601− mdimap f g (MDMap f' g' pab) = MDMap (f' <.> f) (g <.> g') pab
602− mdimap f (EitherFun l r) (MDRight pab)
603− = MDMap (liftFun (plus l id) <.> f) (EitherFun id r) (mright pab)
604− mdimap f g (MDRight pab) = MDMap f g (mright pab)
605−
606− mright (MDirty pab) = MDRight pab
607− mright (MDMap f g pab) = MDMap (ffmap f) (ffmap g) (mright pab)
608− mright (MDRight pab) = MDMap assoc assoc' (mright pab)
609−
610−
611−
612−data WInt = Wrap { unWrap :: !Int }
613−
614−--test :: MoreProfunctor p => p Int Int -> p (Either WInt Int) (Either WInt Int)
615−--test pii = mdimap (PlusFun unWrap id) (liftFun id) (mplusp Wrap (mright pii))
616−
617−test :: MoreProfunctor p => p Int Int -> p WInt WInt
618−test pii = mdimap (liftFun too) (EitherFun Wrap Wrap) (mright pii)
619− where
620− too :: WInt -> Either Int Int
621− too (Wrap 0) = Left 0
622− too (Wrap n) = Right n
623−
624−spec1 :: forall p . Choice p => p Int Int -> p WInt WInt
625−spec1 eta = wrappedProfunctor (test (WrappedProfunctor eta))
626−
627−spec :: Choice p => p Int Int -> p WInt WInt
628−spec eta = prismRavel test eta
629−
630−injPrism :: MoreProfunctor p => MoreBoggle p s t -> p s t
631−injPrism (MDRight pa) = mright pa
632−injPrism (MDirty pa) = pa
633−injPrism (MDMap f g pa) = mdimap f g pa
634−projPrism = MDirty
635−
636−
637−prismRavel :: (Choice p)
638− => (MoreBoggle (WrappedProfunctor p) a b -> MoreBoggle (WrappedProfunctor p) s t)
639− -> (p a b -> p s t)
640−prismRavel coy pafb = wrappedProfunctor (injPrism (coy (projPrism (WrappedProfunctor pafb))))
641−{-# INLINE prismRavel #-}
642−-}
643−
644−
645−
test/Spec.hs−1
@@ -18,7 +18,6 @@ import Data.Profunctor
1818import Data.Generics.Product
1919import Data.Generics.Internal.Lens (prismPRavel)
2020import Data.Generics.Sum
21−import Data.Generics.Product.Boggle
2221import Test.Inspection
2322import Test.HUnit
2423import Util