1{-# LANGUAGE CPP #-} 2-- | The 'These' type and associated operations. Now enhanced with "Control.Lens" magic! 3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE DeriveGeneric #-} 5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE Safe #-} 7 8#if MIN_VERSION_base(4,9,0) 9#define LIFTED_FUNCTOR_CLASSES 1 10#else 11#if MIN_VERSION_transformers(0,5,0) 12#define LIFTED_FUNCTOR_CLASSES 1 13#else 14#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) 15#define LIFTED_FUNCTOR_CLASSES 1 16#endif 17#endif 18#endif 19 20module Data.These ( 21 These(..) 22 23 -- * Functions to get rid of 'These' 24 , these 25 , fromThese 26 , mergeThese 27 , mergeTheseWith 28 29 -- * Partition 30 , partitionThese 31 , partitionHereThere 32 , partitionEithersNE 33 34 -- * Distributivity 35 -- 36 -- | This distributivity combinators aren't isomorphisms! 37 , distrThesePair 38 , undistrThesePair 39 , distrPairThese 40 , undistrPairThese 41 ) where 42 43import Control.Applicative (Applicative (..), (<$>)) 44import Control.DeepSeq (NFData (..)) 45import Data.Bifoldable (Bifoldable (..)) 46import Data.Bifunctor (Bifunctor (..)) 47import Data.Binary (Binary (..)) 48import Data.Bitraversable (Bitraversable (..)) 49import Data.Data (Data, Typeable) 50import Data.Either (partitionEithers) 51import Data.Foldable (Foldable (..)) 52import Data.Hashable (Hashable (..)) 53import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..)) 54import Data.List.NonEmpty (NonEmpty (..)) 55import Data.Monoid (Monoid (..)) 56import Data.Semigroup (Semigroup (..)) 57import Data.Traversable (Traversable (..)) 58import GHC.Generics (Generic) 59import Prelude 60 (Bool (..), Either (..), Eq (..), Functor (..), Int, Monad (..), 61 Ord (..), Ordering (..), Read (..), Show (..), fail, id, lex, readParen, 62 seq, showParen, showString, ($), (&&), (.)) 63 64#if MIN_VERSION_deepseq(1,4,3) 65import Control.DeepSeq (NFData1 (..), NFData2 (..)) 66#endif 67 68#if __GLASGOW_HASKELL__ >= 706 69import GHC.Generics (Generic1) 70#endif 71 72#ifdef MIN_VERSION_assoc 73import Data.Bifunctor.Assoc (Assoc (..)) 74import Data.Bifunctor.Swap (Swap (..)) 75#endif 76 77#ifdef LIFTED_FUNCTOR_CLASSES 78import Data.Functor.Classes 79 (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..), 80 Show1 (..), Show2 (..)) 81#else 82import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) 83#endif 84 85-- $setup 86-- >>> import Control.Lens 87 88-- -------------------------------------------------------------------------- 89-- | The 'These' type represents values with two non-exclusive possibilities. 90-- 91-- This can be useful to represent combinations of two values, where the 92-- combination is defined if either input is. Algebraically, the type 93-- @'These' A B@ represents @(A + B + AB)@, which doesn't factor easily into 94-- sums and products--a type like @'Either' A (B, 'Maybe' A)@ is unclear and 95-- awkward to use. 96-- 97-- 'These' has straightforward instances of 'Functor', 'Monad', &c., and 98-- behaves like a hybrid error/writer monad, as would be expected. 99-- 100-- For zipping and unzipping of structures with 'These' values, see 101-- "Data.Align". 102data These a b = This a | That b | These a b 103 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic 104#if __GLASGOW_HASKELL__ >= 706 105 , Generic1 106#endif 107 ) 108 109------------------------------------------------------------------------------- 110-- Eliminators 111------------------------------------------------------------------------------- 112 113-- | Case analysis for the 'These' type. 114these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c 115these l _ _ (This a) = l a 116these _ r _ (That x) = r x 117these _ _ lr (These a x) = lr a x 118 119-- | Takes two default values and produces a tuple. 120fromThese :: a -> b -> These a b -> (a, b) 121fromThese x y = these (`pair` y) (x `pair`) pair where 122 pair = (,) 123 124-- | Coalesce with the provided operation. 125mergeThese :: (a -> a -> a) -> These a a -> a 126mergeThese = these id id 127 128-- | 'bimap' and coalesce results with the provided operation. 129mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c 130mergeTheseWith f g op t = mergeThese op $ bimap f g t 131 132------------------------------------------------------------------------------- 133-- Partitioning 134------------------------------------------------------------------------------- 135 136-- | Select each constructor and partition them into separate lists. 137partitionThese :: [These a b] -> ([a], [b], [(a, b)]) 138partitionThese [] = ([], [], []) 139partitionThese (t:ts) = case t of 140 This x -> (x : xs, ys, xys) 141 That y -> ( xs, y : ys, xys) 142 These x y -> ( xs, ys, (x,y) : xys) 143 where 144 ~(xs,ys,xys) = partitionThese ts 145 146-- | Select 'here' and 'there' elements and partition them into separate lists. 147-- 148-- @since 0.8 149partitionHereThere :: [These a b] -> ([a], [b]) 150partitionHereThere [] = ([], []) 151partitionHereThere (t:ts) = case t of 152 This x -> (x : xs, ys) 153 That y -> ( xs, y : ys) 154 These x y -> (x : xs, y : ys) 155 where 156 ~(xs,ys) = partitionHereThere ts 157 158-- | Like 'partitionEithers' but for 'NonEmpty' types. 159-- 160-- * either all are 'Left' 161-- * either all are 'Right' 162-- * or there is both 'Left' and 'Right' stuff 163-- 164-- /Note:/ this is not online algorithm. In the worst case it will traverse 165-- the whole list before deciding the result constructor. 166-- 167-- >>> partitionEithersNE $ Left 'x' :| [Right 'y'] 168-- These ('x' :| "") ('y' :| "") 169-- 170-- >>> partitionEithersNE $ Left 'x' :| map Left "yz" 171-- This ('x' :| "yz") 172-- 173-- @since 1.0.1 174partitionEithersNE :: NonEmpty (Either a b) -> These (NonEmpty a) (NonEmpty b) 175partitionEithersNE (x :| xs) = case (x, ls, rs) of 176 (Left y, ys, []) -> This (y :| ys) 177 (Left y, ys, z:zs) -> These (y :| ys) (z :| zs) 178 (Right z, [], zs) -> That (z :| zs) 179 (Right z, y:ys, zs) -> These (y :| ys) (z :| zs) 180 where 181 (ls, rs) = partitionEithers xs 182 183 184------------------------------------------------------------------------------- 185-- Distributivity 186------------------------------------------------------------------------------- 187 188distrThesePair :: These (a, b) c -> (These a c, These b c) 189distrThesePair (This (a, b)) = (This a, This b) 190distrThesePair (That c) = (That c, That c) 191distrThesePair (These (a, b) c) = (These a c, These b c) 192 193undistrThesePair :: (These a c, These b c) -> These (a, b) c 194undistrThesePair (This a, This b) = This (a, b) 195undistrThesePair (That c, That _) = That c 196undistrThesePair (These a c, These b _) = These (a, b) c 197undistrThesePair (This _, That c) = That c 198undistrThesePair (This a, These b c) = These (a, b) c 199undistrThesePair (That c, This _) = That c 200undistrThesePair (That c, These _ _) = That c 201undistrThesePair (These a c, This b) = These (a, b) c 202undistrThesePair (These _ c, That _) = That c 203 204 205distrPairThese :: (These a b, c) -> These (a, c) (b, c) 206distrPairThese (This a, c) = This (a, c) 207distrPairThese (That b, c) = That (b, c) 208distrPairThese (These a b, c) = These (a, c) (b, c) 209 210undistrPairThese :: These (a, c) (b, c) -> (These a b, c) 211undistrPairThese (This (a, c)) = (This a, c) 212undistrPairThese (That (b, c)) = (That b, c) 213undistrPairThese (These (a, c) (b, _)) = (These a b, c) 214 215------------------------------------------------------------------------------- 216-- Instances 217------------------------------------------------------------------------------- 218 219 220 221instance (Semigroup a, Semigroup b) => Semigroup (These a b) where 222 This a <> This b = This (a <> b) 223 This a <> That y = These a y 224 This a <> These b y = These (a <> b) y 225 That x <> This b = These b x 226 That x <> That y = That (x <> y) 227 That x <> These b y = These b (x <> y) 228 These a x <> This b = These (a <> b) x 229 These a x <> That y = These a (x <> y) 230 These a x <> These b y = These (a <> b) (x <> y) 231 232instance Functor (These a) where 233 fmap _ (This x) = This x 234 fmap f (That y) = That (f y) 235 fmap f (These x y) = These x (f y) 236 237instance Foldable (These a) where 238 foldr _ z (This _) = z 239 foldr f z (That x) = f x z 240 foldr f z (These _ x) = f x z 241 242instance Traversable (These a) where 243 traverse _ (This a) = pure $ This a 244 traverse f (That x) = That <$> f x 245 traverse f (These a x) = These a <$> f x 246 sequenceA (This a) = pure $ This a 247 sequenceA (That x) = That <$> x 248 sequenceA (These a x) = These a <$> x 249 250instance Bifunctor These where 251 bimap f _ (This a ) = This (f a) 252 bimap _ g (That x) = That (g x) 253 bimap f g (These a x) = These (f a) (g x) 254 255instance Bifoldable These where 256 bifold = these id id mappend 257 bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z)) 258 bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y) 259 260instance Bitraversable These where 261 bitraverse f _ (This x) = This <$> f x 262 bitraverse _ g (That x) = That <$> g x 263 bitraverse f g (These x y) = These <$> f x <*> g y 264 265instance (Semigroup a) => Applicative (These a) where 266 pure = That 267 This a <*> _ = This a 268 That _ <*> This b = This b 269 That f <*> That x = That (f x) 270 That f <*> These b x = These b (f x) 271 These a _ <*> This b = This (a <> b) 272 These a f <*> That x = These a (f x) 273 These a f <*> These b x = These (a <> b) (f x) 274 275 276instance (Semigroup a) => Monad (These a) where 277 return = pure 278 This a >>= _ = This a 279 That x >>= k = k x 280 These a x >>= k = case k x of 281 This b -> This (a <> b) 282 That y -> These a y 283 These b y -> These (a <> b) y 284 285------------------------------------------------------------------------------- 286-- Data.Functor.Classes 287------------------------------------------------------------------------------- 288 289#ifdef LIFTED_FUNCTOR_CLASSES 290-- | @since 1.1.1 291instance Eq2 These where 292 liftEq2 f _ (This a) (This a') = f a a' 293 liftEq2 _ g (That b) (That b') = g b b' 294 liftEq2 f g (These a b) (These a' b') = f a a' && g b b' 295 liftEq2 _ _ _ _ = False 296 297-- | @since 1.1.1 298instance Eq a => Eq1 (These a) where 299 liftEq = liftEq2 (==) 300 301-- | @since 1.1.1 302instance Ord2 These where 303 liftCompare2 f _ (This a) (This a') = f a a' 304 liftCompare2 _ _ (This _) _ = LT 305 liftCompare2 _ _ _ (This _) = GT 306 liftCompare2 _ g (That b) (That b') = g b b' 307 liftCompare2 _ _ (That _) _ = LT 308 liftCompare2 _ _ _ (That _) = GT 309 liftCompare2 f g (These a b) (These a' b') = f a a' `mappend` g b b' 310 311-- | @since 1.1.1 312instance Ord a => Ord1 (These a) where 313 liftCompare = liftCompare2 compare 314 315-- | @since 1.1.1 316instance Show a => Show1 (These a) where 317 liftShowsPrec = liftShowsPrec2 showsPrec showList 318 319-- | @since 1.1.1 320instance Show2 These where 321 liftShowsPrec2 sa _ _sb _ d (This a) = showParen (d > 10) 322 $ showString "This " 323 . sa 11 a 324 liftShowsPrec2 _sa _ sb _ d (That b) = showParen (d > 10) 325 $ showString "That " 326 . sb 11 b 327 liftShowsPrec2 sa _ sb _ d (These a b) = showParen (d > 10) 328 $ showString "These " 329 . sa 11 a 330 . showString " " 331 . sb 11 b 332 333-- | @since 1.1.1 334instance Read2 These where 335 liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> cons s 336 where 337 cons s0 = do 338 (ident, s1) <- lex s0 339 case ident of 340 "This" -> do 341 (a, s2) <- ra 11 s1 342 return (This a, s2) 343 "That" -> do 344 (b, s2) <- rb 11 s1 345 return (That b, s2) 346 "These" -> do 347 (a, s2) <- ra 11 s1 348 (b, s3) <- rb 11 s2 349 return (These a b, s3) 350 _ -> [] 351 352-- | @since 1.1.1 353instance Read a => Read1 (These a) where 354 liftReadsPrec = liftReadsPrec2 readsPrec readList 355 356#else 357-- | @since 1.1.1 358instance Eq a => Eq1 (These a) where eq1 = (==) 359-- | @since 1.1.1 360instance Ord a => Ord1 (These a) where compare1 = compare 361-- | @since 1.1.1 362instance Show a => Show1 (These a) where showsPrec1 = showsPrec 363-- | @since 1.1.1 364instance Read a => Read1 (These a) where readsPrec1 = readsPrec 365#endif 366 367------------------------------------------------------------------------------- 368-- assoc 369------------------------------------------------------------------------------- 370 371#ifdef MIN_VERSION_assoc 372-- | @since 0.8 373instance Swap These where 374 swap (This a) = That a 375 swap (That b) = This b 376 swap (These a b) = These b a 377 378-- | @since 0.8 379instance Assoc These where 380 assoc (This (This a)) = This a 381 assoc (This (That b)) = That (This b) 382 assoc (That c) = That (That c) 383 assoc (These (That b) c) = That (These b c) 384 assoc (This (These a b)) = These a (This b) 385 assoc (These (This a) c) = These a (That c) 386 assoc (These (These a b) c) = These a (These b c) 387 388 unassoc (This a) = This (This a) 389 unassoc (That (This b)) = This (That b) 390 unassoc (That (That c)) = That c 391 unassoc (That (These b c)) = These (That b) c 392 unassoc (These a (This b)) = This (These a b) 393 unassoc (These a (That c)) = These (This a) c 394 unassoc (These a (These b c)) = These (These a b) c 395#endif 396 397------------------------------------------------------------------------------- 398-- deepseq 399------------------------------------------------------------------------------- 400 401-- | @since 0.7.1 402instance (NFData a, NFData b) => NFData (These a b) where 403 rnf (This a) = rnf a 404 rnf (That b) = rnf b 405 rnf (These a b) = rnf a `seq` rnf b 406 407#if MIN_VERSION_deepseq(1,4,3) 408-- | @since 1.1.1 409instance NFData a => NFData1 (These a) where 410 liftRnf _rnfB (This a) = rnf a 411 liftRnf rnfB (That b) = rnfB b 412 liftRnf rnfB (These a b) = rnf a `seq` rnfB b 413 414-- | @since 1.1.1 415instance NFData2 These where 416 liftRnf2 rnfA _rnfB (This a) = rnfA a 417 liftRnf2 _rnfA rnfB (That b) = rnfB b 418 liftRnf2 rnfA rnfB (These a b) = rnfA a `seq` rnfB b 419#endif 420 421------------------------------------------------------------------------------- 422-- binary 423------------------------------------------------------------------------------- 424 425-- | @since 0.7.1 426instance (Binary a, Binary b) => Binary (These a b) where 427 put (This a) = put (0 :: Int) >> put a 428 put (That b) = put (1 :: Int) >> put b 429 put (These a b) = put (2 :: Int) >> put a >> put b 430 431 get = do 432 i <- get 433 case (i :: Int) of 434 0 -> This <$> get 435 1 -> That <$> get 436 2 -> These <$> get <*> get 437 _ -> fail "Invalid These index" 438 439------------------------------------------------------------------------------- 440-- hashable 441------------------------------------------------------------------------------- 442 443instance (Hashable a, Hashable b) => Hashable (These a b) where 444 hashWithSalt salt (This a) = 445 salt `hashWithSalt` (0 :: Int) `hashWithSalt` a 446 hashWithSalt salt (That b) = 447 salt `hashWithSalt` (1 :: Int) `hashWithSalt` b 448 hashWithSalt salt (These a b) = 449 salt `hashWithSalt` (2 :: Int) `hashWithSalt` a `hashWithSalt` b 450 451-- | @since 1.1.1 452instance Hashable a => Hashable1 (These a) where 453 liftHashWithSalt _hashB salt (This a) = 454 salt `hashWithSalt` (0 :: Int) `hashWithSalt` a 455 liftHashWithSalt hashB salt (That b) = 456 (salt `hashWithSalt` (1 :: Int)) `hashB` b 457 liftHashWithSalt hashB salt (These a b) = 458 (salt `hashWithSalt` (2 :: Int) `hashWithSalt` a) `hashB` b 459 460-- | @since 1.1.1 461instance Hashable2 These where 462 liftHashWithSalt2 hashA _hashB salt (This a) = 463 (salt `hashWithSalt` (0 :: Int)) `hashA` a 464 liftHashWithSalt2 _hashA hashB salt (That b) = 465 (salt `hashWithSalt` (1 :: Int)) `hashB` b 466 liftHashWithSalt2 hashA hashB salt (These a b) = 467 (salt `hashWithSalt` (2 :: Int)) `hashA` a `hashB` b 468