1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5#if __GLASGOW_HASKELL__ >= 702
6{-# LANGUAGE Trustworthy #-}
7#endif
8
9#if __GLASGOW_HASKELL__ >= 706
10{-# LANGUAGE PolyKinds #-}
11#endif
12
13-----------------------------------------------------------------------------
14-- |
15-- Module      :  Data.Distributive
16-- Copyright   :  (C) 2011-2016 Edward Kmett
17-- License     :  BSD-style (see the file LICENSE)
18--
19-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
20-- Stability   :  provisional
21-- Portability :  portable
22--
23----------------------------------------------------------------------------
24module Data.Distributive
25  ( Distributive(..)
26  , cotraverse
27  , comapM
28  ) where
29
30import Control.Applicative
31import Control.Applicative.Backwards
32import Control.Monad (liftM)
33#if __GLASGOW_HASKELL__ < 707
34import Control.Monad.Instances ()
35#endif
36import Control.Monad.Trans.Identity
37import Control.Monad.Trans.Reader
38import Data.Coerce
39import Data.Functor.Compose
40import Data.Functor.Identity
41import Data.Functor.Product
42import Data.Functor.Reverse
43import qualified Data.Monoid as Monoid
44import Data.Orphans ()
45
46#if MIN_VERSION_base(4,4,0)
47import Data.Complex
48#endif
49#if __GLASGOW_HASKELL__ >= 707 || defined(MIN_VERSION_tagged)
50import Data.Proxy
51#endif
52#if __GLASGOW_HASKELL__ >= 800 || defined(MIN_VERSION_semigroups)
53import qualified Data.Semigroup as Semigroup
54#endif
55#ifdef MIN_VERSION_tagged
56import Data.Tagged
57#endif
58#if __GLASGOW_HASKELL__ >= 702
59import GHC.Generics (U1(..), (:*:)(..), (:.:)(..), Par1(..), Rec1(..), M1(..))
60#endif
61
62#ifdef HLINT
63{-# ANN module "hlint: ignore Use section" #-}
64#endif
65
66-- | This is the categorical dual of 'Traversable'.
67--
68-- Due to the lack of non-trivial comonoids in Haskell, we can restrict
69-- ourselves to requiring a 'Functor' rather than
70-- some Coapplicative class. Categorically every 'Distributive'
71-- functor is actually a right adjoint, and so it must be 'Representable'
72-- endofunctor and preserve all limits. This is a fancy way of saying it
73-- is isomorphic to @(->) x@ for some x.
74--
75-- To be distributable a container will need to have a way to consistently
76-- zip a potentially infinite number of copies of itself. This effectively
77-- means that the holes in all values of that type, must have the same
78-- cardinality, fixed sized vectors, infinite streams, functions, etc.
79-- and no extra information to try to merge together.
80--
81class Functor g => Distributive g where
82#if __GLASGOW_HASKELL__ >= 707
83  {-# MINIMAL distribute | collect #-}
84#endif
85  -- | The dual of 'Data.Traversable.sequenceA'
86  --
87  -- >>> distribute [(+1),(+2)] 1
88  -- [2,3]
89  --
90  -- @
91  -- 'distribute' = 'collect' 'id'
92  -- 'distribute' . 'distribute' = 'id'
93  -- @
94  distribute  :: Functor f => f (g a) -> g (f a)
95  distribute  = collect id
96
97  -- |
98  -- @
99  -- 'collect' f = 'distribute' . 'fmap' f
100  -- 'fmap' f = 'runIdentity' . 'collect' ('Identity' . f)
101  -- 'fmap' 'distribute' . 'collect' f = 'getCompose' . 'collect' ('Compose' . f)
102  -- @
103
104  collect     :: Functor f => (a -> g b) -> f a -> g (f b)
105  collect f   = distribute . fmap f
106
107  -- | The dual of 'Data.Traversable.sequence'
108  --
109  -- @
110  -- 'distributeM' = 'fmap' 'unwrapMonad' . 'distribute' . 'WrapMonad'
111  -- @
112  distributeM :: Monad m => m (g a) -> g (m a)
113  distributeM = fmap unwrapMonad . distribute . WrapMonad
114
115  -- |
116  -- @
117  -- 'collectM' = 'distributeM' . 'liftM' f
118  -- @
119  collectM    :: Monad m => (a -> g b) -> m a -> g (m b)
120  collectM f  = distributeM . liftM f
121
122-- | The dual of 'Data.Traversable.traverse'
123--
124-- @
125-- 'cotraverse' f = 'fmap' f . 'distribute'
126-- @
127cotraverse :: (Distributive g, Functor f) => (f a -> b) -> f (g a) -> g b
128cotraverse f = fmap f . distribute
129
130-- | The dual of 'Data.Traversable.mapM'
131--
132-- @
133-- 'comapM' f = 'fmap' f . 'distributeM'
134-- @
135comapM :: (Distributive g, Monad m) => (m a -> b) -> m (g a) -> g b
136comapM f = fmap f . distributeM
137
138instance Distributive Identity where
139  collect = coerce (fmap :: (a -> b) -> f a -> f b)
140    :: forall a b f . Functor f => (a -> Identity b) -> f a -> Identity (f b)
141  distribute = Identity . fmap runIdentity
142
143#if __GLASGOW_HASKELL__ >= 707 || defined(MIN_VERSION_tagged)
144instance Distributive Proxy where
145  collect _ _ = Proxy
146  distribute _ = Proxy
147#endif
148
149#if defined(MIN_VERSION_tagged)
150instance Distributive (Tagged t) where
151  collect = coerce (fmap :: (a -> b) -> f a -> f b)
152    :: forall a b f . Functor f => (a -> Tagged t b) -> f a -> Tagged t (f b)
153  distribute = Tagged . fmap unTagged
154#endif
155
156instance Distributive ((->)e) where
157  distribute a e = fmap ($e) a
158  collect f q e = fmap (flip f e) q
159
160instance Distributive g => Distributive (ReaderT e g) where
161  distribute a = ReaderT $ \e -> collect (flip runReaderT e) a
162  collect f x = ReaderT $ \e -> collect (\a -> runReaderT (f a) e) x
163
164instance Distributive g => Distributive (IdentityT g) where
165  collect = coerce (collect :: (a -> g b) -> f a -> g (f b))
166            :: forall a b f . Functor f => (a -> IdentityT g b) -> f a -> IdentityT g (f b)
167
168instance (Distributive f, Distributive g) => Distributive (Compose f g) where
169  distribute = Compose . fmap distribute . collect getCompose
170  collect f = Compose . fmap distribute . collect (coerce f)
171
172instance (Distributive f, Distributive g) => Distributive (Product f g) where
173  -- It might be tempting to write a 'collect' implementation that
174  -- composes the passed function with fstP and sndP. This could be bad,
175  -- because it would lead to the passed function being evaluated twice
176  -- for each element of the underlying functor.
177  distribute wp = Pair (collect fstP wp) (collect sndP wp) where
178    fstP (Pair a _) = a
179    sndP (Pair _ b) = b
180
181
182instance Distributive f => Distributive (Backwards f) where
183  distribute = Backwards . collect forwards
184  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))
185    :: forall g a b . Functor g
186    => (a -> Backwards f b) -> g a -> Backwards f (g b)
187
188instance Distributive f => Distributive (Reverse f) where
189  distribute = Reverse . collect getReverse
190  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))
191    :: forall g a b . Functor g
192    => (a -> Reverse f b) -> g a -> Reverse f (g b)
193
194instance Distributive Monoid.Dual where
195  collect = coerce (fmap :: (a -> b) -> f a -> f b)
196    :: forall f a b . Functor f
197    => (a -> Monoid.Dual b) -> f a -> Monoid.Dual (f b)
198  distribute = Monoid.Dual . fmap Monoid.getDual
199
200instance Distributive Monoid.Product where
201  collect = coerce (fmap :: (a -> b) -> f a -> f b)
202    :: forall f a b . Functor f
203    => (a -> Monoid.Product b) -> f a -> Monoid.Product (f b)
204  distribute = Monoid.Product . fmap Monoid.getProduct
205
206instance Distributive Monoid.Sum where
207  collect = coerce (fmap :: (a -> b) -> f a -> f b)
208    :: forall f a b . Functor f
209    => (a -> Monoid.Sum b) -> f a -> Monoid.Sum (f b)
210  distribute = Monoid.Sum . fmap Monoid.getSum
211
212#if __GLASGOW_HASKELL__ >= 800 || defined(MIN_VERSION_semigroups)
213instance Distributive Semigroup.Min where
214  collect = coerce (fmap :: (a -> b) -> f a -> f b)
215    :: forall f a b . Functor f
216    => (a -> Semigroup.Min b) -> f a -> Semigroup.Min (f b)
217  distribute = Semigroup.Min . fmap Semigroup.getMin
218
219instance Distributive Semigroup.Max where
220  collect = coerce (fmap :: (a -> b) -> f a -> f b)
221    :: forall f a b . Functor f
222    => (a -> Semigroup.Max b) -> f a -> Semigroup.Max (f b)
223  distribute = Semigroup.Max . fmap Semigroup.getMax
224
225instance Distributive Semigroup.First where
226  collect = coerce (fmap :: (a -> b) -> f a -> f b)
227    :: forall f a b . Functor f
228    => (a -> Semigroup.First b) -> f a -> Semigroup.First (f b)
229  distribute = Semigroup.First . fmap Semigroup.getFirst
230
231instance Distributive Semigroup.Last where
232  collect = coerce (fmap :: (a -> b) -> f a -> f b)
233    :: forall f a b . Functor f
234    => (a -> Semigroup.Last b) -> f a -> Semigroup.Last (f b)
235  distribute = Semigroup.Last . fmap Semigroup.getLast
236#endif
237
238#if MIN_VERSION_base(4,4,0)
239instance Distributive Complex where
240  distribute wc = fmap realP wc :+ fmap imagP wc where
241    -- Redefine realPart and imagPart to avoid incurring redundant RealFloat
242    -- constraints on older versions of base
243    realP (r :+ _) = r
244    imagP (_ :+ i) = i
245#endif
246
247instance (Distributive m, Monad m) => Distributive (WrappedMonad m) where
248  collect f = WrapMonad . collect (coerce f)
249
250#if __GLASGOW_HASKELL__ >= 702
251instance Distributive U1 where
252  distribute _ = U1
253
254instance (Distributive a, Distributive b) => Distributive (a :*: b) where
255  -- It might be tempting to write a 'collect' implementation that
256  -- composes the passed function with fstP and sndP. This could be bad,
257  -- because it would lead to the passed function being evaluated twice
258  -- for each element of the underlying functor.
259  distribute f = collect fstP f :*: collect sndP f where
260    fstP (l :*: _) = l
261    sndP (_ :*: r) = r
262
263instance (Distributive a, Distributive b) => Distributive (a :.: b) where
264  distribute = Comp1 . fmap distribute . collect unComp1
265  collect f = Comp1 . fmap distribute . collect (coerce f)
266
267instance Distributive Par1 where
268  distribute = Par1 . fmap unPar1
269  collect = coerce (fmap :: (a -> b) -> f a -> f b)
270    :: forall f a b . Functor f => (a -> Par1 b) -> f a -> Par1 (f b)
271
272instance Distributive f => Distributive (Rec1 f) where
273  distribute = Rec1 . collect unRec1
274  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))
275    :: forall g a b . Functor g
276    => (a -> Rec1 f b) -> g a -> Rec1 f (g b)
277
278instance Distributive f => Distributive (M1 i c f) where
279  distribute = M1 . collect unM1
280  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))
281    :: forall g a b . Functor g
282    => (a -> M1 i c f b) -> g a -> M1 i c f (g b)
283#endif
284