{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
module Data.These (
These(..)
, these
, fromThese
, mergeThese
, mergeTheseWith
, partitionThese
, partitionHereThere
, partitionEithersNE
, distrThesePair
, undistrThesePair
, distrPairThese
, undistrPairThese
) where
import Prelude ()
import Prelude.Compat
import Control.DeepSeq (NFData (..))
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Binary (Binary (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Data (Data, Typeable)
import Data.Either (partitionEithers)
import Data.Hashable (Hashable (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Semigroup (Semigroup (..))
import GHC.Generics (Generic)
#if __GLASGOW_HASKELL__ >= 706
import GHC.Generics (Generic1)
#endif
#ifdef MIN_VERSION_assoc
import Data.Bifunctor.Assoc (Assoc (..))
import Data.Bifunctor.Swap (Swap (..))
#endif
data These a b = This a | That b | These a b
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic
#if __GLASGOW_HASKELL__ >= 706
, Generic1
#endif
)
these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these l _ _ (This a) = l a
these _ r _ (That x) = r x
these _ _ lr (These a x) = lr a x
fromThese :: a -> b -> These a b -> (a, b)
fromThese x y = these (`pair` y) (x `pair`) pair where
pair = (,)
mergeThese :: (a -> a -> a) -> These a a -> a
mergeThese = these id id
mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c
mergeTheseWith f g op t = mergeThese op $ bimap f g t
partitionThese :: [These a b] -> ([a], [b], [(a, b)])
partitionThese [] = ([], [], [])
partitionThese (t:ts) = case t of
This x -> (x : xs, ys, xys)
That y -> ( xs, y : ys, xys)
These x y -> ( xs, ys, (x,y) : xys)
where
~(xs,ys,xys) = partitionThese ts
partitionHereThere :: [These a b] -> ([a], [b])
partitionHereThere [] = ([], [])
partitionHereThere (t:ts) = case t of
This x -> (x : xs, ys)
That y -> ( xs, y : ys)
These x y -> (x : xs, y : ys)
where
~(xs,ys) = partitionHereThere ts
partitionEithersNE :: NonEmpty (Either a b) -> These (NonEmpty a) (NonEmpty b)
partitionEithersNE (x :| xs) = case (x, ls, rs) of
(Left y, ys, []) -> This (y :| ys)
(Left y, ys, z:zs) -> These (y :| ys) (z :| zs)
(Right z, [], zs) -> That (z :| zs)
(Right z, y:ys, zs) -> These (y :| ys) (z :| zs)
where
(ls, rs) = partitionEithers xs
distrThesePair :: These (a, b) c -> (These a c, These b c)
distrThesePair (This (a, b)) = (This a, This b)
distrThesePair (That c) = (That c, That c)
distrThesePair (These (a, b) c) = (These a c, These b c)
undistrThesePair :: (These a c, These b c) -> These (a, b) c
undistrThesePair (This a, This b) = This (a, b)
undistrThesePair (That c, That _) = That c
undistrThesePair (These a c, These b _) = These (a, b) c
undistrThesePair (This _, That c) = That c
undistrThesePair (This a, These b c) = These (a, b) c
undistrThesePair (That c, This _) = That c
undistrThesePair (That c, These _ _) = That c
undistrThesePair (These a c, This b) = These (a, b) c
undistrThesePair (These _ c, That _) = That c
distrPairThese :: (These a b, c) -> These (a, c) (b, c)
distrPairThese (This a, c) = This (a, c)
distrPairThese (That b, c) = That (b, c)
distrPairThese (These a b, c) = These (a, c) (b, c)
undistrPairThese :: These (a, c) (b, c) -> (These a b, c)
undistrPairThese (This (a, c)) = (This a, c)
undistrPairThese (That (b, c)) = (That b, c)
undistrPairThese (These (a, c) (b, _)) = (These a b, c)
instance (Semigroup a, Semigroup b) => Semigroup (These a b) where
This a <> This b = This (a <> b)
This a <> That y = These a y
This a <> These b y = These (a <> b) y
That x <> This b = These b x
That x <> That y = That (x <> y)
That x <> These b y = These b (x <> y)
These a x <> This b = These (a <> b) x
These a x <> That y = These a (x <> y)
These a x <> These b y = These (a <> b) (x <> y)
instance Functor (These a) where
fmap _ (This x) = This x
fmap f (That y) = That (f y)
fmap f (These x y) = These x (f y)
instance Foldable (These a) where
foldr _ z (This _) = z
foldr f z (That x) = f x z
foldr f z (These _ x) = f x z
instance Traversable (These a) where
traverse _ (This a) = pure $ This a
traverse f (That x) = That <$> f x
traverse f (These a x) = These a <$> f x
sequenceA (This a) = pure $ This a
sequenceA (That x) = That <$> x
sequenceA (These a x) = These a <$> x
instance Bifunctor These where
bimap f _ (This a ) = This (f a)
bimap _ g (That x) = That (g x)
bimap f g (These a x) = These (f a) (g x)
instance Bifoldable These where
bifold = these id id mappend
bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z))
bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y)
instance Bitraversable These where
bitraverse f _ (This x) = This <$> f x
bitraverse _ g (That x) = That <$> g x
bitraverse f g (These x y) = These <$> f x <*> g y
instance (Semigroup a) => Applicative (These a) where
pure = That
This a <*> _ = This a
That _ <*> This b = This b
That f <*> That x = That (f x)
That f <*> These b x = These b (f x)
These a _ <*> This b = This (a <> b)
These a f <*> That x = These a (f x)
These a f <*> These b x = These (a <> b) (f x)
instance (Semigroup a) => Monad (These a) where
return = pure
This a >>= _ = This a
That x >>= k = k x
These a x >>= k = case k x of
This b -> This (a <> b)
That y -> These a y
These b y -> These (a <> b) y
instance (Hashable a, Hashable b) => Hashable (These a b)
#ifdef MIN_VERSION_assoc
instance Swap These where
swap (This a) = That a
swap (That b) = This b
swap (These a b) = These b a
instance Assoc These where
assoc (This (This a)) = This a
assoc (This (That b)) = That (This b)
assoc (That c) = That (That c)
assoc (These (That b) c) = That (These b c)
assoc (This (These a b)) = These a (This b)
assoc (These (This a) c) = These a (That c)
assoc (These (These a b) c) = These a (These b c)
unassoc (This a) = This (This a)
unassoc (That (This b)) = This (That b)
unassoc (That (That c)) = That c
unassoc (That (These b c)) = These (That b) c
unassoc (These a (This b)) = This (These a b)
unassoc (These a (That c)) = These (This a) c
unassoc (These a (These b c)) = These (These a b) c
#endif
instance (NFData a, NFData b) => NFData (These a b) where
rnf (This a) = rnf a
rnf (That b) = rnf b
rnf (These a b) = rnf a `seq` rnf b
instance (Binary a, Binary b) => Binary (These a b) where
put (This a) = put (0 :: Int) >> put a
put (That b) = put (1 :: Int) >> put b
put (These a b) = put (2 :: Int) >> put a >> put b
get = do
i <- get
case (i :: Int) of
0 -> This <$> get
1 -> That <$> get
2 -> These <$> get <*> get
_ -> fail "Invalid These index"