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