1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE Safe #-}
4{-# LANGUAGE DeriveGeneric      #-}
5
6#if MIN_VERSION_base(4,9,0)
7#define LIFTED_FUNCTOR_CLASSES 1
8#else
9#if MIN_VERSION_transformers(0,5,0)
10#define LIFTED_FUNCTOR_CLASSES 1
11#else
12#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)
13#define LIFTED_FUNCTOR_CLASSES 1
14#endif
15#endif
16#endif
17
18-----------------------------------------------------------------------------
19-- |
20--
21-- The strict variant of the standard Haskell 'L.Either' type and the
22-- corresponding variants of the functions from "Data.Either".
23--
24-- Note that the strict 'Either' type is not an applicative functor, and
25-- therefore also no monad. The reasons are the same as the ones for the
26-- strict @Maybe@ type, which are explained in "Data.Maybe.Strict".
27--
28-----------------------------------------------------------------------------
29
30module Data.Strict.Either (
31    Either(..)
32  , either
33  , isLeft, isRight
34  , fromLeft, fromRight
35  , lefts, rights
36  , partitionEithers
37) where
38
39-- import parts explicitly, helps with compatibility
40import           Prelude ( Functor (..), Eq (..), Ord (..), Show (..), Read (..), Bool (..), (.), ($)
41                         , error, Ordering (..), showParen, showString, lex, return, readParen)
42import           Control.Applicative (pure, (<$>))
43import           Data.Semigroup (Semigroup (..))
44import           Data.Foldable (Foldable (..))
45import           Data.Traversable (Traversable (..))
46
47-- Lazy variants
48import qualified Prelude             as L
49
50import           Control.DeepSeq     (NFData (..))
51import           Data.Bifoldable     (Bifoldable (..))
52import           Data.Bifunctor      (Bifunctor (..))
53import           Data.Binary         (Binary (..))
54import           Data.Bitraversable  (Bitraversable (..))
55import           Data.Hashable       (Hashable(..))
56import           Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..))
57import           GHC.Generics        (Generic)
58import           Data.Data           (Data (..), Typeable)
59
60#if __GLASGOW_HASKELL__ >= 706
61import           GHC.Generics        (Generic1)
62#endif
63
64#if MIN_VERSION_deepseq(1,4,3)
65import Control.DeepSeq (NFData1 (..), NFData2 (..))
66#endif
67
68#ifdef MIN_VERSION_assoc
69import           Data.Bifunctor.Assoc (Assoc (..))
70import           Data.Bifunctor.Swap  (Swap (..))
71#endif
72
73#ifdef LIFTED_FUNCTOR_CLASSES
74import Data.Functor.Classes
75       (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..),
76       Show1 (..), Show2 (..))
77#else
78import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..))
79#endif
80
81-- | The strict choice type.
82data Either a b = Left !a | Right !b
83  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic
84#if __GLASGOW_HASKELL__ >= 706
85    , Generic1
86#endif
87    )
88
89toStrict :: L.Either a b -> Either a b
90toStrict (L.Left x)  = Left x
91toStrict (L.Right y) = Right y
92
93toLazy :: Either a b -> L.Either a b
94toLazy (Left x)  = L.Left x
95toLazy (Right y) = L.Right y
96
97-- | Case analysis: if the value is @'Left' a@, apply the first function to @a@;
98-- if it is @'Right' b@, apply the second function to @b@.
99either :: (a -> c) -> (b -> c) -> Either a b -> c
100either f _ (Left  x) = f x
101either _ g (Right y) = g y
102
103-- | Yields 'True' iff the argument is of the form @Left _@.
104--
105isLeft :: Either a b -> Bool
106isLeft (Left _) = True
107isLeft _        = False
108
109-- | Yields 'True' iff the argument is of the form @Right _@.
110--
111isRight :: Either a b -> Bool
112isRight (Right _) = True
113isRight _         = False
114
115-- | Extracts the element out of a 'Left' and throws an error if the argument
116-- is a 'Right'.
117fromLeft :: Either a b -> a
118fromLeft (Left x) = x
119fromLeft _        = error "Data.Strict.Either.fromLeft: Right"
120
121-- | Extracts the element out of a 'Right' and throws an error if the argument
122-- is a 'Left'.
123fromRight :: Either a b -> b
124fromRight (Right x) = x
125fromRight _         = error "Data.Strict.Either.fromRight: Left"
126
127-- | Analogous to 'L.lefts' in "Data.Either".
128lefts   :: [Either a b] -> [a]
129lefts x = [a | Left a <- x]
130
131-- | Analogous to 'L.rights' in "Data.Either".
132rights   :: [Either a b] -> [b]
133rights x = [a | Right a <- x]
134
135-- | Analogous to 'L.partitionEithers' in "Data.Either".
136partitionEithers :: [Either a b] -> ([a],[b])
137partitionEithers =
138    L.foldr (either left right) ([],[])
139  where
140    left  a ~(l, r) = (a:l, r)
141    right a ~(l, r) = (l, a:r)
142
143-- Instances
144------------
145
146instance Functor (Either a) where
147  fmap _ (Left  x) = Left x
148  fmap f (Right y) = Right (f y)
149
150instance Foldable (Either e) where
151  foldr _ y (Left _)  = y
152  foldr f y (Right x) = f x y
153
154  foldl _ y (Left _)  = y
155  foldl f y (Right x) = f y x
156
157instance Traversable (Either e) where
158  traverse _ (Left x)  = pure (Left x)
159  traverse f (Right x) = Right <$> f x
160
161instance Semigroup (Either a b) where
162  Left _ <> b = b
163  a      <> _ = a
164
165-- deepseq
166instance (NFData a, NFData b) => NFData (Either a b) where
167  rnf = rnf . toLazy
168
169#if MIN_VERSION_deepseq(1,4,3)
170instance (NFData a) => NFData1 (Either a) where
171  liftRnf rnfA = liftRnf rnfA . toLazy
172
173instance NFData2 Either where
174  liftRnf2 rnfA rnfB = liftRnf2 rnfA rnfB . toLazy
175#endif
176
177-- binary
178instance (Binary a, Binary b) => Binary (Either a b) where
179  put = put . toLazy
180  get = toStrict <$> get
181
182-- bifunctors
183instance Bifunctor Either where
184  bimap f _ (Left a) = Left (f a)
185  bimap _ g (Right a) = Right (g a)
186  first f = either (Left . f) Right
187  second g = either Left (Right . g)
188
189instance Bifoldable Either where
190  bifold (Left a) = a
191  bifold (Right b) = b
192  bifoldMap = either
193  bifoldr f _ c (Left a) = f a c
194  bifoldr _ g c (Right b) = g b c
195  bifoldl f _ c (Left a) = f c a
196  bifoldl _ g c (Right b) = g c b
197
198instance Bitraversable Either where
199  bitraverse f _ (Left a) = fmap Left (f a)
200  bitraverse _ g (Right b) = fmap Right (g b)
201
202-- hashable
203instance (Hashable a, Hashable b) => Hashable (Either a b) where
204  hashWithSalt salt = hashWithSalt salt . toLazy
205
206instance (Hashable a) => Hashable1 (Either a) where
207  liftHashWithSalt hashA salt = liftHashWithSalt hashA salt . toLazy
208
209instance Hashable2 Either where
210  liftHashWithSalt2 hashA hashB salt = liftHashWithSalt2 hashA hashB salt . toLazy
211
212-- assoc
213#ifdef MIN_VERSION_assoc
214instance Assoc Either where
215    assoc (Left (Left a))  = Left a
216    assoc (Left (Right b)) = Right (Left b)
217    assoc (Right c)        = Right (Right c)
218
219    unassoc (Left a)          = Left (Left a)
220    unassoc (Right (Left b))  = Left (Right b)
221    unassoc (Right (Right c)) = Right c
222
223instance Swap Either where
224    swap (Left x) = Right x
225    swap (Right x) = Left x
226#endif
227
228-- Data.Functor.Classes
229#ifdef LIFTED_FUNCTOR_CLASSES
230instance Eq2 Either where
231  liftEq2 f _ (Left a)  (Left a')  = f a a'
232  liftEq2 _ g (Right b) (Right b') = g b b'
233  liftEq2 _ _ _         _          = False
234
235instance Eq a => Eq1 (Either a) where
236  liftEq = liftEq2 (==)
237
238instance Ord2 Either where
239  liftCompare2 f _ (Left a)    (Left a')     = f a a'
240  liftCompare2 _ _ (Left _)    _             = LT
241  liftCompare2 _ _ _           (Left _)      = GT
242  liftCompare2 _ g (Right b)    (Right b')     = g b b'
243
244instance Ord a => Ord1 (Either a) where
245  liftCompare = liftCompare2 compare
246
247instance Show a => Show1 (Either a) where
248  liftShowsPrec = liftShowsPrec2 showsPrec showList
249
250instance Show2 Either where
251  liftShowsPrec2 sa _ _sb _ d (Left a) = showParen (d > 10)
252    $ showString "Left "
253    . sa 11 a
254  liftShowsPrec2 _sa _ sb _ d (Right b) = showParen (d > 10)
255    $ showString "Right "
256    . sb 11 b
257
258instance Read2 Either where
259  liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> cons s
260    where
261      cons s0 = do
262        (ident, s1) <- lex s0
263        case ident of
264            "Left" ->  do
265                (a, s2) <- ra 11 s1
266                return (Left a, s2)
267            "Right" ->  do
268                (b, s2) <- rb 11 s1
269                return (Right b, s2)
270            _ -> []
271
272instance Read a => Read1 (Either a) where
273  liftReadsPrec = liftReadsPrec2 readsPrec readList
274#else
275instance Eq a   => Eq1   (Either a) where eq1        = (==)
276instance Ord a  => Ord1  (Either a) where compare1   = compare
277instance Show a => Show1 (Either a) where showsPrec1 = showsPrec
278instance Read a => Read1 (Either a) where readsPrec1 = readsPrec
279#endif
280