1{-# LANGUAGE RankNTypes #-}
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.
10-- == Optimization Goals
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
18-- The following type characterizes our desired normal form.
20-- > data Normal :: (* -> *) -> * -> * where
21-- > Pure :: a -> Normal f a
22-- > Normal1 :: Normal1 f a -> Normal f a
24-- > data Normal1 :: (* -> *) -> * -> * where
25-- > Ap :: Normal1 f (a -> b) -> f a -> Normal1 f b
26-- > Normal2 :: Normal2 f a -> Normal1 f a
28-- > data Normal2 :: (* -> *) -> * -> * where
29-- > Fmap :: (a -> b) -> f a -> Normal2 f b -- function ≠ 'id'
30-- > Lift :: f a -> Normal2 f a
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:
36-- > f <$> Ap mg mx = Ap ((f .) <$> mg) mx
37-- > f <$> Normal2 mx = Normal2 (f <$> x)
39-- == Optimization Techniques
41-- This transformation uses four primary techniques to achieve optimization.
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.
52-- [/multiple equivalent representations/]
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
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.
67-- 'MapK' tracks the eventual argument to 'fmap'. 'ApK' tracks the eventual
68-- left-most argument to '<.>'. 'PureK' tracks uses of 'pure'.
70-- [/typed tagless final encodings/]
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.
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.
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.
90 , liftBoggle, lowerBoggle
94 , ApWrap(..), liftApWrap, lowerApWrap
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
109import Control.Applicative
111import GHC.Exts ( inline )
113infixl 4 <<$>, <<.>, <.>
115type LensLike f s t a b = (a -> f b) -> (s -> f t)
116type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
117type Traversal' s a = Traversal s s a a
119-- | This class is a mid-point between 'Functor' and 'Applicative'
120-- for types that support the '<*>' operation but not 'pure'
122-- It provides an operation for lifted function application ('<.>')
124-- Implementations of this class must follow these laws:
128-- * @(\\f g x -> f (g x)) '<$>' mf '<.>' mg '<.>' mx = mf '<.>' (mg '<.>' mx)@
132-- * @(\\g x -> f (g x)) '<$>' mg '<.>' mx = f '<$>' (mg '<.>' mx)@
133-- * @(\\g x -> g (f x)) '<$>' mg '<.>' mx = mg '<.>' (f '<$>' mx)@
135-- If @f@ is an 'Applicative', it should satisfy
138class Functor f => Apply f where
139 -- | Lifted application
140 (<.>) :: f (a -> b) -> f a -> f b
141 {-# MINIMAL (<.>) #-}
143------------------------------------------------------------------------
145-- | 'ApWrap' provides an 'Apply' instance in terms of an underlying
146-- 'Applicative' instance.
147newtype ApWrap f a = ApWrap (f a)
149liftApWrap :: f a -> ApWrap f a
152lowerApWrap :: ApWrap f a -> f a
153lowerApWrap (ApWrap fa) = fa
155instance Functor f => Functor (ApWrap f) where
156 fmap f (ApWrap x) = ApWrap (f <$> x)
158-- | @('<.>') = ('<*>')@
159instance Applicative f => Apply (ApWrap f) where
160 ApWrap f <.> ApWrap x = ApWrap (f <*> x)
163------------------------------------------------------------------------
165-- | This type fuses all uses of 'fmap' into a single use of 'fmap' on
166-- the underlying 'Functor' @f@.
168-- There is a natural isomorphism between @f@ and @'MapK' f@ witnessed by
169-- 'liftMapK' and 'lowerMapK' which is respected by the 'Functor' instance
171newtype MapK f a = MapK (forall b. (a -> b) -> f b)
173liftMapK :: Functor f => f a -> MapK f a
174liftMapK fa = MapK (<$> fa)
176lowerMapK :: MapK f a -> f a
177lowerMapK fa = id <<$> fa
179-- | Like '<$>' but removes the 'MapK'
180(<<$>) :: (a -> b) -> MapK f a -> f b
183-- | Note: no underlying 'Functor' required
184instance Functor (MapK f) where
185 fmap f x = MapK (\z -> (z . f) <<$> x)
187------------------------------------------------------------------------
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!
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@.
195data MapK1 f a = MapK1 (f a) (MapK f a)
196 -- ^ Invariant: @(x :: f a) == 'lowerMapK' (y :: 'MapK' f a)
198liftMapK1 :: Functor f => f a -> MapK1 f a
199liftMapK1 fa = MapK1 fa (liftMapK fa)
201lowerMapK1 :: MapK1 f a -> f a
202lowerMapK1 (MapK1 fa _) = fa
204-- | Note: no underlying 'Functor' required
205instance Functor (MapK1 f) where
206 fmap f (MapK1 _ g) = MapK1 (f <<$> g) (f <$> g)
208instance 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))
212------------------------------------------------------------------------
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.
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@.
221newtype ApK f a = ApK (forall b. f (a -> b) -> f b)
223liftApK :: Apply f => f a -> ApK f a
224liftApK fa = ApK (<.> fa)
226lowerApK :: Applicative f => ApK f a -> f a
227lowerApK fa = pure id <<.> fa
229-- | Like '<.>' but removes 'ApK'
230(<<.>) :: f (a -> b) -> ApK f a -> f b
233instance Functor f => Functor (ApK f) where
234 fmap f x = ApK (\g -> (\a b -> a (f b)) <$> g <<.> x)
236-- | Note that this 'Apply' instance only uses the underlying 'Functor'
237instance Functor f => Apply (ApK f) where
238 f <.> x = ApK (\g -> (.) <$> g <<.> f <<.> x)
240------------------------------------------------------------------------
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 '<.>'
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@.
248data ApK1 f a = ApK1 (f a) (ApK f a)
249 -- ^ Invariant: @(x :: f a) == 'lowerApK' (y :: 'ApK' f a)@
251instance Functor f => Functor (ApK1 f) where
252 fmap f (ApK1 x y) = ApK1 (f <$> x) (f <$> y)
254-- | Note that this 'Apply' instance only uses the underlying 'Functor'
255instance Functor f => Apply (ApK1 f) where
256 ApK1 fl fr <.> ApK1 _ x = ApK1 (fl <<.> x) (fr <.> x)
258liftApK1 :: Apply f => f a -> ApK1 f a
259liftApK1 fa = ApK1 fa (liftApK fa)
261lowerApK1 :: ApK1 f a -> f a
262lowerApK1 (ApK1 fa _) = fa
264------------------------------------------------------------------------
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.
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@.
274data PureK f a = Pure a | Dirty (f a)
276lowerPureK :: Applicative f => PureK f a -> f a
277lowerPureK (Pure a) = pure a
278lowerPureK (Dirty fa) = fa
280liftPureK :: f a -> PureK f a
283instance Functor f => Functor (PureK f) where
284 fmap f (Pure x) = Pure (f x)
285 fmap f (Dirty x) = Dirty (f <$> x)
287instance 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
292-- Note that this 'Applicative' instance only uses the underlying 'Apply'
293instance Apply f => Applicative (PureK f) where
297-- | Transform the underlying type.
298natPureK :: (f a -> g a) -> PureK f a -> PureK g a
299natPureK f (Dirty fa) = Dirty (f fa)
300natPureK _ (Pure a) = Pure a
302------------------------------------------------------------------------
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.
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.
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'
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.
320-- 'ApWrap' is at the very bottom. It only exists to provide an 'Apply'
321-- instance to the underlying type @f@.
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@.
326newtype Boggle f a = Boggle (PureK (ApK1 (MapK1 (ApWrap f))) a)
328instance Functor (Boggle f) where
329 fmap f (Boggle x) = Boggle (f <$> x)
332instance Applicative (Boggle f) where
333 pure x = Boggle (pure x)
335 Boggle x <*> Boggle y = Boggle (x <*> y)
338liftBoggle :: Applicative f => f a -> Boggle f a
339liftBoggle = Boggle . liftPureK . liftApK1 . liftMapK1 . liftApWrap
340{-# INLINE[1] liftBoggle #-}
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
347lowerBoggle :: Applicative f => Boggle f a -> f a
349 = lowerPureK . natPureK (lowerApWrap . lowerMapK1 . lowerApK1) . (\(Boggle b) -> b)
350{-# INLINE lowerBoggle #-}
352-- | Optimize a 'Traversal' by fusing the '<$>'s and left-associating the '<*>'s
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".
356boggling :: Applicative f => LensLike (Boggle f) s t a b -> LensLike f s t a b
357boggling l = \f x -> lowerBoggle (l (\x -> (liftBoggle (f x))) x)
358{-# INLINE boggling #-}
361------------------------------------------------------------------------
363-- | Local implementation of @Codensity@ type from @kan-extensions@.
364-- This type captures the concept of a partially applied '>>=' function.
365newtype BindK f a = BindK { runBindK :: forall b. (a -> f b) -> f b }
367instance Functor (BindK f) where
370instance Applicative (BindK f) where
371 pure x = BindK $ \k -> k x
374instance Alternative f => Alternative (BindK f) where
375 empty = BindK $ \_ -> empty
376 (<|>) = liftBindK2 (<|>)
379instance Monad (BindK f) where
380 BindK m >>= f = BindK $ \k -> m $ \a -> runBindK (f a) k
382instance Alternative f => MonadPlus (BindK f)
384-- | Run a @'BindK' f@ computation with 'pure' as the final continuation.
385lowerBindK :: Applicative f => BindK f a -> f a
386lowerBindK (BindK k) = k pure
388liftBindK :: Monad f => f a -> BindK f a
389liftBindK fa = BindK (fa >>=)
391liftBindK1 :: (forall a. f a -> f a) -> BindK f b -> BindK f b
392liftBindK1 f (BindK k) = BindK (f . k)
394liftBindK2 :: (forall a. f a -> f a -> f a) -> BindK f b -> BindK f b -> BindK f b
395liftBindK2 f (BindK m) (BindK n) = BindK (\k -> f (m k) (n k))
397traversePair f (a, b) = (,) <$> f a <*> f b
399test :: Applicative f => (a -> f a) -> (a, a) -> f (a, a)
400test = boggling traversePair
405liftBoggle fa <*> (pure (5+) <*> liftBoggle fb)
407((Boggle . liftPureK . liftApK1 . liftMapK1 . liftApWrap) fa)
409 (pure (5+) <*> (Boggle . liftPureK . liftApK1 . liftMapK1 . liftApWrap) fb)
413 ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))))))
419 ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))))
422 ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))))))
425 ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))))
429 ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))))))
432 ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))))
437 ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))))))
440 ApK1 (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) (liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))
445 ApK1 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))) (liftApK (MapK1 (ApWrap fa) (liftMapK (ApWrap fa))))))
448 ApK1 ((+5) <$> MapK1 (ApWrap fb) (liftMapK (ApWrap fb))) ((+5) <$> liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb)))))
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 -}
464 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
465 <<.> ((+5) <$> liftApK (MapK1 (ApWrap fb) (liftMapK (ApWrap fb))))
471 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
472 <<.> ((+5) <$> liftApK (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))
478 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
479 <<.> ((+5) <$> ApK (<.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))
484 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
485 <<.> (ApK (\g -> (\a b -> a (5 + b)) <$> g <<.>
486 (ApK (<.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb)))))
491 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
492 <<.> (ApK (\g -> (\a b -> a (5 + b)) <$>
493 (g <.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))))
498 (\a b -> a (5 + b)) <$> (
499 (MapK1 (ApWrap fa) (liftMapK (ApWrap fa)))
500 <.> (MapK1 (ApWrap fb) (MapK (<$> (ApWrap fb))))))
505 (\a b -> a (5 + b)) <$> (
506 (MapK1 (ApWrap fa <.> ApWrap fb)
507 (\k -> (\a b -> k (a b)) <<$> (MapK (<$> (ApWrap fa)))))
513 (\a b -> a (5 + b)) <$> (
514 (MapK1 (ApWrap fa <.> ApWrap fb)
515 (ApWrap ((\k -> (\a b -> k (a b))) <$> fa <*> fb))))
522 (\a b -> a (5 + b)) <$> ApWrap fa <.> ApWrap fb))))
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list