diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +# 0.7.1 + +- Add `AlignWithKey` in `Data.Align.Key` (added dependency `keys`) +- Add `These` instances for + - `binary`: `Binary` + - `aeson`: `FromJSON`, `ToJSON` + - `QuickCheck`: `Arbitrary`, `CoArbitrary`, `Function` + - `deepseq`: `NFData` + # 0.7 - Breaking change: Generalized `Monad`, `Applicative` instances of `These` and `Chronicle` to require only a `Semigroup` constraint diff --git a/Data/Align/Key.hs b/Data/Align/Key.hs new file mode 100644 --- /dev/null +++ b/Data/Align/Key.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | Module : Data.Aligned.Key +-- +-- 'These'-based zipping and unzipping of indexed functors. +module Data.Align.Key ( + AlignWithKey (..) + ) where + +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) + +-- | Keyed version of 'Align'. +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 + alignWithKey f a b = mapWithKey f (align a b) + +instance AlignWithKey Maybe +instance AlignWithKey [] +--instance AlignWithKey ZipList +instance AlignWithKey Seq +instance AlignWithKey IntMap +instance Ord k => AlignWithKey (Map k) +instance (Eq k, Hashable k) => AlignWithKey (HashMap k) +instance AlignWithKey Vector diff --git a/Data/These.hs b/Data/These.hs --- a/Data/These.hs +++ b/Data/These.hs @@ -2,8 +2,10 @@ -- | Module : Data.These -- -- The 'These' type and associated operations. Now enhanced with @Control.Lens@ magic! +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Data.These ( These(..) @@ -61,6 +63,15 @@ import GHC.Generics import Prelude hiding (foldr) +import Control.DeepSeq (NFData (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.=)) +import Data.Binary (Binary (..)) +import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), oneof) +import Test.QuickCheck.Function (Function (..), functionMap) + +import qualified Data.HashMap.Strict as HM +import qualified Data.Aeson as Aeson + -- -------------------------------------------------------------------------- -- | The 'These' type represents values with two non-exclusive possibilities. -- @@ -271,3 +282,64 @@ (>>=) = (>>-) instance (Hashable a, Hashable b) => Hashable (These a b) + +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 + +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 + put (These a b) = put (2 :: Int) >> put a >> put b + + get = do + i <- get + case (i :: Int) of + 0 -> This <$> get + 1 -> That <$> get + 2 -> These <$> get <*> get + _ -> fail "Invalid These index" + +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 + +instance (FromJSON a, FromJSON b) => FromJSON (These a b) where + parseJSON = Aeson.withObject "These a b" (p . HM.toList) + where + p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b + p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b + p [("This", a)] = This <$> parseJSON a + p [("That", b)] = That <$> parseJSON b + p _ = fail "Expected object with 'This' and 'That' keys only" + +instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where + arbitrary = oneof [ This <$> arbitrary + , That <$> arbitrary + , These <$> arbitrary <*> arbitrary + ] + shrink (This x) = This <$> shrink x + shrink (That y) = That <$> shrink y + shrink (These x y) = [This x, That y] ++ + [These x' y' | (x', y') <- shrink (x, y)] + +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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -These -- an either-or-both data type +These — an either-or-both data type ==================================== [![Build Status](https://secure.travis-ci.org/isomorphism/these.svg)](http://travis-ci.org/isomorphism/these) @@ -19,7 +19,7 @@ `here` and `there` are traversals over elements of the same type, suitable for use with `Control.Lens`. This has the dramatic benefit that if you're using `lens` you can ignore the dreadfully bland `mapThis` and `mapThat` functions in favor of saying `over here` and `over there`. -Align -- structural unions +Align — structural unions ========================== There is a notion of "zippy" `Applicative`s where `liftA2 (,)` behaves like `zip` in the sense that if the `Functor` is regarded as a container with distinct locations, each element of the result is a pair of the values that occupied the same location in the two inputs. For this to be possible, the result can only contain values at locations where both inputs also contained values. In a sense, this is the intersection of the "shapes" of the two inputs. @@ -55,7 +55,7 @@ cmccann: unfortunately it is too perfect an abstraction to be useful. ``` -ChronicleT -- a.k.a. These as a monad +ChronicleT — a.k.a. These as a monad ===================================== `These a` has an obvious `Monad` instance, provided here in monad transformer form. diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -9,6 +9,7 @@ import Control.Applicative import Control.Monad (join) import Data.Align +import Data.Align.Key import Data.Foldable import Data.Bifunctor import Data.Functor.Compose @@ -23,6 +24,7 @@ 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 @@ -31,6 +33,10 @@ import Test.Tasty import Test.Tasty.QuickCheck as QC +import qualified Data.Aeson as Aeson +import qualified Data.Binary as Binary +import qualified Data.Set as Set + -- For old GHC to work data Proxy (a :: * -> *) = Proxy @@ -38,7 +44,7 @@ main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [theseProps] +tests = testGroup "Tests" [theseProps, alignWithKeyProps] theseProps :: TestTree theseProps = testGroup "These" @@ -61,8 +67,22 @@ , crosswalkLaws "Vector" (Proxy :: Proxy V.Vector) , testProperty "Map value laziness property" mapStrictnessProp , testProperty "IntMap value laziness property" intmapStrictnessProp + , aesonProps + , binaryProps ] +alignWithKeyProps :: TestTree +alignWithKeyProps = testGroup "AlignWithKey" + [ testProperty "example" $ once $ example + ] + where + example = alignWithKey (,) "foo" "quux" === + [ (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: mapStrictnessProp :: [Int] -> [Int] -> Bool mapStrictnessProp lkeys rkeys = Prelude.length (nub lkeys) <= Map.size (lhs `align` rhs) @@ -187,42 +207,50 @@ lhs = crosswalk f x rhs = sequenceL . fmap f $ x +------------------------------------------------------------------------------- -- Orphan instances +------------------------------------------------------------------------------- instance (Arbitrary a, Arbitrary (f a), Arbitrary (g a)) => Arbitrary (P.Product f g a) where arbitrary = P.Pair <$> arbitrary <*> arbitrary shrink (P.Pair x y) = [P.Pair x' y' | (x', y') <- shrink (x, y)] -instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where - arbitrary = oneof [ This <$> arbitrary - , That <$> arbitrary - , These <$> arbitrary <*> arbitrary - ] - shrink (This x) = This <$> shrink x - shrink (That y) = That <$> shrink y - shrink (These x y) = [This x, That y] ++ - [These x' y' | (x', y') <- shrink (x, y)] -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) - #if !MIN_VERSION_quickcheck_instances(0,3,12) instance Arbitrary a => Arbitrary (V.Vector a) where arbitrary = V.fromList <$> arbitrary shrink = fmap V.fromList . shrink . V.toList #endif +#if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary a => Arbitrary (ZipList a) where arbitrary = ZipList <$> arbitrary shrink = fmap ZipList . shrink . getZipList +#endif + +------------------------------------------------------------------------------- +-- aeson +------------------------------------------------------------------------------- + +aesonProps :: TestTree +aesonProps = testGroup "aeson" + [ testProperty "roundtrip / direct" prop1 + , testProperty "roundtrip / toJSON" prop2 + ] + where + prop1 :: These Int String -> Property + prop1 x = Just x === Aeson.decode (Aeson.encode x) + + prop2 :: These Int String -> Property + prop2 x = Just x === Aeson.decode (Aeson.encode $ Aeson.toJSON x) + +------------------------------------------------------------------------------- +-- binary +------------------------------------------------------------------------------- + +binaryProps :: TestTree +binaryProps = testProperty "binary / roundtrip" prop + where + prop :: These Int String -> Property + prop x = x === Binary.decode (Binary.encode x) diff --git a/these.cabal b/these.cabal --- a/these.cabal +++ b/these.cabal @@ -1,5 +1,5 @@ Name: these -Version: 0.7 +Version: 0.7.1 Synopsis: An either-or-both data type & a generalized 'zip with padding' typeclass Homepage: https://github.com/isomorphism/these License: BSD3 @@ -30,21 +30,29 @@ Library Exposed-modules: Data.These, Data.Align, + Data.Align.Key, Control.Monad.Chronicle, Control.Monad.Chronicle.Class, Control.Monad.Trans.Chronicle - Build-depends: base >= 4.4 && < 5, - containers >= 0.4 && < 0.6, - mtl >= 2 && < 2.3, - transformers >= 0.2 && < 0.6, - bifunctors >= 0.1 && < 5.4, - semigroupoids >= 1.0 && < 5.1, - profunctors >= 3 && < 5.3, - vector >= 0.4 && < 0.12, - transformers-compat >= 0.2 && < 0.6, - hashable >= 1.2.3 && < 1.3, - unordered-containers >= 0.2 && < 0.3, - data-default-class >= 0.0 && < 0.2 + + Build-depends: base >= 4.4 && < 4.10, + aeson >= 0.7.0.4 && < 0.12, + bifunctors >= 0.1 && < 5.5, + binary >= 0.5.0.2 && < 0.9, + containers >= 0.4 && < 0.6, + data-default-class >= 0.0 && < 0.2, + deepseq >= 1.3.0.0 && < 1.5, + hashable >= 1.2.3 && < 1.3, + keys >= 3.10 && < 3.12, + mtl >= 2 && < 2.3, + profunctors >= 3 && < 5.3, + QuickCheck >= 2.8 && < 2.9.2, + semigroupoids >= 1.0 && < 5.2, + transformers >= 0.2 && < 0.6, + transformers-compat >= 0.2 && < 0.6, + unordered-containers >= 0.2 && < 0.3, + vector >= 0.4 && < 0.12, + vector-instances >= 3.3.1 && < 3.4 if impl(ghc <7.5) build-depends: ghc-prim @@ -60,14 +68,16 @@ hs-source-dirs: test ghc-options: -Wall build-depends: these, - base >= 4.5 && < 4.10, - transformers >= 0.2 && < 0.6, - vector >= 0.4 && < 0.12, - bifunctors >= 0.1 && < 5.4, - containers >= 0.4 && < 0.6, - hashable >= 1.2.3 && < 1.3, - unordered-containers >= 0.2 && < 0.3, - tasty >= 0.10 && < 0.12, - tasty-quickcheck >= 0.8 && < 0.9, - QuickCheck >= 2.8 && < 2.8.3, - quickcheck-instances >= 0.3.6 && < 0.4 + base >= 4.5, + quickcheck-instances >= 0.3.6 && < 0.3.13, + tasty >= 0.10 && < 0.12, + tasty-quickcheck >= 0.8 && < 0.9, + aeson, + bifunctors, + binary, + containers, + hashable, + QuickCheck, + transformers, + unordered-containers, + vector