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 Trustworthy #-} 7module Data.These ( 8 These(..) 9 10 -- * Functions to get rid of 'These' 11 , these 12 , fromThese 13 , mergeThese 14 , mergeTheseWith 15 16 -- * Partition 17 , partitionThese 18 , partitionHereThere 19 , partitionEithersNE 20 21 -- * Distributivity 22 -- 23 -- | This distributivity combinators aren't isomorphisms! 24 , distrThesePair 25 , undistrThesePair 26 , distrPairThese 27 , undistrPairThese 28 ) where 29 30import Prelude () 31import Prelude.Compat 32 33import Control.DeepSeq (NFData (..)) 34import Data.Bifoldable (Bifoldable (..)) 35import Data.Bifunctor (Bifunctor (..)) 36import Data.Binary (Binary (..)) 37import Data.Bitraversable (Bitraversable (..)) 38import Data.Data (Data, Typeable) 39import Data.Either (partitionEithers) 40import Data.Hashable (Hashable (..)) 41import Data.List.NonEmpty (NonEmpty (..)) 42import Data.Semigroup (Semigroup (..)) 43import GHC.Generics (Generic) 44 45#if __GLASGOW_HASKELL__ >= 706 46import GHC.Generics (Generic1) 47#endif 48 49#ifdef MIN_VERSION_assoc 50import Data.Bifunctor.Assoc (Assoc (..)) 51import Data.Bifunctor.Swap (Swap (..)) 52#endif 53 54-- $setup 55-- >>> import Control.Lens 56 57-- -------------------------------------------------------------------------- 58-- | The 'These' type represents values with two non-exclusive possibilities. 59-- 60-- This can be useful to represent combinations of two values, where the 61-- combination is defined if either input is. Algebraically, the type 62-- @'These' A B@ represents @(A + B + AB)@, which doesn't factor easily into 63-- sums and products--a type like @'Either' A (B, 'Maybe' A)@ is unclear and 64-- awkward to use. 65-- 66-- 'These' has straightforward instances of 'Functor', 'Monad', &c., and 67-- behaves like a hybrid error/writer monad, as would be expected. 68-- 69-- For zipping and unzipping of structures with 'These' values, see 70-- "Data.Align". 71data These a b = This a | That b | These a b 72 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic 73#if __GLASGOW_HASKELL__ >= 706 74 , Generic1 75#endif 76 ) 77 78------------------------------------------------------------------------------- 79-- Eliminators 80------------------------------------------------------------------------------- 81 82-- | Case analysis for the 'These' type. 83these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c 84these l _ _ (This a) = l a 85these _ r _ (That x) = r x 86these _ _ lr (These a x) = lr a x 87 88-- | Takes two default values and produces a tuple. 89fromThese :: a -> b -> These a b -> (a, b) 90fromThese x y = these (`pair` y) (x `pair`) pair where 91 pair = (,) 92 93-- | Coalesce with the provided operation. 94mergeThese :: (a -> a -> a) -> These a a -> a 95mergeThese = these id id 96 97-- | 'bimap' and coalesce results with the provided operation. 98mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c 99mergeTheseWith f g op t = mergeThese op $ bimap f g t 100 101------------------------------------------------------------------------------- 102-- Partitioning 103------------------------------------------------------------------------------- 104 105-- | Select each constructor and partition them into separate lists. 106partitionThese :: [These a b] -> ([a], [b], [(a, b)]) 107partitionThese [] = ([], [], []) 108partitionThese (t:ts) = case t of 109 This x -> (x : xs, ys, xys) 110 That y -> ( xs, y : ys, xys) 111 These x y -> ( xs, ys, (x,y) : xys) 112 where 113 ~(xs,ys,xys) = partitionThese ts 114 115-- | Select 'here' and 'there' elements and partition them into separate lists. 116-- 117-- @since 0.8 118partitionHereThere :: [These a b] -> ([a], [b]) 119partitionHereThere [] = ([], []) 120partitionHereThere (t:ts) = case t of 121 This x -> (x : xs, ys) 122 That y -> ( xs, y : ys) 123 These x y -> (x : xs, y : ys) 124 where 125 ~(xs,ys) = partitionHereThere ts 126 127-- | Like 'partitionEithers' but for 'NonEmpty' types. 128-- 129-- * either all are 'Left' 130-- * either all are 'Right' 131-- * or there is both 'Left' and 'Right' stuff 132-- 133-- /Note:/ this is not online algorithm. In the worst case it will traverse 134-- the whole list before deciding the result constructor. 135-- 136-- >>> partitionEithersNE $ Left 'x' :| [Right 'y'] 137-- These ('x' :| "") ('y' :| "") 138-- 139-- >>> partitionEithersNE $ Left 'x' :| map Left "yz" 140-- This ('x' :| "yz") 141-- 142-- @since 1.0.1 143partitionEithersNE :: NonEmpty (Either a b) -> These (NonEmpty a) (NonEmpty b) 144partitionEithersNE (x :| xs) = case (x, ls, rs) of 145 (Left y, ys, []) -> This (y :| ys) 146 (Left y, ys, z:zs) -> These (y :| ys) (z :| zs) 147 (Right z, [], zs) -> That (z :| zs) 148 (Right z, y:ys, zs) -> These (y :| ys) (z :| zs) 149 where 150 (ls, rs) = partitionEithers xs 151 152 153------------------------------------------------------------------------------- 154-- Distributivity 155------------------------------------------------------------------------------- 156 157distrThesePair :: These (a, b) c -> (These a c, These b c) 158distrThesePair (This (a, b)) = (This a, This b) 159distrThesePair (That c) = (That c, That c) 160distrThesePair (These (a, b) c) = (These a c, These b c) 161 162undistrThesePair :: (These a c, These b c) -> These (a, b) c 163undistrThesePair (This a, This b) = This (a, b) 164undistrThesePair (That c, That _) = That c 165undistrThesePair (These a c, These b _) = These (a, b) c 166undistrThesePair (This _, That c) = That c 167undistrThesePair (This a, These b c) = These (a, b) c 168undistrThesePair (That c, This _) = That c 169undistrThesePair (That c, These _ _) = That c 170undistrThesePair (These a c, This b) = These (a, b) c 171undistrThesePair (These _ c, That _) = That c 172 173 174distrPairThese :: (These a b, c) -> These (a, c) (b, c) 175distrPairThese (This a, c) = This (a, c) 176distrPairThese (That b, c) = That (b, c) 177distrPairThese (These a b, c) = These (a, c) (b, c) 178 179undistrPairThese :: These (a, c) (b, c) -> (These a b, c) 180undistrPairThese (This (a, c)) = (This a, c) 181undistrPairThese (That (b, c)) = (That b, c) 182undistrPairThese (These (a, c) (b, _)) = (These a b, c) 183 184------------------------------------------------------------------------------- 185-- Instances 186------------------------------------------------------------------------------- 187 188 189 190instance (Semigroup a, Semigroup b) => Semigroup (These a b) where 191 This a <> This b = This (a <> b) 192 This a <> That y = These a y 193 This a <> These b y = These (a <> b) y 194 That x <> This b = These b x 195 That x <> That y = That (x <> y) 196 That x <> These b y = These b (x <> y) 197 These a x <> This b = These (a <> b) x 198 These a x <> That y = These a (x <> y) 199 These a x <> These b y = These (a <> b) (x <> y) 200 201instance Functor (These a) where 202 fmap _ (This x) = This x 203 fmap f (That y) = That (f y) 204 fmap f (These x y) = These x (f y) 205 206instance Foldable (These a) where 207 foldr _ z (This _) = z 208 foldr f z (That x) = f x z 209 foldr f z (These _ x) = f x z 210 211instance Traversable (These a) where 212 traverse _ (This a) = pure $ This a 213 traverse f (That x) = That <$> f x 214 traverse f (These a x) = These a <$> f x 215 sequenceA (This a) = pure $ This a 216 sequenceA (That x) = That <$> x 217 sequenceA (These a x) = These a <$> x 218 219instance Bifunctor These where 220 bimap f _ (This a ) = This (f a) 221 bimap _ g (That x) = That (g x) 222 bimap f g (These a x) = These (f a) (g x) 223 224instance Bifoldable These where 225 bifold = these id id mappend 226 bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z)) 227 bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y) 228 229instance Bitraversable These where 230 bitraverse f _ (This x) = This <$> f x 231 bitraverse _ g (That x) = That <$> g x 232 bitraverse f g (These x y) = These <$> f x <*> g y 233 234instance (Semigroup a) => Applicative (These a) where 235 pure = That 236 This a <*> _ = This a 237 That _ <*> This b = This b 238 That f <*> That x = That (f x) 239 That f <*> These b x = These b (f x) 240 These a _ <*> This b = This (a <> b) 241 These a f <*> That x = These a (f x) 242 These a f <*> These b x = These (a <> b) (f x) 243 244 245instance (Semigroup a) => Monad (These a) where 246 return = pure 247 This a >>= _ = This a 248 That x >>= k = k x 249 These a x >>= k = case k x of 250 This b -> This (a <> b) 251 That y -> These a y 252 These b y -> These (a <> b) y 253instance (Hashable a, Hashable b) => Hashable (These a b) 254 255------------------------------------------------------------------------------- 256-- assoc 257------------------------------------------------------------------------------- 258 259#ifdef MIN_VERSION_assoc 260-- | @since 0.8 261instance Swap These where 262 swap (This a) = That a 263 swap (That b) = This b 264 swap (These a b) = These b a 265 266-- | @since 0.8 267instance Assoc These where 268 assoc (This (This a)) = This a 269 assoc (This (That b)) = That (This b) 270 assoc (That c) = That (That c) 271 assoc (These (That b) c) = That (These b c) 272 assoc (This (These a b)) = These a (This b) 273 assoc (These (This a) c) = These a (That c) 274 assoc (These (These a b) c) = These a (These b c) 275 276 unassoc (This a) = This (This a) 277 unassoc (That (This b)) = This (That b) 278 unassoc (That (That c)) = That c 279 unassoc (That (These b c)) = These (That b) c 280 unassoc (These a (This b)) = This (These a b) 281 unassoc (These a (That c)) = These (This a) c 282 unassoc (These a (These b c)) = These (These a b) c 283#endif 284 285------------------------------------------------------------------------------- 286-- deepseq 287------------------------------------------------------------------------------- 288 289-- | @since 0.7.1 290instance (NFData a, NFData b) => NFData (These a b) where 291 rnf (This a) = rnf a 292 rnf (That b) = rnf b 293 rnf (These a b) = rnf a `seq` rnf b 294 295------------------------------------------------------------------------------- 296-- binary 297------------------------------------------------------------------------------- 298 299-- | @since 0.7.1 300instance (Binary a, Binary b) => Binary (These a b) where 301 put (This a) = put (0 :: Int) >> put a 302 put (That b) = put (1 :: Int) >> put b 303 put (These a b) = put (2 :: Int) >> put a >> put b 304 305 get = do 306 i <- get 307 case (i :: Int) of 308 0 -> This <$> get 309 1 -> That <$> get 310 2 -> These <$> get <*> get 311 _ -> fail "Invalid These index" 312