1{-# LANGUAGE CPP, TypeOperators #-} 2 3#if __GLASGOW_HASKELL__ >= 702 4{-# LANGUAGE Trustworthy #-} 5#endif 6----------------------------------------------------------------------------- 7-- | 8-- Copyright : (C) 2011-2015 Edward Kmett 9-- License : BSD-style (see the file LICENSE) 10-- 11-- Maintainer : Edward Kmett <ekmett@gmail.com> 12-- Stability : provisional 13-- Portability : portable 14-- 15---------------------------------------------------------------------------- 16module Data.Semigroup.Traversable.Class 17 ( Bitraversable1(..) 18 , Traversable1(..) 19 ) where 20 21import Control.Applicative 22import Control.Applicative.Backwards 23import Control.Applicative.Lift 24import Control.Monad.Trans.Identity 25import Data.Bitraversable 26import Data.Bifunctor 27import Data.Bifunctor.Biff 28import Data.Bifunctor.Clown 29import Data.Bifunctor.Flip 30import Data.Bifunctor.Joker 31import Data.Bifunctor.Join 32import Data.Bifunctor.Product as Bifunctor 33import Data.Bifunctor.Tannen 34import Data.Bifunctor.Wrapped 35import Data.Functor.Apply 36import Data.Functor.Compose 37 38import Data.Functor.Identity 39import Data.Functor.Product as Functor 40import Data.Functor.Reverse 41import Data.Functor.Sum as Functor 42import Data.List.NonEmpty (NonEmpty(..)) 43import qualified Data.Monoid as Monoid 44import Data.Orphans () 45import Data.Semigroup as Semigroup 46import Data.Semigroup.Foldable 47import Data.Semigroup.Bifoldable 48#ifdef MIN_VERSION_tagged 49import Data.Tagged 50#endif 51#if __GLASGOW_HASKELL__ < 710 52import Data.Traversable 53#endif 54import Data.Traversable.Instances () 55 56#if MIN_VERSION_base(4,4,0) 57import Data.Complex 58#endif 59 60#ifdef MIN_VERSION_containers 61import Data.Tree 62#endif 63 64#ifdef MIN_VERSION_generic_deriving 65import Generics.Deriving.Base 66#else 67import GHC.Generics 68#endif 69 70class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where 71 bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) 72 bitraverse1 f g = bisequence1 . bimap f g 73 {-# INLINE bitraverse1 #-} 74 75 bisequence1 :: Apply f => t (f a) (f b) -> f (t a b) 76 bisequence1 = bitraverse1 id id 77 {-# INLINE bisequence1 #-} 78 79#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 80 {-# MINIMAL bitraverse1 | bisequence1 #-} 81#endif 82 83instance Bitraversable1 Arg where 84 bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b 85 86instance Bitraversable1 Either where 87 bitraverse1 f _ (Left a) = Left <$> f a 88 bitraverse1 _ g (Right b) = Right <$> g b 89 {-# INLINE bitraverse1 #-} 90 91instance Bitraversable1 (,) where 92 bitraverse1 f g (a, b) = (,) <$> f a <.> g b 93 {-# INLINE bitraverse1 #-} 94 95instance Bitraversable1 ((,,) x) where 96 bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b 97 {-# INLINE bitraverse1 #-} 98 99instance Bitraversable1 ((,,,) x y) where 100 bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b 101 {-# INLINE bitraverse1 #-} 102 103instance Bitraversable1 ((,,,,) x y z) where 104 bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b 105 {-# INLINE bitraverse1 #-} 106 107instance Bitraversable1 Const where 108 bitraverse1 f _ (Const a) = Const <$> f a 109 {-# INLINE bitraverse1 #-} 110 111#ifdef MIN_VERSION_tagged 112instance Bitraversable1 Tagged where 113 bitraverse1 _ g (Tagged b) = Tagged <$> g b 114 {-# INLINE bitraverse1 #-} 115#endif 116 117instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where 118 bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff 119 {-# INLINE bitraverse1 #-} 120 121instance Traversable1 f => Bitraversable1 (Clown f) where 122 bitraverse1 f _ = fmap Clown . traverse1 f . runClown 123 {-# INLINE bitraverse1 #-} 124 125instance Bitraversable1 p => Bitraversable1 (Flip p) where 126 bitraverse1 f g = fmap Flip . bitraverse1 g f . runFlip 127 {-# INLINE bitraverse1 #-} 128 129instance Bitraversable1 p => Traversable1 (Join p) where 130 traverse1 f (Join a) = fmap Join (bitraverse1 f f a) 131 {-# INLINE traverse1 #-} 132 sequence1 (Join a) = fmap Join (bisequence1 a) 133 {-# INLINE sequence1 #-} 134 135instance Traversable1 g => Bitraversable1 (Joker g) where 136 bitraverse1 _ g = fmap Joker . traverse1 g . runJoker 137 {-# INLINE bitraverse1 #-} 138 139instance (Bitraversable1 f, Bitraversable1 g) => Bitraversable1 (Bifunctor.Product f g) where 140 bitraverse1 f g (Bifunctor.Pair x y) = Bifunctor.Pair <$> bitraverse1 f g x <.> bitraverse1 f g y 141 {-# INLINE bitraverse1 #-} 142 143instance (Traversable1 f, Bitraversable1 p) => Bitraversable1 (Tannen f p) where 144 bitraverse1 f g = fmap Tannen . traverse1 (bitraverse1 f g) . runTannen 145 {-# INLINE bitraverse1 #-} 146 147instance Bitraversable1 p => Bitraversable1 (WrappedBifunctor p) where 148 bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor 149 {-# INLINE bitraverse1 #-} 150 151 152class (Foldable1 t, Traversable t) => Traversable1 t where 153 traverse1 :: Apply f => (a -> f b) -> t a -> f (t b) 154 sequence1 :: Apply f => t (f b) -> f (t b) 155 156 sequence1 = traverse1 id 157 traverse1 f = sequence1 . fmap f 158 159#if __GLASGOW_HASKELL__ >= 708 160 {-# MINIMAL traverse1 | sequence1 #-} 161#endif 162 163instance Traversable1 f => Traversable1 (Rec1 f) where 164 traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as 165 166instance Traversable1 f => Traversable1 (M1 i c f) where 167 traverse1 f (M1 as) = M1 <$> traverse1 f as 168 169instance Traversable1 Par1 where 170 traverse1 f (Par1 a) = Par1 <$> f a 171 172instance Traversable1 V1 where 173 traverse1 _ v = v `seq` undefined 174 175instance (Traversable1 f, Traversable1 g) => Traversable1 (f :*: g) where 176 traverse1 f (as :*: bs) = (:*:) <$> traverse1 f as <.> traverse1 f bs 177 178instance (Traversable1 f, Traversable1 g) => Traversable1 (f :+: g) where 179 traverse1 f (L1 as) = L1 <$> traverse1 f as 180 traverse1 f (R1 bs) = R1 <$> traverse1 f bs 181 182instance (Traversable1 f, Traversable1 g) => Traversable1 (f :.: g) where 183 traverse1 f (Comp1 m) = Comp1 <$> traverse1 (traverse1 f) m 184 185instance Traversable1 Identity where 186 traverse1 f = fmap Identity . f . runIdentity 187 188instance Traversable1 f => Traversable1 (IdentityT f) where 189 traverse1 f = fmap IdentityT . traverse1 f . runIdentityT 190 191instance Traversable1 f => Traversable1 (Backwards f) where 192 traverse1 f = fmap Backwards . traverse1 f . forwards 193 194instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where 195 traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose 196 197instance Traversable1 f => Traversable1 (Lift f) where 198 traverse1 f (Pure x) = Pure <$> f x 199 traverse1 f (Other y) = Other <$> traverse1 f y 200 201instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where 202 traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b 203 204instance Traversable1 f => Traversable1 (Reverse f) where 205 traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse 206 207instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where 208 traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x 209 traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y 210 211#if MIN_VERSION_base(4,4,0) 212instance Traversable1 Complex where 213 traverse1 f (a :+ b) = (:+) <$> f a <.> f b 214 {-# INLINE traverse1 #-} 215#endif 216 217#ifdef MIN_VERSION_tagged 218instance Traversable1 (Tagged a) where 219 traverse1 f (Tagged a) = Tagged <$> f a 220#endif 221 222#ifdef MIN_VERSION_containers 223instance Traversable1 Tree where 224 traverse1 f (Node a []) = (`Node`[]) <$> f a 225 traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs) 226#endif 227 228instance Traversable1 NonEmpty where 229 traverse1 f (a :| []) = (:|[]) <$> f a 230 traverse1 f (a :| (b: bs)) = (\a' (b':| bs') -> a' :| b': bs') <$> f a <.> traverse1 f (b :| bs) 231 232instance Traversable1 ((,) a) where 233 traverse1 f (a, b) = (,) a <$> f b 234 235instance Traversable1 g => Traversable1 (Joker g a) where 236 traverse1 g = fmap Joker . traverse1 g . runJoker 237 {-# INLINE traverse1 #-} 238 239instance Traversable1 Monoid.Sum where 240 traverse1 g (Monoid.Sum a) = Monoid.Sum <$> g a 241 242instance Traversable1 Monoid.Product where 243 traverse1 g (Monoid.Product a) = Monoid.Product <$> g a 244 245instance Traversable1 Monoid.Dual where 246 traverse1 g (Monoid.Dual a) = Monoid.Dual <$> g a 247 248#if MIN_VERSION_base(4,8,0) 249instance Traversable1 f => Traversable1 (Monoid.Alt f) where 250 traverse1 g (Monoid.Alt m) = Monoid.Alt <$> traverse1 g m 251#endif 252 253instance Traversable1 Semigroup.First where 254 traverse1 g (Semigroup.First a) = Semigroup.First <$> g a 255 256instance Traversable1 Semigroup.Last where 257 traverse1 g (Semigroup.Last a) = Semigroup.Last <$> g a 258 259instance Traversable1 Semigroup.Min where 260 traverse1 g (Semigroup.Min a) = Semigroup.Min <$> g a 261 262instance Traversable1 Semigroup.Max where 263 traverse1 g (Semigroup.Max a) = Semigroup.Max <$> g a 264