these 0.7.5 → 0.7.6
raw patch · 8 files changed
+1024/−307 lines, 8 filesdep +base-compatdep +lensdep −profunctorsdep ~QuickCheckdep ~aesondep ~base
Dependencies added: base-compat, lens
Dependencies removed: profunctors
Dependency ranges changed: QuickCheck, aeson, base, bifunctors, binary, containers, data-default-class, hashable, keys, mtl, semigroupoids, semigroups, tasty, tasty-quickcheck, transformers, transformers-compat, unordered-containers, vector, vector-instances
Files
- CHANGELOG.md +16/−2
- Data/Align.hs +94/−53
- Data/Align/Indexed.hs +44/−0
- Data/Align/Key.hs +17/−11
- Data/Functor/These.hs +259/−0
- Data/These.hs +203/−88
- test/Tests.hs +295/−83
- these.cabal +96/−70
CHANGELOG.md view
@@ -1,12 +1,26 @@+# 0.7.6++- Tigthen lower bounds+- Add dependency on `lens`+- Add `assoc`, `reassoc`, `swap` and `Swapped` instance+- Add since annotations for things added in 0.7.x+- Add `AlignWithKey ZipList` instance+- Add `Data.Align.Indexed` module.+- Add `Data.Functor.These` with `These1` data type.+- Add associativity law+- Add `toList` property to enforce "align"-feel.+- `Map` and `IntMap` `Align` instances implemented using merge combinators+ (when available)+ # 0.7.5 -- Add Compose and (,) Crosswalk instances+- Add `Compose` and `(,)` `Crosswalk` instances - Add `bitraverseThese` - GHC-8.6 support # 0.7.4 -- QuickCheck-2.10 support: Arbitrary1/2 instances+- `QuickCheck-2.10` support: `Arbitrary1/2` instances - GHC-8.2 support # 0.7.3
Data/Align.hs view
@@ -6,70 +6,78 @@ -- shapes, plus traversal of (bi)foldable (bi)functors through said -- functors. module Data.Align (- Align(..)- -- * Specialized aligns- , malign, salign, padZip, padZipWith- , lpadZip, lpadZipWith- , rpadZip, rpadZipWith- , alignVectorWith+ Align(..)+ -- * Specialized aligns+ , malign, salign, padZip, padZipWith+ , lpadZip, lpadZipWith+ , rpadZip, rpadZipWith+ , alignVectorWith - -- * Unalign- , Unalign(..)+ -- * Unalign+ , Unalign(..) - -- * Crosswalk- , Crosswalk(..)+ -- * Crosswalk+ , Crosswalk(..) - -- * Bicrosswalk- , Bicrosswalk(..)- ) where+ -- * Bicrosswalk+ , Bicrosswalk(..)+ ) where -- TODO: More instances.. -import Control.Applicative-import Data.Bifoldable (Bifoldable(..))-import Data.Bifunctor (Bifunctor(..))-import Data.Foldable-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Functor.Product-import Data.Hashable (Hashable(..))-import Data.HashMap.Strict (HashMap)-import Data.Maybe (catMaybes)-import Data.Monoid hiding (Product, (<>))-import Data.Semigroup (Semigroup (..))-import Data.Sequence (Seq)-import Data.These-import qualified Data.Vector as V-import Data.Vector.Generic (Vector, unstream, stream, empty)-import Data.Vector.Fusion.Stream.Monadic (Stream(..), Step(..))-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Sequence as Seq+import Prelude ()+import Prelude.Compat++import Control.Applicative (ZipList (..))+import Data.Bifoldable (Bifoldable (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Functor.Compose (Compose (..))+import Data.Functor.Identity (Identity (..))+import Data.Functor.Product (Product (..))+import Data.Hashable (Hashable (..))+import Data.HashMap.Strict (HashMap)+import Data.Maybe (catMaybes)+import Data.Semigroup (Semigroup (..))+import Data.Sequence (Seq)+import Data.Vector.Fusion.Stream.Monadic (Step (..), Stream (..))+import Data.Vector.Generic (Vector, empty, stream, unstream)++import qualified Data.HashMap.Strict as HashMap+import qualified Data.Sequence as Seq+import qualified Data.Vector as V import qualified Data.Vector.Fusion.Stream.Monadic as Stream-import qualified Data.Vector.Generic as VG (fromList, foldr)+import qualified Data.Vector.Generic as VG (foldr, fromList) #if MIN_VERSION_vector(0,11,0)-import Data.Vector.Fusion.Bundle.Monadic (Bundle (..))+import Data.Vector.Fusion.Bundle.Monadic (Bundle (..)) import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle-import qualified Data.Vector.Fusion.Bundle.Size as Bundle+import qualified Data.Vector.Fusion.Bundle.Size as Bundle #else import qualified Data.Vector.Fusion.Stream.Size as Stream #endif -#if MIN_VERSION_containers(0, 5, 0)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map+#if MIN_VERSION_containers(0,5,0)+import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as Map -import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap+import Data.IntMap.Lazy (IntMap)+import qualified Data.IntMap.Lazy as IntMap++#if MIN_VERSION_containers(0,5,9)+import qualified Data.Map.Merge.Lazy as Map+import qualified Data.IntMap.Merge.Lazy as IntMap+#endif++-- containers <0.5 #else-import Data.Map (Map)+import Data.Map (Map) import qualified Data.Map as Map -import Data.IntMap (IntMap)+import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap #endif -import Prelude hiding (foldr) -- Fix redundant import warnings+import Data.These oops :: String -> a oops = error . ("Data.Align: internal error: " ++)@@ -78,17 +86,17 @@ -- | Functors supporting a zip operation that takes the union of -- non-uniform shapes. ----- If your functor is actually a functor from @Kleisli Maybe@ to--- @Hask@ (so it supports @maybeMap :: (a -> Maybe b) -> f a -> f--- b@), then an @Align@ instance is making your functor lax monoidal--- w.r.t. the cartesian monoidal structure on @Kleisli Maybe@,--- because @These@ is the cartesian product in that category @(a ->--- Maybe (These b c) ~ (a -> Maybe b, a -> Maybe c))@. This insight--- is due to rwbarton.+-- If your functor is actually a functor from @Kleisli Maybe@ to+-- @Hask@ (so it supports @maybeMap :: (a -> Maybe b) -> f a -> f+-- b@), then an @Align@ instance is making your functor lax monoidal+-- w.r.t. the cartesian monoidal structure on @Kleisli Maybe@,+-- because @These@ is the cartesian product in that category @(a ->+-- Maybe (These b c) ~ (a -> Maybe b, a -> Maybe c))@. This insight+-- is due to rwbarton. ----- Minimal definition: @nil@ and either @align@ or @alignWith@.+-- Minimal definition: @nil@ and either @align@ or @alignWith@. ----- Laws:+-- == Laws: -- -- @ -- (\`align` nil) = fmap This@@ -96,7 +104,20 @@ -- join align = fmap (join These) -- align (f \<$> x) (g \<$> y) = bimap f g \<$> align x y -- alignWith f a b = f \<$> align a b+-- align (align x y) z = fmap assoc (align x (align y z)) -- @+--+-- /Note:/ @'join' f x = f x x@+--+-- And an addition property if @f@ is 'Foldable',+-- which tries to enforce 'align'-feel:+-- neither values are duplicated nor lost.+--+-- @+-- toList x = toListOf (folded . here) (align x y)+-- = mapMaybe justHere (toList (align x y))+-- @+-- class (Functor f) => Align f where -- | An empty strucutre. @'align'@ing with @'nil'@ will produce a structure with -- the same shape and elements as the other input, modulo @'This'@ or @'That'@.@@ -124,7 +145,7 @@ "alignWith f nil nil" forall f. alignWith f nil nil = nil "alignWith f x x" forall f x. alignWith f x x = fmap (\y -> f (These y y)) x - #-}+ #-} instance Align Maybe where@@ -171,15 +192,31 @@ instance (Ord k) => Align (Map k) where nil = Map.empty+#if MIN_VERSION_containers(0,5,9)+ alignWith f = Map.merge (Map.mapMissing (\_ x -> f (This x)))+ (Map.mapMissing (\_ y -> f (That y)))+ (Map.zipWithMatched (\_ x y -> f (These x y)))+#elif MIN_VERSION_containers(0,5,0)+ alignWith f = Map.mergeWithKey (\_ x y -> Just $ f $ These x y) (fmap (f . This)) (fmap (f . That))+#else align m n = Map.unionWith merge (Map.map This m) (Map.map That n) where merge (This a) (That b) = These a b merge _ _ = oops "Align Map: merge"+#endif instance Align IntMap where nil = IntMap.empty+#if MIN_VERSION_containers(0,5,9)+ alignWith f = IntMap.merge (IntMap.mapMissing (\_ x -> f (This x)))+ (IntMap.mapMissing (\_ y -> f (That y)))+ (IntMap.zipWithMatched (\_ x y -> f (These x y)))+#elif MIN_VERSION_containers(0,5,0)+ alignWith f = IntMap.mergeWithKey (\_ x y -> Just $ f $ These x y) (fmap (f . This)) (fmap (f . That))+#else align m n = IntMap.unionWith merge (IntMap.map This m) (IntMap.map That n) where merge (This a) (That b) = These a b merge _ _ = oops "Align IntMap: merge"+#endif instance (Align f, Align g) => Align (Product f g) where nil = Pair nil nil@@ -243,6 +280,8 @@ malign = alignWith (mergeThese mappend) -- | Align two structures and combine with '<>'.+--+-- @since 0.7.3 salign :: (Align f, Semigroup a) => f a -> f a -> f a salign = alignWith (mergeThese (<>)) @@ -369,12 +408,14 @@ instance Crosswalk V.Vector where crosswalk = crosswalkVector +-- | @since 0.7.5 instance Crosswalk ((,) a) where crosswalk fun (a, x) = fmap ((,) a) (fun x) -- can't (shouldn't) do longer tuples until there are Functor and Foldable -- instances for them +-- | @since 0.7.5 instance (Crosswalk f, Crosswalk g) => Crosswalk (Compose f g) where crosswalk f = id . fmap Compose -- can't coerce: maybe the Align-able thing has role nominal
+ Data/Align/Indexed.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+-----------------------------------------------------------------------------+-- | Module : Data.Align.Indexed+--+-- 'These'-based zipping and unzipping of indexed functors.+--+-- @since 0.7.6+module Data.Align.Indexed (+ AlignWithIndex (..),+ ) where++import Control.Lens (FunctorWithIndex)+import Data.Vector.Instances ()++import Data.Align+import Data.These++-- Instances+import Control.Applicative (ZipList)+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Sequence (Seq)+import Data.Vector (Vector)++import qualified Data.Align.Key as Key++-- | Keyed version of 'Align'.+--+-- @since 0.7.6+class (FunctorWithIndex i f, Align f) => AlignWithIndex i f | f -> i where+ -- | Analogous to @'alignWith'@, but also provides an index.+ ialign :: (i -> These a b -> c) -> f a -> f b -> f c++instance AlignWithIndex () Maybe where ialign = Key.alignWithKey+instance AlignWithIndex Int [] where ialign = Key.alignWithKey+instance AlignWithIndex Int ZipList where ialign = Key.alignWithKey+instance AlignWithIndex Int Seq where ialign = Key.alignWithKey+instance AlignWithIndex Int IntMap where ialign = Key.alignWithKey+instance Ord k => AlignWithIndex k (Map k) where ialign = Key.alignWithKey+instance (Eq k, Hashable k) => AlignWithIndex k (HashMap k) where ialign = Key.alignWithKey+instance AlignWithIndex Int Vector where ialign = Key.alignWithKey
Data/Align/Key.hs view
@@ -1,27 +1,31 @@ -------------------------------------------------------------------------------- | Module : Data.Aligned.Key+-- | Module : Data.Align.Key -- -- 'These'-based zipping and unzipping of indexed functors.+--+-- @since 0.7.1 module Data.Align.Key (- AlignWithKey (..)+ AlignWithKey (..), ) where -import Data.Key (Key, Keyed (..))+import Data.Key (Key, Keyed (..)) import Data.Vector.Instances () import Data.Align import Data.These -- Instances---import Control.Applicative (ZipList)-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import Data.IntMap (IntMap)-import Data.Map (Map)-import Data.Sequence (Seq)-import Data.Vector (Vector)+import Control.Applicative (ZipList)+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Sequence (Seq)+import Data.Vector (Vector) -- | Keyed version of 'Align'.+--+-- @since 0.7.1 class (Keyed f, Align f) => AlignWithKey f where -- | Analogous to @'alignWith'@, but also provides an index. alignWithKey :: (Key f -> These a b -> c) -> f a -> f b -> f c@@ -29,7 +33,9 @@ instance AlignWithKey Maybe instance AlignWithKey []---instance AlignWithKey ZipList++-- | @since 0.7.6+instance AlignWithKey ZipList instance AlignWithKey Seq instance AlignWithKey IntMap instance Ord k => AlignWithKey (Map k)
+ Data/Functor/These.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++#if MIN_VERSION_base(4,9,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers(0,5,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)+#define LIFTED_FUNCTOR_CLASSES 1+#endif+#endif+#endif++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+module Data.Functor.These (+ These1 (..),+ ) where++import Prelude ()+import Prelude.Compat++import Data.Aeson+ (FromJSON (..), FromJSON1 (..), ToJSON (..), ToJSON1 (..), (.=))+import Data.Data (Data)+import Data.Functor.Classes+ (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..), compare1, eq1, readsPrec1,+ showsPrec1)+import Data.Typeable (Typeable)+import GHC.Generics (Generic, Generic1)+import Test.QuickCheck+ (Arbitrary (..), Arbitrary1 (..), arbitrary1, liftShrink2, oneof,+ shrink1)++#if MIN_VERSION_deepseq(1,4,3)+import Control.DeepSeq (NFData (..), NFData1 (..), rnf1)+#endif++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Aeson (pair)+import qualified Data.HashMap.Strict as HM++data These1 f g a+ = This1 (f a)+ | That1 (g a)+ | These1 (f a) (g a)+ deriving (Functor, Foldable, Traversable, Generic+#if __GLASGOW_HASKELL__ >= 706+ , Generic1+#endif+#if __GLASGOW_HASKELL__ >= 708+ , Typeable, Data+#endif+ )++-------------------------------------------------------------------------------+-- Eq1+-------------------------------------------------------------------------------++instance (Eq1 f, Eq1 g) => Eq1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftEq eq (This1 f) (This1 f') = liftEq eq f f'+ liftEq eq (That1 g) (That1 g') = liftEq eq g g'+ liftEq eq (These1 f g) (These1 f' g') = liftEq eq f f' && liftEq eq g g'++ liftEq _ This1 {} _ = False+ liftEq _ That1 {} _ = False+ liftEq _ These1 {} _ = False+#else+ eq1 (This1 f) (This1 f') = eq1 f f'+ eq1 (That1 g) (That1 g') = eq1 g g'+ eq1 (These1 f g) (These1 f' g') = eq1 f f' && eq1 g g'++ eq1 This1 {} _ = False+ eq1 That1 {} _ = False+ eq1 These1 {} _ = False+#endif++-------------------------------------------------------------------------------+-- Ord1+-------------------------------------------------------------------------------++instance (Ord1 f, Ord1 g) => Ord1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftCompare cmp (This1 f) (This1 f') = liftCompare cmp f f'+ liftCompare _cmp (This1 _) _ = LT+ liftCompare _cmp _ (This1 _) = GT++ liftCompare cmp (That1 g) (That1 g') = liftCompare cmp g g'+ liftCompare _cmp (That1 _) _ = LT+ liftCompare _cmp _ (That1 _) = GT++ liftCompare cmp (These1 f g) (These1 f' g') =+ liftCompare cmp f f' `mappend` liftCompare cmp g g'+#else+ compare1 (This1 f) (This1 f') = compare1 f f'+ compare1 (This1 _) _ = LT+ compare1 _ (This1 _) = GT++ compare1 (That1 g) (That1 g') = compare1 g g'+ compare1 (That1 _) _ = LT+ compare1 _ (That1 _) = GT++ compare1 (These1 f g) (These1 f' g') =+ compare1 f f' `mappend` compare1 g g'+#endif+++-------------------------------------------------------------------------------+-- Show1+-------------------------------------------------------------------------------++instance (Show1 f, Show1 g) => Show1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftShowsPrec sp sl d (This1 f) = showParen (d > 10)+ $ showString "This1 "+ . liftShowsPrec sp sl 11 f+ liftShowsPrec sp sl d (That1 g) = showParen (d > 10)+ $ showString "That1 "+ . liftShowsPrec sp sl 11 g+ liftShowsPrec sp sl d (These1 f g) = showParen (d > 10)+ $ showString "These1 "+ . liftShowsPrec sp sl 11 f+ . showChar ' '+ . liftShowsPrec sp sl 11 g+#else+ showsPrec1 d (This1 f) = showParen (d > 10)+ $ showString "This1 "+ . showsPrec1 11 f+ showsPrec1 d (That1 g) = showParen (d > 10)+ $ showString "That1 "+ . showsPrec1 11 g+ showsPrec1 d (These1 f g) = showParen (d > 10)+ $ showString "These1 "+ . showsPrec1 11 f+ . showChar ' '+ . showsPrec1 11 g+#endif++-------------------------------------------------------------------------------+-- Read1+-------------------------------------------------------------------------------++instance (Read1 f, Read1 g) => Read1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftReadsPrec rp rl d = readParen (d > 10) $ \s0 -> do+ (t, s1) <- lex s0+ case t of+ "This1" -> do+ (x, s2) <- liftReadsPrec rp rl 11 s1+ return (This1 x, s2)+ "That1" -> do+ (y, s2) <- liftReadsPrec rp rl 11 s1+ return (That1 y, s2)+ "These1" -> do+ (x, s2) <- liftReadsPrec rp rl 11 s1+ (y, s3) <- liftReadsPrec rp rl 11 s2+ return (These1 x y, s3)+ _ -> []+#else+ readsPrec1 d = readParen (d > 10) $ \s0 -> do+ (t, s1) <- lex s0+ case t of+ "This1" -> do+ (x, s2) <- readsPrec1 11 s1+ return (This1 x, s2)+ "That1" -> do+ (y, s2) <- readsPrec1 11 s1+ return (That1 y, s2)+ "These1" -> do+ (x, s2) <- readsPrec1 11 s1+ (y, s3) <- readsPrec1 11 s2+ return (These1 x y, s3)+ _ -> []+#endif++-------------------------------------------------------------------------------+-- Eq, Ord, Show, Read+-------------------------------------------------------------------------------++instance (Eq1 f, Eq1 g, Eq a) => Eq (These1 f g a) where (==) = eq1+instance (Ord1 f, Ord1 g, Ord a) => Ord (These1 f g a) where compare = compare1+instance (Show1 f, Show1 g, Show a) => Show (These1 f g a) where showsPrec = showsPrec1+instance (Read1 f, Read1 g, Read a) => Read (These1 f g a) where readsPrec = readsPrec1++-------------------------------------------------------------------------------+-- deepseq+-------------------------------------------------------------------------------++#if MIN_VERSION_deepseq(1,4,3)+-- | This instance is available only with @deepseq >= 1.4.3.0@+instance (NFData1 f, NFData1 g) => NFData1 (These1 f g) where+ liftRnf r (This1 x) = liftRnf r x+ liftRnf r (That1 y) = liftRnf r y+ liftRnf r (These1 x y) = liftRnf r x `seq` liftRnf r y++-- | This instance is available only with @deepseq >= 1.4.3.0@+instance (NFData1 f, NFData1 g, NFData a) => NFData (These1 f g a) where+ rnf = rnf1+#endif++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where+ liftToJSON tx tl (This1 a) = Aeson.object [ "This" .= liftToJSON tx tl a ]+ liftToJSON tx tl (That1 b) = Aeson.object [ "That" .= liftToJSON tx tl b ]+ liftToJSON tx tl (These1 a b) = Aeson.object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ]++ liftToEncoding tx tl (This1 a) = Aeson.pairs $ Aeson.pair "This" (liftToEncoding tx tl a)+ liftToEncoding tx tl (That1 b) = Aeson.pairs $ Aeson.pair "That" (liftToEncoding tx tl b)+ liftToEncoding tx tl (These1 a b) = Aeson.pairs $+ Aeson.pair "This" (liftToEncoding tx tl a) `mappend`+ Aeson.pair "That" (liftToEncoding tx tl b)++instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where+ liftParseJSON px pl = Aeson.withObject "These1" (p . HM.toList)+ where+ p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b+ p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b+ p [("This", a)] = This1 <$> liftParseJSON px pl a+ p [("That", b)] = That1 <$> liftParseJSON px pl b+ p _ = fail "Expected object with 'This' and 'That' keys only"++instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where+ toJSON = Aeson.toJSON1+ toEncoding = Aeson.toEncoding1++instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where+ parseJSON = Aeson.parseJSON1++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (These1 f g) where+ liftArbitrary arb = oneof+ [ This1 <$> liftArbitrary arb+ , That1 <$> liftArbitrary arb+ , These1 <$> liftArbitrary arb <*> liftArbitrary arb+ ]++ liftShrink shr (This1 x) = This1 <$> liftShrink shr x+ liftShrink shr (That1 y) = That1 <$> liftShrink shr y+ liftShrink shr (These1 x y) =+ [ This1 x, That1 y ] +++ [ These1 x' y'+ | (x', y') <- liftShrink2 (liftShrink shr) (liftShrink shr) (x, y)+ ]++instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (These1 f g a) where+ arbitrary = arbitrary1+ shrink = shrink1
Data/These.hs view
@@ -1,93 +1,102 @@ ----------------------------------------------------------------------------- -- | Module : Data.These ----- The 'These' type and associated operations. Now enhanced with @Control.Lens@ magic!-{-# LANGUAGE CPP #-}+-- The 'These' type and associated operations. Now enhanced with "Control.Lens" magic! {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} module Data.These (- These(..)+ These(..) - -- * Functions to get rid of 'These'- , these- , fromThese- , mergeThese- , mergeTheseWith+ -- * Functions to get rid of 'These'+ , these+ , fromThese+ , mergeThese+ , mergeTheseWith - -- * Traversals- , here, there+ -- * Traversals+ , here, there - -- * Prisms- , _This, _That, _These+ -- * Half selections+ , justHere+ , justThere - -- * Case selections- , justThis- , justThat- , justThese+ -- * Prisms+ , _This, _That, _These - , catThis- , catThat- , catThese+ -- * Case selections+ , justThis+ , justThat+ , justThese - , partitionThese+ , catThis+ , catThat+ , catThese - -- * Case predicates- , isThis- , isThat- , isThese+ , partitionThese - -- * Map operations- , mapThese- , mapThis- , mapThat+ -- * Case predicates+ , isThis+ , isThat+ , isThese - , bitraverseThese+ -- * Map operations+ , mapThese+ , mapThis+ , mapThat - -- $align- ) where+ , bitraverseThese -import Control.Applicative-import Control.Monad-import Data.Bifoldable-import Data.Bifunctor-import Data.Bitraversable-import Data.Foldable-import Data.Functor.Bind-import Data.Hashable (Hashable(..))-import Data.Maybe (isJust, mapMaybe)-import Data.Profunctor-import Data.Semigroup-import Data.Semigroup.Bifoldable-import Data.Semigroup.Bitraversable-import Data.Traversable-import Data.Data-import GHC.Generics-import Prelude hiding (foldr)+ -- * Associativity and commutativity+ , swap+ , assoc+ , reassoc+ ) where -import Control.DeepSeq (NFData (..))-import Data.Aeson (FromJSON (..), ToJSON (..), (.=))-import Data.Binary (Binary (..))-import Test.QuickCheck (Arbitrary (..), Arbitrary1 (..), Arbitrary2 (..), CoArbitrary (..), oneof, arbitrary1, shrink1)-import Test.QuickCheck.Function (Function (..), functionMap)+import Prelude ()+import Prelude.Compat -import qualified Data.HashMap.Strict as HM-import qualified Data.Aeson as Aeson-#if MIN_VERSION_aeson(1,0,0)+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)-#endif+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+-- @'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) @@ -111,50 +120,102 @@ mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c mergeTheseWith f g op t = mergeThese op $ mapThese f g t ---- | A @Traversal@ of the first half of a 'These', suitable for use with @Control.Lens@.+-- | 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 @Traversal@ of the second half of a 'These', suitable for use with @Control.Lens@.+-- | 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 --- <cmccann> is there a recipe for creating suitable definitions anywhere?--- <edwardk> not yet--- <edwardk> prism bt seta = dimap seta (either pure (fmap bt)) . right'--- (let's all pretend I know how this works ok)-prism :: (Choice p, Applicative f) => (b -> t) -> (s -> Either t a) -> p a (f b) -> p s (f t)-prism bt seta = dimap seta (either pure (fmap bt)) . right'+-- | @'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 --- | A 'Prism' selecting the 'This' constructor.-_This :: (Choice p, Applicative f) => p a (f a) -> p (These a b) (f (These a b))+-- | @'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 'Prism' selecting the 'That' constructor.-_That :: (Choice p, Applicative f) => p b (f b) -> p (These a b) (f (These a b))+-- | 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 'Prism' selecting the 'These' constructor. 'These' names are ridiculous!-_These :: (Choice p, Applicative f) => p (a, b) (f (a, b)) -> p (These a b) (f (These a b))+-- | 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' = preview '_This'@+-- | @'justThis' = 'Control.Lens.preview' '_This'@ justThis :: These a b -> Maybe a justThis (This a) = Just a justThis _ = Nothing --- | @'justThat' = preview '_That'@+-- | @'justThat' = 'Control.Lens.preview' '_That'@ justThat :: These a b -> Maybe b justThat (That x) = Just x justThat _ = Nothing --- | @'justThese' = preview '_These'@+-- | @'justThese' = 'Control.Lens.preview' '_These'@ justThese :: These a b -> Maybe (a, b) justThese (These a x) = Just (a, x) justThese _ = Nothing@@ -177,16 +238,18 @@ 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' = over 'here'@+-- | @'mapThis' = 'Control.Lens.over' 'here'@ mapThis :: (a -> c) -> These a b -> These c b mapThis f = mapThese f id --- | @'mapThat' = over 'there'@+-- | @'mapThat' = 'Control.Lens.over' 'there'@ mapThat :: (b -> d) -> These a b -> These a d mapThat f = mapThese id f @@ -209,12 +272,51 @@ 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 --- $align+-- | 'These' is associative. ----- For zipping and unzipping of structures with 'These' values, see--- "Data.Align".+-- @+-- '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@@ -265,6 +367,10 @@ 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@@ -292,11 +398,13 @@ 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@@ -310,17 +418,17 @@ 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 ] -#if MIN_VERSION_aeson(0,10,0) toEncoding (This a) = Aeson.pairs $ "This" .= a toEncoding (That b) = Aeson.pairs $ "That" .= b toEncoding (These a b) = Aeson.pairs $ "This" .= a <> "That" .= b-#endif +-- | @since 0.7.1 instance (FromJSON a, FromJSON b) => FromJSON (These a b) where parseJSON = Aeson.withObject "These a b" (p . HM.toList) where@@ -330,7 +438,7 @@ p [("That", b)] = That <$> parseJSON b p _ = fail "Expected object with 'This' and 'That' keys only" -#if MIN_VERSION_aeson(1,0,0)+-- | @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 ]@@ -340,6 +448,7 @@ 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 ]@@ -349,6 +458,7 @@ 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@@ -358,6 +468,7 @@ 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@@ -366,8 +477,8 @@ p [("This", a)] = This <$> parseJSON a p [("That", b)] = That <$> pb b p _ = fail "Expected object with 'This' and 'That' keys only"-#endif +-- | @since 0.7.4 instance Arbitrary2 These where liftArbitrary2 arbA arbB = oneof [ This <$> arbA@@ -380,14 +491,17 @@ 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@@ -399,4 +513,5 @@ 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)
test/Tests.hs view
@@ -1,40 +1,52 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections #-} module Main (main) where -import Control.Applicative-import Control.Monad (join)+import Prelude ()+import Prelude.Compat++import Control.Applicative (ZipList (..))+import Control.Lens (folded, toListOf)+import Control.Monad (join)+import Data.Bifunctor (bimap)+import Data.Foldable (toList)+import Data.Functor.Compose (Compose (..))+import Data.Functor.Identity (Identity (..))+import Data.HashMap.Strict (HashMap)+import Data.IntMap (IntMap)+import Data.List (nub)+import Data.Map (Map)+import Data.Maybe (mapMaybe)+import Data.Semigroup (Semigroup (..))+import Data.Sequence (Seq)+import Data.Traversable (fmapDefault, foldMapDefault)+import Test.QuickCheck+ (Arbitrary (..), CoArbitrary (..), Property, elements, once, (.&&.),+ (===))+import Test.QuickCheck.Function (Fun (..))+import Test.QuickCheck.Instances ()+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.Aeson as Aeson+import qualified Data.Binary as Binary+import qualified Data.Functor.Product as P+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Vector as V+import qualified Test.Tasty.QuickCheck as QC+ import Data.Align+import Data.Align.Indexed import Data.Align.Key-import Data.Foldable-import Data.Bifunctor-import Data.Functor.Compose-import Data.Functor.Identity-import qualified Data.Functor.Product as P-import Data.HashMap.Strict (HashMap)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.List as L-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Sequence (Seq)-import Data.Monoid import Data.These-import Data.Int (Int8)-import Data.Traversable-import qualified Data.Vector as V-import Prelude -- Fix redundant import warnings-import Test.QuickCheck.Function-import Test.QuickCheck.Instances ()-import Test.Tasty-import Test.Tasty.QuickCheck as QC -import qualified Data.Aeson as Aeson-import qualified Data.Binary as Binary- -- For old GHC to work data Proxy (a :: * -> *) = Proxy @@ -42,61 +54,90 @@ main = defaultMain tests tests :: TestTree-tests = testGroup "Tests" [theseProps, alignWithKeyProps]+tests = testGroup "Tests"+ [ theseProps+ , alignProps+ , alignWithKeyProps+ , crosswalkProps+ , testGroup "Semigroup"+ [ semigroupLaws "These" (These "x" "y")+ , semigroupLaws "SearchResult" (ScannedAndFound "x" "y")+ , monoidLaws "List" "x" -- to disallow+ ]+ ] theseProps :: TestTree theseProps = testGroup "These"- [ functorProps- , traversableProps- , dataAlignLaws "[]" (Proxy :: Proxy [])- , dataAlignLaws "HashMap String" (Proxy :: Proxy (HashMap String))- , dataAlignLaws "IntMap" (Proxy :: Proxy IntMap)- , dataAlignLaws "Map Char" (Proxy :: Proxy (Map Char))- , dataAlignLaws "Maybe" (Proxy :: Proxy Maybe)- , dataAlignLaws "Product [] Maybe" (Proxy :: Proxy (P.Product [] Maybe))- , dataAlignLaws "Seq" (Proxy :: Proxy Seq)- , dataAlignLaws "Vector" (Proxy :: Proxy V.Vector)- , dataAlignLaws "ZipList" (Proxy :: Proxy ZipList)- , crosswalkLaws "[]" (Proxy :: Proxy [])- -- , crosswalkLaws "Identity" (Proxy :: Proxy Identity)- , crosswalkLaws "Maybe" (Proxy :: Proxy Maybe)- , crosswalkLaws "These" (Proxy :: Proxy (These Int))- , crosswalkLaws "Seq" (Proxy :: Proxy Seq)- , crosswalkLaws "Vector" (Proxy :: Proxy V.Vector)- , crosswalkLaws "(,) Int" (Proxy :: Proxy ((,) Int))- , crosswalkLaws "Compose [] []" (Proxy :: Proxy (Compose [] []))- , testProperty "Map value laziness property" mapStrictnessProp- , testProperty "IntMap value laziness property" intmapStrictnessProp- , aesonProps- , binaryProps- ]+ [ functorProps+ , traversableProps+ , testProperty "Map value laziness property" mapStrictnessProp+ , testProperty "IntMap value laziness property" intmapStrictnessProp+ , aesonProps+ , binaryProps+ ] +crosswalkProps :: TestTree+crosswalkProps = testGroup "Crosswalk"+ [ crosswalkLaws "[]" (Proxy :: Proxy [])+ -- , crosswalkLaws "Identity" (Proxy :: Proxy Identity)+ , crosswalkLaws "Maybe" (Proxy :: Proxy Maybe)+ , crosswalkLaws "These" (Proxy :: Proxy (These Int))+ , crosswalkLaws "Seq" (Proxy :: Proxy Seq)+ , crosswalkLaws "Vector" (Proxy :: Proxy V.Vector)+ , crosswalkLaws "(,) Int" (Proxy :: Proxy ((,) Int))+ , crosswalkLaws "Compose [] []" (Proxy :: Proxy (Compose [] []))+ ]++alignProps :: TestTree+alignProps = testGroup "Align"+ [ dataAlignLaws "[]" (Proxy :: Proxy [])+ , dataAlignLaws "HashMap String" (Proxy :: Proxy (HashMap String))+ , dataAlignLaws "IntMap" (Proxy :: Proxy IntMap)+ , dataAlignLaws "Map Char" (Proxy :: Proxy (Map Char))+ , dataAlignLaws "Maybe" (Proxy :: Proxy Maybe)+ , dataAlignLaws "Product [] Maybe" (Proxy :: Proxy (P.Product [] Maybe))+ , dataAlignLaws "Seq" (Proxy :: Proxy Seq)+ , dataAlignLaws "Vector" (Proxy :: Proxy V.Vector)+ , dataAlignLaws "ZipList" (Proxy :: Proxy ZipList)+ -- , dataAlignLaws "WrongMap" (Proxy :: Proxy (WrongMap Char))+ -- weird objects:+ -- , dataAlignLaws "Const String" (Proxy :: Proxy (Const String))+ , dataAlignLaws "R" (Proxy :: Proxy R)+ -- , dataAlignLaws "Weirdmap" (Proxy :: Proxy (WeirdMap Char))+ ]+ alignWithKeyProps :: TestTree-alignWithKeyProps = testGroup "AlignWithKey"- [ testProperty "example" $ once $ example+alignWithKeyProps = testGroup "AlignWithKey / AlignWithIndex"+ [ testProperty "example" $ once $ exampleK+ , testProperty "example" $ once $ exampleI ] where- example = alignWithKey (,) "foo" "quux" ===+ exampleK = alignWithKey (,) "foo" "quux" === exampleV+ exampleI = ialign (,) "foo" "quux" === exampleV++ exampleV = [ (0, These 'f' 'q') , (1, These 'o' 'u') , (2, These 'o' 'u') , (3, That 'x') ] --- Even the `align` is defined using strict combinators, this will still work:+-- Even the `align` is/was defined using strict combinators, this will still work: mapStrictnessProp :: [Int] -> [Int] -> Bool-mapStrictnessProp lkeys rkeys = Prelude.length (nub lkeys) <= Map.size (lhs `align` rhs)+mapStrictnessProp lkeys rkeys = length (nub lkeys) <= Map.size (lhs `align` rhs) where lhs = Map.fromList $ fmap (,loop) lkeys rhs = Map.fromList $ fmap (,loop) rkeys+ loop :: Int- loop = loop+ loop = error "break" intmapStrictnessProp :: [Int] -> [Int] -> Bool-intmapStrictnessProp lkeys rkeys = Prelude.length (nub lkeys) <= IntMap.size (lhs `align` rhs)+intmapStrictnessProp lkeys rkeys = length (nub lkeys) <= IntMap.size (lhs `align` rhs) where lhs = IntMap.fromList $ fmap (,loop) lkeys rhs = IntMap.fromList $ fmap (,loop) rkeys+ loop :: Int- loop = loop+ loop = error "break" functorIdentityProp :: (Functor f, Eq (f a), Show (f a)) => f a -> Property functorIdentityProp x = fmap id x === x@@ -131,6 +172,10 @@ , QC.testProperty "foldable" (traversableFoldableProp :: These Bool Int -> (Fun Int [Bool]) -> Property) ] +-------------------------------------------------------------------------------+-- Align laws+-------------------------------------------------------------------------------+ -- Data.Align -- (\`align` nil) = fmap This@@ -138,10 +183,13 @@ -- join align = fmap (join These) -- align (f \<$> x) (g \<$> y) = bimap f g \<$> align x y -- alignWith f a b = f \<$> align a b--dataAlignLaws :: forall (f :: * -> *). ( Align f+--+-- We also require a sixth property, when f is Foldable.+dataAlignLaws :: forall (f :: * -> *). ( Align f, Foldable f , Eq (f (These Int Int)) , Show (f (These Int Int))+ , Eq (f (These (These Int Int) Int))+ , Show (f (These (These Int Int) Int)) , CoArbitrary (These Int Int) , Arbitrary (f Int) , Eq (f Int)@@ -150,25 +198,124 @@ -> Proxy f -> TestTree dataAlignLaws name _ = testGroup ("Data.Align laws: " <> name)- [ QC.testProperty "right identity" rightIdentityProp- , QC.testProperty "left identity" leftIdentityProp- , QC.testProperty "join" joinProp- , QC.testProperty "bimap" bimapProp- , QC.testProperty "alignWith" alignWithProp- ]- where rightIdentityProp :: f Int -> Property- rightIdentityProp xs = (xs `align` (nil :: f Int)) === fmap This xs- leftIdentityProp :: f Int -> Property- leftIdentityProp xs = ((nil :: f Int) `align` xs) === fmap That xs- joinProp :: f Int -> Property- joinProp xs = join align xs === fmap (join These) xs- bimapProp :: f Int -> f Int -> Fun Int Int -> Fun Int Int -> Property- bimapProp xs ys (Fun _ f) (Fun _ g) =- align (f <$> xs) (g <$> ys) === (bimap f g <$> align xs ys)- alignWithProp :: f Int -> f Int -> Fun (These Int Int) Int -> Property- alignWithProp xs ys (Fun _ f) =- alignWith f xs ys === (f <$> align xs ys)+ [ QC.testProperty "right identity" rightIdentityProp+ , QC.testProperty "left identity" leftIdentityProp+ , QC.testProperty "join" joinProp+ , QC.testProperty "bimap" bimapProp+ , QC.testProperty "alignWith" alignWithProp+ , QC.testProperty "assoc" assocProp+ , QC.testProperty "alignToList" alignToListProp+ ]+ where+ rightIdentityProp :: f Int -> Property+ rightIdentityProp xs = (xs `align` (nil :: f Int)) === fmap This xs + leftIdentityProp :: f Int -> Property+ leftIdentityProp xs = ((nil :: f Int) `align` xs) === fmap That xs++ joinProp :: f Int -> Property+ joinProp xs = join align xs === fmap (join These) xs++ bimapProp :: f Int -> f Int -> Fun Int Int -> Fun Int Int -> Property+ bimapProp xs ys (Fun _ f) (Fun _ g) =+ align (f <$> xs) (g <$> ys) === (bimap f g <$> align xs ys)++ alignWithProp :: f Int -> f Int -> Fun (These Int Int) Int -> Property+ alignWithProp xs ys (Fun _ f) =+ alignWith f xs ys === (f <$> align xs ys)++ assocProp :: f Int -> f Int -> f Int -> Property+ assocProp xs ys zs = rhs === lhs+ where+ rhs = (xs `align` ys) `align` zs+ lhs = fmap assoc $ xs `align` (ys `align` zs)++ alignToListProp :: f Int -> f Int -> Property+ alignToListProp xs ys =+ toList xs === toListOf (folded . here) xys+ .&&.+ toList xs === mapMaybe justHere (toList xys)+ .&&.+ toList ys === toListOf (folded . there) xys+ where+ xys = align xs ys++---------------------------------------------------------------------------+-- WrongMap doesn't satisfy Align laws+-------------------------------------------------------------------------------++newtype WrongMap k v = WM (Map k v) deriving (Eq, Ord, Show, Functor, Foldable)++instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (WrongMap k v) where+ arbitrary = WM <$> arbitrary+ shrink (WM m) = WM <$> shrink m++instance Ord k => Align (WrongMap k) where+ nil = WM Map.empty+ align (WM x) (WM y)+ | Map.null y = WM $ This <$> x+ | Map.null x = WM $ That <$> y+ | otherwise = WM $ Map.intersectionWith These x y++-------------------------------------------------------------------------------+-- WeirdMap+-------------------------------------------------------------------------------++-- | Sequence-like __invalid__ 'Align' instance for Map.+--+-- Satisfies first five laws;+-- Doesn't satisfy /assoc/ or /toList/ laws.+--+newtype WeirdMap k v = WeirdMap (Map k v)+ deriving (Eq, Ord, Show, Functor, Foldable)++instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (WeirdMap k v) where+ arbitrary = WeirdMap <$> arbitrary+ shrink (WeirdMap m) = WeirdMap <$> shrink m++instance Ord k => Align (WeirdMap k) where+ nil = WeirdMap Map.empty++ alignWith f (WeirdMap x) (WeirdMap y) = WeirdMap $ Map.fromList $+ alignWith g (Map.toList x) (Map.toList y)+ where+ g (This (k, a)) = (k, f (This a))+ g (That (k, a)) = (k, f (That a))+ g (These (k, a) (_, b)) = (k, f (These a b))++-------------------------------------------------------------------------------+-- Const is invalid Align with Monoid, we need Idemporent monoid!+-------------------------------------------------------------------------------++{-+instance Monoid a => Align (Const a) where+ nil = Const mempty+ align (Const a) (Const b) = Const (mappend a b)+-}++-------------------------------------------------------------------------------+-- R does satisfy Align laws, though is weird+-- https://github.com/isomorphism/these/issues/96+-------------------------------------------------------------------------------++newtype R a = Nest [[a]]+ deriving (Show, Eq, Ord, Functor, Foldable)++instance Align R where+ nil = Nest []++ align (Nest ass) (Nest bss)+ | null ass = That <$> Nest bss+ | null bss = This <$> Nest ass+ | shape ass == shape bss = Nest $ zipWith (zipWith These) ass bss+ | otherwise = Nest [align (concat ass) (concat bss)]+ where+ shape = fmap (() <$)++instance Arbitrary a => Arbitrary (R a) where+ arbitrary = Nest <$> arbitrary+ shrink (Nest xss) = Nest <$> shrink xss+ data Index = I1 | I2 | I3 | I4 deriving (Eq, Ord, Show, Enum, Bounded) @@ -179,6 +326,10 @@ shrink I3 = [I1, I2] shrink I4 = [I1, I2, I3] +-------------------------------------------------------------------------------+-- Crosswalk laws+-------------------------------------------------------------------------------+ crosswalkLaws :: forall (t :: * -> *). ( Crosswalk t@@ -232,3 +383,64 @@ where prop :: These Int String -> Property prop x = x === Binary.decode (Binary.encode x)++-------------------------------------------------------------------------------+-- SearchResult+-------------------------------------------------------------------------------++semigroupLaws+ :: forall a. (Semigroup a, Show a, Eq a, Arbitrary a)+ => String -> a -> TestTree+semigroupLaws name _ = testGroup ("Semigroup: " ++ name)+ [ QC.testProperty "associativity" assocProp+ ]+ where+ assocProp :: a -> a -> a -> Property+ assocProp x y z = (x <> y) <> z === x <> (y <> z)++monoidLaws+ :: forall a. (Monoid a, Show a, Eq a, Arbitrary a)+ => String -> a -> TestTree+monoidLaws name _ = testGroup ("Monoid: " ++ name)+ [ QC.testProperty "associativity" assocProp+ , QC.testProperty "left-identity" idLeftProp+ , QC.testProperty "right-identity" idRightProp+ ]+ where+ assocProp :: a -> a -> a -> Property+ assocProp x y z = (x `mappend` y) `mappend` z === x `mappend` (y `mappend` z)++ idLeftProp :: a -> Property+ idLeftProp x = mappend mempty x === x++ idRightProp :: a -> Property+ idRightProp x = mappend x mempty === x++-- | Either a, or b, or both a and b+--+-- See https://github.com/isomorphism/these/issues/80+data SearchResult a b = Scanned a | Found b | ScannedAndFound a b+ deriving (Eq, Ord, Show)++instance (Arbitrary a, Arbitrary b) => Arbitrary (SearchResult a b) where+ arbitrary = srFromThese <$> arbitrary++srFromThese :: These a b -> SearchResult a b+srFromThese (This a) = Scanned a+srFromThese (That b) = Found b+srFromThese (These a b) = ScannedAndFound a b++-- | Accumulate 'a's from left to right, until one 'b' is found+instance Semigroup a => Semigroup (SearchResult a b) where+ ScannedAndFound a b <> _ = ScannedAndFound a b+ Found b <> _ = Found b+ Scanned a <> Scanned a' = Scanned (a <> a')+ Scanned a <> Found b = ScannedAndFound a b+ Scanned a <> ScannedAndFound a' b = ScannedAndFound (a <> a') b++{-+-- almost lawful+instance Monoid a => Monoid (SearchResult a b) where+ mappend = (<>)+ mempty = Scanned mempty+-}
these.cabal view
@@ -1,16 +1,21 @@-Name: these-Version: 0.7.5-Synopsis: An either-or-both data type & a generalized 'zip with padding' typeclass-Homepage: https://github.com/isomorphism/these-License: BSD3-License-file: LICENSE-Author: C. McCann-Maintainer: cam@uptoisomorphism.net-Category: Data,Control-Build-type: Simple-Extra-source-files: README.md, CHANGELOG.md-Cabal-version: >=1.8-Description:+cabal-version: >=1.10+name: these+version: 0.7.6+synopsis:+ An either-or-both data type & a generalized 'zip with padding' typeclass++homepage: https://github.com/isomorphism/these+license: BSD3+license-file: LICENSE+author: C. McCann+maintainer: oleg.grenrus@iki.fi+category: Data,Control+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++description: This package provides a data type @These a b@ which can hold a value of either type or values of each type. This is usually thought of as an "inclusive or" type (contrasting @Either a b@ as "exclusive or") or as an "outer join" type@@ -22,71 +27,92 @@ . Also included is @ChronicleT@, a monad transformer based on the Monad instance for @These a@, along with the usual monad transformer bells and whistles.+ .+ For a dependency light version, check <https://hackage.haskell.org/package/data-or> package.+ tested-with:- GHC==7.4.2,- GHC==7.6.3,- GHC==7.8.4,- GHC==7.10.3,- GHC==8.0.2,- GHC==8.2.2,- GHC==8.4.3,- GHC==8.6.1+ ghc ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3 source-repository head- type: git+ type: git location: https://github.com/isomorphism/these.git -Library- Exposed-modules: Data.These,- Data.Align,- Data.Align.Key,- Control.Monad.Chronicle,- Control.Monad.Chronicle.Class,- Control.Monad.Trans.Chronicle+library+ default-language: Haskell2010+ ghc-options: -Wall+ exposed-modules:+ Control.Monad.Chronicle+ Control.Monad.Chronicle.Class+ Control.Monad.Trans.Chronicle+ Data.Align+ Data.Align.Indexed+ Data.Align.Key+ Data.Functor.These+ Data.These - Build-depends: base >= 4.4 && < 4.13,- aeson >= 0.7.0.4 && < 1.5,- bifunctors >= 0.1 && < 5.6,- binary >= 0.5.0.2 && < 0.10,- containers >= 0.4 && < 0.7,- data-default-class >= 0.0 && < 0.2,- deepseq >= 1.3.0.0 && < 1.5,- hashable >= 1.2.3 && < 1.3,- keys >= 3.10 && < 3.13,- mtl >= 2 && < 2.3,- profunctors >= 3 && < 5.4,- QuickCheck >= 2.10 && < 2.13,- semigroupoids >= 5 && < 5.4,- transformers >= 0.2 && < 0.6,- transformers-compat >= 0.2 && < 0.7,- unordered-containers >= 0.2.4.0 && < 0.3,- vector >= 0.4 && < 0.13,- vector-instances >= 3.3.1 && < 3.5+ -- ghc boot libs+ build-depends:+ base >=4.5.1.0 && <4.13+ , binary >=0.5.1.0 && <0.10+ , containers >=0.4.2.1 && <0.7+ , deepseq >=1.3.0.0 && <1.5+ , mtl >=2.1.3 && <2.3+ , transformers >=0.3.0.0 && <0.6++ -- other dependencies+ build-depends:+ aeson >=1.4.2.0 && <1.5+ , base-compat >=0.10.5 && <0.11+ , bifunctors >=5.5.3 && <5.6+ , data-default-class >=0.1.2.0 && <0.2+ , hashable >=1.2.7.0 && <1.3+ , keys >=3.12.1 && <3.13+ , lens >=4.17 && <4.18+ , QuickCheck >=2.12.6.1 && <2.13+ , semigroupoids >=5.3.1 && <5.4+ , transformers-compat >=0.6.2 && <0.7+ , unordered-containers >=0.2.8.0 && <0.3+ , vector >=0.12.0.2 && <0.13+ , vector-instances >=3.4 && <3.5+ if impl(ghc <7.5)- build-depends: ghc-prim+ build-depends: ghc-prim - if !impl(ghc >= 8.0)- build-depends:- semigroups >= 0.8 && < 0.19+ if !impl(ghc >=8.0)+ build-depends: semigroups >=0.18.5 && <0.19 - ghc-options: -Wall+ -- Ensure Data.Functor.Classes is always available+ if impl(ghc >=7.10)+ build-depends: transformers >=0.4.2.0 test-suite test- type: exitcode-stdio-1.0- main-is: Tests.hs- hs-source-dirs: test- ghc-options: -Wall- build-depends: these,- base >= 4.5,- quickcheck-instances >= 0.3.15 && < 0.4,- tasty >= 0.10 && < 1.2,- tasty-quickcheck >= 0.8 && < 0.11,- aeson,- bifunctors,- binary,- containers,- hashable,- QuickCheck,- transformers,- unordered-containers,- vector+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: test+ ghc-options: -Wall++ -- library constrained dependencies+ build-depends:+ aeson+ , base+ , base-compat+ , bifunctors+ , binary+ , containers+ , hashable+ , lens+ , QuickCheck+ , these+ , transformers+ , unordered-containers+ , vector++ if !impl(ghc >=8.0)+ build-depends: semigroups++ -- additional dependencies+ build-depends:+ quickcheck-instances >=0.3.15 && <0.4+ , tasty >=1.2 && <1.3+ , tasty-quickcheck >=0.10 && <0.11