diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# 0.8.1 + +- Add `Semialign` `Tree`, `Tagged`, `(->) e`; `Align` `Compose` and `Proxy` instances +- Allow `semigroups-0.19` and `hashable-1.3` + # 0.8.0 - Split `align` and `alignWith` into own class: `Semialign`. diff --git a/Data/Align.hs b/Data/Align.hs --- a/Data/Align.hs +++ b/Data/Align.hs @@ -39,13 +39,16 @@ import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) import Data.Semigroup (Semigroup (..)) import Data.Sequence (Seq) +import Data.Tagged (Tagged (..)) 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.Tree as T import qualified Data.Vector as V import qualified Data.Vector.Fusion.Stream.Monadic as Stream import qualified Data.Vector.Generic as VG (foldr, fromList) @@ -161,6 +164,11 @@ -- Instances ------------------------------------------------------------------------------- +-- | @since 0.8.1 +instance Semialign ((->) e) where + align f g x = These (f x) (g x) + alignWith h f g x = h (These (f x) (g x)) + instance Align Maybe where nil = Nothing @@ -214,6 +222,10 @@ yn = Seq.length ys fc x y = f (These x y) +-- | @since 0.8.1 +instance Semialign T.Tree where + align (T.Node x xs) (T.Node y ys) = T.Node (These x y) (alignWith (these (fmap This) (fmap That) align) xs ys) + instance (Ord k) => Align (Map k) where nil = Map.empty @@ -257,6 +269,14 @@ align (Pair a b) (Pair c d) = Pair (align a c) (align b d) alignWith f (Pair a b) (Pair c d) = Pair (alignWith f a c) (alignWith f b d) +-- | @since 0.8.1 +instance (Align f, Semialign g) => Align (Compose f g) where + nil = Compose nil + +-- | @since 0.8.1 +instance (Semialign f, Semialign g) => Semialign (Compose f g) where + align (Compose x) (Compose y) = Compose (alignWith (these (fmap This) (fmap That) align) x y) + -- Based on the Data.Vector.Fusion.Stream.Monadic zipWith implementation instance Monad m => Align (Stream m) where nil = Stream.empty @@ -314,6 +334,19 @@ align m n = HashMap.unionWith merge (HashMap.map This m) (HashMap.map That n) where merge (This a) (That b) = These a b merge _ _ = oops "Align HashMap: merge" + +-- | @since 0.8.1 +instance Semialign (Tagged b) where + alignWith f (Tagged x) (Tagged y) = Tagged (f (These x y)) + +-- | @since 0.8.1 +instance Semialign Proxy where + alignWith _ _ _ = Proxy + align _ _ = Proxy + +-- | @since 0.8.1 +instance Align Proxy where + nil = Proxy -- | Align two structures and combine with 'mappend'. -- diff --git a/Data/These/Combinators.hs b/Data/These/Combinators.hs --- a/Data/These/Combinators.hs +++ b/Data/These/Combinators.hs @@ -96,7 +96,7 @@ bimapThese :: (a -> c) -> (b -> d) -> These a b -> These c d bimapThese = bimap --- | @'mapThis' = 'Control.Lens.over' 'here'@ +-- | @'mapHere' = 'Control.Lens.over' 'here'@ mapHere :: (a -> c) -> These a b -> These c b mapHere = first @@ -133,7 +133,7 @@ assocThese :: These (These a b) c -> These a (These b c) assocThese = assoc --- | 'These is associative. See 'assocThese'. +-- | 'These' is associative. See 'assocThese'. -- -- @since 0.8 unassocThese :: These a (These b c) -> These (These a b) c @@ -227,7 +227,7 @@ -- | @'hasHere' = 'isJust' . 'justHere'@ hasHere = isJust . justHere --- | @'hasThere' = 'isJust' . 'jusThere'@ +-- | @'hasThere' = 'isJust' . 'justThere'@ hasThere = isJust . justThere ------------------------------------------------------------------------------- diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MonoLocalBinds #-} @@ -21,6 +22,7 @@ import Data.HashMap.Strict (HashMap) import Data.IntMap (IntMap) import Data.List (nub) +import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Maybe (mapMaybe) import Data.Semigroup (Semigroup (..)) @@ -39,6 +41,7 @@ import qualified Data.Functor.Product as P import qualified Data.IntMap as IntMap import qualified Data.Map as Map +import qualified Data.Tree as T import qualified Data.Vector as V import qualified Test.Tasty.QuickCheck as QC @@ -92,20 +95,24 @@ 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)) + [ dataAlignLaws "[]" (CAlign :: C []) + , dataAlignLaws "HashMap String" (CAlign :: C (HashMap String)) + , dataAlignLaws "IntMap" (CAlign :: C IntMap) + , dataAlignLaws "Map Char" (CAlign :: C (Map Char)) + , dataAlignLaws "Maybe" (CAlign :: C Maybe) + , dataAlignLaws "Product [] Maybe" (CAlign :: C (P.Product [] Maybe)) + , dataAlignLaws "Compose [] Maybe" (CAlign :: C (Compose [] Maybe)) + , dataAlignLaws "Seq" (CAlign :: C Seq) + , dataAlignLaws "Vector" (CAlign :: C V.Vector) + , dataAlignLaws "ZipList" (CAlign :: C ZipList) + , dataAlignLaws "Tree" (CSemialign :: C T.Tree) + , dataAlignLaws "NonEmpty" (CSemialign :: C NonEmpty) + + -- , dataAlignLaws "WrongMap" (CAlign :: C (WrongMap Char)) -- weird objects: - -- , dataAlignLaws "Const String" (Proxy :: Proxy (Const String)) - , dataAlignLaws "R" (Proxy :: Proxy R) - -- , dataAlignLaws "Weirdmap" (Proxy :: Proxy (WeirdMap Char)) + -- , dataAlignLaws "Const String" (CAlign :: C (Const String)) + , dataAlignLaws "R" (CAlign :: C R) + -- , dataAlignLaws "Weirdmap" (CAlign :: C (WeirdMap Char)) ] alignWithKeyProps :: TestTree @@ -180,6 +187,10 @@ -- Data.Align +data C f where + CSemialign :: Semialign f => C f + CAlign :: Align f => C f + -- (\`align` nil) = fmap This -- (nil \`align`) = fmap That -- join align = fmap (join These) @@ -187,52 +198,67 @@ -- alignWith f a b = f \<$> align a b -- -- 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 Int (These Int Int))) - , Show (f (These Int (These Int Int))) - , CoArbitrary (These Int Int) - , Arbitrary (f Int) - , Eq (f Int) - , Show (f Int)) - => String - -> 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 - , QC.testProperty "assoc" assocProp - , QC.testProperty "alignToList" alignToListProp - ] +dataAlignLaws + :: forall (f :: * -> *). + ( Foldable f + , Eq (f (These Int Int)) + , Show (f (These Int Int)) + , Eq (f (These Int (These Int Int))) + , Show (f (These Int (These Int Int))) + , CoArbitrary (These Int Int) + , Arbitrary (f Int) + , Eq (f Int) + , Show (f Int) + ) + => String + -> C f + -> TestTree +dataAlignLaws name p = + testGroup ("Data.Align laws: " <> name) props where - rightIdentityProp :: f Int -> Property + props = case p of + CSemialign -> semialignProps + CAlign -> semialignProps ++ alignLaws + + semialignProps :: Semialign f => [TestTree] + semialignProps = + [ QC.testProperty "join" joinProp + , QC.testProperty "bimap" bimapProp + , QC.testProperty "alignWith" alignWithProp + , QC.testProperty "assoc" assocProp + , QC.testProperty "alignToList" alignToListProp + ] + + alignLaws :: Align f => [TestTree] + alignLaws = + [ QC.testProperty "right identity" rightIdentityProp + , QC.testProperty "left identity" leftIdentityProp + ] + + rightIdentityProp :: Align f => f Int -> Property rightIdentityProp xs = (xs `align` (nil :: f Int)) === fmap This xs - leftIdentityProp :: f Int -> Property + leftIdentityProp :: Align f => f Int -> Property leftIdentityProp xs = ((nil :: f Int) `align` xs) === fmap That xs - joinProp :: f Int -> Property + joinProp :: Semialign f => 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 :: Semialign f => 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 :: Semialign f => 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 :: Semialign f => f Int -> f Int -> f Int -> Property assocProp xs ys zs = lhs === fmap assocThese rhs where rhs = (xs `align` ys) `align` zs lhs = xs `align` (ys `align` zs) - alignToListProp :: f Int -> f Int -> Property + alignToListProp :: Semialign f => f Int -> f Int -> Property alignToListProp xs ys = toList xs === toListOf (folded . here) xys .&&. diff --git a/these.cabal b/these.cabal --- a/these.cabal +++ b/these.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: these -version: 0.8 +version: 0.8.1 synopsis: An either-or-both data type & a generalized 'zip with padding' typeclass @@ -31,7 +31,7 @@ For a dependency light version, check package. tested-with: - 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 + ghc ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.4 source-repository head type: git @@ -68,10 +68,11 @@ , 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 + , hashable >=1.2.7.0 && <1.4 , keys >=3.12.1 && <3.13 , lens >=4.17 && <4.18 - , QuickCheck >=2.12.6.1 && <2.13 + , tagged >=0.8.6 && <0.9 + , QuickCheck >=2.12.6.1 && <2.14 , semigroupoids >=5.3.1 && <5.4 , transformers-compat >=0.6.2 && <0.7 , unordered-containers >=0.2.8.0 && <0.3 @@ -82,7 +83,7 @@ build-depends: ghc-prim if !impl(ghc >=8.0) - build-depends: semigroups >=0.18.5 && <0.19 + build-depends: semigroups >=0.18.5 && <0.20 -- Ensure Data.Functor.Classes is always available if impl(ghc >=7.10)