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