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