1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE EmptyDataDecls #-}
4{-# LANGUAGE TypeFamilies #-}
5
6#if __GLASGOW_HASKELL__ >= 702
7{-# LANGUAGE DeriveGeneric #-}
8#endif
9
10#if __GLASGOW_HASKELL__ >= 706
11{-# LANGUAGE PolyKinds #-}
12#endif
13
14#if __GLASGOW_HASKELL__ >= 708
15{-# LANGUAGE Safe #-}
16#elif __GLASGOW_HASKELL__ >= 702
17{-# LANGUAGE Trustworthy #-}
18#endif
19#include "bifunctors-common.h"
20
21module Data.Bifunctor.Sum where
22
23import Data.Bifunctor
24import Data.Bifunctor.Functor
25import Data.Bifoldable
26import Data.Bitraversable
27
28#if __GLASGOW_HASKELL__ < 710
29import Data.Functor
30import Data.Monoid hiding (Sum)
31#endif
32#if __GLASGOW_HASKELL__ >= 708
33import Data.Typeable
34#endif
35#if __GLASGOW_HASKELL__ >= 702
36import GHC.Generics
37#endif
38#if LIFTED_FUNCTOR_CLASSES
39import Data.Functor.Classes
40#endif
41
42data Sum p q a b = L2 (p a b) | R2 (q a b)
43  deriving ( Eq, Ord, Show, Read
44#if __GLASGOW_HASKELL__ >= 702
45           , Generic
46#endif
47#if __GLASGOW_HASKELL__ >= 708
48           , Generic1
49           , Typeable
50#endif
51           )
52
53#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708
54data SumMetaData
55data SumMetaConsL2
56data SumMetaConsR2
57
58instance Datatype SumMetaData where
59    datatypeName _ = "Sum"
60    moduleName _ = "Data.Bifunctor.Sum"
61
62instance Constructor SumMetaConsL2 where
63    conName _ = "L2"
64
65instance Constructor SumMetaConsR2 where
66    conName _ = "R2"
67
68instance Generic1 (Sum p q a) where
69    type Rep1 (Sum p q a) = D1 SumMetaData ((:+:)
70        (C1 SumMetaConsL2 (S1 NoSelector (Rec1 (p a))))
71        (C1 SumMetaConsR2 (S1 NoSelector (Rec1 (q a)))))
72    from1 (L2 p) = M1 (L1 (M1 (M1 (Rec1 p))))
73    from1 (R2 q) = M1 (R1 (M1 (M1 (Rec1 q))))
74    to1 (M1 (L1 (M1 (M1 p)))) = L2 (unRec1 p)
75    to1 (M1 (R1 (M1 (M1 q)))) = R2 (unRec1 q)
76#endif
77
78#if LIFTED_FUNCTOR_CLASSES
79instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Sum f g a) where
80  liftEq = liftEq2 (==)
81instance (Eq2 f, Eq2 g) => Eq2 (Sum f g) where
82  liftEq2 f g (L2 x1) (L2 x2) = liftEq2 f g x1 x2
83  liftEq2 _ _ (L2 _)  (R2 _)  = False
84  liftEq2 _ _ (R2 _)  (L2 _)  = False
85  liftEq2 f g (R2 y1) (R2 y2) = liftEq2 f g y1 y2
86
87instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Sum f g a) where
88  liftCompare = liftCompare2 compare
89instance (Ord2 f, Ord2 g) => Ord2 (Sum f g) where
90  liftCompare2 f g (L2 x1) (L2 x2) = liftCompare2 f g x1 x2
91  liftCompare2 _ _ (L2 _)  (R2 _)  = LT
92  liftCompare2 _ _ (R2 _)  (L2 _)  = GT
93  liftCompare2 f g (R2 y1) (R2 y2) = liftCompare2 f g y1 y2
94
95instance (Read2 f, Read2 g, Read a) => Read1 (Sum f g a) where
96  liftReadsPrec = liftReadsPrec2 readsPrec readList
97instance (Read2 f, Read2 g) => Read2 (Sum f g) where
98  liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $
99    readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "L2" L2 `mappend`
100    readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "R2" R2
101
102instance (Show2 f, Show2 g, Show a) => Show1 (Sum f g a) where
103  liftShowsPrec = liftShowsPrec2 showsPrec showList
104instance (Show2 f, Show2 g) => Show2 (Sum f g) where
105  liftShowsPrec2 sp1 sl1 sp2 sl2 p (L2 x) =
106    showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "L2" p x
107  liftShowsPrec2 sp1 sl1 sp2 sl2 p (R2 y) =
108    showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "R2" p y
109#endif
110
111instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where
112  bimap f g (L2 p) = L2 (bimap f g p)
113  bimap f g (R2 q) = R2 (bimap f g q)
114  first f (L2 p) = L2 (first f p)
115  first f (R2 q) = R2 (first f q)
116  second f (L2 p) = L2 (second f p)
117  second f (R2 q) = R2 (second f q)
118
119instance (Bifoldable p, Bifoldable q) => Bifoldable (Sum p q) where
120  bifoldMap f g (L2 p) = bifoldMap f g p
121  bifoldMap f g (R2 q) = bifoldMap f g q
122
123instance (Bitraversable p, Bitraversable q) => Bitraversable (Sum p q) where
124  bitraverse f g (L2 p) = L2 <$> bitraverse f g p
125  bitraverse f g (R2 q) = R2 <$> bitraverse f g q
126
127instance BifunctorFunctor (Sum p) where
128  bifmap _ (L2 p) = L2 p
129  bifmap f (R2 q) = R2 (f q)
130
131instance BifunctorMonad (Sum p) where
132  bireturn = R2
133  bijoin (L2 p) = L2 p
134  bijoin (R2 q) = q
135  bibind _ (L2 p) = L2 p
136  bibind f (R2 q) = f q
137