1{-# LANGUAGE CPP                #-}
2-- | The 'These' type and associated operations. Now enhanced with "Control.Lens" magic!
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveGeneric      #-}
5{-# LANGUAGE OverloadedStrings  #-}
6{-# LANGUAGE Safe               #-}
7
8#if MIN_VERSION_base(4,9,0)
9#define LIFTED_FUNCTOR_CLASSES 1
10#else
11#if MIN_VERSION_transformers(0,5,0)
12#define LIFTED_FUNCTOR_CLASSES 1
13#else
14#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)
15#define LIFTED_FUNCTOR_CLASSES 1
16#endif
17#endif
18#endif
19
20module Data.These (
21      These(..)
22
23    -- * Functions to get rid of 'These'
24    , these
25    , fromThese
26    , mergeThese
27    , mergeTheseWith
28
29    -- * Partition
30    , partitionThese
31    , partitionHereThere
32    , partitionEithersNE
33
34    -- * Distributivity
35    --
36    -- | This distributivity combinators aren't isomorphisms!
37    , distrThesePair
38    , undistrThesePair
39    , distrPairThese
40    , undistrPairThese
41    ) where
42
43import Control.Applicative  (Applicative (..), (<$>))
44import Control.DeepSeq      (NFData (..))
45import Data.Bifoldable      (Bifoldable (..))
46import Data.Bifunctor       (Bifunctor (..))
47import Data.Binary          (Binary (..))
48import Data.Bitraversable   (Bitraversable (..))
49import Data.Data            (Data, Typeable)
50import Data.Either          (partitionEithers)
51import Data.Foldable        (Foldable (..))
52import Data.Hashable        (Hashable (..))
53import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..))
54import Data.List.NonEmpty   (NonEmpty (..))
55import Data.Monoid          (Monoid (..))
56import Data.Semigroup       (Semigroup (..))
57import Data.Traversable     (Traversable (..))
58import GHC.Generics         (Generic)
59import Prelude
60       (Bool (..), Either (..), Eq (..), Functor (..), Int, Monad (..),
61       Ord (..), Ordering (..), Read (..), Show (..), fail, id, lex, readParen,
62       seq, showParen, showString, ($), (&&), (.))
63
64#if MIN_VERSION_deepseq(1,4,3)
65import Control.DeepSeq (NFData1 (..), NFData2 (..))
66#endif
67
68#if __GLASGOW_HASKELL__ >= 706
69import GHC.Generics (Generic1)
70#endif
71
72#ifdef MIN_VERSION_assoc
73import Data.Bifunctor.Assoc (Assoc (..))
74import Data.Bifunctor.Swap  (Swap (..))
75#endif
76
77#ifdef LIFTED_FUNCTOR_CLASSES
78import Data.Functor.Classes
79       (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..),
80       Show1 (..), Show2 (..))
81#else
82import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..))
83#endif
84
85-- $setup
86-- >>> import Control.Lens
87
88-- --------------------------------------------------------------------------
89-- | The 'These' type represents values with two non-exclusive possibilities.
90--
91--   This can be useful to represent combinations of two values, where the
92--   combination is defined if either input is. Algebraically, the type
93--   @'These' A B@ represents @(A + B + AB)@, which doesn't factor easily into
94--   sums and products--a type like @'Either' A (B, 'Maybe' A)@ is unclear and
95--   awkward to use.
96--
97--   'These' has straightforward instances of 'Functor', 'Monad', &c., and
98--   behaves like a hybrid error/writer monad, as would be expected.
99--
100--   For zipping and unzipping of structures with 'These' values, see
101--   "Data.Align".
102data These a b = This a | That b | These a b
103  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic
104#if __GLASGOW_HASKELL__ >= 706
105    , Generic1
106#endif
107    )
108
109-------------------------------------------------------------------------------
110-- Eliminators
111-------------------------------------------------------------------------------
112
113-- | Case analysis for the 'These' type.
114these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
115these l _ _ (This a) = l a
116these _ r _ (That x) = r x
117these _ _ lr (These a x) = lr a x
118
119-- | Takes two default values and produces a tuple.
120fromThese :: a -> b -> These a b -> (a, b)
121fromThese x y = these (`pair` y) (x `pair`) pair where
122    pair = (,)
123
124-- | Coalesce with the provided operation.
125mergeThese :: (a -> a -> a) -> These a a -> a
126mergeThese = these id id
127
128-- | 'bimap' and coalesce results with the provided operation.
129mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c
130mergeTheseWith f g op t = mergeThese op $ bimap f g t
131
132-------------------------------------------------------------------------------
133-- Partitioning
134-------------------------------------------------------------------------------
135
136-- | Select each constructor and partition them into separate lists.
137partitionThese :: [These a b] -> ([a], [b], [(a, b)])
138partitionThese []     = ([], [], [])
139partitionThese (t:ts) = case t of
140    This x    -> (x : xs,     ys,         xys)
141    That y    -> (    xs, y : ys,         xys)
142    These x y -> (    xs,     ys, (x,y) : xys)
143  where
144    ~(xs,ys,xys) = partitionThese ts
145
146-- | Select 'here' and 'there' elements and partition them into separate lists.
147--
148-- @since 0.8
149partitionHereThere :: [These a b] -> ([a], [b])
150partitionHereThere []     = ([], [])
151partitionHereThere (t:ts) = case t of
152    This x     -> (x : xs,     ys)
153    That y     -> (    xs, y : ys)
154    These x  y -> (x : xs, y : ys)
155  where
156    ~(xs,ys) = partitionHereThere ts
157
158-- | Like 'partitionEithers' but for 'NonEmpty' types.
159--
160-- * either all are 'Left'
161-- * either all are 'Right'
162-- * or there is both 'Left' and 'Right' stuff
163--
164-- /Note:/ this is not online algorithm. In the worst case it will traverse
165-- the whole list before deciding the result constructor.
166--
167-- >>> partitionEithersNE $ Left 'x' :| [Right 'y']
168-- These ('x' :| "") ('y' :| "")
169--
170-- >>> partitionEithersNE $ Left 'x' :| map Left "yz"
171-- This ('x' :| "yz")
172--
173-- @since 1.0.1
174partitionEithersNE :: NonEmpty (Either a b) -> These (NonEmpty a) (NonEmpty b)
175partitionEithersNE (x :| xs) = case (x, ls, rs) of
176    (Left y,  ys,   [])   -> This (y :| ys)
177    (Left y,  ys,   z:zs) -> These (y :| ys) (z :| zs)
178    (Right z, [],   zs)   -> That (z :| zs)
179    (Right z, y:ys, zs)   -> These (y :| ys) (z :| zs)
180  where
181    (ls, rs) = partitionEithers xs
182
183
184-------------------------------------------------------------------------------
185-- Distributivity
186-------------------------------------------------------------------------------
187
188distrThesePair :: These (a, b) c -> (These a c, These b c)
189distrThesePair (This (a, b))    = (This a, This b)
190distrThesePair (That c)         = (That c, That c)
191distrThesePair (These (a, b) c) = (These a c, These b c)
192
193undistrThesePair :: (These a c, These b c) -> These (a, b) c
194undistrThesePair (This a,    This b)    = This (a, b)
195undistrThesePair (That c,    That _)    = That c
196undistrThesePair (These a c, These b _) = These (a, b) c
197undistrThesePair (This _,    That c)    = That c
198undistrThesePair (This a,    These b c) = These (a, b) c
199undistrThesePair (That c,    This _)    = That c
200undistrThesePair (That c,    These _ _) = That c
201undistrThesePair (These a c, This b)    = These (a, b) c
202undistrThesePair (These _ c, That _)    = That c
203
204
205distrPairThese :: (These a b, c) -> These (a, c) (b, c)
206distrPairThese (This a,    c) = This (a, c)
207distrPairThese (That b,    c) = That (b, c)
208distrPairThese (These a b, c) = These (a, c) (b, c)
209
210undistrPairThese :: These (a, c) (b, c) -> (These a b, c)
211undistrPairThese (This (a, c))         = (This a, c)
212undistrPairThese (That (b, c))         = (That b, c)
213undistrPairThese (These (a, c) (b, _)) = (These a b, c)
214
215-------------------------------------------------------------------------------
216-- Instances
217-------------------------------------------------------------------------------
218
219
220
221instance (Semigroup a, Semigroup b) => Semigroup (These a b) where
222    This  a   <> This  b   = This  (a <> b)
223    This  a   <> That    y = These  a             y
224    This  a   <> These b y = These (a <> b)       y
225    That    x <> This  b   = These       b   x
226    That    x <> That    y = That           (x <> y)
227    That    x <> These b y = These       b  (x <> y)
228    These a x <> This  b   = These (a <> b)  x
229    These a x <> That    y = These  a       (x <> y)
230    These a x <> These b y = These (a <> b) (x <> y)
231
232instance Functor (These a) where
233    fmap _ (This x) = This x
234    fmap f (That y) = That (f y)
235    fmap f (These x y) = These x (f y)
236
237instance Foldable (These a) where
238    foldr _ z (This _) = z
239    foldr f z (That x) = f x z
240    foldr f z (These _ x) = f x z
241
242instance Traversable (These a) where
243    traverse _ (This a) = pure $ This a
244    traverse f (That x) = That <$> f x
245    traverse f (These a x) = These a <$> f x
246    sequenceA (This a) = pure $ This a
247    sequenceA (That x) = That <$> x
248    sequenceA (These a x) = These a <$> x
249
250instance Bifunctor These where
251    bimap f _ (This  a  ) = This (f a)
252    bimap _ g (That    x) = That (g x)
253    bimap f g (These a x) = These (f a) (g x)
254
255instance Bifoldable These where
256    bifold = these id id mappend
257    bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z))
258    bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y)
259
260instance Bitraversable These where
261    bitraverse f _ (This x) = This <$> f x
262    bitraverse _ g (That x) = That <$> g x
263    bitraverse f g (These x y) = These <$> f x <*> g y
264
265instance (Semigroup a) => Applicative (These a) where
266    pure = That
267    This  a   <*> _         = This a
268    That    _ <*> This  b   = This b
269    That    f <*> That    x = That (f x)
270    That    f <*> These b x = These b (f x)
271    These a _ <*> This  b   = This (a <> b)
272    These a f <*> That    x = These a (f x)
273    These a f <*> These b x = These (a <> b) (f x)
274
275
276instance (Semigroup a) => Monad (These a) where
277    return = pure
278    This  a   >>= _ = This a
279    That    x >>= k = k x
280    These a x >>= k = case k x of
281                          This  b   -> This  (a <> b)
282                          That    y -> These a y
283                          These b y -> These (a <> b) y
284
285-------------------------------------------------------------------------------
286-- Data.Functor.Classes
287-------------------------------------------------------------------------------
288
289#ifdef LIFTED_FUNCTOR_CLASSES
290-- | @since 1.1.1
291instance Eq2 These where
292  liftEq2 f _ (This a)    (This a')     = f a a'
293  liftEq2 _ g (That b)    (That b')     = g b b'
294  liftEq2 f g (These a b) (These a' b') = f a a' && g b b'
295  liftEq2 _ _ _           _             = False
296
297-- | @since 1.1.1
298instance Eq a => Eq1 (These a) where
299  liftEq = liftEq2 (==)
300
301-- | @since 1.1.1
302instance Ord2 These where
303  liftCompare2 f _ (This a)    (This a')     = f a a'
304  liftCompare2 _ _ (This _)    _             = LT
305  liftCompare2 _ _ _           (This _)      = GT
306  liftCompare2 _ g (That b)    (That b')     = g b b'
307  liftCompare2 _ _ (That _)    _             = LT
308  liftCompare2 _ _ _           (That _)      = GT
309  liftCompare2 f g (These a b) (These a' b') = f a a' `mappend` g b b'
310
311-- | @since 1.1.1
312instance Ord a => Ord1 (These a) where
313  liftCompare = liftCompare2 compare
314
315-- | @since 1.1.1
316instance Show a => Show1 (These a) where
317  liftShowsPrec = liftShowsPrec2 showsPrec showList
318
319-- | @since 1.1.1
320instance Show2 These where
321  liftShowsPrec2 sa _ _sb _ d (This a) = showParen (d > 10)
322    $ showString "This "
323    . sa 11 a
324  liftShowsPrec2 _sa _ sb _ d (That b) = showParen (d > 10)
325    $ showString "That "
326    . sb 11 b
327  liftShowsPrec2 sa _ sb _ d (These a b) = showParen (d > 10)
328    $ showString "These "
329    . sa 11 a
330    . showString " "
331    . sb 11 b
332
333-- | @since 1.1.1
334instance Read2 These where
335  liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> cons s
336    where
337      cons s0 = do
338        (ident, s1) <- lex s0
339        case ident of
340            "This" ->  do
341                (a, s2) <- ra 11 s1
342                return (This a, s2)
343            "That" ->  do
344                (b, s2) <- rb 11 s1
345                return (That b, s2)
346            "These" -> do
347                (a, s2) <- ra 11 s1
348                (b, s3) <- rb 11 s2
349                return (These a b, s3)
350            _ -> []
351
352-- | @since 1.1.1
353instance Read a => Read1 (These a) where
354  liftReadsPrec = liftReadsPrec2 readsPrec readList
355
356#else
357-- | @since 1.1.1
358instance Eq a   => Eq1   (These a) where eq1        = (==)
359-- | @since 1.1.1
360instance Ord a  => Ord1  (These a) where compare1   = compare
361-- | @since 1.1.1
362instance Show a => Show1 (These a) where showsPrec1 = showsPrec
363-- | @since 1.1.1
364instance Read a => Read1 (These a) where readsPrec1 = readsPrec
365#endif
366
367-------------------------------------------------------------------------------
368-- assoc
369-------------------------------------------------------------------------------
370
371#ifdef MIN_VERSION_assoc
372-- | @since 0.8
373instance Swap These where
374    swap (This a)    = That a
375    swap (That b)    = This b
376    swap (These a b) = These b a
377
378-- | @since 0.8
379instance Assoc These where
380    assoc (This (This a))       = This a
381    assoc (This (That b))       = That (This b)
382    assoc (That c)              = That (That c)
383    assoc (These (That b) c)    = That (These b c)
384    assoc (This (These a b))    = These a (This b)
385    assoc (These (This a) c)    = These a (That c)
386    assoc (These (These a b) c) = These a (These b c)
387
388    unassoc (This a)              = This (This a)
389    unassoc (That (This b))       = This (That b)
390    unassoc (That (That c))       = That c
391    unassoc (That (These b c))    = These (That b) c
392    unassoc (These a (This b))    = This (These a b)
393    unassoc (These a (That c))    = These (This a) c
394    unassoc (These a (These b c)) = These (These a b) c
395#endif
396
397-------------------------------------------------------------------------------
398-- deepseq
399-------------------------------------------------------------------------------
400
401-- | @since 0.7.1
402instance (NFData a, NFData b) => NFData (These a b) where
403    rnf (This a)    = rnf a
404    rnf (That b)    = rnf b
405    rnf (These a b) = rnf a `seq` rnf b
406
407#if MIN_VERSION_deepseq(1,4,3)
408-- | @since 1.1.1
409instance NFData a => NFData1 (These a) where
410    liftRnf _rnfB (This a)    = rnf a
411    liftRnf  rnfB (That b)    = rnfB b
412    liftRnf  rnfB (These a b) = rnf a `seq` rnfB b
413
414-- | @since 1.1.1
415instance NFData2 These where
416    liftRnf2  rnfA _rnfB (This a)    = rnfA a
417    liftRnf2 _rnfA  rnfB (That b)    = rnfB b
418    liftRnf2  rnfA  rnfB (These a b) = rnfA a `seq` rnfB b
419#endif
420
421-------------------------------------------------------------------------------
422-- binary
423-------------------------------------------------------------------------------
424
425-- | @since 0.7.1
426instance (Binary a, Binary b) => Binary (These a b) where
427    put (This a)    = put (0 :: Int) >> put a
428    put (That b)    = put (1 :: Int) >> put b
429    put (These a b) = put (2 :: Int) >> put a >> put b
430
431    get = do
432        i <- get
433        case (i :: Int) of
434            0 -> This <$> get
435            1 -> That <$> get
436            2 -> These <$> get <*> get
437            _ -> fail "Invalid These index"
438
439-------------------------------------------------------------------------------
440-- hashable
441-------------------------------------------------------------------------------
442
443instance (Hashable a, Hashable b) => Hashable (These a b) where
444    hashWithSalt salt (This a) =
445        salt `hashWithSalt` (0 :: Int) `hashWithSalt` a
446    hashWithSalt salt (That b) =
447        salt `hashWithSalt` (1 :: Int) `hashWithSalt` b
448    hashWithSalt salt (These a b) =
449        salt `hashWithSalt` (2 :: Int) `hashWithSalt` a `hashWithSalt` b
450
451-- | @since 1.1.1
452instance Hashable a => Hashable1 (These a) where
453    liftHashWithSalt _hashB salt (This a) =
454        salt `hashWithSalt` (0 :: Int) `hashWithSalt` a
455    liftHashWithSalt  hashB salt (That b) =
456        (salt `hashWithSalt` (1 :: Int)) `hashB` b
457    liftHashWithSalt  hashB salt (These a b) =
458        (salt `hashWithSalt` (2 :: Int) `hashWithSalt` a) `hashB` b
459
460-- | @since 1.1.1
461instance Hashable2 These where
462    liftHashWithSalt2  hashA _hashB salt (This a) =
463        (salt `hashWithSalt` (0 :: Int)) `hashA` a
464    liftHashWithSalt2 _hashA  hashB salt (That b) =
465        (salt `hashWithSalt` (1 :: Int)) `hashB` b
466    liftHashWithSalt2  hashA  hashB salt (These a b) =
467        (salt `hashWithSalt` (2 :: Int)) `hashA` a `hashB` b
468