{-# OPTIONS_GHC -Wall -O2 #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
module Data.These.Unpacked
( These(This,That,Both)
, these
, fromThese
, mergeThese
, mergeTheseWith
, here
, there
, justThis
, justThat
, justThese
, catThis
, catThat
, catThese
, partitionThese
, isThis
, isThat
, isThese
, mapThese
, mapThis
, mapThat
, fromBaseThese
, toBaseThese
) where
import Prelude
(seq)
import Control.Applicative (Applicative((<*>), pure))
import Control.DeepSeq (NFData(rnf))
import Control.Monad (Monad(return, (>>=)))
import Data.Bifoldable (Bifoldable(bifold, bifoldl, bifoldr))
import Data.Bifunctor (Bifunctor(bimap, first, second))
import Data.Bitraversable (Bitraversable(bitraverse))
import Data.Bool (Bool(False), (&&))
import Data.Data
( Data(gfoldl, gunfold, toConstr, dataTypeOf, dataCast2)
, Constr, mkConstr, constrIndex
, DataType, mkDataType
, Fixity(Prefix)
)
import Data.Eq (Eq((==)))
import Data.Foldable
(Foldable(foldr))
import Data.Function (id, flip, (.), ($))
import Data.Functor (Functor(fmap), (<$>))
import Data.Maybe.Unpacked (Maybe(Just,Nothing), isJust, mapMaybe)
import Data.Monoid (Monoid(mappend))
import Data.Ord (Ord(compare, (>=)), Ordering(EQ, GT, LT))
import Data.Semigroup (Semigroup((<>)))
import qualified Data.These as BaseThese
import Data.Traversable (Traversable(sequenceA, traverse))
import Data.Typeable (gcast2)
import GHC.Base (Int(I#))
import GHC.Read (Read(readPrec), expectP)
import GHC.Show (Show(showsPrec), showString, showParen, showSpace)
import Text.Read (parens, Lexeme(Ident), (+++), readListPrec, readListDefault, readListPrecDefault)
import qualified Text.Read as TextRead
import Text.ParserCombinators.ReadPrec
(prec, step)
data These a b = These (# a | b | (# a, b #) #)
pattern This :: a -> These a b
pattern This a = These (# a | | #)
pattern That :: b -> These a b
pattern That b = These (# | b | #)
pattern Both :: a -> b -> These a b
pattern Both a b = These (# | | (# a, b #) #)
{-# COMPLETE This, That, Both #-}
these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
{-# INLINE these #-}
these fa fb fab (These x) = case x of
(# a | | #) -> fa a
(# | b | #) -> fb b
(# | | (# a, b #) #) -> fab a b
fromThese :: a -> b -> These a b -> (a, b)
{-# INLINE fromThese #-}
fromThese defA defB ths = these (\a -> (a, defB)) (\b -> (defA, b)) (\a b -> (a, b)) ths
partitionThese :: [These a b] -> ( [(a, b)], ([a], [b]) )
{-# INLINEABLE [0] partitionThese #-}
partitionThese [] = ([], ([], []))
partitionThese (Both x y : xs) = first ((x, y) : ) $ partitionThese xs
partitionThese (This x : xs) = second (first (x:)) $ partitionThese xs
partitionThese (That y : xs) = second (second (y:)) $ partitionThese xs
mergeThese :: (a -> a -> a) -> These a a -> a
{-# INLINE mergeThese #-}
mergeThese = these id id
mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c
{-# INLINE mergeTheseWith #-}
mergeTheseWith f g op t = mergeThese op $ mapThese f g t
here :: (Applicative f) => (a -> f b) -> These a t -> f (These b t)
{-# INLINE here #-}
here f = these (\a -> This <$> f a) (\b -> pure (That b)) (\a b -> flip Both b <$> f a)
there :: (Applicative f) => (a -> f b) -> These t a -> f (These t b)
{-# INLINE there #-}
there f = these (\a -> pure (This a)) (\b -> That <$> f b) (\a b -> Both a <$> f b)
justThis :: These a b -> Maybe a
{-# INLINE justThis #-}
justThis = these Just (\_ -> Nothing) (\_ _ -> Nothing)
justThat :: These a b -> Maybe b
{-# INLINE justThat #-}
justThat = these (\_ -> Nothing) Just (\_ _ -> Nothing)
justThese :: These a b -> Maybe (a, b)
{-# INLINE justThese #-}
justThese = these (\_ -> Nothing) (\_ -> Nothing) (\a b -> Just (a, b))
isThis :: These a b -> Bool
{-# INLINE isThis #-}
isThis = isJust . justThis
isThat :: These a b -> Bool
{-# INLINE isThat #-}
isThat = isJust . justThat
isThese :: These a b -> Bool
{-# INLINE isThese #-}
isThese = isJust . justThese
mapThese :: (a -> c) -> (b -> d) -> These a b -> These c d
{-# INLINE mapThese #-}
mapThese fac fbd = these (This . fac) (That . fbd) (\a b -> Both (fac a) (fbd b))
mapThis :: (a -> c) -> These a b -> These c b
{-# INLINE mapThis #-}
mapThis f = mapThese f id
mapThat :: (b -> d) -> These a b -> These a d
{-# INLINE mapThat #-}
mapThat f = mapThese id f
catThis :: [These a b] -> [a]
{-# INLINE catThis #-}
catThis = mapMaybe justThis
catThat :: [These a b] -> [b]
{-# INLINE catThat #-}
catThat = mapMaybe justThat
catThese :: [These a b] -> [(a,b)]
{-# INLINE catThese #-}
catThese = mapMaybe justThese
fromBaseThese :: BaseThese.These a b -> These a b
fromBaseThese (BaseThese.This a ) = This a
fromBaseThese (BaseThese.That b) = That b
fromBaseThese (BaseThese.These a b) = Both a b
toBaseThese :: These a b -> BaseThese.These a b
toBaseThese (This a ) = BaseThese.This a
toBaseThese (That b) = BaseThese.That b
toBaseThese (Both a b) = BaseThese.These a b
instance (Semigroup a, Semigroup b) => Semigroup (These a b) where
This a <> This b = This (a <> b)
This a <> That y = Both a y
This a <> Both b y = Both (a <> b) y
That x <> This b = Both b x
That x <> That y = That (x <> y)
That x <> Both b y = Both b (x <> y)
Both a x <> This b = Both (a <> b) x
Both a x <> That y = Both a (x <> y)
Both a x <> Both b y = Both (a <> b) (x <> y)
{-# INLINE (<>) #-}
instance Functor (These a) where
fmap _ (This x) = This x
fmap f (That y) = That (f y)
fmap f (Both x y) = Both x (f y)
{-# INLINE fmap #-}
instance Semigroup a => Applicative (These a) where
pure = That
{-# INLINE pure #-}
This a <*> _ = This a
That _ <*> This b = This b
That f <*> That x = That (f x)
That f <*> Both b x = Both b (f x)
Both a _ <*> This b = This (a <> b)
Both a f <*> That x = Both a (f x)
Both a f <*> Both b x = Both (a <> b) (f x)
{-# INLINE (<*>) #-}
instance Semigroup a => Monad (These a) where
return = That
{-# INLINE return #-}
This a >>= _ = This a
That x >>= k = k x
Both a x >>= k = case k x of
This b -> This (a <> b)
That y -> Both a y
Both b y -> Both (a <> b) y
{-# INLINE (>>=) #-}
instance Foldable (These a) where
foldr _ z (This _) = z
foldr f z (That x) = f x z
foldr f z (Both _ x) = f x z
{-# INLINE foldr #-}
instance Traversable (These a) where
traverse _ (This a) = pure $ This a
traverse f (That x) = That <$> f x
traverse f (Both a x) = Both a <$> f x
{-# INLINE traverse #-}
sequenceA (This a) = pure $ This a
sequenceA (That x) = That <$> x
sequenceA (Both a x) = Both a <$> x
{-# INLINE sequenceA #-}
instance Bifunctor These where
bimap = mapThese
{-# INLINE bimap #-}
first = mapThis
{-# INLINE first #-}
second = mapThat
{-# INLINE second #-}
instance Bifoldable These where
bifold = these id id mappend
{-# INLINE bifold #-}
bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z))
{-# INLINE bifoldr #-}
bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y)
{-# INLINE bifoldl #-}
instance Bitraversable These where
bitraverse f _ (This x) = This <$> f x
bitraverse _ g (That x) = That <$> g x
bitraverse f g (Both x y) = Both <$> f x <*> g y
instance (NFData a, NFData b) => NFData (These a b) where
rnf (This a ) = rnf a
rnf (That b) = rnf b
rnf (Both a b) = rnf a `seq` rnf b
instance (Eq a, Eq b) => Eq (These a b) where
This a == This b = a == b
That a == That b = a == b
Both a b == Both a' b' = a == a' && b == b'
_ == _ = False
{-# INLINE (==) #-}
instance (Ord a, Ord b) => Ord (These a b) where
compare x y
= case x of
This a -> case y of
This b -> compare a b
_ -> LT
That a -> case y of
This {} -> GT
That b -> compare a b
_ -> LT
Both a b -> case y of
Both a' b' -> case (compare a a') of
LT -> LT
EQ -> compare b b'
GT -> GT
_ -> GT
{-# INLINE compare #-}
instance (Read a, Read b) => Read (These a b) where
readPrec
= parens
(prec
10
(do expectP (Ident "This")
a <- step readPrec
return (This a))
+++
(prec
10
(do expectP (Ident "That")
b <- step readPrec
return (That b))
+++
prec
10
(do expectP (Ident "These")
a <- step readPrec
b <- step readPrec
return (Both a b))))
readList = readListDefault
readListPrec = readListPrecDefault
instance (Show a, Show b) => Show (These a b) where
showsPrec i (This a) = showParen (i >= 11) ((.) (showString "This " ) (showsPrec 11 a))
showsPrec i (That b) = showParen (i >= 11) ((.) (showString "That " ) (showsPrec 11 b))
showsPrec i (Both a b) = showParen (i >= 11) ((.) (showString "These ") ((.) (showsPrec 11 a) ((.) showSpace (showsPrec 11 b))))
instance (Data a, Data b) => Data (These a b) where
gfoldl k z (This a) = z This `k` a
gfoldl k z (That b) = z That `k` b
gfoldl k z (Both a b) = (z Both `k` a) `k` b
gunfold k z c = case constrIndex c of
I# 1# -> k (z This)
I# 2# -> k (z That)
_ -> k (k (z Both))
toConstr (This _) = cThis
toConstr (That _) = cThat
toConstr (Both _ _) = cThese
dataTypeOf _ = tThese
dataCast2 f = gcast2 f
tThese :: DataType
tThese = mkDataType "These" [cThis, cThat, cThese]
cThis, cThat, cThese :: Constr
cThis = mkConstr tThese "This" [] Prefix
cThat = mkConstr tThese "That" [] Prefix
cThese = mkConstr tThese "These" [] Prefix