1{-# LANGUAGE CPP #-} 2{-# LANGUAGE Trustworthy #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4----------------------------------------------------------------------------- 5-- | 6-- Copyright : (C) 2011-2018 Edward Kmett 7-- License : BSD-style (see the file LICENSE) 8-- 9-- Maintainer : Edward Kmett <ekmett@gmail.com> 10-- Stability : provisional 11-- Portability : portable 12-- 13-- For a good explanation of profunctors in Haskell see Dan Piponi's article: 14-- 15-- <http://blog.sigfpe.com/2011/07/profunctors-in-haskell.html> 16-- 17-- This module includes /unsafe/ composition operators that are useful in 18-- practice when it comes to generating optimal core in GHC. 19-- 20-- If you import this module you are taking upon yourself the obligation 21-- that you will only call the operators with @#@ in their names with functions 22-- that are operationally identity such as @newtype@ constructors or the field 23-- accessor of a @newtype@. 24-- 25-- If you are ever in doubt, use 'rmap' or 'lmap'. 26---------------------------------------------------------------------------- 27module Data.Profunctor.Unsafe 28 ( 29 -- * Profunctors 30 Profunctor(..) 31 ) where 32 33import Control.Arrow 34import Control.Category 35import Control.Comonad (Cokleisli(..)) 36import Control.Monad (liftM) 37import Data.Bifunctor.Biff (Biff(..)) 38import Data.Bifunctor.Clown (Clown(..)) 39import Data.Bifunctor.Joker (Joker(..)) 40import Data.Bifunctor.Product (Product(..)) 41import Data.Bifunctor.Sum (Sum(..)) 42import Data.Bifunctor.Tannen (Tannen(..)) 43import Data.Coerce (Coercible, coerce) 44#if __GLASGOW_HASKELL__ < 710 45import Data.Functor 46#endif 47import Data.Functor.Contravariant (Contravariant(..)) 48import Data.Tagged 49import Prelude hiding (id,(.)) 50 51infixr 9 #. 52infixl 8 .# 53 54---------------------------------------------------------------------------- 55-- Profunctors 56---------------------------------------------------------------------------- 57 58-- | Formally, the class 'Profunctor' represents a profunctor 59-- from @Hask@ -> @Hask@. 60-- 61-- Intuitively it is a bifunctor where the first argument is contravariant 62-- and the second argument is covariant. 63-- 64-- You can define a 'Profunctor' by either defining 'dimap' or by defining both 65-- 'lmap' and 'rmap'. 66-- 67-- If you supply 'dimap', you should ensure that: 68-- 69-- @'dimap' 'id' 'id' ≡ 'id'@ 70-- 71-- If you supply 'lmap' and 'rmap', ensure: 72-- 73-- @ 74-- 'lmap' 'id' ≡ 'id' 75-- 'rmap' 'id' ≡ 'id' 76-- @ 77-- 78-- If you supply both, you should also ensure: 79-- 80-- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ 81-- 82-- These ensure by parametricity: 83-- 84-- @ 85-- 'dimap' (f '.' g) (h '.' i) ≡ 'dimap' g h '.' 'dimap' f i 86-- 'lmap' (f '.' g) ≡ 'lmap' g '.' 'lmap' f 87-- 'rmap' (f '.' g) ≡ 'rmap' f '.' 'rmap' g 88-- @ 89class Profunctor p where 90 -- | Map over both arguments at the same time. 91 -- 92 -- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ 93 dimap :: (a -> b) -> (c -> d) -> p b c -> p a d 94 dimap f g = lmap f . rmap g 95 {-# INLINE dimap #-} 96 97 -- | Map the first argument contravariantly. 98 -- 99 -- @'lmap' f ≡ 'dimap' f 'id'@ 100 lmap :: (a -> b) -> p b c -> p a c 101 lmap f = dimap f id 102 {-# INLINE lmap #-} 103 104 -- | Map the second argument covariantly. 105 -- 106 -- @'rmap' ≡ 'dimap' 'id'@ 107 rmap :: (b -> c) -> p a b -> p a c 108 rmap = dimap id 109 {-# INLINE rmap #-} 110 111 -- | Strictly map the second argument argument 112 -- covariantly with a function that is assumed 113 -- operationally to be a cast, such as a newtype 114 -- constructor. 115 -- 116 -- /Note:/ This operation is explicitly /unsafe/ 117 -- since an implementation may choose to use 118 -- 'unsafeCoerce' to implement this combinator 119 -- and it has no way to validate that your function 120 -- meets the requirements. 121 -- 122 -- If you implement this combinator with 123 -- 'unsafeCoerce', then you are taking upon yourself 124 -- the obligation that you don't use GADT-like 125 -- tricks to distinguish values. 126 -- 127 -- If you import "Data.Profunctor.Unsafe" you are 128 -- taking upon yourself the obligation that you 129 -- will only call this with a first argument that is 130 -- operationally identity. 131 -- 132 -- The semantics of this function with respect to bottoms 133 -- should match the default definition: 134 -- 135 -- @('Profuctor.Unsafe.#.') ≡ \\_ -> \\p -> p \`seq\` 'rmap' 'coerce' p@ 136 (#.) :: forall a b c q. Coercible c b => q b c -> p a b -> p a c 137 (#.) = \_ -> \p -> p `seq` rmap (coerce (id :: c -> c) :: b -> c) p 138 {-# INLINE (#.) #-} 139 140 -- | Strictly map the first argument argument 141 -- contravariantly with a function that is assumed 142 -- operationally to be a cast, such as a newtype 143 -- constructor. 144 -- 145 -- /Note:/ This operation is explicitly /unsafe/ 146 -- since an implementation may choose to use 147 -- 'unsafeCoerce' to implement this combinator 148 -- and it has no way to validate that your function 149 -- meets the requirements. 150 -- 151 -- If you implement this combinator with 152 -- 'unsafeCoerce', then you are taking upon yourself 153 -- the obligation that you don't use GADT-like 154 -- tricks to distinguish values. 155 -- 156 -- If you import "Data.Profunctor.Unsafe" you are 157 -- taking upon yourself the obligation that you 158 -- will only call this with a second argument that is 159 -- operationally identity. 160 -- 161 -- @('.#') ≡ \\p -> p \`seq\` \\f -> 'lmap' 'coerce' p@ 162 (.#) :: forall a b c q. Coercible b a => p b c -> q a b -> p a c 163 (.#) = \p -> p `seq` \_ -> lmap (coerce (id :: b -> b) :: a -> b) p 164 {-# INLINE (.#) #-} 165 166 {-# MINIMAL dimap | (lmap, rmap) #-} 167 168instance Profunctor (->) where 169 dimap ab cd bc = cd . bc . ab 170 {-# INLINE dimap #-} 171 lmap = flip (.) 172 {-# INLINE lmap #-} 173 rmap = (.) 174 {-# INLINE rmap #-} 175 (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b 176 (.#) pbc _ = coerce pbc 177 {-# INLINE (#.) #-} 178 {-# INLINE (.#) #-} 179 180instance Profunctor Tagged where 181 dimap _ f (Tagged s) = Tagged (f s) 182 {-# INLINE dimap #-} 183 lmap _ = retag 184 {-# INLINE lmap #-} 185 rmap = fmap 186 {-# INLINE rmap #-} 187 (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b 188 {-# INLINE (#.) #-} 189 Tagged s .# _ = Tagged s 190 {-# INLINE (.#) #-} 191 192instance Monad m => Profunctor (Kleisli m) where 193 dimap f g (Kleisli h) = Kleisli (liftM g . h . f) 194 {-# INLINE dimap #-} 195 lmap k (Kleisli f) = Kleisli (f . k) 196 {-# INLINE lmap #-} 197 rmap k (Kleisli f) = Kleisli (liftM k . f) 198 {-# INLINE rmap #-} 199 -- We cannot safely overload (#.) because we didn't provide the 'Monad'. 200 (.#) pbc _ = coerce pbc 201 {-# INLINE (.#) #-} 202 203instance Functor w => Profunctor (Cokleisli w) where 204 dimap f g (Cokleisli h) = Cokleisli (g . h . fmap f) 205 {-# INLINE dimap #-} 206 lmap k (Cokleisli f) = Cokleisli (f . fmap k) 207 {-# INLINE lmap #-} 208 rmap k (Cokleisli f) = Cokleisli (k . f) 209 {-# INLINE rmap #-} 210 -- We cannot safely overload (.#) because we didn't provide the 'Functor'. 211 (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b 212 {-# INLINE (#.) #-} 213 214instance Contravariant f => Profunctor (Clown f) where 215 lmap f (Clown fa) = Clown (contramap f fa) 216 {-# INLINE lmap #-} 217 rmap _ (Clown fa) = Clown fa 218 {-# INLINE rmap #-} 219 dimap f _ (Clown fa) = Clown (contramap f fa) 220 {-# INLINE dimap #-} 221 222instance Functor f => Profunctor (Joker f) where 223 lmap _ (Joker fb) = Joker fb 224 {-# INLINE lmap #-} 225 rmap g (Joker fb) = Joker (fmap g fb) 226 {-# INLINE rmap #-} 227 dimap _ g (Joker fb) = Joker (fmap g fb) 228 {-# INLINE dimap #-} 229 230instance (Profunctor p, Functor f, Functor g) => Profunctor (Biff p f g) where 231 lmap f (Biff p) = Biff (lmap (fmap f) p) 232 rmap g (Biff p) = Biff (rmap (fmap g) p) 233 dimap f g (Biff p) = Biff (dimap (fmap f) (fmap g) p) 234 235instance (Profunctor p, Profunctor q) => Profunctor (Product p q) where 236 lmap f (Pair p q) = Pair (lmap f p) (lmap f q) 237 {-# INLINE lmap #-} 238 rmap g (Pair p q) = Pair (rmap g p) (rmap g q) 239 {-# INLINE rmap #-} 240 dimap f g (Pair p q) = Pair (dimap f g p) (dimap f g q) 241 {-# INLINE dimap #-} 242 (#.) f (Pair p q) = Pair (f #. p) (f #. q) 243 {-# INLINE (#.) #-} 244 (.#) (Pair p q) f = Pair (p .# f) (q .# f) 245 {-# INLINE (.#) #-} 246 247instance (Profunctor p, Profunctor q) => Profunctor (Sum p q) where 248 lmap f (L2 x) = L2 (lmap f x) 249 lmap f (R2 y) = R2 (lmap f y) 250 {-# INLINE lmap #-} 251 rmap g (L2 x) = L2 (rmap g x) 252 rmap g (R2 y) = R2 (rmap g y) 253 {-# INLINE rmap #-} 254 dimap f g (L2 x) = L2 (dimap f g x) 255 dimap f g (R2 y) = R2 (dimap f g y) 256 {-# INLINE dimap #-} 257 f #. L2 x = L2 (f #. x) 258 f #. R2 y = R2 (f #. y) 259 {-# INLINE (#.) #-} 260 L2 x .# f = L2 (x .# f) 261 R2 y .# f = R2 (y .# f) 262 {-# INLINE (.#) #-} 263 264instance (Functor f, Profunctor p) => Profunctor (Tannen f p) where 265 lmap f (Tannen h) = Tannen (lmap f <$> h) 266 {-# INLINE lmap #-} 267 rmap g (Tannen h) = Tannen (rmap g <$> h) 268 {-# INLINE rmap #-} 269 dimap f g (Tannen h) = Tannen (dimap f g <$> h) 270 {-# INLINE dimap #-} 271 (#.) f (Tannen h) = Tannen ((f #.) <$> h) 272 {-# INLINE (#.) #-} 273 (.#) (Tannen h) f = Tannen ((.# f) <$> h) 274 {-# INLINE (.#) #-} 275