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