diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Data/Align.hs b/Data/Align.hs --- a/Data/Align.hs +++ b/Data/Align.hs @@ -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 diff --git a/Data/Align/Indexed.hs b/Data/Align/Indexed.hs new file mode 100644 --- /dev/null +++ b/Data/Align/Indexed.hs @@ -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 diff --git a/Data/Align/Key.hs b/Data/Align/Key.hs --- a/Data/Align/Key.hs +++ b/Data/Align/Key.hs @@ -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) diff --git a/Data/Functor/These.hs b/Data/Functor/These.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/These.hs @@ -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 diff --git a/Data/These.hs b/Data/These.hs --- a/Data/These.hs +++ b/Data/These.hs @@ -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 --- is there a recipe for creating suitable definitions anywhere? --- not yet --- 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) diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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 +-} diff --git a/these.cabal b/these.cabal --- a/these.cabal +++ b/these.cabal @@ -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 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