git.iko.soy/generic-lens
on master help sign in
Clean up
6a82eafCsongor Kiss
generic-lens.cabal−4
compare with master
unifiedsplit
@@ -27,9 +27,6 @@ library
27 , Data.Generics.Product.Typed
27 , Data.Generics.Product.Typed
28 , Data.Generics.Labels
28 , Data.Generics.Labels
29 , Data.Generics.Product.Types
29 , Data.Generics.Product.Types
30− , Data.Generics.Product.Boggle
31−
32− , Boggle
33
30
34 , Data.Generics.Sum
31 , Data.Generics.Sum
35 , Data.Generics.Sum.Any
32 , Data.Generics.Sum.Any
@@ -54,7 +51,6 @@ library
54 , Data.Generics.Product.Internal.Subtype
51 , Data.Generics.Product.Internal.Subtype
55 , Data.Generics.Product.Internal.Typed
52 , Data.Generics.Product.Internal.Typed
56 , Data.Generics.Product.Internal.Types
53 , Data.Generics.Product.Internal.Types
57− , Data.Profunctor.Extra
58
54
59 build-depends: base >= 4.9 && <= 5.0
55 build-depends: base >= 4.9 && <= 5.0
60 , profunctors >= 5.0 && <= 6.0
56 , 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
20import Control.Applicative (Const(..))
20import Control.Applicative (Const(..))
21import Data.Functor.Identity (Identity(..))
21import Data.Functor.Identity (Identity(..))
22import Data.Monoid (First (..))
22import Data.Monoid (First (..))
23−import Data.Profunctor (Choice(right'), Profunctor(dimap, rmap))
23+import Data.Profunctor (Choice(right'), Profunctor(dimap))
24−import Data.Profunctor.Extra
25import Data.Profunctor.Unsafe ((#.), (.#))
24import Data.Profunctor.Unsafe ((#.), (.#))
26import Data.Tagged
25import Data.Tagged
27import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
26import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
28−import Boggle hiding (Dirty)
29−import Debug.Trace
30
27
31-- | Type alias for lens
28-- | Type alias for lens
32type Lens' s a
29type Lens' s a
@@ -39,6 +36,9 @@ type Lens s t a b
39type Traversal' s a
36type Traversal' s a
40 = forall f. Applicative f => (a -> f a) -> s -> f s
37 = forall f. Applicative f => (a -> f a) -> s -> f s
41
38
39+type Traversal s t a b
40+ = forall f. Applicative f => (a -> f b) -> s -> f t
41+
42-- | Type alias for prism
42-- | Type alias for prism
43type Prism s t a b
43type Prism s t a b
44 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
44 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
@@ -55,11 +55,8 @@ type Iso' s a
55type Iso s t a b
55type Iso s t a b
56 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
56 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
57
57
58−type IsoE s t a b
59− = forall p f. (MProfunctor p) => p a b -> p s t
60−
61type IsoP s t a b
58type 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
63
60
64-- | Getting
61-- | Getting
65(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
62(^.) :: 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
122prismP bt seta eta = dimap seta (either id bt) (right' eta)
119prismP bt seta eta = dimap seta (either id bt) (right' eta)
123{-# INLINE prismP #-}
120{-# INLINE prismP #-}
124
121
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+
125-- | A type and its generic representation are isomorphic
127-- | A type and its generic representation are isomorphic
126repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
128repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
127repIso = dimap from (fmap to)
129repIso = dimap from (fmap to)
@@ -284,14 +286,6 @@ instance Choice (Market a b) where
284 Right a -> Right a
286 Right a -> Right a
285 {-# INLINE right' #-}
287 {-# INLINE right' #-}
286
288
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−
295prism2prismp :: Market a b s t -> PrismP s t a b
289prism2prismp :: Market a b s t -> PrismP s t a b
296prism2prismp (Market bt seta) = prismP bt seta
290prism2prismp (Market bt seta) = prismP bt seta
297
291
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
27 ( GHasTypes (..)
27 ( GHasTypes (..)
28 ) where
28 ) where
29
29
30−--import Data.Generics.Internal.Families
31−import Data.Generics.Internal.Lens
32−
33import Data.Kind (Type)
30import Data.Kind (Type)
34import GHC.Generics
31import GHC.Generics
35−import Boggle
36
32
37-- |As 'HasTypes' but over generic representations as defined by
33-- |As 'HasTypes' but over generic representations as defined by
38-- "GHC.Generics".
34-- "GHC.Generics".
src/Data/Generics/Product/Types.hs−4
@@ -30,14 +30,10 @@ module Data.Generics.Product.Types
30 HasTypes (..)
30 HasTypes (..)
31 ) where
31 ) where
32
32
33−--import Data.Generics.Internal.Families
34import Data.Generics.Internal.Lens
33import Data.Generics.Internal.Lens
35import Data.Generics.Product.Internal.Types
34import Data.Generics.Product.Internal.Types
36
35
37−--import Data.Kind (Constraint, Type)
38import GHC.Generics (Generic (Rep), from, to)
36import GHC.Generics (Generic (Rep), from, to)
39−import Boggle
40−--import GHC.TypeLits (TypeError, ErrorMessage (..))
41
37
42class HasTypes a s where
38class HasTypes a s where
43 types :: Traversal' s a
39 types :: Traversal' s a
src/Data/Generics/Sum/Constructors.hs−1
@@ -40,7 +40,6 @@ import Data.Generics.Sum.Internal.Constructors
40import Data.Kind (Constraint, Type)
40import Data.Kind (Constraint, Type)
41import GHC.Generics (Generic (Rep))
41import GHC.Generics (Generic (Rep))
42import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
43−import Data.Profunctor.Extra
44
43
45-- $setup
44-- $setup
46-- == /Running example:/
45-- == /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
18import Data.Generics.Product
18import Data.Generics.Product
19import Data.Generics.Internal.Lens (prismPRavel)
19import Data.Generics.Internal.Lens (prismPRavel)
20import Data.Generics.Sum
20import Data.Generics.Sum
21−import Data.Generics.Product.Boggle
22import Test.Inspection
21import Test.Inspection
23import Test.HUnit
22import Test.HUnit
24import Util
23import Util