these-1.2: src/Data/Functor/These.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
#if MIN_VERSION_base(4,9,0)
#define LIFTED_FUNCTOR_CLASSES 1
#else
#if MIN_VERSION_transformers (0,5,0)
#define LIFTED_FUNCTOR_CLASSES 1
#else
#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)
#define LIFTED_FUNCTOR_CLASSES 1
#endif
#endif
#endif
module Data.Functor.These (
These1 (..),
) where
import Data.Foldable (Foldable)
import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..))
import Data.Monoid (Monoid (..))
import Data.Semigroup (Semigroup (..))
import Data.Traversable (Traversable)
import GHC.Generics (Generic)
import Prelude
(Bool (..), Eq (..), Functor, Ord (..), Ordering (..), Read (..),
Show (..), lex, readParen, return, seq, showChar, showParen, showString,
($), (&&), (.))
import qualified Data.Foldable as F
import qualified Data.Foldable1 as F1
#if MIN_VERSION_deepseq(1,4,3)
import Control.DeepSeq (NFData (..), NFData1 (..))
#else
import Control.DeepSeq (NFData (..))
#endif
#if __GLASGOW_HASKELL__ >= 706
import GHC.Generics (Generic1)
#endif
#if __GLASGOW_HASKELL__ >= 708
import Data.Data (Data)
import Data.Typeable (Typeable)
#endif
-------------------------------------------------------------------------------
-- These1
-------------------------------------------------------------------------------
data These1 f g a
= This1 (f a)
| That1 (g a)
| These1 (f a) (g a)
deriving (Functor, Foldable, Traversable, Generic
#if __GLASGOW_HASKELL__ >= 706
, Generic1
#endif
#if __GLASGOW_HASKELL__ >= 708
, Typeable, Data
#endif
)
-------------------------------------------------------------------------------
-- Eq1
-------------------------------------------------------------------------------
instance (Eq1 f, Eq1 g) => Eq1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
liftEq eq (This1 f) (This1 f') = liftEq eq f f'
liftEq eq (That1 g) (That1 g') = liftEq eq g g'
liftEq eq (These1 f g) (These1 f' g') = liftEq eq f f' && liftEq eq g g'
liftEq _ This1 {} _ = False
liftEq _ That1 {} _ = False
liftEq _ These1 {} _ = False
#else
eq1 (This1 f) (This1 f') = eq1 f f'
eq1 (That1 g) (That1 g') = eq1 g g'
eq1 (These1 f g) (These1 f' g') = eq1 f f' && eq1 g g'
eq1 This1 {} _ = False
eq1 That1 {} _ = False
eq1 These1 {} _ = False
#endif
-------------------------------------------------------------------------------
-- Ord1
-------------------------------------------------------------------------------
instance (Ord1 f, Ord1 g) => Ord1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
liftCompare cmp (This1 f) (This1 f') = liftCompare cmp f f'
liftCompare _cmp (This1 _) _ = LT
liftCompare _cmp _ (This1 _) = GT
liftCompare cmp (That1 g) (That1 g') = liftCompare cmp g g'
liftCompare _cmp (That1 _) _ = LT
liftCompare _cmp _ (That1 _) = GT
liftCompare cmp (These1 f g) (These1 f' g') =
liftCompare cmp f f' `mappend` liftCompare cmp g g'
#else
compare1 (This1 f) (This1 f') = compare1 f f'
compare1 (This1 _) _ = LT
compare1 _ (This1 _) = GT
compare1 (That1 g) (That1 g') = compare1 g g'
compare1 (That1 _) _ = LT
compare1 _ (That1 _) = GT
compare1 (These1 f g) (These1 f' g') =
compare1 f f' `mappend` compare1 g g'
#endif
-------------------------------------------------------------------------------
-- Show1
-------------------------------------------------------------------------------
instance (Show1 f, Show1 g) => Show1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
liftShowsPrec sp sl d (This1 f) = showParen (d > 10)
$ showString "This1 "
. liftShowsPrec sp sl 11 f
liftShowsPrec sp sl d (That1 g) = showParen (d > 10)
$ showString "That1 "
. liftShowsPrec sp sl 11 g
liftShowsPrec sp sl d (These1 f g) = showParen (d > 10)
$ showString "These1 "
. liftShowsPrec sp sl 11 f
. showChar ' '
. liftShowsPrec sp sl 11 g
#else
showsPrec1 d (This1 f) = showParen (d > 10)
$ showString "This1 "
. showsPrec1 11 f
showsPrec1 d (That1 g) = showParen (d > 10)
$ showString "That1 "
. showsPrec1 11 g
showsPrec1 d (These1 f g) = showParen (d > 10)
$ showString "These1 "
. showsPrec1 11 f
. showChar ' '
. showsPrec1 11 g
#endif
-------------------------------------------------------------------------------
-- Read1
-------------------------------------------------------------------------------
instance (Read1 f, Read1 g) => Read1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
liftReadsPrec rp rl d = readParen (d > 10) $ \s0 -> do
(t, s1) <- lex s0
case t of
"This1" -> do
(x, s2) <- liftReadsPrec rp rl 11 s1
return (This1 x, s2)
"That1" -> do
(y, s2) <- liftReadsPrec rp rl 11 s1
return (That1 y, s2)
"These1" -> do
(x, s2) <- liftReadsPrec rp rl 11 s1
(y, s3) <- liftReadsPrec rp rl 11 s2
return (These1 x y, s3)
_ -> []
#else
readsPrec1 d = readParen (d > 10) $ \s0 -> do
(t, s1) <- lex s0
case t of
"This1" -> do
(x, s2) <- readsPrec1 11 s1
return (This1 x, s2)
"That1" -> do
(y, s2) <- readsPrec1 11 s1
return (That1 y, s2)
"These1" -> do
(x, s2) <- readsPrec1 11 s1
(y, s3) <- readsPrec1 11 s2
return (These1 x y, s3)
_ -> []
#endif
-------------------------------------------------------------------------------
-- Eq, Ord, Show, Read
-------------------------------------------------------------------------------
instance (Eq (f a), Eq (g a), Eq a) => Eq (These1 f g a) where
This1 f == This1 f' = f == f'
That1 g == That1 g' = g == g'
These1 f g == These1 f' g' = f == f' && g == g'
This1 {} == _ = False
That1 {} == _ = False
These1 {} == _ = False
instance (Ord (f a), Ord (g a), Ord a) => Ord (These1 f g a) where
compare (This1 f) (This1 f') = compare f f'
compare (This1 _) _ = LT
compare _ (This1 _) = GT
compare (That1 g) (That1 g') = compare g g'
compare (That1 _) _ = LT
compare _ (That1 _) = GT
compare (These1 f g) (These1 f' g') =
compare f f' `mappend` compare g g'
instance (Show (f a), Show (g a), Show a) => Show (These1 f g a) where
showsPrec d (This1 f) = showParen (d > 10)
$ showString "This1 "
. showsPrec 11 f
showsPrec d (That1 g) = showParen (d > 10)
$ showString "That1 "
. showsPrec 11 g
showsPrec d (These1 f g) = showParen (d > 10)
$ showString "These1 "
. showsPrec 11 f
. showChar ' '
. showsPrec 11 g
instance (Read (f a), Read (g a), Read a) => Read (These1 f g a) where
readsPrec d = readParen (d > 10) $ \s0 -> do
(t, s1) <- lex s0
case t of
"This1" -> do
(x, s2) <- readsPrec 11 s1
return (This1 x, s2)
"That1" -> do
(y, s2) <- readsPrec 11 s1
return (That1 y, s2)
"These1" -> do
(x, s2) <- readsPrec 11 s1
(y, s3) <- readsPrec 11 s2
return (These1 x y, s3)
_ -> []
-------------------------------------------------------------------------------
-- deepseq
-------------------------------------------------------------------------------
#if MIN_VERSION_deepseq(1,4,3)
-- | This instance is available only with @deepseq >= 1.4.3.0@
instance (NFData1 f, NFData1 g) => NFData1 (These1 f g) where
liftRnf r (This1 x) = liftRnf r x
liftRnf r (That1 y) = liftRnf r y
liftRnf r (These1 x y) = liftRnf r x `seq` liftRnf r y
#endif
-- | Available always
--
-- @since 1.2
instance (NFData (f a), NFData (g a), NFData a) => NFData (These1 f g a) where
rnf (This1 x) = rnf x
rnf (That1 y) = rnf y
rnf (These1 x y) = rnf x `seq` rnf y
-------------------------------------------------------------------------------
-- foldable1
-------------------------------------------------------------------------------
-- | @since 1.2
instance (F1.Foldable1 f, F1.Foldable1 g) => F1.Foldable1 (These1 f g) where
foldMap1 f (This1 x) = F1.foldMap1 f x
foldMap1 f (That1 y) = F1.foldMap1 f y
foldMap1 f (These1 x y) = F1.foldMap1 f x <> F1.foldMap1 f y
foldrMap1 f g (This1 x) = F1.foldrMap1 f g x
foldrMap1 f g (That1 y) = F1.foldrMap1 f g y
foldrMap1 f g (These1 x y) = F.foldr g (F1.foldrMap1 f g y) x
head (This1 x) = F1.head x
head (That1 y) = F1.head y
head (These1 x _) = F1.head x
last (This1 x) = F1.last x
last (That1 y) = F1.last y
last (These1 _ y) = F1.last y