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