1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE Safe #-}
6module Data.Profunctor.Traversing
7  ( Traversing(..)
8  , CofreeTraversing(..)
9  , FreeTraversing(..)
10  -- * Profunctor in terms of Traversing
11  , dimapWandering
12  , lmapWandering
13  , rmapWandering
14  -- * Strong in terms of Traversing
15  , firstTraversing
16  , secondTraversing
17  -- * Choice in terms of Traversing
18  , leftTraversing
19  , rightTraversing
20  ) where
21
22import Control.Applicative
23import Control.Arrow (Kleisli(..))
24import Data.Bifunctor.Tannen
25import Data.Functor.Compose
26import Data.Functor.Identity
27import Data.Orphans ()
28import Data.Profunctor.Choice
29import Data.Profunctor.Monad
30import Data.Profunctor.Strong
31import Data.Profunctor.Types
32import Data.Profunctor.Unsafe
33import Data.Traversable
34import Data.Tuple (swap)
35
36#if __GLASGOW_HASKELL__ < 710
37import Data.Monoid (Monoid)
38import Data.Foldable
39import Prelude hiding (mapM)
40#endif
41
42firstTraversing :: Traversing p => p a b -> p (a, c) (b, c)
43firstTraversing = dimap swap swap . traverse'
44
45secondTraversing :: Traversing p => p a b -> p (c, a) (c, b)
46secondTraversing = traverse'
47
48swapE :: Either a b -> Either b a
49swapE = either Right Left
50
51-- | A definition of 'dimap' for 'Traversing' instances that define
52-- an explicit 'wander'.
53dimapWandering :: Traversing p => (a' -> a) -> (b -> b') -> p a b -> p a' b'
54dimapWandering f g = wander (\afb a' -> g <$> afb (f a'))
55
56-- | 'lmapWandering' may be a more efficient implementation
57-- of 'lmap' than the default produced from 'dimapWandering'.
58lmapWandering :: Traversing p => (a -> b) -> p b c -> p a c
59lmapWandering f = wander (\afb a' -> afb (f a'))
60
61-- | 'rmapWandering' is the same as the default produced from
62-- 'dimapWandering'.
63rmapWandering :: Traversing p => (b -> c) -> p a b -> p a c
64rmapWandering g = wander (\afb a' -> g <$> afb a')
65
66leftTraversing :: Traversing p => p a b -> p (Either a c) (Either b c)
67leftTraversing = dimap swapE swapE . traverse'
68
69rightTraversing :: Traversing p => p a b -> p (Either c a) (Either c b)
70rightTraversing = traverse'
71
72newtype Bazaar a b t = Bazaar { runBazaar :: forall f. Applicative f => (a -> f b) -> f t }
73  deriving Functor
74
75instance Applicative (Bazaar a b) where
76  pure a = Bazaar $ \_ -> pure a
77  mf <*> ma = Bazaar $ \k -> runBazaar mf k <*> runBazaar ma k
78
79instance Profunctor (Bazaar a) where
80  dimap f g m = Bazaar $ \k -> g <$> runBazaar m (fmap f . k)
81
82sell :: a -> Bazaar a b b
83sell a = Bazaar $ \k -> k a
84
85newtype Baz t b a = Baz { runBaz :: forall f. Applicative f => (a -> f b) -> f t }
86  deriving Functor
87
88-- bsell :: a -> Baz b b a
89-- bsell a = Baz $ \k -> k a
90
91-- aar :: Bazaar a b t -> Baz t b a
92-- aar (Bazaar f) = Baz f
93
94sold :: Baz t a a -> t
95sold m = runIdentity (runBaz m Identity)
96
97instance Foldable (Baz t b) where
98  foldMap = foldMapDefault
99
100instance Traversable (Baz t b) where
101  traverse f bz = fmap (\m -> Baz (runBazaar m)) . getCompose . runBaz bz $ \x -> Compose $ sell <$> f x
102
103instance Profunctor (Baz t) where
104  dimap f g m = Baz $ \k -> runBaz m (fmap f . k . g)
105
106-- | Note: Definitions in terms of 'wander' are much more efficient!
107class (Choice p, Strong p) => Traversing p where
108  -- | Laws:
109  --
110  -- @
111  -- 'traverse'' ≡ 'wander' 'traverse'
112  -- 'traverse'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'traverse''
113  -- 'traverse'' '.' 'traverse'' ≡ 'dimap' 'Compose' 'getCompose' '.' 'traverse''
114  -- 'dimap' 'Identity' 'runIdentity' '.' 'traverse'' ≡ 'id'
115  -- @
116  traverse' :: Traversable f => p a b -> p (f a) (f b)
117  traverse' = wander traverse
118
119  -- | This combinator is mutually defined in terms of 'traverse''
120  wander :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t
121  wander f pab = dimap (\s -> Baz $ \afb -> f afb s) sold (traverse' pab)
122
123  {-# MINIMAL wander | traverse' #-}
124
125instance Traversing (->) where
126  traverse' = fmap
127  wander f ab = runIdentity #. f (Identity #. ab)
128
129instance Monoid m => Traversing (Forget m) where
130  traverse' (Forget h) = Forget (foldMap h)
131  wander f (Forget h) = Forget (getConst . f (Const . h))
132
133instance Monad m => Traversing (Kleisli m) where
134  traverse' (Kleisli m) = Kleisli (mapM m)
135  wander f (Kleisli amb) = Kleisli $ unwrapMonad #. f (WrapMonad #. amb)
136
137instance Applicative m => Traversing (Star m) where
138  traverse' (Star m) = Star (traverse m)
139  wander f (Star amb) = Star (f amb)
140
141instance (Functor f, Traversing p) => Traversing (Tannen f p) where
142  traverse' = Tannen . fmap traverse' . runTannen
143
144newtype CofreeTraversing p a b = CofreeTraversing { runCofreeTraversing :: forall f. Traversable f => p (f a) (f b) }
145
146instance Profunctor p => Profunctor (CofreeTraversing p) where
147  lmap f (CofreeTraversing p) = CofreeTraversing (lmap (fmap f) p)
148  rmap g (CofreeTraversing p) = CofreeTraversing (rmap (fmap g) p)
149  dimap f g (CofreeTraversing p) = CofreeTraversing (dimap (fmap f) (fmap g) p)
150
151instance Profunctor p => Strong (CofreeTraversing p) where
152  second' = traverse'
153
154instance Profunctor p => Choice (CofreeTraversing p) where
155  right' = traverse'
156
157instance Profunctor p => Traversing (CofreeTraversing p) where
158  -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .#
159  traverse' (CofreeTraversing p) = CofreeTraversing (dimap Compose getCompose p)
160
161instance ProfunctorFunctor CofreeTraversing where
162  promap f (CofreeTraversing p) = CofreeTraversing (f p)
163
164instance ProfunctorComonad CofreeTraversing where
165  proextract (CofreeTraversing p) = runIdentity #. p .# Identity
166  produplicate (CofreeTraversing p) = CofreeTraversing (CofreeTraversing (dimap Compose getCompose p))
167
168-- | @FreeTraversing -| CofreeTraversing@
169data FreeTraversing p a b where
170  FreeTraversing :: Traversable f => (f y -> b) -> p x y -> (a -> f x) -> FreeTraversing p a b
171
172instance Functor (FreeTraversing p a) where
173  fmap f (FreeTraversing l m r) = FreeTraversing (f . l) m r
174
175instance Profunctor (FreeTraversing p) where
176  lmap f (FreeTraversing l m r) = FreeTraversing l m (r . f)
177  rmap g (FreeTraversing l m r) = FreeTraversing (g . l) m r
178  dimap f g (FreeTraversing l m r) = FreeTraversing (g . l) m (r . f)
179  g #. FreeTraversing l m r = FreeTraversing (g #. l) m r
180  FreeTraversing l m r .# f = FreeTraversing l m (r .# f)
181
182instance Strong (FreeTraversing p) where
183  second' = traverse'
184
185instance Choice (FreeTraversing p) where
186  right' = traverse'
187
188instance Traversing (FreeTraversing p) where
189  traverse' (FreeTraversing l m r) = FreeTraversing (fmap l .# getCompose) m (Compose #. fmap r)
190
191instance ProfunctorFunctor FreeTraversing where
192  promap f (FreeTraversing l m r) = FreeTraversing l (f m) r
193
194instance ProfunctorMonad FreeTraversing where
195  proreturn p = FreeTraversing runIdentity p Identity
196  projoin (FreeTraversing l (FreeTraversing l' m r') r) = FreeTraversing ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r))
197