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