these 0.4.2 → 0.6.0.0
raw patch · 4 files changed
+202/−17 lines, 4 filesdep +QuickCheckdep +ghc-primdep +tastydep ~basedep ~bifunctorsdep ~mtl
Dependencies added: QuickCheck, ghc-prim, tasty, tasty-quickcheck, these
Dependency ranges changed: base, bifunctors, mtl, profunctors, semigroupoids, semigroups, transformers, vector
Files
- Data/Align.hs +25/−1
- Data/These.hs +14/−3
- test/Tests.hs +134/−0
- these.cabal +29/−13
Data/Align.hs view
@@ -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
Data/These.hs view
@@ -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 @@ -- <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' - -- | 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
+ test/Tests.hs view
@@ -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
these.cabal view
@@ -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