1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE UndecidableInstances #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9#if __GLASGOW_HASKELL__ >= 707
10{-# LANGUAGE RoleAnnotations #-}
11#endif
12-----------------------------------------------------------------------------
13-- |
14-- Module      :  Control.Lens.Internal.Magma
15-- Copyright   :  (C) 2012-2016 Edward Kmett
16-- License     :  BSD-style (see the file LICENSE)
17-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
18-- Stability   :  experimental
19-- Portability :  non-portable
20--
21----------------------------------------------------------------------------
22module Control.Lens.Internal.Magma
23  (
24  -- * Magma
25    Magma(..)
26  , runMagma
27  -- * Molten
28  , Molten(..)
29  -- * Mafic
30  , Mafic(..)
31  , runMafic
32  -- * TakingWhile
33  , TakingWhile(..)
34  , runTakingWhile
35  ) where
36
37import Prelude ()
38
39import Control.Comonad
40import Control.Lens.Internal.Bazaar
41import Control.Lens.Internal.Context
42import Control.Lens.Internal.Indexed
43import Control.Lens.Internal.Prelude
44import Data.Functor.Apply
45
46------------------------------------------------------------------------------
47-- Magma
48------------------------------------------------------------------------------
49
50-- | This provides a way to peek at the internal structure of a
51-- 'Control.Lens.Traversal.Traversal' or 'Control.Lens.Traversal.IndexedTraversal'
52data Magma i t b a where
53  MagmaAp   :: Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
54  MagmaPure :: x -> Magma i x b a
55  MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a
56  Magma :: i -> a -> Magma i b b a
57
58#if __GLASGOW_HASKELL__ >= 707
59-- note the 3rd argument infers as phantom, but that would be unsound
60type role Magma representational nominal nominal nominal
61#endif
62
63instance Functor (Magma i t b) where
64  fmap f (MagmaAp x y)    = MagmaAp (fmap f x) (fmap f y)
65  fmap _ (MagmaPure x)    = MagmaPure x
66  fmap f (MagmaFmap xy x) = MagmaFmap xy (fmap f x)
67  fmap f (Magma i a)  = Magma i (f a)
68
69instance Foldable (Magma i t b) where
70  foldMap f (MagmaAp x y)   = foldMap f x `mappend` foldMap f y
71  foldMap _ MagmaPure{}     = mempty
72  foldMap f (MagmaFmap _ x) = foldMap f x
73  foldMap f (Magma _ a) = f a
74
75instance Traversable (Magma i t b) where
76  traverse f (MagmaAp x y)    = MagmaAp <$> traverse f x <*> traverse f y
77  traverse _ (MagmaPure x)    = pure (MagmaPure x)
78  traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x
79  traverse f (Magma i a)  = Magma i <$> f a
80
81instance (Show i, Show a) => Show (Magma i t b a) where
82  showsPrec d (MagmaAp x y) = showParen (d > 4) $
83    showsPrec 4 x . showString " <*> " . showsPrec 5 y
84  showsPrec d (MagmaPure _) = showParen (d > 10) $
85    showString "pure .."
86  showsPrec d (MagmaFmap _ x) = showParen (d > 4) $
87    showString ".. <$> " . showsPrec 5 x
88  showsPrec d (Magma i a) = showParen (d > 10) $
89    showString "Magma " . showsPrec 11 i . showChar ' ' . showsPrec 11 a
90
91-- | Run a 'Magma' where all the individual leaves have been converted to the
92-- expected type
93runMagma :: Magma i t a a -> t
94runMagma (MagmaAp l r)   = runMagma l (runMagma r)
95runMagma (MagmaFmap f r) = f (runMagma r)
96runMagma (MagmaPure x)   = x
97runMagma (Magma _ a) = a
98
99------------------------------------------------------------------------------
100-- Molten
101------------------------------------------------------------------------------
102
103-- | This is a a non-reassociating initially encoded version of 'Bazaar'.
104newtype Molten i a b t = Molten { runMolten :: Magma i t b a }
105
106instance Functor (Molten i a b) where
107  fmap f (Molten xs) = Molten (MagmaFmap f xs)
108  {-# INLINE fmap #-}
109
110instance Apply (Molten i a b) where
111  (<.>) = (<*>)
112  {-# INLINE (<.>) #-}
113
114instance Applicative (Molten i a b) where
115  pure  = Molten #. MagmaPure
116  {-# INLINE pure #-}
117  Molten xs <*> Molten ys = Molten (MagmaAp xs ys)
118  {-# INLINE (<*>) #-}
119
120instance Sellable (Indexed i) (Molten i) where
121  sell = Indexed (\i -> Molten #. Magma i)
122  {-# INLINE sell #-}
123
124instance Bizarre (Indexed i) (Molten i) where
125  bazaar f (Molten (MagmaAp x y))   = bazaar f (Molten x) <*> bazaar f (Molten y)
126  bazaar f (Molten (MagmaFmap g x)) = g <$> bazaar f (Molten x)
127  bazaar _ (Molten (MagmaPure x))   = pure x
128  bazaar f (Molten (Magma i a)) = indexed f i a
129
130instance IndexedFunctor (Molten i) where
131  ifmap f (Molten xs) = Molten (MagmaFmap f xs)
132  {-# INLINE ifmap #-}
133
134instance IndexedComonad (Molten i) where
135  iextract (Molten (MagmaAp x y))   = iextract (Molten x) (iextract (Molten y))
136  iextract (Molten (MagmaFmap f y)) = f (iextract (Molten y))
137  iextract (Molten (MagmaPure x))   = x
138  iextract (Molten (Magma _ a)) = a
139
140  iduplicate (Molten (Magma i a)) = Molten #. Magma i <$> Molten (Magma i a)
141  iduplicate (Molten (MagmaPure x))   = pure (pure x)
142  iduplicate (Molten (MagmaFmap f y)) = iextend (fmap f) (Molten y)
143  iduplicate (Molten (MagmaAp x y))   = iextend (<*>) (Molten x) <*> iduplicate (Molten y)
144
145  iextend k (Molten (Magma i a)) = (k .# Molten) . Magma i <$> Molten (Magma i a)
146  iextend k (Molten (MagmaPure x))   = pure (k (pure x))
147  iextend k (Molten (MagmaFmap f y)) = iextend (k . fmap f) (Molten y)
148  iextend k (Molten (MagmaAp x y))   = iextend (\x' y' -> k $ x' <*> y') (Molten x) <*> iduplicate (Molten y)
149
150instance a ~ b => Comonad (Molten i a b) where
151  extract   = iextract
152  {-# INLINE extract #-}
153  extend    = iextend
154  {-# INLINE extend #-}
155  duplicate = iduplicate
156  {-# INLINE duplicate #-}
157
158------------------------------------------------------------------------------
159-- Mafic
160------------------------------------------------------------------------------
161
162-- | This is used to generate an indexed magma from an unindexed source
163--
164-- By constructing it this way we avoid infinite reassociations in sums where possible.
165data Mafic a b t = Mafic Int (Int -> Magma Int t b a)
166
167-- | Generate a 'Magma' using from a prefix sum.
168runMafic :: Mafic a b t -> Magma Int t b a
169runMafic (Mafic _ k) = k 0
170
171instance Functor (Mafic a b) where
172  fmap f (Mafic w k) = Mafic w (MagmaFmap f . k)
173  {-# INLINE fmap #-}
174
175instance Apply (Mafic a b) where
176  Mafic wf mf <.> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf))
177  {-# INLINE (<.>) #-}
178
179instance Applicative (Mafic a b) where
180  pure a = Mafic 0 $ \_ -> MagmaPure a
181  {-# INLINE pure #-}
182  Mafic wf mf <*> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf))
183  {-# INLINE (<*>) #-}
184
185instance Sellable (->) Mafic where
186  sell a = Mafic 1 $ \ i -> Magma i a
187  {-# INLINE sell #-}
188
189instance Bizarre (Indexed Int) Mafic where
190  bazaar (pafb :: Indexed Int a (f b)) (Mafic _ k) = go (k 0) where
191    go :: Magma Int t b a -> f t
192    go (MagmaAp x y)   = go x <*> go y
193    go (MagmaFmap f x) = f <$> go x
194    go (MagmaPure x)   = pure x
195    go (Magma i a) = indexed pafb (i :: Int) a
196  {-# INLINE bazaar #-}
197
198instance IndexedFunctor Mafic where
199  ifmap f (Mafic w k) = Mafic w (MagmaFmap f . k)
200  {-# INLINE ifmap #-}
201
202------------------------------------------------------------------------------
203-- TakingWhile
204------------------------------------------------------------------------------
205
206-- | This is used to generate an indexed magma from an unindexed source
207--
208-- By constructing it this way we avoid infinite reassociations where possible.
209--
210-- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant',
211-- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma'
212data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a))
213#if __GLASGOW_HASKELL__ >= 707
214type role TakingWhile nominal nominal nominal nominal nominal
215#endif
216
217-- | Generate a 'Magma' with leaves only while the predicate holds from left to right.
218runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a)
219runTakingWhile (TakingWhile _ _ k) = k True
220
221instance Functor (TakingWhile p f a b) where
222  fmap f (TakingWhile w t k) = let ft = f t in TakingWhile w ft $ \b -> if b then MagmaFmap f (k b) else MagmaPure ft
223  {-# INLINE fmap #-}
224
225instance Apply (TakingWhile p f a b) where
226  TakingWhile wf tf mf <.> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o ->
227    if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta)
228  {-# INLINE (<.>) #-}
229
230instance Applicative (TakingWhile p f a b) where
231  pure a = TakingWhile True a $ \_ -> MagmaPure a
232  {-# INLINE pure #-}
233  TakingWhile wf tf mf <*> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o ->
234    if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta)
235  {-# INLINE (<*>) #-}
236
237instance Corepresentable p => Bizarre p (TakingWhile p g) where
238  bazaar (pafb :: p a (f b)) ~(TakingWhile _ _ k) = go (k True) where
239    go :: Magma () t b (Corep p a) -> f t
240    go (MagmaAp x y)  = go x <*> go y
241    go (MagmaFmap f x)  = f <$> go x
242    go (MagmaPure x)    = pure x
243    go (Magma _ wa) = cosieve pafb wa
244  {-# INLINE bazaar #-}
245
246-- This constraint is unused intentionally, it protects TakingWhile
247instance Contravariant f => Contravariant (TakingWhile p f a b) where
248  contramap _ = (<$) (error "contramap: TakingWhile")
249  {-# INLINE contramap #-}
250
251instance IndexedFunctor (TakingWhile p f) where
252  ifmap = fmap
253  {-# INLINE ifmap #-}
254