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