diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,16 @@ Version 0.3.1.0 --------------- +*October 21, 2019* + + + +* Add `HasNonEmpty` instance for *nonempty-vector* +* Changed `splitLookup` to use `These` instead of a tuple of `Maybe`s. + +Version 0.3.1.0 +--------------- + *June 13, 2019* diff --git a/nonempty-containers.cabal b/nonempty-containers.cabal --- a/nonempty-containers.cabal +++ b/nonempty-containers.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: ba935c3c5707ed9ae691a7496155c303f8b100b1fb53ed3ada7af6de3a68b61d +-- hash: b3957939f119319cc87a4a5bed720ba0d54e8e7a4ddff1240df072483ee72097 name: nonempty-containers -version: 0.3.1.0 +version: 0.3.2.0 synopsis: Non-empty variants of containers data types, with full API description: Efficient and optimized non-empty versions of types from /containers/. Inspired by /non-empty-containers/ library, except attempting a more @@ -23,7 +23,7 @@ copyright: (c) Justin Le 2018 license: BSD3 license-file: LICENSE -tested-with: GHC >= 8.2 && < 8.8 +tested-with: GHC >= 8.4 build-type: Simple extra-source-files: README.md @@ -56,8 +56,10 @@ , comonad , containers >=0.5.9 , deepseq + , nonempty-vector , semigroupoids , these + , vector default-language: Haskell2010 test-suite nonempty-containers-test @@ -81,9 +83,11 @@ , hedgehog >=1.0 , hedgehog-fn >=1.0 , nonempty-containers + , nonempty-vector , semigroupoids , tasty , tasty-hedgehog >=1.0 , text , these + , vector default-language: Haskell2010 diff --git a/src/Data/Containers/NonEmpty.hs b/src/Data/Containers/NonEmpty.hs --- a/src/Data/Containers/NonEmpty.hs +++ b/src/Data/Containers/NonEmpty.hs @@ -20,7 +20,7 @@ -- -- Used to convert between and in between possibly-empty and non-empty -- types. Instances are provided for all modules in this package, as well --- as for 'NonEmpty' in /base/. +-- as for 'NonEmpty' in /base/ and 'NonEmptyVector'. module Data.Containers.NonEmpty ( HasNonEmpty(..) , pattern IsNonEmpty, pattern IsEmpty @@ -38,6 +38,8 @@ import Data.Sequence.NonEmpty (NESeq(..)) import Data.Set (Set) import Data.Set.NonEmpty (NESet) +import Data.Vector (Vector) +import Data.Vector.NonEmpty (NonEmptyVector) import qualified Data.IntMap as IM import qualified Data.IntMap.NonEmpty as NEIM import qualified Data.IntSet as IS @@ -49,6 +51,8 @@ import qualified Data.Sequence.NonEmpty as NESeq import qualified Data.Set as S import qualified Data.Set.NonEmpty as NES +import qualified Data.Vector as V +import qualified Data.Vector.NonEmpty as NEV -- | If @s@ is an instance of @HasNonEmpty@, it means that there is -- a corresponding "non-empty" version of @s@, @'NE' s@. @@ -160,6 +164,12 @@ isEmpty = Seq.null unsafeToNonEmpty = NESeq.unsafeFromSeq +instance HasNonEmpty (Vector a) where + type NE (Vector a) = NonEmptyVector a + nonEmpty = NEV.fromVector + fromNonEmpty = NEV.toVector + empty = V.empty + isEmpty = V.null -- | The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat a @s@ as -- if it were either a @'IsNonEmpty' n@ (where @n@ is a non-empty version diff --git a/src/Data/IntMap/NonEmpty.hs b/src/Data/IntMap/NonEmpty.hs --- a/src/Data/IntMap/NonEmpty.hs +++ b/src/Data/IntMap/NonEmpty.hs @@ -238,7 +238,7 @@ import Control.Applicative import Data.Bifunctor import Data.Functor.Identity -import Data.IntMap.Internal (IntMap(..), Key) +import Data.IntMap.Internal (IntMap(..)) import Data.IntMap.NonEmpty.Internal import Data.IntSet (IntSet) import Data.IntSet.NonEmpty.Internal (NEIntSet(..)) @@ -1647,36 +1647,37 @@ split k n@(NEIntMap k0 v m0) = case compare k k0 of LT -> Just $ That n EQ -> That <$> nonEmptyMap m0 - GT -> case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> Just $ This (singleton k0 v) - (Just _ , Nothing) -> Just $ This (insertMapMin k0 v m1) - (Nothing, Just n2) -> Just $ These (singleton k0 v) n2 - (Just _ , Just n2) -> Just $ These (insertMapMin k0 v m1) n2 + GT -> Just $ case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> This (singleton k0 v) + (Just _ , Nothing) -> This (insertMapMin k0 v m1) + (Nothing, Just n2) -> These (singleton k0 v) n2 + (Just _ , Just n2) -> These (insertMapMin k0 v m1) n2 where (m1, m2) = M.split k m0 {-# INLINABLE split #-} -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just --- like 'split' but also returns @'lookup' k map@, as a @'Maybe' a@. +-- like 'split' but also returns @'lookup' k map@, as the first field in +-- the 'These': -- --- > splitLookup 2 (fromList ((5,"a") :| [(3,"b")])) == (Nothing , Just (That (fromList ((3,"b") :| [(5,"a")])))) --- > splitLookup 3 (fromList ((5,"a") :| [(3,"b")])) == (Just "b", Just (That (singleton 5 "a"))) --- > splitLookup 4 (fromList ((5,"a") :| [(3,"b")])) == (Nothing , Just (These (singleton 3 "b") (singleton 5 "a"))) --- > splitLookup 5 (fromList ((5,"a") :| [(3,"b")])) == (Just "a", Just (This (singleton 3 "b")) --- > splitLookup 6 (fromList ((5,"a") :| [(3,"b")])) == (Nothing , Just (This (fromList ((3,"b") :| [(5,"a")]))) --- > splitLookup 5 (singleton 5 "a") == (Just "a", Nothing) +-- > splitLookup 2 (fromList ((5,"a") :| [(3,"b")])) == That (That (fromList ((3,"b") :| [(5,"a")]))) +-- > splitLookup 3 (fromList ((5,"a") :| [(3,"b")])) == These "b" (That (singleton 5 "a")) +-- > splitLookup 4 (fromList ((5,"a") :| [(3,"b")])) == That (These (singleton 3 "b") (singleton 5 "a")) +-- > splitLookup 5 (fromList ((5,"a") :| [(3,"b")])) == These "a" (This (singleton 3 "b")) +-- > splitLookup 6 (fromList ((5,"a") :| [(3,"b")])) == That (This (fromList ((3,"b") :| [(5,"a")]))) +-- > splitLookup 5 (singleton 5 "a") == This "a" splitLookup :: Key -> NEIntMap a - -> (Maybe a, Maybe (These (NEIntMap a) (NEIntMap a))) + -> These a (These (NEIntMap a) (NEIntMap a)) splitLookup k n@(NEIntMap k0 v0 m0) = case compare k k0 of - LT -> (Nothing, Just $ That n) - EQ -> (Just v0, That <$> nonEmptyMap m0) - GT -> (v ,) $ case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> Just $ This (singleton k0 v0) - (Just _ , Nothing) -> Just $ This (insertMapMin k0 v0 m1) - (Nothing, Just n2) -> Just $ These (singleton k0 v0) n2 - (Just _ , Just n2) -> Just $ These (insertMapMin k0 v0 m1) n2 + LT -> That . That $ n + EQ -> maybe (This v0) (These v0 . That) . nonEmptyMap $ m0 + GT -> maybe That These v $ case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> This (singleton k0 v0) + (Just _ , Nothing) -> This (insertMapMin k0 v0 m1) + (Nothing, Just n2) -> These (singleton k0 v0) n2 + (Just _ , Just n2) -> These (insertMapMin k0 v0 m1) n2 where (m1, v, m2) = M.splitLookup k m0 {-# INLINABLE splitLookup #-} diff --git a/src/Data/IntSet/NonEmpty/Internal.hs b/src/Data/IntSet/NonEmpty/Internal.hs --- a/src/Data/IntSet/NonEmpty/Internal.hs +++ b/src/Data/IntSet/NonEmpty/Internal.hs @@ -39,7 +39,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup import Data.Semigroup.Foldable (Foldable1) -import Data.Typeable (Typeable) import Text.Read import qualified Data.Foldable as F import qualified Data.IntSet as S diff --git a/src/Data/Map/NonEmpty.hs b/src/Data/Map/NonEmpty.hs --- a/src/Data/Map/NonEmpty.hs +++ b/src/Data/Map/NonEmpty.hs @@ -1876,37 +1876,38 @@ split k n@(NEMap k0 v m0) = case compare k k0 of LT -> Just $ That n EQ -> That <$> nonEmptyMap m0 - GT -> case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> Just $ This (singleton k0 v) - (Just _ , Nothing) -> Just $ This (insertMapMin k0 v m1) - (Nothing, Just n2) -> Just $ These (singleton k0 v) n2 - (Just _ , Just n2) -> Just $ These (insertMapMin k0 v m1) n2 + GT -> Just $ case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> This (singleton k0 v) + (Just _ , Nothing) -> This (insertMapMin k0 v m1) + (Nothing, Just n2) -> These (singleton k0 v) n2 + (Just _ , Just n2) -> These (insertMapMin k0 v m1) n2 where (m1, m2) = M.split k m0 {-# INLINABLE split #-} -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just --- like 'split' but also returns @'lookup' k map@, as a @'Maybe' a@. +-- like 'split' but also returns @'lookup' k map@, as the first field in +-- the 'These': -- --- > splitLookup 2 (fromList ((5,"a") :| [(3,"b")])) == (Nothing , Just (That (fromList ((3,"b") :| [(5,"a")])))) --- > splitLookup 3 (fromList ((5,"a") :| [(3,"b")])) == (Just "b", Just (That (singleton 5 "a"))) --- > splitLookup 4 (fromList ((5,"a") :| [(3,"b")])) == (Nothing , Just (These (singleton 3 "b") (singleton 5 "a"))) --- > splitLookup 5 (fromList ((5,"a") :| [(3,"b")])) == (Just "a", Just (This (singleton 3 "b")) --- > splitLookup 6 (fromList ((5,"a") :| [(3,"b")])) == (Nothing , Just (This (fromList ((3,"b") :| [(5,"a")]))) --- > splitLookup 5 (singleton 5 "a") == (Just "a", Nothing) +-- > splitLookup 2 (fromList ((5,"a") :| [(3,"b")])) == That (That (fromList ((3,"b") :| [(5,"a")]))) +-- > splitLookup 3 (fromList ((5,"a") :| [(3,"b")])) == These "b" (That (singleton 5 "a")) +-- > splitLookup 4 (fromList ((5,"a") :| [(3,"b")])) == That (These (singleton 3 "b") (singleton 5 "a")) +-- > splitLookup 5 (fromList ((5,"a") :| [(3,"b")])) == These "a" (This (singleton 3 "b")) +-- > splitLookup 6 (fromList ((5,"a") :| [(3,"b")])) == That (This (fromList ((3,"b") :| [(5,"a")]))) +-- > splitLookup 5 (singleton 5 "a") == This "a" splitLookup :: Ord k => k -> NEMap k a - -> (Maybe a, Maybe (These (NEMap k a) (NEMap k a))) + -> These a (These (NEMap k a) (NEMap k a)) splitLookup k n@(NEMap k0 v0 m0) = case compare k k0 of - LT -> (Nothing, Just $ That n) - EQ -> (Just v0, That <$> nonEmptyMap m0) - GT -> (v ,) $ case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> Just $ This (singleton k0 v0) - (Just _ , Nothing) -> Just $ This (insertMapMin k0 v0 m1) - (Nothing, Just n2) -> Just $ These (singleton k0 v0) n2 - (Just _ , Just n2) -> Just $ These (insertMapMin k0 v0 m1) n2 + LT -> That . That $ n + EQ -> maybe (This v0) (These v0 . That) . nonEmptyMap $ m0 + GT -> maybe That These v $ case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> This (singleton k0 v0) + (Just _ , Nothing) -> This (insertMapMin k0 v0 m1) + (Nothing, Just n2) -> These (singleton k0 v0) n2 + (Just _ , Just n2) -> These (insertMapMin k0 v0 m1) n2 where (m1, v, m2) = M.splitLookup k m0 {-# INLINABLE splitLookup #-} diff --git a/src/Data/Map/NonEmpty/Internal.hs b/src/Data/Map/NonEmpty/Internal.hs --- a/src/Data/Map/NonEmpty/Internal.hs +++ b/src/Data/Map/NonEmpty/Internal.hs @@ -64,7 +64,6 @@ import Data.Semigroup import Data.Semigroup.Foldable (Foldable1(fold1)) import Data.Semigroup.Traversable (Traversable1(..)) -import Data.Typeable (Typeable) import Prelude hiding (foldr1, foldl1, foldr, foldl, map) import Text.Read import qualified Data.Foldable as F diff --git a/src/Data/Sequence/NonEmpty/Internal.hs b/src/Data/Sequence/NonEmpty/Internal.hs --- a/src/Data/Sequence/NonEmpty/Internal.hs +++ b/src/Data/Sequence/NonEmpty/Internal.hs @@ -53,7 +53,6 @@ import Data.Bifunctor import Data.Coerce import Data.Data -import Data.Foldable (Foldable) import Data.Functor.Alt import Data.Functor.Bind import Data.Functor.Classes diff --git a/src/Data/Set/NonEmpty/Internal.hs b/src/Data/Set/NonEmpty/Internal.hs --- a/src/Data/Set/NonEmpty/Internal.hs +++ b/src/Data/Set/NonEmpty/Internal.hs @@ -47,17 +47,16 @@ import Data.Data import Data.Function import Data.Functor.Classes -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup -import Data.Semigroup.Foldable (Foldable1) -import Data.Set.Internal (Set(..)) -import Data.Typeable (Typeable) -import Prelude hiding (foldr, foldr1, foldl, foldl1) +import Data.Semigroup.Foldable (Foldable1) +import Data.Set.Internal (Set(..)) +import Prelude hiding (foldr, foldr1, foldl, foldl1) import Text.Read -import qualified Data.Foldable as F -import qualified Data.Semigroup.Foldable as F1 -import qualified Data.Set as S -import qualified Data.Set.Internal as S +import qualified Data.Foldable as F +import qualified Data.Semigroup.Foldable as F1 +import qualified Data.Set as S +import qualified Data.Set.Internal as S #if !MIN_VERSION_containers(0,5,11) import Utils.Containers.Internal.StrictPair diff --git a/test/Tests/IntMap.hs b/test/Tests/IntMap.hs --- a/test/Tests/IntMap.hs +++ b/test/Tests/IntMap.hs @@ -630,8 +630,8 @@ NEM.split prop_splitLookup :: Property -prop_splitLookup = ttProp (GTIntKey :-> GTNEIntMap :-> TTMaybe TTVal :*: TTMThese TTNEIntMap TTNEIntMap) - (\k -> (\(x,y,z) -> (y,(x,z))) . M.splitLookup k) +prop_splitLookup = ttProp (GTIntKey :-> GTNEIntMap :-> TTTThese TTVal TTNEIntMap TTNEIntMap) + (\k -> (\(x,y,z) -> (y,x,z)) . M.splitLookup k) NEM.splitLookup prop_isSubmapOfBy :: Property diff --git a/test/Tests/Map.hs b/test/Tests/Map.hs --- a/test/Tests/Map.hs +++ b/test/Tests/Map.hs @@ -674,8 +674,8 @@ NEM.split prop_splitLookup :: Property -prop_splitLookup = ttProp (GTKey :-> GTNEMap :-> TTMaybe TTVal :*: TTMThese TTNEMap TTNEMap) - (\k -> (\(x,y,z) -> (y,(x,z))) . M.splitLookup k) +prop_splitLookup = ttProp (GTKey :-> GTNEMap :-> TTTThese TTVal TTNEMap TTNEMap) + (\k -> (\(x,y,z) -> (y,x,z)) . M.splitLookup k) NEM.splitLookup prop_isSubmapOfBy :: Property diff --git a/test/Tests/Util.hs b/test/Tests/Util.hs --- a/test/Tests/Util.hs +++ b/test/Tests/Util.hs @@ -246,6 +246,11 @@ => TestType a b -> TestType c d -> TestType (a, c) (Maybe (These b d)) + TTTThese :: (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c, Eq e, Show e, Monoid e) + => TestType a b + -> TestType c d + -> TestType e f + -> TestType (Maybe a, c, e) (These b (These d f)) TTMaybe :: TestType a b -> TestType (Maybe a) (Maybe b) TTEither :: TestType a b @@ -367,6 +372,17 @@ Just (These y1 y2) -> do runTT t1 x1 y1 runTT t2 x2 y2 + TTTThese t1 t2 t3 -> \(x1,x2,x3) -> \case + This y1 -> do + mapM_ (flip (runTT t1) y1) x1 + x2 === mempty + x3 === mempty + That y23 -> do + x1 === mempty + runTT (TTThese t2 t3) (x2, x3) y23 + These y1 y23 -> do + mapM_ (flip (runTT t1) y1) x1 + runTT (TTThese t2 t3) (x2, x3) y23 TTMaybe tt -> \x y -> do isJust y === isJust y traverse_ (uncurry (runTT tt)) $ liftA2 (,) x y