these-0.7.6: Data/These.hs
-----------------------------------------------------------------------------
-- | Module : Data.These
--
-- The 'These' type and associated operations. Now enhanced with "Control.Lens" magic!
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.These (
These(..)
-- * Functions to get rid of 'These'
, these
, fromThese
, mergeThese
, mergeTheseWith
-- * Traversals
, here, there
-- * Half selections
, justHere
, justThere
-- * Prisms
, _This, _That, _These
-- * Case selections
, justThis
, justThat
, justThese
, catThis
, catThat
, catThese
, partitionThese
-- * Case predicates
, isThis
, isThat
, isThese
-- * Map operations
, mapThese
, mapThis
, mapThat
, bitraverseThese
-- * Associativity and commutativity
, swap
, assoc
, reassoc
) where
import Prelude ()
import Prelude.Compat
import Control.DeepSeq (NFData (..))
import Control.Lens (Prism', Swapped (..), iso, prism)
import Data.Aeson (FromJSON (..), ToJSON (..), (.=))
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Binary (Binary (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Data (Data, Typeable)
import Data.Functor.Bind (Apply (..), Bind (..))
import Data.Hashable (Hashable (..))
import Data.Maybe (isJust, mapMaybe)
import Data.Semigroup (Semigroup (..))
import Data.Semigroup.Bifoldable (Bifoldable1 (..))
import Data.Semigroup.Bitraversable (Bitraversable1 (..))
import GHC.Generics (Generic)
import Test.QuickCheck
(Arbitrary (..), Arbitrary1 (..), Arbitrary2 (..), CoArbitrary (..),
arbitrary1, oneof, shrink1)
import Test.QuickCheck.Function (Function (..), functionMap)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson (pair)
import qualified Data.HashMap.Strict as HM
-- $setup
-- >>> import Control.Lens
-- --------------------------------------------------------------------------
-- | The 'These' type represents values with two non-exclusive possibilities.
--
-- This can be useful to represent combinations of two values, where the
-- combination is defined if either input is. Algebraically, the type
-- @'These' A B@ represents @(A + B + AB)@, which doesn't factor easily into
-- sums and products--a type like @'Either' A (B, 'Maybe' A)@ is unclear and
-- awkward to use.
--
-- 'These' has straightforward instances of 'Functor', 'Monad', &c., and
-- behaves like a hybrid error/writer monad, as would be expected.
--
-- For zipping and unzipping of structures with 'These' values, see
-- "Data.Align".
data These a b = This a | That b | These a b
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
-- | Case analysis for the 'These' type.
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
-- | Takes two default values and produces a tuple.
fromThese :: a -> b -> These a b -> (a, b)
fromThese _ x (This a ) = (a, x)
fromThese a _ (That x ) = (a, x)
fromThese _ _ (These a x) = (a, x)
-- | Coalesce with the provided operation.
mergeThese :: (a -> a -> a) -> These a a -> a
mergeThese = these id id
-- | BiMap and coalesce results with the provided operation.
mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c
mergeTheseWith f g op t = mergeThese op $ mapThese f g t
-- | A 'Control.Lens.Traversal' of the first half of a 'These', suitable for use with "Control.Lens".
--
-- @
-- 'here' :: 'Control.Lens.Traversal' ('These' a t) ('These' b t) a b
-- @
--
-- >>> over here show (That 1)
-- That 1
--
-- >>> over here show (These 'a' 2)
-- These "'a'" 2
--
here :: (Applicative f) => (a -> f b) -> These a t -> f (These b t)
here f (This x) = This <$> f x
here f (These x y) = flip These y <$> f x
here _ (That x) = pure (That x)
-- | A 'Control.Lens.Traversal' of the second half of a 'These', suitable for use with "Control.Lens".
--
-- @
-- 'there' :: 'Control.Lens.Traversal' ('These' t b) ('These' t b) a b
-- @
--
-- >>> over there show (That 1)
-- That "1"
--
-- >>> over there show (These 'a' 2)
-- These 'a' "2"
--
there :: (Applicative f) => (a -> f b) -> These t a -> f (These t b)
there _ (This x) = pure (This x)
there f (These x y) = These x <$> f y
there f (That x) = That <$> f x
-- | @'justHere' = 'Control.Lens.preview' 'here'@
--
-- >>> justHere (This 'x')
-- Just 'x'
--
-- >>> justHere (That 'y')
-- Nothing
--
-- >>> justHere (These 'x' 'y')
-- Just 'x'
--
justHere :: These a b -> Maybe a
justHere (This a) = Just a
justHere (That _) = Nothing
justHere (These a _) = Just a
-- | @'justThere' = 'Control.Lens.preview' 'there'@
--
-- >>> justThere (This 'x')
-- Nothing
--
-- >>> justThere (That 'y')
-- Just 'y'
--
-- >>> justThere (These 'x' 'y')
-- Just 'y'
--
justThere :: These a b -> Maybe b
justThere (This _) = Nothing
justThere (That b) = Just b
justThere (These _ b) = Just b
-- | A 'Control.Lens.Prism'' selecting the 'This' constructor.
--
-- /Note:/ cannot change type.
_This :: Prism' (These a b) a
_This = prism This (these Right (Left . That) (\x y -> Left $ These x y))
-- | A 'Control.Lens.Prism'' selecting the 'That' constructor.
--
-- /Note:/ cannot change type.
_That :: Prism' (These a b) b
_That = prism That (these (Left . This) Right (\x y -> Left $ These x y))
-- | A 'Control.Lens.Prism'' selecting the 'These' constructor. 'These' names are ridiculous!
--
-- /Note:/ cannot change type.
_These :: Prism' (These a b) (a, b)
_These = prism (uncurry These) (these (Left . This) (Left . That) (\x y -> Right (x, y)))
-- | @'justThis' = 'Control.Lens.preview' '_This'@
justThis :: These a b -> Maybe a
justThis (This a) = Just a
justThis _ = Nothing
-- | @'justThat' = 'Control.Lens.preview' '_That'@
justThat :: These a b -> Maybe b
justThat (That x) = Just x
justThat _ = Nothing
-- | @'justThese' = 'Control.Lens.preview' '_These'@
justThese :: These a b -> Maybe (a, b)
justThese (These a x) = Just (a, x)
justThese _ = Nothing
isThis, isThat, isThese :: These a b -> Bool
-- | @'isThis' = 'isJust' . 'justThis'@
isThis = isJust . justThis
-- | @'isThat' = 'isJust' . 'justThat'@
isThat = isJust . justThat
-- | @'isThese' = 'isJust' . 'justThese'@
isThese = isJust . justThese
-- | 'Bifunctor' map.
mapThese :: (a -> c) -> (b -> d) -> These a b -> These c d
mapThese f _ (This a ) = This (f a)
mapThese _ g (That x) = That (g x)
mapThese f g (These a x) = These (f a) (g x)
-- | 'Bitraversable'.
--
-- @since 0.7.5
bitraverseThese :: Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d)
bitraverseThese f _ (This x) = This <$> f x
bitraverseThese _ g (That x) = That <$> g x
bitraverseThese f g (These x y) = These <$> f x <*> g y
-- | @'mapThis' = 'Control.Lens.over' 'here'@
mapThis :: (a -> c) -> These a b -> These c b
mapThis f = mapThese f id
-- | @'mapThat' = 'Control.Lens.over' 'there'@
mapThat :: (b -> d) -> These a b -> These a d
mapThat f = mapThese id f
-- | Select all 'This' constructors from a list.
catThis :: [These a b] -> [a]
catThis = mapMaybe justThis
-- | Select all 'That' constructors from a list.
catThat :: [These a b] -> [b]
catThat = mapMaybe justThat
-- | Select all 'These' constructors from a list.
catThese :: [These a b] -> [(a, b)]
catThese = mapMaybe justThese
-- | Select each constructor and partition them into separate lists.
partitionThese :: [These a b] -> ( [(a, b)], ([a], [b]) )
partitionThese [] = ([], ([], []))
partitionThese (These 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
-- | 'These' is commutative.
--
-- @
-- 'swap' . 'swap' = 'id'
-- @
--
-- @since 0.7.6
swap :: These a b -> These b a
swap (This a) = That a
swap (That b) = This b
swap (These a b) = These b a
-- | 'These' is associative.
--
-- @
-- 'assoc' . 'reassoc' = 'id'
-- 'reassoc' . 'assoc' = 'id'
-- @
--
-- @since 0.7.6
assoc :: These a (These b c) -> These (These a b) c
assoc (This a) = This (This a)
assoc (That (This b)) = This (That b)
assoc (That (That c)) = That c
assoc (That (These b c)) = These (That b) c
assoc (These a (This b)) = This (These a b)
assoc (These a (That c)) = These (This a) c
assoc (These a (These b c)) = These (These a b) c
-- | 'These is associative. See 'assoc'.
--
-- @since 0.7.6
reassoc :: These (These a b) c -> These a (These b c)
reassoc (This (This a)) = This a
reassoc (This (That b)) = That (This b)
reassoc (That c) = That (That c)
reassoc (These (That b) c) = That (These b c)
reassoc (This (These a b)) = These a (This b)
reassoc (These (This a) c) = These a (That c)
reassoc (These (These a b) c) = These a (These b c)
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
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 = mapThese
first = mapThis
second = mapThat
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 Bifoldable1 These where
bifold1 = these id id (<>)
instance Bitraversable These where
bitraverse = bitraverseThese
instance Bitraversable1 These where
bitraverse1 f _ (This x) = This <$> f x
bitraverse1 _ g (That x) = That <$> g x
bitraverse1 f g (These x y) = These <$> f x <.> g y
-- | @since 0.7.6
instance Swapped These where
swapped = iso swap swap
instance (Semigroup a) => Apply (These a) where
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) => Applicative (These a) where
pure = That
(<*>) = (<.>)
instance (Semigroup a) => Bind (These a) where
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 (Semigroup a) => Monad (These a) where
return = pure
(>>=) = (>>-)
instance (Hashable a, Hashable b) => Hashable (These a b)
-- | @since 0.7.1
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
-- | @since 0.7.1
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"
-- | @since 0.7.1
instance (ToJSON a, ToJSON b) => ToJSON (These a b) where
toJSON (This a) = Aeson.object [ "This" .= a ]
toJSON (That b) = Aeson.object [ "That" .= b ]
toJSON (These a b) = Aeson.object [ "This" .= a, "That" .= b ]
toEncoding (This a) = Aeson.pairs $ "This" .= a
toEncoding (That b) = Aeson.pairs $ "That" .= b
toEncoding (These a b) = Aeson.pairs $ "This" .= a <> "That" .= b
-- | @since 0.7.1
instance (FromJSON a, FromJSON b) => FromJSON (These a b) where
parseJSON = Aeson.withObject "These a b" (p . HM.toList)
where
p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b
p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b
p [("This", a)] = This <$> parseJSON a
p [("That", b)] = That <$> parseJSON b
p _ = fail "Expected object with 'This' and 'That' keys only"
-- | @since 0.7.2
instance Aeson.ToJSON2 These where
liftToJSON2 toa _ _tob _ (This a) = Aeson.object [ "This" .= toa a ]
liftToJSON2 _toa _ tob _ (That b) = Aeson.object [ "That" .= tob b ]
liftToJSON2 toa _ tob _ (These a b) = Aeson.object [ "This" .= toa a, "That" .= tob b ]
liftToEncoding2 toa _ _tob _ (This a) = Aeson.pairs $ Aeson.pair "This" (toa a)
liftToEncoding2 _toa _ tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)
liftToEncoding2 toa _ tob _ (These a b) = Aeson.pairs $ Aeson.pair "This" (toa a) <> Aeson.pair "That" (tob b)
-- | @since 0.7.2
instance ToJSON a => Aeson.ToJSON1 (These a) where
liftToJSON _tob _ (This a) = Aeson.object [ "This" .= a ]
liftToJSON tob _ (That b) = Aeson.object [ "That" .= tob b ]
liftToJSON tob _ (These a b) = Aeson.object [ "This" .= a, "That" .= tob b ]
liftToEncoding _tob _ (This a) = Aeson.pairs $ "This" .= a
liftToEncoding tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)
liftToEncoding tob _ (These a b) = Aeson.pairs $ "This" .= a <> Aeson.pair "That" (tob b)
-- | @since 0.7.2
instance Aeson.FromJSON2 These where
liftParseJSON2 pa _ pb _ = Aeson.withObject "These a b" (p . HM.toList)
where
p [("This", a), ("That", b)] = These <$> pa a <*> pb b
p [("That", b), ("This", a)] = These <$> pa a <*> pb b
p [("This", a)] = This <$> pa a
p [("That", b)] = That <$> pb b
p _ = fail "Expected object with 'This' and 'That' keys only"
-- | @since 0.7.2
instance FromJSON a => Aeson.FromJSON1 (These a) where
liftParseJSON pb _ = Aeson.withObject "These a b" (p . HM.toList)
where
p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b
p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b
p [("This", a)] = This <$> parseJSON a
p [("That", b)] = That <$> pb b
p _ = fail "Expected object with 'This' and 'That' keys only"
-- | @since 0.7.4
instance Arbitrary2 These where
liftArbitrary2 arbA arbB = oneof
[ This <$> arbA
, That <$> arbB
, These <$> arbA <*> arbB
]
liftShrink2 shrA _shrB (This x) = This <$> shrA x
liftShrink2 _shrA shrB (That y) = That <$> shrB y
liftShrink2 shrA shrB (These x y) =
[This x, That y] ++ [These x' y' | (x', y') <- liftShrink2 shrA shrB (x, y)]
-- | @since 0.7.4
instance (Arbitrary a) => Arbitrary1 (These a) where
liftArbitrary = liftArbitrary2 arbitrary
liftShrink = liftShrink2 shrink
-- | @since 0.7.1
instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where
arbitrary = arbitrary1
shrink = shrink1
-- | @since 0.7.1
instance (Function a, Function b) => Function (These a b) where
function = functionMap g f
where
g (This a) = Left a
g (That b) = Right (Left b)
g (These a b) = Right (Right (a, b))
f (Left a) = This a
f (Right (Left b)) = That b
f (Right (Right (a, b))) = These a b
-- | @since 0.7.1
instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (These a b)