211a0db0a204e3bd8a157c60751f5bd351827a12
[darcs-mirrors/transformers.git] / Data / Functor / Classes.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__ >= 702
3 {-# LANGUAGE Safe #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 710
6 {-# LANGUAGE AutoDeriveTypeable #-}
7 #endif
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Data.Functor.Classes
11 -- Copyright : (c) Ross Paterson 2013
12 -- License : BSD-style (see the file LICENSE)
13 --
14 -- Maintainer : R.Paterson@city.ac.uk
15 -- Stability : experimental
16 -- Portability : portable
17 --
18 -- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to
19 -- unary and binary type constructors.
20 --
21 -- These classes are needed to express the constraints on arguments of
22 -- transformers in portable Haskell. Thus for a new transformer @T@,
23 -- one might write instances like
24 --
25 -- > instance (Eq1 f) => Eq1 (T f) where ...
26 -- > instance (Ord1 f) => Ord1 (T f) where ...
27 -- > instance (Read1 f) => Read1 (T f) where ...
28 -- > instance (Show1 f) => Show1 (T f) where ...
29 --
30 -- If these instances can be defined, defining instances of the base
31 -- classes is mechanical:
32 --
33 -- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1
34 -- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1
35 -- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1
36 -- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1
37 --
38 -----------------------------------------------------------------------------
39
40 module Data.Functor.Classes (
41 -- * Liftings of Prelude classes
42 -- ** For unary constructors
43 Eq1(..), eq1,
44 Ord1(..), compare1,
45 Read1(..), readsPrec1,
46 Show1(..), showsPrec1,
47 -- ** For binary constructors
48 Eq2(..), eq2,
49 Ord2(..), compare2,
50 Read2(..), readsPrec2,
51 Show2(..), showsPrec2,
52 -- * Helper functions
53 -- $example
54 readsData,
55 readsUnaryWith,
56 readsBinaryWith,
57 showsUnaryWith,
58 showsBinaryWith,
59 -- ** Obsolete helpers
60 readsUnary,
61 readsUnary1,
62 readsBinary1,
63 showsUnary,
64 showsUnary1,
65 showsBinary1,
66 ) where
67
68 import Control.Applicative (Const(Const))
69 import Data.Functor.Identity (Identity(Identity))
70 import Data.Monoid (mappend)
71 import Text.Show (showListWith)
72
73 -- | Lifting of the 'Eq' class to unary type constructors.
74 class Eq1 f where
75 -- | Lift an equality test through the type constructor.
76 --
77 -- The function will usually be applied to an equality function,
78 -- but the more general type ensures that the implementation uses
79 -- it to compare elements of the first container with elements of
80 -- the second.
81 liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool
82
83 -- | Lift the standard @('==')@ function through the type constructor.
84 eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool
85 eq1 = liftEq (==)
86
87 -- | Lifting of the 'Ord' class to unary type constructors.
88 class (Eq1 f) => Ord1 f where
89 -- | Lift a 'compare' function through the type constructor.
90 --
91 -- The function will usually be applied to a comparison function,
92 -- but the more general type ensures that the implementation uses
93 -- it to compare elements of the first container with elements of
94 -- the second.
95 liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering
96
97 -- | Lift the standard 'compare' function through the type constructor.
98 compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering
99 compare1 = liftCompare compare
100
101 -- | Lifting of the 'Read' class to unary type constructors.
102 class Read1 f where
103 -- | 'readsPrec' function for an application of the type constructor
104 -- based on 'readsPrec' and 'readList' functions for the argument type.
105 liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
106
107 -- | 'readList' function for an application of the type constructor
108 -- based on 'readsPrec' and 'readList' functions for the argument type.
109 -- The default implementation using standard list syntax is correct
110 -- for most types.
111 liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
112 liftReadList rp rl = readListWith (liftReadsPrec rp rl 0)
113
114 -- | Read a list (using square brackets and commas), given a function
115 -- for reading elements.
116 readListWith :: ReadS a -> ReadS [a]
117 readListWith rp =
118 readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])
119 where
120 readl s = [([],t) | ("]",t) <- lex s] ++
121 [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]
122 readl' s = [([],t) | ("]",t) <- lex s] ++
123 [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]
124
125 -- | Lift the standard 'readsPrec' and 'readList' functions through the
126 -- type constructor.
127 readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)
128 readsPrec1 = liftReadsPrec readsPrec readList
129
130 -- | Lifting of the 'Show' class to unary type constructors.
131 class Show1 f where
132 -- | 'showsPrec' function for an application of the type constructor
133 -- based on 'showsPrec' and 'showList' functions for the argument type.
134 liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
135 Int -> f a -> ShowS
136
137 -- | 'showList' function for an application of the type constructor
138 -- based on 'showsPrec' and 'showList' functions for the argument type.
139 -- The default implementation using standard list syntax is correct
140 -- for most types.
141 liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
142 [f a] -> ShowS
143 liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)
144
145 -- | Lift the standard 'showsPrec' and 'showList' functions through the
146 -- type constructor.
147 showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS
148 showsPrec1 = liftShowsPrec showsPrec showList
149
150 -- | Lifting of the 'Eq' class to binary type constructors.
151 class Eq2 f where
152 -- | Lift equality tests through the type constructor.
153 --
154 -- The function will usually be applied to equality functions,
155 -- but the more general type ensures that the implementation uses
156 -- them to compare elements of the first container with elements of
157 -- the second.
158 liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
159
160 -- | Lift the standard @('==')@ function through the type constructor.
161 eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool
162 eq2 = liftEq2 (==) (==)
163
164 -- | Lifting of the 'Ord' class to binary type constructors.
165 class (Eq2 f) => Ord2 f where
166 -- | Lift 'compare' functions through the type constructor.
167 --
168 -- The function will usually be applied to comparison functions,
169 -- but the more general type ensures that the implementation uses
170 -- them to compare elements of the first container with elements of
171 -- the second.
172 liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->
173 f a c -> f b d -> Ordering
174
175 -- | Lift the standard 'compare' function through the type constructor.
176 compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering
177 compare2 = liftCompare2 compare compare
178
179 -- | Lifting of the 'Read' class to binary type constructors.
180 class Read2 f where
181 -- | 'readsPrec' function for an application of the type constructor
182 -- based on 'readsPrec' and 'readList' functions for the argument types.
183 liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->
184 (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)
185
186 -- | 'readList' function for an application of the type constructor
187 -- based on 'readsPrec' and 'readList' functions for the argument types.
188 -- The default implementation using standard list syntax is correct
189 -- for most types.
190 liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->
191 (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
192 liftReadList2 rp1 rl1 rp2 rl2 =
193 readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0)
194
195 -- | Lift the standard 'readsPrec' function through the type constructor.
196 readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)
197 readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList
198
199 -- | Lifting of the 'Show' class to binary type constructors.
200 class Show2 f where
201 -- | 'showsPrec' function for an application of the type constructor
202 -- based on 'showsPrec' and 'showList' functions for the argument types.
203 liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
204 (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS
205
206 -- | 'showList' function for an application of the type constructor
207 -- based on 'showsPrec' and 'showList' functions for the argument types.
208 -- The default implementation using standard list syntax is correct
209 -- for most types.
210 liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
211 (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS
212 liftShowList2 sp1 sl1 sp2 sl2 =
213 showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)
214
215 -- | Lift the standard 'showsPrec' function through the type constructor.
216 showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS
217 showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList
218
219 -- Instances for Prelude type constructors
220
221 instance Eq1 Maybe where
222 liftEq _ Nothing Nothing = True
223 liftEq _ Nothing (Just _) = False
224 liftEq _ (Just _) Nothing = False
225 liftEq eq (Just x) (Just y) = eq x y
226
227 instance Ord1 Maybe where
228 liftCompare _ Nothing Nothing = EQ
229 liftCompare _ Nothing (Just _) = LT
230 liftCompare _ (Just _) Nothing = GT
231 liftCompare comp (Just x) (Just y) = comp x y
232
233 instance Read1 Maybe where
234 liftReadsPrec rp _ d =
235 readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])
236 `mappend`
237 readsData (readsUnaryWith rp "Just" Just) d
238
239 instance Show1 Maybe where
240 liftShowsPrec _ _ _ Nothing = showString "Nothing"
241 liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x
242
243 instance Eq1 [] where
244 liftEq _ [] [] = True
245 liftEq _ [] (_:_) = False
246 liftEq _ (_:_) [] = False
247 liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys
248
249 instance Ord1 [] where
250 liftCompare _ [] [] = EQ
251 liftCompare _ [] (_:_) = LT
252 liftCompare _ (_:_) [] = GT
253 liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys
254
255 instance Read1 [] where
256 liftReadsPrec _ rl _ = rl
257
258 instance Show1 [] where
259 liftShowsPrec _ sl _ = sl
260
261 instance Eq2 (,) where
262 liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2
263
264 instance Ord2 (,) where
265 liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =
266 comp1 x1 x2 `mappend` comp2 y1 y2
267
268 instance Read2 (,) where
269 liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
270 [((x,y), w) | ("(",s) <- lex r,
271 (x,t) <- rp1 0 s,
272 (",",u) <- lex t,
273 (y,v) <- rp2 0 u,
274 (")",w) <- lex v]
275
276 instance Show2 (,) where
277 liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
278 showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'
279
280 instance (Eq a) => Eq1 ((,) a) where
281 liftEq = liftEq2 (==)
282
283 instance (Ord a) => Ord1 ((,) a) where
284 liftCompare = liftCompare2 compare
285
286 instance (Read a) => Read1 ((,) a) where
287 liftReadsPrec = liftReadsPrec2 readsPrec readList
288
289 instance (Show a) => Show1 ((,) a) where
290 liftShowsPrec = liftShowsPrec2 showsPrec showList
291
292 instance Eq2 Either where
293 liftEq2 e1 _ (Left x) (Left y) = e1 x y
294 liftEq2 _ _ (Left _) (Right _) = False
295 liftEq2 _ _ (Right _) (Left _) = False
296 liftEq2 _ e2 (Right x) (Right y) = e2 x y
297
298 instance Ord2 Either where
299 liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y
300 liftCompare2 _ _ (Left _) (Right _) = LT
301 liftCompare2 _ _ (Right _) (Left _) = GT
302 liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y
303
304 instance Read2 Either where
305 liftReadsPrec2 rp1 _ rp2 _ = readsData $
306 readsUnaryWith rp1 "Left" Left `mappend`
307 readsUnaryWith rp2 "Right" Right
308
309 instance Show2 Either where
310 liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x
311 liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x
312
313 instance (Eq a) => Eq1 (Either a) where
314 liftEq = liftEq2 (==)
315
316 instance (Ord a) => Ord1 (Either a) where
317 liftCompare = liftCompare2 compare
318
319 instance (Read a) => Read1 (Either a) where
320 liftReadsPrec = liftReadsPrec2 readsPrec readList
321
322 instance (Show a) => Show1 (Either a) where
323 liftShowsPrec = liftShowsPrec2 showsPrec showList
324
325 -- Instances for other functors defined in the base package
326
327 instance Eq1 Identity where
328 liftEq eq (Identity x) (Identity y) = eq x y
329
330 instance Ord1 Identity where
331 liftCompare comp (Identity x) (Identity y) = comp x y
332
333 instance Read1 Identity where
334 liftReadsPrec rp _ = readsData $
335 readsUnaryWith rp "Identity" Identity
336
337 instance Show1 Identity where
338 liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x
339
340 instance Eq2 Const where
341 liftEq2 eq _ (Const x) (Const y) = eq x y
342
343 instance Ord2 Const where
344 liftCompare2 comp _ (Const x) (Const y) = comp x y
345
346 instance Read2 Const where
347 liftReadsPrec2 rp _ _ _ = readsData $
348 readsUnaryWith rp "Const" Const
349
350 instance Show2 Const where
351 liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x
352
353 instance (Eq a) => Eq1 (Const a) where
354 liftEq = liftEq2 (==)
355 instance (Ord a) => Ord1 (Const a) where
356 liftCompare = liftCompare2 compare
357 instance (Read a) => Read1 (Const a) where
358 liftReadsPrec = liftReadsPrec2 readsPrec readList
359 instance (Show a) => Show1 (Const a) where
360 liftShowsPrec = liftShowsPrec2 showsPrec showList
361
362 -- Building blocks
363
364 -- | @'readsData' p d@ is a parser for datatypes where each alternative
365 -- begins with a data constructor. It parses the constructor and
366 -- passes it to @p@. Parsers for various constructors can be constructed
367 -- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with
368 -- @mappend@ from the @Monoid@ class.
369 readsData :: (String -> ReadS a) -> Int -> ReadS a
370 readsData reader d =
371 readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]
372
373 -- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor
374 -- and then parses its argument using @rp@.
375 readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
376 readsUnaryWith rp name cons kw s =
377 [(cons x,t) | kw == name, (x,t) <- rp 11 s]
378
379 -- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary
380 -- data constructor and then parses its arguments using @rp1@ and @rp2@
381 -- respectively.
382 readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->
383 String -> (a -> b -> t) -> String -> ReadS t
384 readsBinaryWith rp1 rp2 name cons kw s =
385 [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]
386
387 -- | @'showsUnaryWith' sp n d x@ produces the string representation of a
388 -- unary data constructor with name @n@ and argument @x@, in precedence
389 -- context @d@.
390 showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
391 showsUnaryWith sp name d x = showParen (d > 10) $
392 showString name . showChar ' ' . sp 11 x
393
394 -- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string
395 -- representation of a binary data constructor with name @n@ and arguments
396 -- @x@ and @y@, in precedence context @d@.
397 showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->
398 String -> Int -> a -> b -> ShowS
399 showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $
400 showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y
401
402 -- Obsolete building blocks
403
404 -- | @'readsUnary' n c n'@ matches the name of a unary data constructor
405 -- and then parses its argument using 'readsPrec'.
406 {-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-}
407 readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t
408 readsUnary name cons kw s =
409 [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]
410
411 -- | @'readsUnary1' n c n'@ matches the name of a unary data constructor
412 -- and then parses its argument using 'readsPrec1'.
413 {-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-}
414 readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t
415 readsUnary1 name cons kw s =
416 [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]
417
418 -- | @'readsBinary1' n c n'@ matches the name of a binary data constructor
419 -- and then parses its arguments using 'readsPrec1'.
420 {-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-}
421 readsBinary1 :: (Read1 f, Read1 g, Read a) =>
422 String -> (f a -> g a -> t) -> String -> ReadS t
423 readsBinary1 name cons kw s =
424 [(cons x y,u) | kw == name,
425 (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]
426
427 -- | @'showsUnary' n d x@ produces the string representation of a unary data
428 -- constructor with name @n@ and argument @x@, in precedence context @d@.
429 {-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-}
430 showsUnary :: (Show a) => String -> Int -> a -> ShowS
431 showsUnary name d x = showParen (d > 10) $
432 showString name . showChar ' ' . showsPrec 11 x
433
434 -- | @'showsUnary1' n d x@ produces the string representation of a unary data
435 -- constructor with name @n@ and argument @x@, in precedence context @d@.
436 {-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-}
437 showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS
438 showsUnary1 name d x = showParen (d > 10) $
439 showString name . showChar ' ' . showsPrec1 11 x
440
441 -- | @'showsBinary1' n d x y@ produces the string representation of a binary
442 -- data constructor with name @n@ and arguments @x@ and @y@, in precedence
443 -- context @d@.
444 {-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-}
445 showsBinary1 :: (Show1 f, Show1 g, Show a) =>
446 String -> Int -> f a -> g a -> ShowS
447 showsBinary1 name d x y = showParen (d > 10) $
448 showString name . showChar ' ' . showsPrec1 11 x .
449 showChar ' ' . showsPrec1 11 y
450
451 {- $example
452 These functions can be used to assemble 'Read' and 'Show' instances for
453 new algebraic types. For example, given the definition
454
455 > data T f a = Zero a | One (f a) | Two a (f a)
456
457 a standard 'Read1' instance may be defined as
458
459 > instance (Read1 f) => Read1 (T f) where
460 > liftReadsPrec rp rl = readsData $
461 > readsUnaryWith rp "Zero" Zero `mappend`
462 > readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend`
463 > readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two
464
465 and the corresponding 'Show1' instance as
466
467 > instance (Show1 f) => Show1 (T f) where
468 > liftShowsPrec sp _ d (Zero x) =
469 > showsUnaryWith sp "Zero" d x
470 > liftShowsPrec sp sl d (One x) =
471 > showsUnaryWith (liftShowsPrec sp sl) "One" d x
472 > liftShowsPrec sp sl d (Two x y) =
473 > showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y
474
475 -}