diff --git a/Data/Align.hs b/Data/Align.hs --- a/Data/Align.hs +++ b/Data/Align.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | Module : Data.Align -- @@ -36,13 +37,20 @@ import Data.Monoid (Monoid(..)) import Data.Sequence (Seq) import Data.These -import Data.Vector.Generic (Vector, unstream, stream) +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.IntMap as IntMap import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Vector.Fusion.Stream.Monadic as Stream +#if MIN_VERSION_vector(0,11,0) +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 +#else import qualified Data.Vector.Fusion.Stream.Size as Stream +#endif import Prelude @@ -139,8 +147,13 @@ -- Based on the Data.Vector.Fusion.Stream.Monadic zipWith implementation instance Monad m => Align (Stream m) where nil = Stream.empty +#if MIN_VERSION_vector(0,11,0) + alignWith f (Stream stepa sa) (Stream stepb sb) + = Stream step (sa, sb, Nothing, False) +#else alignWith f (Stream stepa sa na) (Stream stepb sb nb) = Stream step (sa, sb, Nothing, False) (Stream.larger na nb) +#endif where step (sa, sb, Nothing, False) = do r <- stepa sa @@ -159,6 +172,17 @@ (Just x, False) -> Yield (f $ This x) (sa, sb, Nothing, adone) (_, True) -> Done _ -> Skip (sa, sb, Nothing, False) + +#if MIN_VERSION_vector(0,11,0) +instance Monad m => Align (Bundle m v) where + nil = Bundle.empty + alignWith f Bundle{sElems = sa, sSize = na} Bundle{sElems = sb, sSize = nb} + = Bundle.fromStream (alignWith f sa sb) (Bundle.larger na nb) +#endif + +instance Align V.Vector where + nil = Data.Vector.Generic.empty + alignWith = alignVectorWith alignVectorWith :: (Vector v a, Vector v b, Vector v c) => (These a b -> c) -> v a -> v b -> v c diff --git a/Data/These.hs b/Data/These.hs --- a/Data/These.hs +++ b/Data/These.hs @@ -2,6 +2,8 @@ -- | Module : Data.These -- -- The 'These' type and associated operations. Now enhanced with @Control.Lens@ magic! +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} module Data.These ( These(..) @@ -9,6 +11,7 @@ , these , fromThese , mergeThese + , mergeTheseWith -- * Traversals , here, there @@ -53,6 +56,8 @@ import Data.Semigroup.Bifoldable import Data.Semigroup.Bitraversable import Data.Traversable +import Data.Data +import GHC.Generics import Prelude hiding (foldr) -- -------------------------------------------------------------------------- @@ -67,7 +72,7 @@ -- 'These' has straightforward instances of 'Functor', 'Monad', &c., and -- behaves like a hybrid error/writer monad, as would be expected. data These a b = This a | That b | These a b - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | Case analysis for the 'These' type. these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c @@ -85,7 +90,11 @@ mergeThese :: (a -> a -> a) -> These a a -> a mergeThese = these id id +-- | BiMap and coalesce results with the provided operation. +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@. here :: (Applicative f) => (a -> f b) -> These a t -> f (These b t) here f (This x) = This <$> f x @@ -102,9 +111,9 @@ -- 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' - -- | A 'Prism' selecting the 'This' constructor. _This :: (Choice p, Applicative f) => p a (f a) -> p (These a b) (f (These a b)) _This = prism This (these Right (Left . That) (\x y -> Left $ These x y)) @@ -200,7 +209,9 @@ fmap f (These x y) = These x (f y) instance Foldable (These a) where - foldr f z = foldr f z . justThat + foldr _ z (This _) = z + foldr f z (That x) = f x z + foldr f z (These _ x) = f x z instance Traversable (These a) where traverse _ (This a) = pure $ This a diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,134 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +module Main (main) where + +import Control.Applicative +import Control.Monad (join) +import Data.Align +import Data.Foldable +import Data.Bifunctor +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Monoid +import Data.These +import Data.Traversable +import qualified Data.Vector as V +import Test.QuickCheck.Function +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +-- For old GHC to work +data Proxy (a :: * -> *) = Proxy + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [theseProps] + +theseProps :: TestTree +theseProps = testGroup "These" + [ functorProps + , traversableProps + , dataAlignLaws "[]" (Proxy :: Proxy []) + , dataAlignLaws "Maybe" (Proxy :: Proxy Maybe) + , dataAlignLaws "Vector" (Proxy :: Proxy V.Vector) + ] + +functorIdentityProp :: (Functor f, Eq (f a), Show (f a)) => f a -> Property +functorIdentityProp x = fmap id x === x + +functorCompositionProp :: (Functor f, Show (f c), Eq (f c)) => f a -> Fun a b -> Fun b c -> Property +functorCompositionProp x (Fun _ f) (Fun _ g) = fmap g (fmap f x) === fmap (g . f) x + +functorProps :: TestTree +functorProps = testGroup "Functor" + [ QC.testProperty "identity" (functorIdentityProp :: These Int Bool -> Property) + , QC.testProperty "composition" (functorCompositionProp :: These Int Int -> Fun Int Int -> Fun Int Int -> Property) + ] + +traversableIdentityProp :: (Traversable t, Eq (t a), Show (t a)) => t a -> Property +traversableIdentityProp x = traverse Identity x === Identity x + +traversableCompositionProp :: (Traversable t, Applicative g, Applicative f, Show (Compose f g (t b)), Eq (Compose f g (t b))) + => t a1 -> Fun a1 (f a) -> Fun a (g b) -> Property +traversableCompositionProp x (Fun _ f) (Fun _ g) = traverse (Compose . fmap g . f) x === (Compose . fmap (traverse g) . traverse f $ x) + +traversableFunctorProp :: (Traversable f, Show (f b), Eq (f b)) => f a -> Fun a b -> Property +traversableFunctorProp x (Fun _ f) = fmap f x === fmapDefault f x + +traversableFoldableProp :: (Monoid m, Traversable t, Show m, Eq m) => t a -> Fun a m -> Property +traversableFoldableProp x (Fun _ f) = foldMap f x === foldMapDefault f x + +traversableProps :: TestTree +traversableProps = testGroup "Traversable" + [ QC.testProperty "identity" (traversableIdentityProp :: These Int Bool -> Property) + , QC.testProperty "composition" (traversableCompositionProp :: These Bool Int -> Fun Int (Maybe Int) -> Fun Int (Either Bool Int) -> Property) + , QC.testProperty "functor" (traversableFunctorProp :: These Bool Int -> (Fun Int Int) -> Property) + , QC.testProperty "foldable" (traversableFoldableProp :: These Bool Int -> (Fun Int [Bool]) -> Property) + ] + +-- Data.Align + +-- (\`align` nil) = fmap This +-- (nil \`align`) = fmap That +-- 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 + , Eq (f (These Int Int)) + , Show (f (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 + ] + 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) + +-- Orphan instances + +instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where + arbitrary = oneof [ This <$> arbitrary + , That <$> arbitrary + , These <$> arbitrary <*> arbitrary + ] + +instance (Function a, Function b) => Function (These a b) where + function = functionMap g f + where + g (This a) = Left a + g (That b) = Right (Left b) + g (These a b) = Right (Right (a, b)) + + f (Left a) = This a + f (Right (Left b)) = That b + f (Right (Right (a, b))) = These a b + +instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (These a b) + +instance Arbitrary a => Arbitrary (V.Vector a) where + arbitrary = V.fromList <$> arbitrary + shrink = fmap V.fromList . shrink . V.toList diff --git a/these.cabal b/these.cabal --- a/these.cabal +++ b/these.cabal @@ -1,5 +1,5 @@ Name: these -Version: 0.4.2 +Version: 0.6.0.0 Synopsis: An either-or-both data type, with corresponding hybrid error/writer monad transformer. Homepage: https://github.com/isomorphism/these License: BSD3 @@ -8,21 +8,37 @@ Maintainer: cam@uptoisomorphism.net Category: Data,Control Build-type: Simple -Cabal-version: >=1.2 +Cabal-version: >=1.8 Library - Exposed-modules: Data.These, - Data.Align, - Control.Monad.Chronicle, - Control.Monad.Chronicle.Class, + Exposed-modules: Data.These, + Data.Align, + Control.Monad.Chronicle, + Control.Monad.Chronicle.Class, Control.Monad.Trans.Chronicle Build-depends: base >= 3 && < 5, containers >= 0.4 && < 0.6, - mtl >= 2 && < 2.2, - transformers >= 0.2 && < 0.4, - semigroups >= 0.8 && < 0.14, - bifunctors >= 0.1 && < 4.2, - semigroupoids >= 1.0 && < 4.1, - profunctors >= 3 && < 4.1, - vector >= 0.4 && < 0.11 + mtl >= 2 && < 2.3, + transformers >= 0.2 && < 0.5, + semigroups >= 0.8 && < 0.17, + bifunctors >= 0.1 && < 5.1, + semigroupoids >= 1.0 && < 5.1, + profunctors >= 3 && < 5.2, + vector >= 0.4 && < 0.12 + if impl(ghc <7.5) + build-depends: ghc-prim + ghc-options: -Wall +test-suite test + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + ghc-options: -Wall + build-depends: base >= 4.5 && < 4.9, + tasty >= 0.10 && < 0.11, + tasty-quickcheck >= 0.8 && < 0.9, + transformers >= 0.2 && < 0.5, + vector >= 0.4 && < 0.12, + bifunctors >= 0.1 && < 5.1, + these, + QuickCheck