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