diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,14 @@ Changelog ========= +Version 0.3.5.x +--------------- + +*May 20, 2025* + +* Support *containers* 0.8 and drop support for *containers* < 0.6.3.1 + (@jonathanknowles) + Version 0.3.4.x --------------- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/nonempty-containers.cabal b/nonempty-containers.cabal --- a/nonempty-containers.cabal +++ b/nonempty-containers.cabal @@ -1,95 +1,100 @@ -cabal-version: 1.12 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack -name: nonempty-containers -version: 0.3.4.5 -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 - faithful port (with under-the-hood optimizations) of the full /containers/ - API. Also contains a convenient typeclass abstraction for converting - betwewen non-empty and possibly-empty variants. See README.md for more - information. -category: Data Structures -homepage: https://github.com/mstksg/nonempty-containers#readme -bug-reports: https://github.com/mstksg/nonempty-containers/issues -author: Justin Le -maintainer: justin@jle.im -copyright: (c) Justin Le 2018 -license: BSD3 -license-file: LICENSE -build-type: Simple -tested-with: - GHC >= 8.4 +name: nonempty-containers +version: 0.3.5.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 + faithful port (with under-the-hood optimizations) of the full /containers/ + API. Also contains a convenient typeclass abstraction for converting + betwewen non-empty and possibly-empty variants. See README.md for more + information. + +category: Data Structures +homepage: https://github.com/mstksg/nonempty-containers#readme +bug-reports: https://github.com/mstksg/nonempty-containers/issues +author: Justin Le +maintainer: justin@jle.im +copyright: (c) Justin Le 2018 +license: BSD3 +license-file: LICENSE +build-type: Simple +tested-with: GHC >=8.10 extra-source-files: - README.md - CHANGELOG.md + CHANGELOG.md + README.md source-repository head - type: git + type: git location: https://github.com/mstksg/nonempty-containers library exposed-modules: - Data.Containers.NonEmpty - Data.IntMap.NonEmpty - Data.IntMap.NonEmpty.Internal - Data.IntSet.NonEmpty - Data.IntSet.NonEmpty.Internal - Data.Map.NonEmpty - Data.Map.NonEmpty.Internal - Data.Sequence.NonEmpty - Data.Sequence.NonEmpty.Internal - Data.Set.NonEmpty - Data.Set.NonEmpty.Internal - other-modules: - Paths_nonempty_containers - hs-source-dirs: - src - ghc-options: -Wall -Wcompat -Wredundant-constraints + Data.Containers.NonEmpty + Data.IntMap.NonEmpty + Data.IntMap.NonEmpty.Internal + Data.IntSet.NonEmpty + Data.IntSet.NonEmpty.Internal + Data.Map.NonEmpty + Data.Map.NonEmpty.Internal + Data.Sequence.NonEmpty + Data.Sequence.NonEmpty.Internal + Data.Set.NonEmpty + Data.Set.NonEmpty.Internal + + other-modules: Paths_nonempty_containers + hs-source-dirs: src + ghc-options: -Wall -Wcompat -Wredundant-constraints build-depends: aeson - , base >=4.9 && <5 + , base >=4.9 && <5 , comonad - , containers >=0.5.9 + , containers >=0.6.3.1 && <0.9 , deepseq , invariant , nonempty-vector , semigroupoids , these , vector + default-language: Haskell2010 test-suite nonempty-containers-test - type: exitcode-stdio-1.0 - main-is: Spec.hs + type: exitcode-stdio-1.0 + main-is: Spec.hs other-modules: - Tests.IntMap - Tests.IntSet - Tests.Map - Tests.Sequence - Tests.Set - Tests.Util - Paths_nonempty_containers - hs-source-dirs: - test - ghc-options: -Wall -Wcompat -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + Paths_nonempty_containers + Tests.IntMap + Tests.IntSet + Tests.Map + Tests.Sequence + Tests.Set + Tests.Util + + hs-source-dirs: test + ghc-options: + -Wall -Wcompat -Wredundant-constraints -threaded -rtsopts + -with-rtsopts=-N + build-depends: - base >=4.9 && <5 + base >=4.9 && <5 , comonad - , containers >=0.5.9 - , hedgehog >=1.0 - , hedgehog-fn >=1.0 + , containers >=0.6.3.1 && <0.9 + , hedgehog >=1.0 + , hedgehog-fn >=1.0 , invariant , nonempty-containers , nonempty-vector , semigroupoids , tasty - , tasty-hedgehog >=1.0 + , 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 @@ -1,8 +1,7 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Containers.NonEmpty @@ -22,39 +21,40 @@ -- types. Instances are provided for all modules in this package, as well -- as for 'NonEmpty' in /base/ and 'NonEmptyVector'. module Data.Containers.NonEmpty ( - HasNonEmpty(..) - , pattern IsNonEmpty, pattern IsEmpty - , overNonEmpty - , onNonEmpty - ) where + HasNonEmpty (..), + pattern IsNonEmpty, + pattern IsEmpty, + overNonEmpty, + onNonEmpty, +) where -import Data.IntMap (IntMap) -import Data.IntMap.NonEmpty (NEIntMap) -import Data.IntSet (IntSet) -import Data.IntSet.NonEmpty (NEIntSet) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map (Map) -import Data.Map.NonEmpty (NEMap) -import Data.Maybe -import Data.Sequence (Seq(..)) -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 -import qualified Data.IntSet.NonEmpty as NEIS -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Map.NonEmpty as NEM -import qualified Data.Sequence as Seq +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.IntMap.NonEmpty (NEIntMap) +import qualified Data.IntMap.NonEmpty as NEIM +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.IntSet.NonEmpty (NEIntSet) +import qualified Data.IntSet.NonEmpty as NEIS +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as M +import Data.Map.NonEmpty (NEMap) +import qualified Data.Map.NonEmpty as NEM +import Data.Maybe +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Sequence.NonEmpty (NESeq (..)) 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 +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NES +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Vector.NonEmpty (NonEmptyVector) +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@. @@ -71,44 +71,44 @@ -- * Usually, @not (isEmpty x) ==> isJust (nonEmpty x)@, but this isn't -- necessary. class HasNonEmpty s where - {-# MINIMAL (nonEmpty | withNonEmpty), fromNonEmpty, empty #-} + {-# MINIMAL (nonEmpty | withNonEmpty), fromNonEmpty, empty #-} - -- | @'NE' s@ is the "non-empty" version of @s@. - type NE s = t | t -> s + -- | @'NE' s@ is the "non-empty" version of @s@. + type NE s = t | t -> s - -- | "Smart constructor" for @'NE' s@ given a (potentailly empty) @s@. - -- Will return 'Nothing' if the @s@ was empty, and @'Just' n@ if the - -- @s@ was not empty, with @n :: 'NE' s@. - -- - -- Should form an isomorphism with @'maybe' 'empty' 'fromNonEmpty'@. - nonEmpty :: s -> Maybe (NE s) - nonEmpty = withNonEmpty Nothing Just + -- | "Smart constructor" for @'NE' s@ given a (potentailly empty) @s@. + -- Will return 'Nothing' if the @s@ was empty, and @'Just' n@ if the + -- @s@ was not empty, with @n :: 'NE' s@. + -- + -- Should form an isomorphism with @'maybe' 'empty' 'fromNonEmpty'@. + nonEmpty :: s -> Maybe (NE s) + nonEmpty = withNonEmpty Nothing Just - -- | Convert a @'NE' s@ (non-empty @s@) back into an @s@, "obscuring" - -- its non-emptiness from its type. - fromNonEmpty :: NE s -> s + -- | Convert a @'NE' s@ (non-empty @s@) back into an @s@, "obscuring" + -- its non-emptiness from its type. + fromNonEmpty :: NE s -> s - -- | Continuation-based version of 'nonEmpty', which can be more - -- efficient in certain situations. - -- - -- @'withNonEmpty' 'empty' 'fromNonEmpty'@ should be @id@. - withNonEmpty :: r -> (NE s -> r) -> s -> r - withNonEmpty def f = maybe def f . nonEmpty + -- | Continuation-based version of 'nonEmpty', which can be more + -- efficient in certain situations. + -- + -- @'withNonEmpty' 'empty' 'fromNonEmpty'@ should be @id@. + withNonEmpty :: r -> (NE s -> r) -> s -> r + withNonEmpty def f = maybe def f . nonEmpty - -- | An empty @s@. - empty :: s + -- | An empty @s@. + empty :: s - -- | Check if an @s@ is empty. - isEmpty :: s -> Bool - isEmpty = isNothing . nonEmpty + -- | Check if an @s@ is empty. + isEmpty :: s -> Bool + isEmpty = isNothing . nonEmpty - -- | Unsafely coerce an @s@ into an @'NE' s@ (non-empty @s@). Is - -- undefined (throws a runtime exception when evaluation is attempted) - -- when the @s@ is empty. - unsafeToNonEmpty :: s -> NE s - unsafeToNonEmpty = fromMaybe e . nonEmpty - where - e = errorWithoutStackTrace "unsafeToNonEmpty: empty input provided" + -- | Unsafely coerce an @s@ into an @'NE' s@ (non-empty @s@). Is + -- undefined (throws a runtime exception when evaluation is attempted) + -- when the @s@ is empty. + unsafeToNonEmpty :: s -> NE s + unsafeToNonEmpty = fromMaybe e . nonEmpty + where + e = errorWithoutStackTrace "unsafeToNonEmpty: empty input provided" -- | Useful function for mapping over the "non-empty" representation of -- a type. @@ -128,67 +128,67 @@ onNonEmpty f = withNonEmpty Nothing (Just . f) instance HasNonEmpty [a] where - type NE [a] = NonEmpty a - nonEmpty = NE.nonEmpty - fromNonEmpty = NE.toList - withNonEmpty def f = \case - [] -> def - x:xs -> f (x :| xs) - empty = [] - isEmpty = null - unsafeToNonEmpty = NE.fromList + type NE [a] = NonEmpty a + nonEmpty = NE.nonEmpty + fromNonEmpty = NE.toList + withNonEmpty def f = \case + [] -> def + x : xs -> f (x :| xs) + empty = [] + isEmpty = null + unsafeToNonEmpty = NE.fromList instance HasNonEmpty (Map k a) where - type NE (Map k a) = NEMap k a - nonEmpty = NEM.nonEmptyMap - fromNonEmpty = NEM.toMap - withNonEmpty = NEM.withNonEmpty - empty = M.empty - isEmpty = M.null - unsafeToNonEmpty = NEM.unsafeFromMap + type NE (Map k a) = NEMap k a + nonEmpty = NEM.nonEmptyMap + fromNonEmpty = NEM.toMap + withNonEmpty = NEM.withNonEmpty + empty = M.empty + isEmpty = M.null + unsafeToNonEmpty = NEM.unsafeFromMap instance HasNonEmpty (IntMap a) where - type NE (IntMap a) = NEIntMap a - nonEmpty = NEIM.nonEmptyMap - fromNonEmpty = NEIM.toMap - withNonEmpty = NEIM.withNonEmpty - empty = IM.empty - isEmpty = IM.null - unsafeToNonEmpty = NEIM.unsafeFromMap + type NE (IntMap a) = NEIntMap a + nonEmpty = NEIM.nonEmptyMap + fromNonEmpty = NEIM.toMap + withNonEmpty = NEIM.withNonEmpty + empty = IM.empty + isEmpty = IM.null + unsafeToNonEmpty = NEIM.unsafeFromMap instance HasNonEmpty (Set a) where - type NE (Set a) = NESet a - nonEmpty = NES.nonEmptySet - fromNonEmpty = NES.toSet - withNonEmpty = NES.withNonEmpty - empty = S.empty - isEmpty = S.null - unsafeToNonEmpty = NES.unsafeFromSet + type NE (Set a) = NESet a + nonEmpty = NES.nonEmptySet + fromNonEmpty = NES.toSet + withNonEmpty = NES.withNonEmpty + empty = S.empty + isEmpty = S.null + unsafeToNonEmpty = NES.unsafeFromSet instance HasNonEmpty IntSet where - type NE IntSet = NEIntSet - nonEmpty = NEIS.nonEmptySet - fromNonEmpty = NEIS.toSet - withNonEmpty = NEIS.withNonEmpty - empty = IS.empty - isEmpty = IS.null - unsafeToNonEmpty = NEIS.unsafeFromSet + type NE IntSet = NEIntSet + nonEmpty = NEIS.nonEmptySet + fromNonEmpty = NEIS.toSet + withNonEmpty = NEIS.withNonEmpty + empty = IS.empty + isEmpty = IS.null + unsafeToNonEmpty = NEIS.unsafeFromSet instance HasNonEmpty (Seq a) where - type NE (Seq a) = NESeq a - nonEmpty = NESeq.nonEmptySeq - fromNonEmpty = NESeq.toSeq - withNonEmpty = NESeq.withNonEmpty - empty = Seq.empty - isEmpty = Seq.null - unsafeToNonEmpty = NESeq.unsafeFromSeq + type NE (Seq a) = NESeq a + nonEmpty = NESeq.nonEmptySeq + fromNonEmpty = NESeq.toSeq + withNonEmpty = NESeq.withNonEmpty + empty = Seq.empty + 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 + 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 @@ -218,7 +218,7 @@ -- a @'NE' s@ back into an @s@, "obscuring" its non-emptiness (see -- 'fromNonEmpty'). pattern IsNonEmpty :: HasNonEmpty s => NE s -> s -pattern IsNonEmpty n <- (nonEmpty->Just n) +pattern IsNonEmpty n <- (nonEmpty -> Just n) where IsNonEmpty n = fromNonEmpty n @@ -241,6 +241,6 @@ -- -- See 'IsNonEmpty' for more information. pattern IsEmpty :: HasNonEmpty s => s -pattern IsEmpty <- (isEmpty->True) +pattern IsEmpty <- (isEmpty -> True) where IsEmpty = empty 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 @@ -1,1974 +1,1997 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Data.IntMap.NonEmpty --- Copyright : (c) Justin Le 2018 --- License : BSD3 --- --- Maintainer : justin@jle.im --- Stability : experimental --- Portability : non-portable --- --- = Non-Empty Finite Integer-Indexed Maps (lazy interface) --- --- The @'NEIntMap' v@ type represents a non-empty finite map (sometimes --- called a dictionary) from integer keys to values of type @v@. --- An 'NEIntMap' is strict in its keys but lazy in its values. --- --- See documentation for 'NEIntMap' for information on how to convert and --- manipulate such non-empty maps. --- --- This module essentially re-imports the API of "Data.IntMap.Lazy" and its --- 'IntMap' type, along with semantics and asymptotics. In most --- situations, asymptotics are different only by a constant factor. In --- some situations, asmyptotics are even better (constant-time instead of --- log-time). --- --- Because 'NEIntMap' is implemented using 'IntMap', all of the caveats of using --- 'IntMap' apply (such as the limitation of the maximum size of maps). --- --- All functions take non-empty maps as inputs. In situations where their --- results can be guarunteed to also be non-empty, they also return --- non-empty maps. In situations where their results could potentially be --- empty, 'IntMap' is returned instead. --- --- Some variants of functions (like 'alter'', 'alterF'', 'adjustMin', --- 'adjustMax', 'adjustMinWithKey', 'adjustMaxWithKey') are provided in --- a way restructured to preserve guaruntees of non-empty maps being --- returned. --- --- Some functions (like 'mapEither', 'partition', 'split') --- have modified return types to account for possible configurations of --- non-emptiness. --- --- This module is intended to be imported qualified, to avoid name clashes with --- "Prelude" and "Data.IntMap" functions: --- --- > import qualified Data.IntMap.NonEmpty as NEIM --- --- Note that all asmyptotics /O(f(n))/ in this module are actually --- /O(min(W, f(n)))/, where @W@ is the number of bits in an 'Int' (32 or --- 64). That is, if @f(n)@ is greater than @W@, all operations are --- constant-time. --- --- At the moment, this package does not provide a variant strict on values --- for these functions, like /containers/ does. This is a planned future --- implementation (PR's are appreciated). For now, you can simulate --- a strict interface by manually forcing values before returning results. -module Data.IntMap.NonEmpty ( - -- * Non-Empty IntMap Type - NEIntMap - , Key - - -- ** Conversions between empty and non-empty maps - , pattern IsNonEmpty - , pattern IsEmpty - , nonEmptyMap - , toMap - , withNonEmpty - , insertMap - , insertMapWith - , insertMapWithKey - , insertMapMin - , insertMapMax - , unsafeFromMap - - -- * Construction - , singleton - , fromSet - - -- ** From Unordered Lists - , fromList - , fromListWith - , fromListWithKey - - -- ** From Ascending Lists - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Insertion - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - - -- * Deletion\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - , alterF - , alter' - , alterF' - - -- * Query - -- ** Lookup - , lookup - , (!?) - , (!) - , findWithDefault - , member - , notMember - , lookupLT - , lookupGT - , lookupLE - , lookupGE - - -- ** Size - , size - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - , unionsWith - - -- ** Difference - , difference - , (\\) - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- -- ** Universal combining function - -- , mergeWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , traverseWithKey1 - , traverseWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeys - , mapKeysWith - , mapKeysMonotonic - - -- * Folds - , foldr - , foldl - , foldr1 - , foldl1 - , foldrWithKey - , foldlWithKey - , foldMapWithKey - - -- ** Strict folds - , foldr' - , foldr1' - , foldl' - , foldl1' - , foldrWithKey' - , foldlWithKey' - - -- * Conversion - , elems - , keys - , assocs - , keysSet - - -- ** Lists - , toList - - -- ** Ordered lists - , toAscList - , toDescList - - -- * Filter - , filter - , filterWithKey - , restrictKeys - , withoutKeys - , partition - , partitionWithKey - - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - - , split - , splitLookup - , splitRoot - - -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy - - -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , updateMin - , updateMax - , adjustMin - , adjustMax - , updateMinWithKey - , updateMaxWithKey - , adjustMinWithKey - , adjustMaxWithKey - , minView - , maxView - - -- * Debugging - , valid - ) where - -import Control.Applicative -import Data.Bifunctor -import Data.Functor.Identity -import Data.IntMap.Internal (IntMap(..)) -import Data.IntMap.NonEmpty.Internal -import Data.IntSet (IntSet) -import Data.IntSet.NonEmpty.Internal (NEIntSet(..)) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe hiding (mapMaybe) -import Data.Semigroup.Foldable (Foldable1) -import Data.These -import Prelude hiding (Foldable(..), map, filter, lookup) -import qualified Data.Foldable as F -import qualified Data.IntMap as M -import qualified Data.IntSet as S -import qualified Data.List.NonEmpty as NE -import qualified Data.Maybe as Maybe -import qualified Data.Semigroup.Foldable as F1 - --- | /O(1)/ match, /O(log n)/ usage of contents. The 'IsNonEmpty' and --- 'IsEmpty' patterns allow you to treat a 'IntMap' as if it were either --- a @'IsNonEmpty' n@ (where @n@ is a 'NEIntMap') or an 'IsEmpty'. --- --- For example, you can pattern match on a 'IntMap': --- --- @ --- myFunc :: 'IntMap' K X -> Y --- myFunc ('IsNonEmpty' n) = -- here, the user provided a non-empty map, and @n@ is the 'NEIntMap' --- myFunc 'IsEmpty' = -- here, the user provided an empty map. --- @ --- --- Matching on @'IsNonEmpty' n@ means that the original 'IntMap' was /not/ --- empty, and you have a verified-non-empty 'NEIntMap' @n@ to use. --- --- Note that patching on this pattern is /O(1)/. However, using the --- contents requires a /O(log n)/ cost that is deferred until after the --- pattern is matched on (and is not incurred at all if the contents are --- never used). --- --- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides --- complete coverage. --- --- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert --- a 'NEIntMap' back into a 'IntMap', obscuring its non-emptiness (see 'toMap'). -pattern IsNonEmpty :: NEIntMap a -> IntMap a -pattern IsNonEmpty n <- (nonEmptyMap->Just n) - where - IsNonEmpty n = toMap n - --- | /O(1)/. The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat --- a 'IntMap' as if it were either a @'IsNonEmpty' n@ (where @n@ is --- a 'NEIntMap') or an 'IsEmpty'. --- --- Matching on 'IsEmpty' means that the original 'IntMap' was empty. --- --- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides --- complete coverage. --- --- This is a bidirectional pattern, so you can use 'IsEmpty' as an --- expression, and it will be interpreted as 'Data.IntMap.empty'. --- --- See 'IsNonEmpty' for more information. -pattern IsEmpty :: IntMap a -pattern IsEmpty <- (M.null->True) - where - IsEmpty = M.empty - -{-# COMPLETE IsNonEmpty, IsEmpty #-} - --- | /O(log n)/. Unsafe version of 'nonEmptyMap'. Coerces a 'IntMap' into an --- 'NEIntMap', but is undefined (throws a runtime exception when evaluation is --- attempted) for an empty 'IntMap'. -unsafeFromMap - :: IntMap a - -> NEIntMap a -unsafeFromMap = withNonEmpty e id - where - e = errorWithoutStackTrace "NEIntMap.unsafeFromMap: empty map" -{-# INLINE unsafeFromMap #-} - --- | /O(log n)/. Convert a 'IntMap' into an 'NEIntMap' by adding a key-value --- pair. Because of this, we know that the map must have at least one --- element, and so therefore cannot be empty. If key is already present, --- will overwrite the original value. --- --- See 'insertMapMin' for a version that is constant-time if the new key is --- /strictly smaller than/ all keys in the original map. --- --- > insertMap 4 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) --- > insertMap 4 "c" Data.IntMap.empty == singleton 4 "c" -insertMap :: Key -> a -> IntMap a -> NEIntMap a -insertMap k v = withNonEmpty (singleton k v) (insert k v) -{-# INLINE insertMap #-} - --- | /O(log n)/. Convert a 'IntMap' into an 'NEIntMap' by adding a key-value --- pair. Because of this, we know that the map must have at least one --- element, and so therefore cannot be empty. Uses a combining function --- with the new value as the first argument if the key is already present. --- --- > insertMapWith (++) 4 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) --- > insertMapWith (++) 5 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"ca")]) -insertMapWith - :: (a -> a -> a) - -> Key - -> a - -> IntMap a - -> NEIntMap a -insertMapWith f k v = withNonEmpty (singleton k v) (insertWith f k v) -{-# INLINE insertMapWith #-} - --- | /O(log n)/. Convert a 'IntMap' into an 'NEIntMap' by adding a key-value --- pair. Because of this, we know that the map must have at least one --- element, and so therefore cannot be empty. Uses a combining function --- with the key and new value as the first and second arguments if the key --- is already present. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "5:xxx|a")]) --- > insertWithKey f 7 "xxx" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) --- > insertWithKey f 5 "xxx" Data.IntMap.empty == singleton 5 "xxx" -insertMapWithKey - :: (Key -> a -> a -> a) - -> Key - -> a - -> IntMap a - -> NEIntMap a -insertMapWithKey f k v = withNonEmpty (singleton k v) (insertWithKey f k v) -{-# INLINE insertMapWithKey #-} - --- | /O(1)/ Convert a 'IntMap' into an 'NEIntMap' by adding a key-value pair --- where the key is /strictly less than/ all keys in the input map. The --- keys in the original map must all be /strictly greater than/ the new --- key. /The precondition is not checked./ --- --- > insertMapMin 2 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((2,"c") :| [(3,"b"), (5,"a")]) --- > valid (insertMapMin 2 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == True --- > valid (insertMapMin 7 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False --- > valid (insertMapMin 3 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False -insertMapMin - :: Key - -> a - -> IntMap a - -> NEIntMap a -insertMapMin = NEIntMap -{-# INLINE insertMapMin #-} - --- | /O(log n)/ Convert a 'IntMap' into an 'NEIntMap' by adding a key-value pair --- where the key is /strictly greater than/ all keys in the input map. The --- keys in the original map must all be /strictly less than/ the new --- key. /The precondition is not checked./ --- --- At the current moment, this is identical simply 'insertMap'; however, --- it is left both for consistency and as a placeholder for a future --- version where optimizations are implemented to allow for a faster --- implementation. --- --- > insertMap 7 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"a"), (7,"c")]) - --- these currently are all valid, but shouldn't be --- > valid (insertMap 7 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == True --- > valid (insertMap 2 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False --- > valid (insertMap 5 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False -insertMapMax - :: Key - -> a - -> IntMap a - -> NEIntMap a -insertMapMax k v = withNonEmpty (singleton k v) go - where - go (NEIntMap k0 v0 m0) = NEIntMap k0 v0 . insertMaxMap k v $ m0 -{-# INLINE insertMapMax #-} - --- | /O(n)/. Build a non-empty map from a non-empty set of keys and --- a function which for each key computes its value. --- --- > fromSet (\k -> replicate k 'a') (Data.Set.NonEmpty.fromList (3 :| [5])) == fromList ((5,"aaaaa") :| [(3,"aaa")]) -fromSet - :: (Key -> a) - -> NEIntSet - -> NEIntMap a -fromSet f (NEIntSet k ks) = NEIntMap k (f k) (M.fromSet f ks) -{-# INLINE fromSet #-} - --- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs --- with a combining function. See also 'fromAscListWith'. --- --- > fromListWith (++) ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "ab") :| [(5, "aba")]) -fromListWith - :: (a -> a -> a) - -> NonEmpty (Key, a) - -> NEIntMap a -fromListWith f = fromListWithKey (const f) -{-# INLINE fromListWith #-} - --- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs --- with a combining function. See also 'fromAscListWithKey'. --- --- > let f k a1 a2 = (show k) ++ a1 ++ a2 --- > fromListWithKey f ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "3ab") :| [(5, "5a5ba")]) -fromListWithKey - :: (Key -> a -> a -> a) - -> NonEmpty (Key, a) - -> NEIntMap a -fromListWithKey f ((k0, v0) :| xs) = F.foldl' go (singleton k0 v0) xs - where - go m (k, v) = insertWithKey f k v m - {-# INLINE go #-} -{-# INLINE fromListWithKey #-} - --- | /O(n)/. Build a map from an ascending non-empty list in linear time. --- /The precondition (input list is ascending) is not checked./ --- --- > fromAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) --- > fromAscList ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "b")]) --- > valid (fromAscList ((3,"b") :| [(5,"a"), (5,"b")])) == True --- > valid (fromAscList ((5,"a") :| [(3,"b"), (5,"b")])) == False -fromAscList - :: NonEmpty (Key, a) - -> NEIntMap a -fromAscList = fromDistinctAscList . combineEq -{-# INLINE fromAscList #-} - --- | /O(n)/. Build a map from an ascending non-empty list in linear time --- with a combining function for equal keys. /The precondition (input list --- is ascending) is not checked./ --- --- > fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "ba")]) --- > valid (fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b"))]) == True --- > valid (fromAscListWith (++) ((5,"a") :| [(3,"b"), (5,"b"))]) == False -fromAscListWith - :: (a -> a -> a) - -> NonEmpty (Key, a) - -> NEIntMap a -fromAscListWith f = fromAscListWithKey (const f) -{-# INLINE fromAscListWith #-} - --- | /O(n)/. Build a map from an ascending non-empty list in linear time --- with a combining function for equal keys. /The precondition (input list --- is ascending) is not checked./ --- --- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 --- > fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")]) == fromList ((3, "b") :| [(5, "5:b5:ba")]) --- > valid (fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")])) == True --- > valid (fromAscListWithKey f ((5,"a") :| [(3,"b"), (5,"b"), (5,"b")])) == False -fromAscListWithKey - :: (Key -> a -> a -> a) - -> NonEmpty (Key, a) - -> NEIntMap a -fromAscListWithKey f = fromDistinctAscList . combineEqWith f -{-# INLINE fromAscListWithKey #-} - --- | /O(n)/. Build a map from an ascending non-empty list of distinct --- elements in linear time. /The precondition is not checked./ --- --- > fromDistinctAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) --- > valid (fromDistinctAscList ((3,"b") :| [(5,"a")])) == True --- > valid (fromDistinctAscList ((3,"b") :| [(5,"a"), (5,"b")])) == False -fromDistinctAscList :: NonEmpty (Key, a) -> NEIntMap a -fromDistinctAscList ((k, v) :| xs) = insertMapMin k v - . M.fromDistinctAscList - $ xs -{-# INLINE fromDistinctAscList #-} - --- | /O(log n)/. Insert a new key and value in the map. --- If the key is already present in the map, the associated value is --- replaced with the supplied value. 'insert' is equivalent to --- @'insertWith' 'const'@. --- --- See 'insertMap' for a version where the first argument is a 'IntMap'. --- --- > insert 5 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'x')]) --- > insert 7 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'a'), (7, 'x')]) -insert - :: Key - -> a - -> NEIntMap a - -> NEIntMap a -insert k v n@(NEIntMap k0 v0 m) = case compare k k0 of - LT -> NEIntMap k v . toMap $ n - EQ -> NEIntMap k v m - GT -> NEIntMap k0 v0 . M.insert k v $ m -{-# INLINE insert #-} - --- | /O(log n)/. Insert with a function, combining key, new value and old --- value. @'insertWithKey' f key value mp@ will insert the pair (key, --- value) into @mp@ if key does not exist in the map. If the key does --- exist, the function will insert the pair @(key,f key new_value --- old_value)@. Note that the key passed to f is the same key passed to --- 'insertWithKey'. --- --- See 'insertMapWithKey' for a version where the first argument is a 'IntMap'. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:xxx|a")]) --- > insertWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) -insertWithKey - :: (Key -> a -> a -> a) - -> Key - -> a - -> NEIntMap a - -> NEIntMap a -insertWithKey f k v n@(NEIntMap k0 v0 m) = case compare k k0 of - LT -> NEIntMap k v . toMap $ n - EQ -> NEIntMap k (f k v v0) m - GT -> NEIntMap k0 v0 $ M.insertWithKey f k v m -{-# INLINE insertWithKey #-} - --- | /O(log n)/. Combines insert operation with old value retrieval. The --- expression (@'insertLookupWithKey' f k x map@) is a pair where the first --- element is equal to (@'lookup' k map@) and the second element equal to --- (@'insertWithKey' f k x map@). --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertLookupWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "5:xxx|a")])) --- > insertLookupWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "xxx")])) --- --- This is how to define @insertLookup@ using @insertLookupWithKey@: --- --- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t --- > insertLookup 5 "x" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "x")])) --- > insertLookup 7 "x" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "x")])) -insertLookupWithKey - :: (Key -> a -> a -> a) - -> Key - -> a - -> NEIntMap a - -> (Maybe a, NEIntMap a) -insertLookupWithKey f k v n@(NEIntMap k0 v0 m) = case compare k k0 of - LT -> (Nothing, NEIntMap k v . toMap $ n ) - EQ -> (Just v , NEIntMap k (f k v v0) m ) - GT -> NEIntMap k0 v0 <$> M.insertLookupWithKey f k v m -{-# INLINE insertLookupWithKey #-} - --- | /O(log n)/. Delete a key and its value from the non-empty map. --- A potentially empty map ('IntMap') is returned, since this might delete the --- last item in the 'NEIntMap'. When the key is not a member of the map, is --- equivalent to 'toMap'. --- --- > delete 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" --- > delete 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.Singleton [(3, "b"), (5, "a")] -delete :: Key -> NEIntMap a -> IntMap a -delete k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> toMap n - EQ -> m - GT -> insertMinMap k0 v . M.delete k $ m -{-# INLINE delete #-} - --- | /O(log n)/. Update a value at a specific key with the result of the --- provided function. When the key is not a member of the map, the original --- map is returned. --- --- > adjust ("new " ++) 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "new a")]) --- > adjust ("new " ++) 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) -adjust - :: (a -> a) - -> Key - -> NEIntMap a - -> NEIntMap a -adjust f = adjustWithKey (const f) -{-# INLINE adjust #-} - --- | /O(log n)/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > let f key x = (show key) ++ ":new " ++ x --- > adjustWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:new a")]) --- > adjustWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) -adjustWithKey - :: (Key -> a -> a) - -> Key - -> NEIntMap a - -> NEIntMap a -adjustWithKey f k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> n - EQ -> NEIntMap k0 (f k0 v) m - GT -> NEIntMap k0 v . M.adjustWithKey f k $ m -{-# INLINE adjustWithKey #-} - --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- Returns a potentially empty map ('IntMap'), because we can't know ahead of --- time if the function returns 'Nothing' and deletes the final item in the --- 'NEIntMap'. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > update f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "new a")] --- > update f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a")] --- > update f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" -update - :: (a -> Maybe a) - -> Key - -> NEIntMap a - -> IntMap a -update f = updateWithKey (const f) -{-# INLINE update #-} - --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the --- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', --- the element is deleted. If it is (@'Just' y@), the key @k@ is bound --- to the new value @y@. --- --- Returns a potentially empty map ('IntMap'), because we can't know ahead of --- time if the function returns 'Nothing' and deletes the final item in the --- 'NEIntMap'. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "5:new a")] --- > updateWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a")] --- > updateWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" -updateWithKey - :: (Key -> a -> Maybe a) - -> Key - -> NEIntMap a - -> IntMap a -updateWithKey f k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> toMap n - EQ -> maybe m (flip (insertMinMap k0) m) . f k0 $ v - GT -> insertMinMap k0 v . M.updateWithKey f k $ m -{-# INLINE updateWithKey #-} - --- | /O(min(n,W))/. Lookup and update. --- The function returns original value, if it is updated. --- This is different behavior than @Data.Map.NonEmpty.updateLookupWithKey@. --- Returns the original key value if the map entry is deleted. --- --- Returns a potentially empty map ('IntMap') in the case that we delete --- the final key of a singleton map. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateLookupWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == (Just "5:new a", Data.IntMap.fromList ((3, "b") :| [(5, "5:new a")])) --- > updateLookupWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == (Nothing, Data.IntMap.fromList ((3, "b") :| [(5, "a")])) --- > updateLookupWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == (Just "b", Data.IntMap.singleton 5 "a") -updateLookupWithKey - :: (Key -> a -> Maybe a) - -> Key - -> NEIntMap a - -> (Maybe a, IntMap a) -updateLookupWithKey f k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> (Nothing, toMap n) - EQ -> let u = f k0 v - in (Just v, maybe m (flip (insertMinMap k0) m) u) - GT -> fmap (insertMinMap k0 v) . M.updateLookupWithKey f k $ m -{-# INLINE updateLookupWithKey #-} - --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at --- @k@, or absence thereof. 'alter' can be used to insert, delete, or --- update a value in a 'IntMap'. In short : @Data.IntMap.lookup k ('alter' --- f k m) = f ('lookup' k m)@. --- --- Returns a potentially empty map ('IntMap'), because we can't know ahead of --- time if the function returns 'Nothing' and deletes the final item in the --- 'NEIntMap'. --- --- See 'alterF'' for a version that disallows deletion, and so therefore --- can return 'NEIntMap'. --- --- > let f _ = Nothing --- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a")] --- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" --- > --- > let f _ = Just "c" --- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a"), (7, "c")] --- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "c")] -alter - :: (Maybe a -> Maybe a) - -> Key - -> NEIntMap a - -> IntMap a -alter f k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> ($ toMap n) . maybe id (insertMinMap k ) $ f Nothing - EQ -> ($ m ) . maybe id (insertMinMap k0) $ f (Just v) - GT -> insertMinMap k0 v . M.alter f k $ m -{-# INLINE alter #-} - --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ --- at @k@, or absence thereof. 'alterF' can be used to inspect, insert, --- delete, or update a value in a 'IntMap'. In short: @Data.IntMap.lookup --- k \<$\> 'alterF' f k m = f ('lookup' k m)@. --- --- Example: --- --- @ --- interactiveAlter :: Int -> NEIntMap Int String -> IO (IntMap Int String) --- interactiveAlter k m = alterF f k m where --- f Nothing = do --- putStrLn $ show k ++ --- " was not found in the map. Would you like to add it?" --- getUserResponse1 :: IO (Maybe String) --- f (Just old) = do --- putStrLn $ "The key is currently bound to " ++ show old ++ --- ". Would you like to change or delete it?" --- getUserResponse2 :: IO (Maybe String) --- @ --- --- Like @Data.IntMap.alterF@ for 'IntMap', 'alterF' can be considered --- to be a unifying generalization of 'lookup' and 'delete'; however, as --- a constrast, it cannot be used to implement 'insert', because it must --- return a 'IntMap' instead of an 'NEIntMap' (because the function might delete --- the final item in the 'NEIntMap'). When used with trivial functors like --- 'Identity' and 'Const', it is often slightly slower than --- specialized 'lookup' and 'delete'. However, when the functor is --- non-trivial and key comparison is not particularly cheap, it is the --- fastest way. --- --- See 'alterF'' for a version that disallows deletion, and so therefore --- can return 'NEIntMap' and be used to implement 'insert' --- --- Note on rewrite rules: --- --- This module includes GHC rewrite rules to optimize 'alterF' for --- the 'Const' and 'Identity' functors. In general, these rules --- improve performance. The sole exception is that when using --- 'Identity', deleting a key that is already absent takes longer --- than it would without the rules. If you expect this to occur --- a very large fraction of the time, you might consider using a --- private copy of the 'Identity' type. --- --- Note: Unlike @Data.IntMap.alterF@ for 'IntMap', 'alterF' is /not/ a flipped --- version of the 'Control.Lens.At.at' combinator from "Control.Lens.At". --- However, it match the shape expected from most functions expecting --- lenses, getters, and setters, so can be thought of as a "psuedo-lens", --- with virtually the same practical applications as a legitimate lens. -alterF - :: Functor f - => (Maybe a -> f (Maybe a)) - -> Key - -> NEIntMap a - -> f (IntMap a) -alterF f k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> ($ toMap n) . maybe id (insertMinMap k ) <$> f Nothing - EQ -> ($ m ) . maybe id (insertMinMap k0) <$> f (Just v) - GT -> insertMinMap k0 v <$> M.alterF f k m -{-# INLINABLE [2] alterF #-} - --- if f ~ Const b, it's a lookup -{-# RULES -"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m - #-} --- if f ~ Identity, it's an 'alter' -{-# RULES -"alterF/Identity" forall k (f :: Maybe a -> Identity (Maybe a)) . alterF f k = Identity . alter (runIdentity . f) k - #-} - --- | /O(log n)/. Variant of 'alter' that disallows deletion. Allows us to --- guarantee that the result is also a non-empty IntMap. -alter' - :: (Maybe a -> a) - -> Key - -> NEIntMap a - -> NEIntMap a -alter' f k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> NEIntMap k (f Nothing) . toMap $ n - EQ -> NEIntMap k0 (f (Just v)) $ m - GT -> NEIntMap k0 v . M.alter (Just . f) k $ m -{-# INLINE alter' #-} - --- | /O(log n)/. Variant of 'alterF' that disallows deletion. Allows us to --- guarantee that the result is also a non-empty IntMap. --- --- Like @Data.IntMap.alterF@ for 'IntMap', can be used to generalize and unify --- 'lookup' and 'insert'. However, because it disallows deletion, it --- cannot be used to implement 'delete'. --- --- See 'alterF' for usage information and caveats. --- --- Note: Neither 'alterF' nor 'alterF'' can be considered flipped versions --- of the 'Control.Lens.At.at' combinator from "Control.Lens.At". However, --- this can match the shape expected from most functions expecting lenses, --- getters, and setters, so can be thought of as a "psuedo-lens", with --- virtually the same practical applications as a legitimate lens. --- --- __WARNING__: The rewrite rule for 'Identity' exposes an inconsistency in --- undefined behavior for "Data.IntMap". @Data.IntMap.alterF@ will actually --- /maintain/ the original key in the map when used with 'Identity'; --- however, @Data.IntMap.insertWith@ will /replace/ the orginal key in the --- map. The rewrite rule for 'alterF'' has chosen to be faithful to --- @Data.IntMap.insertWith@, and /not/ @Data.IntMap.alterF@, for the sake of --- a cleaner implementation. -alterF' - :: Functor f - => (Maybe a -> f a) - -> Key - -> NEIntMap a - -> f (NEIntMap a) -alterF' f k n@(NEIntMap k0 v m) = case compare k k0 of - LT -> flip (NEIntMap k ) (toMap n) <$> f Nothing - EQ -> flip (NEIntMap k0) m <$> f (Just v) - GT -> NEIntMap k0 v <$> M.alterF (fmap Just . f) k m -{-# INLINABLE [2] alterF' #-} - --- if f ~ Const b, it's a lookup -{-# RULES -"alterF'/Const" forall k (f :: Maybe a -> Const b a) . alterF' f k = \m -> Const . getConst . f $ lookup k m - #-} --- if f ~ Identity, it's an insertWith -{-# RULES -"alterF'/Identity" forall k (f :: Maybe a -> Identity a) . alterF' f k = Identity . insertWith (\_ -> runIdentity . f . Just) k (runIdentity (f Nothing)) - #-} - --- | /O(log n)/. Lookup the value at a key in the map. --- --- The function will return the corresponding value as @('Just' value)@, --- or 'Nothing' if the key isn't in the map. --- --- An example of using @lookup@: --- --- > import Prelude hiding (lookup) --- > import Data.Map.NonEmpty --- > --- > employeeDept = fromList (("John","Sales") :| [("Bob","IT")]) --- > deptCountry = fromList (("IT","USA") :| [("Sales","France")]) --- > countryCurrency = fromList (("USA", "Dollar") :| [("France", "Euro")]) --- > --- > employeeCurrency :: String -> Maybe String --- > employeeCurrency name = do --- > dept <- lookup name employeeDept --- > country <- lookup dept deptCountry --- > lookup country countryCurrency --- > --- > main = do --- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John")) --- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete")) --- --- The output of this program: --- --- > John's currency: Just "Euro" --- > Pete's currency: Nothing -lookup - :: Key - -> NEIntMap a - -> Maybe a -lookup k (NEIntMap k0 v m) = case compare k k0 of - LT -> Nothing - EQ -> Just v - GT -> M.lookup k m -{-# INLINE lookup #-} - --- | /O(log n)/. Find the value at a key. Returns 'Nothing' when the --- element can not be found. --- --- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 1 == Nothing --- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 5 == Just 'a' -(!?) :: NEIntMap a -> Key -> Maybe a -(!?) = flip lookup -{-# INLINE (!?) #-} - --- | /O(log n)/. Find the value at a key. Calls 'error' when the element --- can not be found. --- --- > fromList ((5,'a') :| [(3,'b')]) ! 1 Error: element not in the map --- > fromList ((5,'a') :| [(3,'b')]) ! 5 == 'a' -(!) :: NEIntMap a -> Key -> a -(!) m k = fromMaybe e $ m !? k - where - e = error "NEIntMap.!: given key is not an element in the map" -{-# INLINE (!) #-} - -infixl 9 !? -infixl 9 ! - --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns --- the value at key @k@ or returns default value @def@ --- when the key is not in the map. --- --- > findWithDefault 'x' 1 (fromList ((5,'a') :| [(3,'b')])) == 'x' --- > findWithDefault 'x' 5 (fromList ((5,'a') :| [(3,'b')])) == 'a' -findWithDefault - :: a - -> Key - -> NEIntMap a - -> a -findWithDefault def k (NEIntMap k0 v m) = case compare k k0 of - LT -> def - EQ -> v - GT -> M.findWithDefault def k m -{-# INLINE findWithDefault #-} - --- | /O(log n)/. Is the key a member of the map? See also 'notMember'. --- --- > member 5 (fromList ((5,'a') :| [(3,'b')])) == True --- > member 1 (fromList ((5,'a') :| [(3,'b')])) == False -member :: Key -> NEIntMap a -> Bool -member k (NEIntMap k0 _ m) = case compare k k0 of - LT -> False - EQ -> True - GT -> M.member k m -{-# INLINE member #-} - --- | /O(log n)/. Is the key not a member of the map? See also 'member'. --- --- > notMember 5 (fromList ((5,'a') :| [(3,'b')])) == False --- > notMember 1 (fromList ((5,'a') :| [(3,'b')])) == True -notMember :: Key -> NEIntMap a -> Bool -notMember k (NEIntMap k0 _ m) = case compare k k0 of - LT -> True - EQ -> False - GT -> M.notMember k m -{-# INLINE notMember #-} - --- | /O(log n)/. Find largest key smaller than the given one and return the --- corresponding (key, value) pair. --- --- > lookupLT 3 (fromList ((3,'a') :| [(5,'b')])) == Nothing --- > lookupLT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') -lookupLT :: Key -> NEIntMap a -> Maybe (Key, a) -lookupLT k (NEIntMap k0 v m) = case compare k k0 of - LT -> Nothing - EQ -> Nothing - GT -> M.lookupLT k m <|> Just (k0, v) -{-# INLINE lookupLT #-} - --- | /O(log n)/. Find smallest key greater than the given one and return the --- corresponding (key, value) pair. --- --- > lookupGT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') --- > lookupGT 5 (fromList ((3,'a') :| [(5,'b')])) == Nothing -lookupGT :: Key -> NEIntMap a -> Maybe (Key, a) -lookupGT k (NEIntMap k0 v m) = case compare k k0 of - LT -> Just (k0, v) - EQ -> lookupMinMap m - GT -> M.lookupGT k m -{-# INLINE lookupGT #-} - --- | /O(log n)/. Find largest key smaller or equal to the given one and return --- the corresponding (key, value) pair. --- --- > lookupLE 2 (fromList ((3,'a') :| [(5,'b')])) == Nothing --- > lookupLE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') --- > lookupLE 5 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') -lookupLE :: Key -> NEIntMap a -> Maybe (Key, a) -lookupLE k (NEIntMap k0 v m) = case compare k k0 of - LT -> Nothing - EQ -> Just (k0, v) - GT -> M.lookupLE k m <|> Just (k0, v) -{-# INLINE lookupLE #-} - --- | /O(log n)/. Find smallest key greater or equal to the given one and return --- the corresponding (key, value) pair. --- --- > lookupGE 3 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') --- > lookupGE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') --- > lookupGE 6 (fromList ((3,'a') :| [(5,'b')])) == Nothing -lookupGE :: Key -> NEIntMap a -> Maybe (Key, a) -lookupGE k (NEIntMap k0 v m) = case compare k k0 of - LT -> Just (k0, v) - EQ -> Just (k0, v) - GT -> M.lookupGE k m -{-# INLINE lookupGE #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function. --- --- > unionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "aA"), (7, "C")]) -unionWith - :: (a -> a -> a) - -> NEIntMap a - -> NEIntMap a - -> NEIntMap a -unionWith f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of - LT -> NEIntMap k1 v1 . M.unionWith f m1 . toMap $ n2 - EQ -> NEIntMap k1 (f v1 v2) . M.unionWith f m1 $ m2 - GT -> NEIntMap k2 v2 . M.unionWith f (toMap n1) $ m2 -{-# INLINE unionWith #-} - --- | /O(m*log(n\/m + 1)), m <= n/. --- Union with a combining function, given the matching key. --- --- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value --- > unionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "5:a|A"), (7, "C")]) -unionWithKey - :: (Key -> a -> a -> a) - -> NEIntMap a - -> NEIntMap a - -> NEIntMap a -unionWithKey f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of - LT -> NEIntMap k1 v1 . M.unionWithKey f m1 . toMap $ n2 - EQ -> NEIntMap k1 (f k1 v1 v2) . M.unionWithKey f m1 $ m2 - GT -> NEIntMap k2 v2 . M.unionWithKey f (toMap n1) $ m2 -{-# INLINE unionWithKey #-} - --- | The union of a non-empty list of maps, with a combining operation: --- (@'unionsWith' f == 'Data.Foldable.foldl1' ('unionWith' f)@). --- --- > unionsWith (++) (fromList ((5, "a") :| [(3, "b")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "A3") :| [(3, "B3")])]) --- > == fromList ((3, "bB3") :| [(5, "aAA3"), (7, "C")]) -unionsWith - :: Foldable1 f - => (a -> a -> a) - -> f (NEIntMap a) - -> NEIntMap a -unionsWith f (F1.toNonEmpty->(m :| ms)) = F.foldl' (unionWith f) m ms -{-# INLINE unionsWith #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps. --- Return elements of the first map not existing in the second map. --- --- Returns a potentially empty map ('IntMap'), in case the first map is --- a subset of the second map. --- --- > difference (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 3 "b" -difference - :: NEIntMap a - -> NEIntMap b - -> IntMap a -difference n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 _ m2) = case compare k1 k2 of - -- k1 is not in n2, so cannot be deleted - LT -> insertMinMap k1 v1 $ m1 `M.difference` toMap n2 - -- k2 deletes k1, and only k1 - EQ -> m1 `M.difference` m2 - -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. - GT -> toMap n1 `M.difference` m2 -{-# INLINE difference #-} - --- | Same as 'difference'. -(\\) - :: NEIntMap a - -> NEIntMap b - -> IntMap a -(\\) = difference -{-# INLINE (\\) #-} - --- | /O(n+m)/. Difference with a combining function. --- When two equal keys are --- encountered, the combining function is applied to the values of these keys. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- --- Returns a potentially empty map ('IntMap'), in case the first map is --- a subset of the second map and the function returns 'Nothing' for every --- pair. --- --- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing --- > differenceWith f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (7, "C")])) --- > == Data.IntMap.singleton 3 "b:B" -differenceWith - :: (a -> b -> Maybe a) - -> NEIntMap a - -> NEIntMap b - -> IntMap a -differenceWith f = differenceWithKey (const f) -{-# INLINE differenceWith #-} - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- --- Returns a potentially empty map ('IntMap'), in case the first map is --- a subset of the second map and the function returns 'Nothing' for every --- pair. --- --- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing --- > differenceWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (10, "C")])) --- > == Data.IntMap.singleton 3 "3:b|B" -differenceWithKey - :: (Key -> a -> b -> Maybe a) - -> NEIntMap a - -> NEIntMap b - -> IntMap a -differenceWithKey f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of - -- k1 is not in n2, so cannot be deleted - LT -> insertMinMap k1 v1 $ M.differenceWithKey f m1 (toMap n2) - -- k2 deletes k1, and only k1 - EQ -> ($ M.differenceWithKey f m1 m2) . maybe id (insertMinMap k1) $ f k1 v1 v2 - -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. - GT -> M.differenceWithKey f (toMap n1) m2 -{-# INLINE differenceWithKey #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps. --- Return data in the first map for the keys existing in both maps. --- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). --- --- Returns a potentially empty map ('IntMap'), in case the two maps share no --- keys in common. --- --- > intersection (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 5 "a" -intersection - :: NEIntMap a - -> NEIntMap b - -> IntMap a -intersection n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 _ m2) = case compare k1 k2 of - -- k1 is not in n2 - LT -> m1 `M.intersection` toMap n2 - -- k1 and k2 are a part of the result - EQ -> insertMinMap k1 v1 $ m1 `M.intersection` m2 - -- k2 is not in n1 - GT -> toMap n1 `M.intersection` m2 -{-# INLINE intersection #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. --- --- Returns a potentially empty map ('IntMap'), in case the two maps share no --- keys in common. --- --- > intersectionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 5 "aA" -intersectionWith - :: (a -> b -> c) - -> NEIntMap a - -> NEIntMap b - -> IntMap c -intersectionWith f = intersectionWithKey (const f) -{-# INLINE intersectionWith #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. --- --- Returns a potentially empty map ('IntMap'), in case the two maps share no --- keys in common. --- --- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar --- > intersectionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 5 "5:a|A" -intersectionWithKey - :: (Key -> a -> b -> c) - -> NEIntMap a - -> NEIntMap b - -> IntMap c -intersectionWithKey f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of - -- k1 is not in n2 - LT -> M.intersectionWithKey f m1 (toMap n2) - -- k1 and k2 are a part of the result - EQ -> insertMinMap k1 (f k1 v1 v2) $ M.intersectionWithKey f m1 m2 - -- k2 is not in n1 - GT -> M.intersectionWithKey f (toMap n1) m2 -{-# INLINE intersectionWithKey #-} - --- | /O(n)/. IntMap a function over all values in the map. --- --- > let f key x = (show key) ++ ":" ++ x --- > mapWithKey f (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "3:b") :| [(5, "5:a")]) -mapWithKey :: (Key -> a -> b) -> NEIntMap a -> NEIntMap b -mapWithKey f (NEIntMap k v m) = NEIntMap k (f k v) (M.mapWithKey f m) -{-# NOINLINE [1] mapWithKey #-} -{-# RULES -"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) = - mapWithKey (\k a -> f k (g k a)) xs -"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) = - mapWithKey (\k a -> f k (g a)) xs -"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) = - mapWithKey (\k a -> f (g k a)) xs - #-} - --- | /O(n)/. The function 'mapAccum' threads an accumulating argument --- through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList ((5,"a") :| [(3,"b")])) == ("Everything: ba", fromList ((3, "bX") :| [(5, "aX")])) -mapAccum - :: (a -> b -> (a, c)) - -> a - -> NEIntMap b - -> (a, NEIntMap c) -mapAccum f = mapAccumWithKey (\x _ -> f x) -{-# INLINE mapAccum #-} - --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList ((5,"a") :| [(3,"b")])) == ("Everything: 3-b 5-a", fromList ((3, "bX") :| [(5, "aX")])) -mapAccumWithKey - :: (a -> Key -> b -> (a, c)) - -> a - -> NEIntMap b - -> (a, NEIntMap c) -mapAccumWithKey f z0 (NEIntMap k v m) = (z2, NEIntMap k v' m') - where - ~(z1, v') = f z0 k v - ~(z2, m') = M.mapAccumWithKey f z1 m -{-# INLINE mapAccumWithKey #-} - --- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey - :: (a -> Key -> b -> (a, c)) - -> a - -> NEIntMap b - -> (a, NEIntMap c) -mapAccumRWithKey f z0 (NEIntMap k v m) = (z2, NEIntMap k v' m') - where - ~(z1, m') = M.mapAccumRWithKey f z0 m - ~(z2, v') = f z1 k v -{-# INLINE mapAccumRWithKey #-} - --- | /O(n*log n)/. --- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the value at the greatest of the --- original keys is retained. --- --- While the size of the result map may be smaller than the input map, the --- output map is still guaranteed to be non-empty if the input map is --- non-empty. --- --- > mapKeys (+ 1) (fromList ((5,"a") :| [(3,"b")])) == fromList ((4, "b") :| [(6, "a")]) --- > mapKeys (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "c" --- > mapKeys (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "c" -mapKeys - :: (Key -> Key) - -> NEIntMap a - -> NEIntMap a -mapKeys f (NEIntMap k0 v0 m) = fromListWith const - . ((f k0, v0) :|) - . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] - $ m -{-# INLINABLE mapKeys #-} - --- | /O(n*log n)/. --- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. The value at the greater of the two original keys --- is used as the first argument to @c@. --- --- While the size of the result map may be smaller than the input map, the --- output map is still guaranteed to be non-empty if the input map is --- non-empty. --- --- > mapKeysWith (++) (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "cdab" --- > mapKeysWith (++) (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "cdab" -mapKeysWith - :: (a -> a -> a) - -> (Key -> Key) - -> NEIntMap a - -> NEIntMap a -mapKeysWith c f (NEIntMap k0 v0 m) = fromListWith c - . ((f k0, v0) :|) - . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] - $ m -{-# INLINABLE mapKeysWith #-} - --- | /O(n)/. --- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ --- is strictly monotonic. --- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. --- /The precondition is not checked./ --- Semi-formally, we have: --- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- > ==> mapKeysMonotonic f s == mapKeys f s --- > where ls = keys s --- --- This means that @f@ maps distinct original keys to distinct resulting keys. --- This function has better performance than 'mapKeys'. --- --- While the size of the result map may be smaller than the input map, the --- output map is still guaranteed to be non-empty if the input map is --- non-empty. --- --- > mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")])) == fromList ((6, "b") :| [(10, "a")]) --- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")]))) == True --- > valid (mapKeysMonotonic (\ _ -> 1) (fromList ((5,"a") :| [(3,"b")]))) == False -mapKeysMonotonic - :: (Key -> Key) - -> NEIntMap a - -> NEIntMap a -mapKeysMonotonic f (NEIntMap k v m) = NEIntMap (f k) v - . M.mapKeysMonotonic f - $ m -{-# INLINE mapKeysMonotonic #-} - --- | /O(n)/. Fold the keys and values in the map using the given right-associative --- binary operator, such that --- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. --- --- For example, --- --- > keysList map = foldrWithKey (\k x ks -> k:ks) [] map -foldrWithKey :: (Key -> a -> b -> b) -> b -> NEIntMap a -> b -foldrWithKey f z (NEIntMap k v m) = f k v . M.foldrWithKey f z $ m -{-# INLINE foldrWithKey #-} - --- | /O(n)/. Fold the keys and values in the map using the given left-associative --- binary operator, such that --- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. --- --- For example, --- --- > keysList = reverse . foldlWithKey (\ks k x -> k:ks) [] -foldlWithKey :: (a -> Key -> b -> a) -> a -> NEIntMap b -> a -foldlWithKey f z (NEIntMap k v m) = M.foldlWithKey f (f z k v) m -{-# INLINE foldlWithKey #-} - --- | /O(n)/. A strict version of 'foldr1'. Each application of the operator --- is evaluated before using the result in the next application. This --- function is strict in the starting value. -foldr1' :: (a -> a -> a) -> NEIntMap a -> a -foldr1' f (NEIntMap _ v m) = case M.maxView m of - Nothing -> v - Just (y, m') -> let !z = M.foldr' f y m' in v `f` z -{-# INLINE foldr1' #-} - --- | /O(n)/. A strict version of 'foldl1'. Each application of the operator --- is evaluated before using the result in the next application. This --- function is strict in the starting value. -foldl1' :: (a -> a -> a) -> NEIntMap a -> a -foldl1' f (NEIntMap _ v m) = M.foldl' f v m -{-# INLINE foldl1' #-} - --- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldrWithKey' :: (Key -> a -> b -> b) -> b -> NEIntMap a -> b -foldrWithKey' f z (NEIntMap k v m) = f k v y - where - !y = M.foldrWithKey f z m -{-# INLINE foldrWithKey' #-} - --- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldlWithKey' :: (a -> Key -> b -> a) -> a -> NEIntMap b -> a -foldlWithKey' f z (NEIntMap k v m) = M.foldlWithKey' f x m - where - !x = f z k v -{-# INLINE foldlWithKey' #-} - --- | /O(n)/. Return all keys of the map in ascending order. --- --- > keys (fromList ((5,"a") :| [(3,"b")])) == (3 :| [5]) -keys :: NEIntMap a -> NonEmpty Key -keys (NEIntMap k _ m) = k :| M.keys m -{-# INLINE keys #-} - --- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map --- in ascending key order. --- --- > assocs (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) -assocs :: NEIntMap a -> NonEmpty (Key, a) -assocs = toList -{-# INLINE assocs #-} - --- | /O(n)/. The non-empty set of all keys of the map. --- --- > keysSet (fromList ((5,"a") :| [(3,"b")])) == Data.Set.NonEmpty.fromList (3 :| [5]) -keysSet :: NEIntMap a -> NEIntSet -keysSet (NEIntMap k _ m) = NEIntSet k (M.keysSet m) -{-# INLINE keysSet #-} - --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are --- in ascending order. --- --- > toAscList (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) -toAscList :: NEIntMap a -> NonEmpty (Key, a) -toAscList = toList -{-# INLINE toAscList #-} - --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys --- are in descending order. --- --- > toDescList (fromList ((5,"a") :| [(3,"b")])) == ((5,"a") :| [(3,"b")]) -toDescList :: NEIntMap a -> NonEmpty (Key, a) -toDescList (NEIntMap k0 v0 m) = M.foldlWithKey' go ((k0, v0) :| []) m - where - go xs k v = (k, v) NE.<| xs -{-# INLINE toDescList #-} - --- | /O(n)/. Filter all values that satisfy the predicate. --- --- Returns a potentially empty map ('IntMap'), because we could --- potentailly filter out all items in the original 'NEIntMap'. --- --- > filter (> "a") (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" --- > filter (> "x") (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.empty --- > filter (< "a") (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.empty -filter - :: (a -> Bool) - -> NEIntMap a - -> IntMap a -filter f (NEIntMap k v m) - | f v = insertMinMap k v . M.filter f $ m - | otherwise = M.filter f m -{-# INLINE filter #-} - --- | /O(n)/. Filter all keys\/values that satisfy the predicate. --- --- Returns a potentially empty map ('IntMap'), because we could --- potentailly filter out all items in the original 'NEIntMap'. --- --- > filterWithKey (\k _ -> k > 4) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" -filterWithKey - :: (Key -> a -> Bool) - -> NEIntMap a - -> IntMap a -filterWithKey f (NEIntMap k v m) - | f k v = insertMinMap k v . M.filterWithKey f $ m - | otherwise = M.filterWithKey f m -{-# INLINE filterWithKey #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Restrict an 'NEIntMap' to only those keys --- found in a 'Data.Set.Set'. --- --- @ --- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m --- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s --- @ -restrictKeys - :: NEIntMap a - -> IntSet - -> IntMap a -restrictKeys n@(NEIntMap k v m) xs = case S.minView xs of - Nothing -> M.empty - Just (y, ys) -> case compare k y of - -- k is not in xs - LT -> m `M.restrictKeys` xs - -- k and y are a part of the result - EQ -> insertMinMap k v $ m `M.restrictKeys` ys - -- y is not in m - GT -> toMap n `M.restrictKeys` ys -{-# INLINE restrictKeys #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Data.Set.Set' from --- an 'NEIntMap'. --- --- @ --- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m --- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s --- @ -withoutKeys - :: NEIntMap a - -> IntSet - -> IntMap a -withoutKeys n@(NEIntMap k v m) xs = case S.minView xs of - Nothing -> toMap n - Just (y, ys) -> case compare k y of - -- k is not in xs, so cannot be deleted - LT -> insertMinMap k v $ m `M.withoutKeys` xs - -- y deletes k, and only k - EQ -> m `M.withoutKeys` ys - -- y is not in n, so cannot delete anything, so we can just difference n and ys - GT -> toMap n `M.withoutKeys` ys -{-# INLINE withoutKeys #-} - --- | /O(n)/. Partition the map according to a predicate. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the predicate was true for all items. --- * @'That' n2@ means that the predicate was false for all items. --- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the --- predicate) and @n2@ (all of the items that were false for the --- predicate). --- --- See also 'split'. --- --- > partition (> "a") (fromList ((5,"a") :| [(3,"b")])) == These (singleton 3 "b") (singleton 5 "a") --- > partition (< "x") (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) --- > partition (> "x") (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) -partition - :: (a -> Bool) - -> NEIntMap a - -> These (NEIntMap a) (NEIntMap a) -partition f = partitionWithKey (const f) -{-# INLINE partition #-} - --- | /O(n)/. Partition the map according to a predicate. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the predicate was true for all items, --- returning the original map. --- * @'That' n2@ means that the predicate was false for all items, --- returning the original map. --- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the --- predicate) and @n2@ (all of the items that were false for the --- predicate). --- --- See also 'split'. --- --- > partitionWithKey (\ k _ -> k > 3) (fromList ((5,"a") :| [(3,"b")])) == These (singleton 5 "a") (singleton 3 "b") --- > partitionWithKey (\ k _ -> k < 7) (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) --- > partitionWithKey (\ k _ -> k > 7) (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) -partitionWithKey - :: (Key -> a -> Bool) - -> NEIntMap a - -> These (NEIntMap a) (NEIntMap a) -partitionWithKey f n@(NEIntMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) - | f k v -> This n - | otherwise -> That n - (Just n1, Nothing) - | f k v -> This n - | otherwise -> These n1 (singleton k v) - (Nothing, Just n2) - | f k v -> These (singleton k v) n2 - | otherwise -> That n - (Just n1, Just n2) - | f k v -> These (insertMapMin k v m1) n2 - | otherwise -> These n1 (insertMapMin k v m2) - where - (m1, m2) = M.partitionWithKey f m0 -{-# INLINABLE partitionWithKey #-} - --- | /O(n)/. Map values and collect the 'Just' results. --- --- Returns a potentially empty map ('IntMap'), because the function could --- potentially return 'Nothing' on all items in the 'NEIntMap'. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > mapMaybe f (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "new a" -mapMaybe - :: (a -> Maybe b) - -> NEIntMap a - -> IntMap b -mapMaybe f = mapMaybeWithKey (const f) -{-# INLINE mapMaybe #-} - --- | /O(n)/. Map keys\/values and collect the 'Just' results. --- --- Returns a potentially empty map ('IntMap'), because the function could --- potentially return 'Nothing' on all items in the 'NEIntMap'. --- --- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing --- > mapMaybeWithKey f (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "key : 3" -mapMaybeWithKey - :: (Key -> a -> Maybe b) - -> NEIntMap a - -> IntMap b -mapMaybeWithKey f (NEIntMap k v m) = ($ M.mapMaybeWithKey f m) - . maybe id (insertMinMap k) - $ f k v -{-# INLINE mapMaybeWithKey #-} - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the results were all 'Left'. --- * @'That' n2@ means that the results were all 'Right'. --- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') --- and @n2@ (the map where the results were 'Right') --- --- > let f a = if a < "c" then Left a else Right a --- > mapEither f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == These (fromList ((3,"b") :| [(5,"a")])) (fromList ((1,"x") :| [(7,"z")])) --- > --- > mapEither (\ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == That (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) -mapEither - :: (a -> Either b c) - -> NEIntMap a - -> These (NEIntMap b) (NEIntMap c) -mapEither f = mapEitherWithKey (const f) -{-# INLINE mapEither #-} - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the results were all 'Left'. --- * @'That' n2@ means that the results were all 'Right'. --- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') --- and @n2@ (the map where the results were 'Right') --- --- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) --- > mapEitherWithKey f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == These (fromList ((1,2) :| [(3,6)])) (fromList ((5,"aa") :| [(7,"zz")])) --- > --- > mapEitherWithKey (\_ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == That (fromList ((1,"x") :| [(3,"b"), (5,"a"), (7,"z")])) -mapEitherWithKey - :: (Key -> a -> Either b c) - -> NEIntMap a - -> These (NEIntMap b) (NEIntMap c) -mapEitherWithKey f (NEIntMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> case f k v of - Left v' -> This (singleton k v') - Right v' -> That (singleton k v') - (Just n1, Nothing) -> case f k v of - Left v' -> This (insertMapMin k v' m1) - Right v' -> These n1 (singleton k v') - (Nothing, Just n2) -> case f k v of - Left v' -> These (singleton k v') n2 - Right v' -> That (insertMapMin k v' m2) - (Just n1, Just n2) -> case f k v of - Left v' -> These (insertMapMin k v' m1) n2 - Right v' -> These n1 (insertMapMin k v' m2) - where - (m1, m2) = M.mapEitherWithKey f m0 -{-# INLINABLE mapEitherWithKey #-} - --- | /O(log n)/. The expression (@'split' k map@) is potentially a 'These' --- containing up to two 'NEIntMap's based on splitting the map into maps --- containing items before and after the given key @k@. It will never --- return a map that contains @k@ itself. --- --- * 'Nothing' means that @k@ was the only key in the the original map, --- and so there are no items before or after it. --- * @'Just' ('This' n1)@ means @k@ was larger than or equal to all items --- in the map, and @n1@ is the entire original map (minus @k@, if it was --- present) --- * @'Just' ('That' n2)@ means @k@ was smaller than or equal to all --- items in the map, and @n2@ is the entire original map (minus @k@, if --- it was present) --- * @'Just' ('These' n1 n2)@ gives @n1@ (the map of all keys from the --- original map less than @k@) and @n2@ (the map of all keys from the --- original map greater than @k@) --- --- > split 2 (fromList ((5,"a") :| [(3,"b")])) == Just (That (fromList ((3,"b") :| [(5,"a")])) ) --- > split 3 (fromList ((5,"a") :| [(3,"b")])) == Just (That (singleton 5 "a") ) --- > split 4 (fromList ((5,"a") :| [(3,"b")])) == Just (These (singleton 3 "b") (singleton 5 "a")) --- > split 5 (fromList ((5,"a") :| [(3,"b")])) == Just (This (singleton 3 "b") ) --- > split 6 (fromList ((5,"a") :| [(3,"b")])) == Just (This (fromList ((3,"b") :| [(5,"a")])) ) --- > split 5 (singleton 5 "a") == Nothing -split - :: Key - -> NEIntMap a - -> Maybe (These (NEIntMap a) (NEIntMap a)) -split k n@(NEIntMap k0 v m0) = case compare k k0 of - LT -> Just $ That n - EQ -> That <$> nonEmptyMap m0 - 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 the first field in --- the 'These': --- --- > 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 - -> These a (These (NEIntMap a) (NEIntMap a)) -splitLookup k n@(NEIntMap k0 v0 m0) = case compare k k0 of - 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 #-} - --- | /O(1)/. Decompose a map into pieces based on the structure of the --- underlying tree. This function is useful for consuming a map in --- parallel. --- --- No guarantee is made as to the sizes of the pieces; an internal, but --- deterministic process determines this. However, it is guaranteed that --- the pieces returned will be in ascending order (all elements in the --- first submap less than all elements in the second, and so on). --- --- Note that the current implementation does not return more than four --- submaps, but you should not depend on this behaviour because it can --- change in the future without notice. -splitRoot - :: NEIntMap a - -> NonEmpty (NEIntMap a) -splitRoot (NEIntMap k v m) = singleton k v - :| Maybe.mapMaybe nonEmptyMap (M.splitRoot m) -{-# INLINE splitRoot #-} - --- | /O(m*log(n\/m + 1)), m <= n/. --- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -isSubmapOf :: Eq a => NEIntMap a -> NEIntMap a -> Bool -isSubmapOf = isSubmapOfBy (==) -{-# INLINE isSubmapOf #-} - --- | /O(m*log(n\/m + 1)), m <= n/. --- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if --- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when --- applied to their respective values. For example, the following --- expressions are all 'True': --- --- > isSubmapOfBy (==) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (<=) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (fromList (('a',1) :| [('b',2)])) --- --- But the following are all 'False': --- --- > isSubmapOfBy (==) (singleton 'a' 2) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (<) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (singleton 'a' 1) -isSubmapOfBy - :: (a -> b -> Bool) - -> NEIntMap a - -> NEIntMap b - -> Bool -isSubmapOfBy f (NEIntMap k v m0) (toMap->m1) = kvSub - && M.isSubmapOfBy f m0 m1 - where - kvSub = case M.lookup k m1 of - Just v0 -> f v v0 - Nothing -> False -{-# INLINE isSubmapOfBy #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap --- but not equal). Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' --- (==)@). -isProperSubmapOf :: Eq a => NEIntMap a -> NEIntMap a -> Bool -isProperSubmapOf = isProperSubmapOfBy (==) -{-# INLINE isProperSubmapOf #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap --- but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns --- 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, --- and when @f@ returns 'True' when applied to their respective values. For --- example, the following expressions are all 'True': --- --- > isProperSubmapOfBy (==) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) --- > isProperSubmapOfBy (<=) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) --- --- But the following are all 'False': --- --- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (fromList ((1,1) :| [(2,2)])) --- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (singleton 1 1)) --- > isProperSubmapOfBy (<) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) -isProperSubmapOfBy - :: (a -> b -> Bool) - -> NEIntMap a - -> NEIntMap b - -> Bool -isProperSubmapOfBy f m1 m2 = M.size (neimIntMap m1) < M.size (neimIntMap m2) - && isSubmapOfBy f m1 m2 -{-# INLINE isProperSubmapOfBy #-} - --- | /O(1)/. The minimal key of the map. Note that this is total, making --- 'Data.IntMap.lookupMin' obsolete. It is constant-time, so has better --- asymptotics than @Data.IntMap.lookupMin@ and @Data.IntMap.findMin@, as well. --- --- > findMin (fromList ((5,"a") :| [(3,"b")])) == (3,"b") -findMin :: NEIntMap a -> (Key, a) -findMin (NEIntMap k v _) = (k, v) -{-# INLINE findMin #-} - --- | /O(log n)/. The maximal key of the map. Note that this is total, making --- 'Data.IntMap.lookupMin' obsolete. --- --- > findMax (fromList ((5,"a") :| [(3,"b")])) == (5,"a") -findMax :: NEIntMap a -> (Key, a) -findMax (NEIntMap k v m) = fromMaybe (k, v) . lookupMaxMap $ m -{-# INLINE findMax #-} - --- | /O(1)/. Delete the minimal key. Returns a potentially empty map --- ('IntMap'), because we might end up deleting the final key in a singleton --- map. It is constant-time, so has better asymptotics than --- 'Data.IntMap.deleteMin'. --- --- > deleteMin (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.IntMap.fromList [(5,"a"), (7,"c")] --- > deleteMin (singleton 5 "a") == Data.IntMap.empty -deleteMin :: NEIntMap a -> IntMap a -deleteMin (NEIntMap _ _ m) = m -{-# INLINE deleteMin #-} - --- | /O(log n)/. Delete the maximal key. Returns a potentially empty map --- ('IntMap'), because we might end up deleting the final key in a singleton --- map. --- --- > deleteMax (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.IntMap.fromList [(3,"b"), (5,"a")] --- > deleteMax (singleton 5 "a") == Data.IntMap.empty -deleteMax :: NEIntMap a -> IntMap a -deleteMax (NEIntMap k v m) = case M.maxView m of - Nothing -> M.empty - Just (_, m') -> insertMinMap k v m' -{-# INLINE deleteMax #-} - --- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the --- minimal key. Returns a potentially empty map ('IntMap'), because we might --- end up deleting the final key in the map if the function returns --- 'Nothing'. See 'adjustMin' for a version that can guaruntee that we --- return a non-empty map. --- --- > updateMin (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "Xb"), (5, "a")] --- > updateMin (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" -updateMin :: (a -> Maybe a) -> NEIntMap a -> IntMap a -updateMin f = updateMinWithKey (const f) -{-# INLINE updateMin #-} - --- | /O(1)/. A version of 'updateMin' that disallows deletion, allowing us --- to guarantee that the result is also non-empty. -adjustMin :: (a -> a) -> NEIntMap a -> NEIntMap a -adjustMin f = adjustMinWithKey (const f) -{-# INLINE adjustMin #-} - --- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the --- minimal key. Returns a potentially empty map ('IntMap'), because we might --- end up deleting the final key in the map if the function returns --- 'Nothing'. See 'adjustMinWithKey' for a version that guaruntees --- a non-empty map. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" -updateMinWithKey :: (Key -> a -> Maybe a) -> NEIntMap a -> IntMap a -updateMinWithKey f (NEIntMap k v m) = ($ m) . maybe id (insertMinMap k) $ f k v -{-# INLINE updateMinWithKey #-} - --- | /O(1)/. A version of 'adjustMaxWithKey' that disallows deletion, --- allowing us to guarantee that the result is also non-empty. Note that --- it also is able to have better asymptotics than 'updateMinWithKey' in --- general. -adjustMinWithKey :: (Key -> a -> a) -> NEIntMap a -> NEIntMap a -adjustMinWithKey f (NEIntMap k v m) = NEIntMap k (f k v) m -{-# INLINE adjustMinWithKey #-} - --- | /O(log n)/. Update the value at the maximal key. Returns --- a potentially empty map ('IntMap'), because we might end up deleting the --- final key in the map if the function returns 'Nothing'. See 'adjustMax' --- for a version that can guarantee that we return a non-empty map. --- --- > updateMax (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "Xa")] --- > updateMax (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" -updateMax :: (a -> Maybe a) -> NEIntMap a -> IntMap a -updateMax f = updateMaxWithKey (const f) -{-# INLINE updateMax #-} - --- | /O(log n)/. A version of 'updateMax' that disallows deletion, allowing --- us to guarantee that the result is also non-empty. -adjustMax :: (a -> a) -> NEIntMap a -> NEIntMap a -adjustMax f = adjustMaxWithKey (const f) -{-# INLINE adjustMax #-} - --- | /O(log n)/. Update the value at the maximal key. Returns --- a potentially empty map ('IntMap'), because we might end up deleting the --- final key in the map if the function returns 'Nothing'. See --- 'adjustMaxWithKey' for a version that guaruntees a non-empty map. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" -updateMaxWithKey :: (Key -> a -> Maybe a) -> NEIntMap a -> IntMap a -updateMaxWithKey f (NEIntMap k v m) - | M.null m = maybe m (M.singleton k) $ f k v - | otherwise = insertMinMap k v - . M.updateMaxWithKey f - $ m -{-# INLINE updateMaxWithKey #-} - --- | /O(log n)/. A version of 'updateMaxWithKey' that disallows deletion, --- allowing us to guarantee that the result is also non-empty. -adjustMaxWithKey :: (Key -> a -> a) -> NEIntMap a -> NEIntMap a -adjustMaxWithKey f (NEIntMap k0 v m) - | M.null m = NEIntMap k0 (f k0 v) m - | otherwise = insertMapMin k0 v - . M.updateMaxWithKey (\k -> Just . f k) - $ m -{-# INLINE adjustMaxWithKey #-} - --- | /O(1)/. Retrieves the value associated with minimal key of the --- map, and the map stripped of that element. It is constant-time, so has --- better asymptotics than @Data.IntMap.minView@ for 'IntMap'. --- --- Note that unlike @Data.IntMap.minView@ for 'IntMap', this cannot ever fail, --- so doesn't need to return in a 'Maybe'. However, the result 'IntMap' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > minView (fromList ((5,"a") :| [(3,"b")])) == ("b", Data.IntMap.singleton 5 "a") -minView :: NEIntMap a -> (a, IntMap a) -minView = first snd . deleteFindMin -{-# INLINE minView #-} - --- | /O(1)/. Delete and find the minimal key-value pair. It is --- constant-time, so has better asymptotics that @Data.IntMap.minView@ for --- 'IntMap'. --- --- Note that unlike @Data.IntMap.deleteFindMin@ for 'IntMap', this cannot ever --- fail, and so is a total function. However, the result 'IntMap' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > deleteFindMin (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((3,"b"), Data.IntMap.fromList [(5,"a"), (10,"c")]) -deleteFindMin :: NEIntMap a -> ((Key, a), IntMap a) -deleteFindMin (NEIntMap k v m) = ((k, v), m) -{-# INLINE deleteFindMin #-} - --- | /O(log n)/. Retrieves the value associated with maximal key of the --- map, and the map stripped of that element. --- --- Note that unlike @Data.IntMap.maxView@ from 'IntMap', this cannot ever fail, --- so doesn't need to return in a 'Maybe'. However, the result 'IntMap' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > maxView (fromList ((5,"a") :| [(3,"b")])) == ("a", Data.IntMap.singleton 3 "b") -maxView :: NEIntMap a -> (a, IntMap a) -maxView = first snd . deleteFindMax -{-# INLINE maxView #-} - --- | /O(log n)/. Delete and find the minimal key-value pair. --- --- Note that unlike @Data.IntMap.deleteFindMax@ for 'IntMap', this cannot ever --- fail, and so is a total function. However, the result 'IntMap' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > deleteFindMax (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((10,"c"), Data.IntMap.fromList [(3,"b"), (5,"a")]) -deleteFindMax :: NEIntMap a -> ((Key, a), IntMap a) -deleteFindMax (NEIntMap k v m) = maybe ((k, v), M.empty) (second (insertMinMap k v)) - . M.maxViewWithKey - $ m -{-# INLINE deleteFindMax #-} - --- --------------------------- --- Combining functions --- --------------------------- --- --- Code comes from "Data.Map.Internal" from containers, modified slightly --- to work with NonEmpty --- --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 - -combineEq :: NonEmpty (Key, b) -> NonEmpty (Key, b) -combineEq = \case - x :| [] -> x :| [] - x :| xx@(_:_) -> go x xx - where - go z [] = z :| [] - go z@(kz,_) (x@(kx,xx):xs') - | kx==kz = go (kx,xx) xs' - | otherwise = z NE.<| go x xs' - -combineEqWith - :: (Key -> b -> b -> b) - -> NonEmpty (Key, b) - -> NonEmpty (Key, b) -combineEqWith f = \case - x :| [] -> x :| [] - x :| xx@(_:_) -> go x xx - where - go z [] = z :| [] - go z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in go (kx,yy) xs' +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Data.IntMap.NonEmpty +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- = Non-Empty Finite Integer-Indexed Maps (lazy interface) +-- +-- The @'NEIntMap' v@ type represents a non-empty finite map (sometimes +-- called a dictionary) from integer keys to values of type @v@. +-- An 'NEIntMap' is strict in its keys but lazy in its values. +-- +-- See documentation for 'NEIntMap' for information on how to convert and +-- manipulate such non-empty maps. +-- +-- This module essentially re-imports the API of "Data.IntMap.Lazy" and its +-- 'IntMap' type, along with semantics and asymptotics. In most +-- situations, asymptotics are different only by a constant factor. In +-- some situations, asmyptotics are even better (constant-time instead of +-- log-time). +-- +-- Because 'NEIntMap' is implemented using 'IntMap', all of the caveats of using +-- 'IntMap' apply (such as the limitation of the maximum size of maps). +-- +-- All functions take non-empty maps as inputs. In situations where their +-- results can be guarunteed to also be non-empty, they also return +-- non-empty maps. In situations where their results could potentially be +-- empty, 'IntMap' is returned instead. +-- +-- Some variants of functions (like 'alter'', 'alterF'', 'adjustMin', +-- 'adjustMax', 'adjustMinWithKey', 'adjustMaxWithKey') are provided in +-- a way restructured to preserve guaruntees of non-empty maps being +-- returned. +-- +-- Some functions (like 'mapEither', 'partition', 'split') +-- have modified return types to account for possible configurations of +-- non-emptiness. +-- +-- This module is intended to be imported qualified, to avoid name clashes with +-- "Prelude" and "Data.IntMap" functions: +-- +-- > import qualified Data.IntMap.NonEmpty as NEIM +-- +-- Note that all asmyptotics /O(f(n))/ in this module are actually +-- /O(min(W, f(n)))/, where @W@ is the number of bits in an 'Int' (32 or +-- 64). That is, if @f(n)@ is greater than @W@, all operations are +-- constant-time. +-- +-- At the moment, this package does not provide a variant strict on values +-- for these functions, like /containers/ does. This is a planned future +-- implementation (PR's are appreciated). For now, you can simulate +-- a strict interface by manually forcing values before returning results. +module Data.IntMap.NonEmpty ( + -- * Non-Empty IntMap Type + NEIntMap, + Key, + + -- ** Conversions between empty and non-empty maps + pattern IsNonEmpty, + pattern IsEmpty, + nonEmptyMap, + toMap, + withNonEmpty, + insertMap, + insertMapWith, + insertMapWithKey, + insertMapMin, + insertMapMax, + unsafeFromMap, + + -- * Construction + singleton, + fromSet, + + -- ** From Unordered Lists + fromList, + fromListWith, + fromListWithKey, + + -- ** From Ascending Lists + fromAscList, + fromAscListWith, + fromAscListWithKey, + fromDistinctAscList, + + -- * Insertion + insert, + insertWith, + insertWithKey, + insertLookupWithKey, + + -- * Deletion\/Update + delete, + adjust, + adjustWithKey, + update, + updateWithKey, + updateLookupWithKey, + alter, + alterF, + alter', + alterF', + + -- * Query + + -- ** Lookup + lookup, + (!?), + (!), + findWithDefault, + member, + notMember, + lookupLT, + lookupGT, + lookupLE, + lookupGE, + + -- ** Size + size, + + -- * Combine + + -- ** Union + union, + unionWith, + unionWithKey, + unions, + unionsWith, + + -- ** Difference + difference, + (\\), + differenceWith, + differenceWithKey, + + -- ** Intersection + intersection, + intersectionWith, + intersectionWithKey, + -- -- ** Universal combining function + -- , mergeWithKey + + -- * Traversal + + -- ** Map + map, + mapWithKey, + traverseWithKey1, + traverseWithKey, + mapAccum, + mapAccumWithKey, + mapAccumRWithKey, + mapKeys, + mapKeysWith, + mapKeysMonotonic, + + -- * Folds + foldr, + foldl, + foldr1, + foldl1, + foldrWithKey, + foldlWithKey, + foldMapWithKey, + + -- ** Strict folds + foldr', + foldr1', + foldl', + foldl1', + foldrWithKey', + foldlWithKey', + + -- * Conversion + elems, + keys, + assocs, + keysSet, + + -- ** Lists + toList, + + -- ** Ordered lists + toAscList, + toDescList, + + -- * Filter + filter, + filterWithKey, + restrictKeys, + withoutKeys, + partition, + partitionWithKey, + mapMaybe, + mapMaybeWithKey, + mapEither, + mapEitherWithKey, + split, + splitLookup, + splitRoot, + + -- * Submap + isSubmapOf, + isSubmapOfBy, + isProperSubmapOf, + isProperSubmapOfBy, + + -- * Min\/Max + findMin, + findMax, + deleteMin, + deleteMax, + deleteFindMin, + deleteFindMax, + updateMin, + updateMax, + adjustMin, + adjustMax, + updateMinWithKey, + updateMaxWithKey, + adjustMinWithKey, + adjustMaxWithKey, + minView, + maxView, + + -- * Debugging + valid, +) where + +import Control.Applicative +import Data.Bifunctor +import qualified Data.Foldable as F +import Data.Functor.Identity +import qualified Data.IntMap as M +import Data.IntMap.Internal (IntMap (..)) +import Data.IntMap.NonEmpty.Internal +import Data.IntSet (IntSet) +import qualified Data.IntSet as S +import Data.IntSet.NonEmpty.Internal (NEIntSet (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe hiding (mapMaybe) +import qualified Data.Maybe as Maybe +import Data.Semigroup.Foldable (Foldable1) +import qualified Data.Semigroup.Foldable as F1 +import Data.These +import Prelude hiding (Foldable (..), filter, lookup, map) + +-- | /O(1)/ match, /O(log n)/ usage of contents. The 'IsNonEmpty' and +-- 'IsEmpty' patterns allow you to treat a 'IntMap' as if it were either +-- a @'IsNonEmpty' n@ (where @n@ is a 'NEIntMap') or an 'IsEmpty'. +-- +-- For example, you can pattern match on a 'IntMap': +-- +-- @ +-- myFunc :: 'IntMap' K X -> Y +-- myFunc ('IsNonEmpty' n) = -- here, the user provided a non-empty map, and @n@ is the 'NEIntMap' +-- myFunc 'IsEmpty' = -- here, the user provided an empty map. +-- @ +-- +-- Matching on @'IsNonEmpty' n@ means that the original 'IntMap' was /not/ +-- empty, and you have a verified-non-empty 'NEIntMap' @n@ to use. +-- +-- Note that patching on this pattern is /O(1)/. However, using the +-- contents requires a /O(log n)/ cost that is deferred until after the +-- pattern is matched on (and is not incurred at all if the contents are +-- never used). +-- +-- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides +-- complete coverage. +-- +-- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert +-- a 'NEIntMap' back into a 'IntMap', obscuring its non-emptiness (see 'toMap'). +pattern IsNonEmpty :: NEIntMap a -> IntMap a +pattern IsNonEmpty n <- (nonEmptyMap -> Just n) + where + IsNonEmpty n = toMap n + +-- | /O(1)/. The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat +-- a 'IntMap' as if it were either a @'IsNonEmpty' n@ (where @n@ is +-- a 'NEIntMap') or an 'IsEmpty'. +-- +-- Matching on 'IsEmpty' means that the original 'IntMap' was empty. +-- +-- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides +-- complete coverage. +-- +-- This is a bidirectional pattern, so you can use 'IsEmpty' as an +-- expression, and it will be interpreted as 'Data.IntMap.empty'. +-- +-- See 'IsNonEmpty' for more information. +pattern IsEmpty :: IntMap a +pattern IsEmpty <- (M.null -> True) + where + IsEmpty = M.empty + +{-# COMPLETE IsNonEmpty, IsEmpty #-} + +-- | /O(log n)/. Unsafe version of 'nonEmptyMap'. Coerces a 'IntMap' into an +-- 'NEIntMap', but is undefined (throws a runtime exception when evaluation is +-- attempted) for an empty 'IntMap'. +unsafeFromMap :: + IntMap a -> + NEIntMap a +unsafeFromMap = withNonEmpty e id + where + e = errorWithoutStackTrace "NEIntMap.unsafeFromMap: empty map" +{-# INLINE unsafeFromMap #-} + +-- | /O(log n)/. Convert a 'IntMap' into an 'NEIntMap' by adding a key-value +-- pair. Because of this, we know that the map must have at least one +-- element, and so therefore cannot be empty. If key is already present, +-- will overwrite the original value. +-- +-- See 'insertMapMin' for a version that is constant-time if the new key is +-- /strictly smaller than/ all keys in the original map. +-- +-- > insertMap 4 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) +-- > insertMap 4 "c" Data.IntMap.empty == singleton 4 "c" +insertMap :: Key -> a -> IntMap a -> NEIntMap a +insertMap k v = withNonEmpty (singleton k v) (insert k v) +{-# INLINE insertMap #-} + +-- | /O(log n)/. Convert a 'IntMap' into an 'NEIntMap' by adding a key-value +-- pair. Because of this, we know that the map must have at least one +-- element, and so therefore cannot be empty. Uses a combining function +-- with the new value as the first argument if the key is already present. +-- +-- > insertMapWith (++) 4 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) +-- > insertMapWith (++) 5 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"ca")]) +insertMapWith :: + (a -> a -> a) -> + Key -> + a -> + IntMap a -> + NEIntMap a +insertMapWith f k v = withNonEmpty (singleton k v) (insertWith f k v) +{-# INLINE insertMapWith #-} + +-- | /O(log n)/. Convert a 'IntMap' into an 'NEIntMap' by adding a key-value +-- pair. Because of this, we know that the map must have at least one +-- element, and so therefore cannot be empty. Uses a combining function +-- with the key and new value as the first and second arguments if the key +-- is already present. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "5:xxx|a")]) +-- > insertWithKey f 7 "xxx" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) +-- > insertWithKey f 5 "xxx" Data.IntMap.empty == singleton 5 "xxx" +insertMapWithKey :: + (Key -> a -> a -> a) -> + Key -> + a -> + IntMap a -> + NEIntMap a +insertMapWithKey f k v = withNonEmpty (singleton k v) (insertWithKey f k v) +{-# INLINE insertMapWithKey #-} + +-- | /O(1)/ Convert a 'IntMap' into an 'NEIntMap' by adding a key-value pair +-- where the key is /strictly less than/ all keys in the input map. The +-- keys in the original map must all be /strictly greater than/ the new +-- key. /The precondition is not checked./ +-- +-- > insertMapMin 2 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((2,"c") :| [(3,"b"), (5,"a")]) +-- > valid (insertMapMin 2 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == True +-- > valid (insertMapMin 7 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False +-- > valid (insertMapMin 3 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False +insertMapMin :: + Key -> + a -> + IntMap a -> + NEIntMap a +insertMapMin = NEIntMap +{-# INLINE insertMapMin #-} + +-- | /O(log n)/ Convert a 'IntMap' into an 'NEIntMap' by adding a key-value pair +-- where the key is /strictly greater than/ all keys in the input map. The +-- keys in the original map must all be /strictly less than/ the new +-- key. /The precondition is not checked./ +-- +-- At the current moment, this is identical simply 'insertMap'; however, +-- it is left both for consistency and as a placeholder for a future +-- version where optimizations are implemented to allow for a faster +-- implementation. +-- +-- > insertMap 7 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"a"), (7,"c")]) + +-- these currently are all valid, but shouldn't be +-- > valid (insertMap 7 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == True +-- > valid (insertMap 2 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False +-- > valid (insertMap 5 "c" (Data.IntMap.fromList [(5,"a"), (3,"b")])) == False +insertMapMax :: + Key -> + a -> + IntMap a -> + NEIntMap a +insertMapMax k v = withNonEmpty (singleton k v) go + where + go (NEIntMap k0 v0 m0) = NEIntMap k0 v0 . insertMaxMap k v $ m0 +{-# INLINE insertMapMax #-} + +-- | /O(n)/. Build a non-empty map from a non-empty set of keys and +-- a function which for each key computes its value. +-- +-- > fromSet (\k -> replicate k 'a') (Data.Set.NonEmpty.fromList (3 :| [5])) == fromList ((5,"aaaaa") :| [(3,"aaa")]) +fromSet :: + (Key -> a) -> + NEIntSet -> + NEIntMap a +fromSet f (NEIntSet k ks) = NEIntMap k (f k) (M.fromSet f ks) +{-# INLINE fromSet #-} + +-- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs +-- with a combining function. See also 'fromAscListWith'. +-- +-- > fromListWith (++) ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "ab") :| [(5, "aba")]) +fromListWith :: + (a -> a -> a) -> + NonEmpty (Key, a) -> + NEIntMap a +fromListWith f = fromListWithKey (const f) +{-# INLINE fromListWith #-} + +-- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs +-- with a combining function. See also 'fromAscListWithKey'. +-- +-- > let f k a1 a2 = (show k) ++ a1 ++ a2 +-- > fromListWithKey f ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "3ab") :| [(5, "5a5ba")]) +fromListWithKey :: + (Key -> a -> a -> a) -> + NonEmpty (Key, a) -> + NEIntMap a +fromListWithKey f ((k0, v0) :| xs) = F.foldl' go (singleton k0 v0) xs + where + go m (k, v) = insertWithKey f k v m + {-# INLINE go #-} +{-# INLINE fromListWithKey #-} + +-- | /O(n)/. Build a map from an ascending non-empty list in linear time. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > fromAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) +-- > fromAscList ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "b")]) +-- > valid (fromAscList ((3,"b") :| [(5,"a"), (5,"b")])) == True +-- > valid (fromAscList ((5,"a") :| [(3,"b"), (5,"b")])) == False +fromAscList :: + NonEmpty (Key, a) -> + NEIntMap a +fromAscList = fromDistinctAscList . combineEq +{-# INLINE fromAscList #-} + +-- | /O(n)/. Build a map from an ascending non-empty list in linear time +-- with a combining function for equal keys. /The precondition (input list +-- is ascending) is not checked./ +-- +-- > fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "ba")]) +-- > valid (fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b"))]) == True +-- > valid (fromAscListWith (++) ((5,"a") :| [(3,"b"), (5,"b"))]) == False +fromAscListWith :: + (a -> a -> a) -> + NonEmpty (Key, a) -> + NEIntMap a +fromAscListWith f = fromAscListWithKey (const f) +{-# INLINE fromAscListWith #-} + +-- | /O(n)/. Build a map from an ascending non-empty list in linear time +-- with a combining function for equal keys. /The precondition (input list +-- is ascending) is not checked./ +-- +-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 +-- > fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")]) == fromList ((3, "b") :| [(5, "5:b5:ba")]) +-- > valid (fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")])) == True +-- > valid (fromAscListWithKey f ((5,"a") :| [(3,"b"), (5,"b"), (5,"b")])) == False +fromAscListWithKey :: + (Key -> a -> a -> a) -> + NonEmpty (Key, a) -> + NEIntMap a +fromAscListWithKey f = fromDistinctAscList . combineEqWith f +{-# INLINE fromAscListWithKey #-} + +-- | /O(n)/. Build a map from an ascending non-empty list of distinct +-- elements in linear time. /The precondition is not checked./ +-- +-- > fromDistinctAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) +-- > valid (fromDistinctAscList ((3,"b") :| [(5,"a")])) == True +-- > valid (fromDistinctAscList ((3,"b") :| [(5,"a"), (5,"b")])) == False +fromDistinctAscList :: NonEmpty (Key, a) -> NEIntMap a +fromDistinctAscList ((k, v) :| xs) = + insertMapMin k v + . M.fromDistinctAscList + $ xs +{-# INLINE fromDistinctAscList #-} + +-- | /O(log n)/. Insert a new key and value in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value. 'insert' is equivalent to +-- @'insertWith' 'const'@. +-- +-- See 'insertMap' for a version where the first argument is a 'IntMap'. +-- +-- > insert 5 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'x')]) +-- > insert 7 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'a'), (7, 'x')]) +insert :: + Key -> + a -> + NEIntMap a -> + NEIntMap a +insert k v n@(NEIntMap k0 v0 m) = case compare k k0 of + LT -> NEIntMap k v . toMap $ n + EQ -> NEIntMap k v m + GT -> NEIntMap k0 v0 . M.insert k v $ m +{-# INLINE insert #-} + +-- | /O(log n)/. Insert with a function, combining key, new value and old +-- value. @'insertWithKey' f key value mp@ will insert the pair (key, +-- value) into @mp@ if key does not exist in the map. If the key does +-- exist, the function will insert the pair @(key,f key new_value +-- old_value)@. Note that the key passed to f is the same key passed to +-- 'insertWithKey'. +-- +-- See 'insertMapWithKey' for a version where the first argument is a 'IntMap'. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:xxx|a")]) +-- > insertWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) +insertWithKey :: + (Key -> a -> a -> a) -> + Key -> + a -> + NEIntMap a -> + NEIntMap a +insertWithKey f k v n@(NEIntMap k0 v0 m) = case compare k k0 of + LT -> NEIntMap k v . toMap $ n + EQ -> NEIntMap k (f k v v0) m + GT -> NEIntMap k0 v0 $ M.insertWithKey f k v m +{-# INLINE insertWithKey #-} + +-- | /O(log n)/. Combines insert operation with old value retrieval. The +-- expression (@'insertLookupWithKey' f k x map@) is a pair where the first +-- element is equal to (@'lookup' k map@) and the second element equal to +-- (@'insertWithKey' f k x map@). +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertLookupWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "5:xxx|a")])) +-- > insertLookupWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "xxx")])) +-- +-- This is how to define @insertLookup@ using @insertLookupWithKey@: +-- +-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t +-- > insertLookup 5 "x" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "x")])) +-- > insertLookup 7 "x" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "x")])) +insertLookupWithKey :: + (Key -> a -> a -> a) -> + Key -> + a -> + NEIntMap a -> + (Maybe a, NEIntMap a) +insertLookupWithKey f k v n@(NEIntMap k0 v0 m) = case compare k k0 of + LT -> (Nothing, NEIntMap k v . toMap $ n) + EQ -> (Just v, NEIntMap k (f k v v0) m) + GT -> NEIntMap k0 v0 <$> M.insertLookupWithKey f k v m +{-# INLINE insertLookupWithKey #-} + +-- | /O(log n)/. Delete a key and its value from the non-empty map. +-- A potentially empty map ('IntMap') is returned, since this might delete the +-- last item in the 'NEIntMap'. When the key is not a member of the map, is +-- equivalent to 'toMap'. +-- +-- > delete 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" +-- > delete 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.Singleton [(3, "b"), (5, "a")] +delete :: Key -> NEIntMap a -> IntMap a +delete k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> toMap n + EQ -> m + GT -> insertMinMap k0 v . M.delete k $ m +{-# INLINE delete #-} + +-- | /O(log n)/. Update a value at a specific key with the result of the +-- provided function. When the key is not a member of the map, the original +-- map is returned. +-- +-- > adjust ("new " ++) 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "new a")]) +-- > adjust ("new " ++) 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) +adjust :: + (a -> a) -> + Key -> + NEIntMap a -> + NEIntMap a +adjust f = adjustWithKey (const f) +{-# INLINE adjust #-} + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > let f key x = (show key) ++ ":new " ++ x +-- > adjustWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:new a")]) +-- > adjustWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) +adjustWithKey :: + (Key -> a -> a) -> + Key -> + NEIntMap a -> + NEIntMap a +adjustWithKey f k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> n + EQ -> NEIntMap k0 (f k0 v) m + GT -> NEIntMap k0 v . M.adjustWithKey f k $ m +{-# INLINE adjustWithKey #-} + +-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- Returns a potentially empty map ('IntMap'), because we can't know ahead of +-- time if the function returns 'Nothing' and deletes the final item in the +-- 'NEIntMap'. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > update f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "new a")] +-- > update f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a")] +-- > update f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" +update :: + (a -> Maybe a) -> + Key -> + NEIntMap a -> + IntMap a +update f = updateWithKey (const f) +{-# INLINE update #-} + +-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the +-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', +-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound +-- to the new value @y@. +-- +-- Returns a potentially empty map ('IntMap'), because we can't know ahead of +-- time if the function returns 'Nothing' and deletes the final item in the +-- 'NEIntMap'. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "5:new a")] +-- > updateWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a")] +-- > updateWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" +updateWithKey :: + (Key -> a -> Maybe a) -> + Key -> + NEIntMap a -> + IntMap a +updateWithKey f k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> toMap n + EQ -> maybe m (flip (insertMinMap k0) m) . f k0 $ v + GT -> insertMinMap k0 v . M.updateWithKey f k $ m +{-# INLINE updateWithKey #-} + +-- | /O(min(n,W))/. Lookup and update. +-- The function returns original value, if it is updated. +-- This is different behavior than @Data.Map.NonEmpty.updateLookupWithKey@. +-- Returns the original key value if the map entry is deleted. +-- +-- Returns a potentially empty map ('IntMap') in the case that we delete +-- the final key of a singleton map. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateLookupWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == (Just "5:new a", Data.IntMap.fromList ((3, "b") :| [(5, "5:new a")])) +-- > updateLookupWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == (Nothing, Data.IntMap.fromList ((3, "b") :| [(5, "a")])) +-- > updateLookupWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == (Just "b", Data.IntMap.singleton 5 "a") +updateLookupWithKey :: + (Key -> a -> Maybe a) -> + Key -> + NEIntMap a -> + (Maybe a, IntMap a) +updateLookupWithKey f k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> (Nothing, toMap n) + EQ -> + let u = f k0 v + in (Just v, maybe m (flip (insertMinMap k0) m) u) + GT -> fmap (insertMinMap k0 v) . M.updateLookupWithKey f k $ m +{-# INLINE updateLookupWithKey #-} + +-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at +-- @k@, or absence thereof. 'alter' can be used to insert, delete, or +-- update a value in a 'IntMap'. In short : @Data.IntMap.lookup k ('alter' +-- f k m) = f ('lookup' k m)@. +-- +-- Returns a potentially empty map ('IntMap'), because we can't know ahead of +-- time if the function returns 'Nothing' and deletes the final item in the +-- 'NEIntMap'. +-- +-- See 'alterF'' for a version that disallows deletion, and so therefore +-- can return 'NEIntMap'. +-- +-- > let f _ = Nothing +-- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a")] +-- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" +-- > +-- > let f _ = Just "c" +-- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "a"), (7, "c")] +-- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "c")] +alter :: + (Maybe a -> Maybe a) -> + Key -> + NEIntMap a -> + IntMap a +alter f k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> maybe id (insertMinMap k) (f Nothing) (toMap n) + EQ -> maybe id (insertMinMap k0) (f (Just v)) m + GT -> insertMinMap k0 v . M.alter f k $ m +{-# INLINE alter #-} + +-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ +-- at @k@, or absence thereof. 'alterF' can be used to inspect, insert, +-- delete, or update a value in a 'IntMap'. In short: @Data.IntMap.lookup +-- k \<$\> 'alterF' f k m = f ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Int -> NEIntMap Int String -> IO (IntMap Int String) +-- interactiveAlter k m = alterF f k m where +-- f Nothing = do +-- putStrLn $ show k ++ +-- " was not found in the map. Would you like to add it?" +-- getUserResponse1 :: IO (Maybe String) +-- f (Just old) = do +-- putStrLn $ "The key is currently bound to " ++ show old ++ +-- ". Would you like to change or delete it?" +-- getUserResponse2 :: IO (Maybe String) +-- @ +-- +-- Like @Data.IntMap.alterF@ for 'IntMap', 'alterF' can be considered +-- to be a unifying generalization of 'lookup' and 'delete'; however, as +-- a constrast, it cannot be used to implement 'insert', because it must +-- return a 'IntMap' instead of an 'NEIntMap' (because the function might delete +-- the final item in the 'NEIntMap'). When used with trivial functors like +-- 'Identity' and 'Const', it is often slightly slower than +-- specialized 'lookup' and 'delete'. However, when the functor is +-- non-trivial and key comparison is not particularly cheap, it is the +-- fastest way. +-- +-- See 'alterF'' for a version that disallows deletion, and so therefore +-- can return 'NEIntMap' and be used to implement 'insert' +-- +-- Note on rewrite rules: +-- +-- This module includes GHC rewrite rules to optimize 'alterF' for +-- the 'Const' and 'Identity' functors. In general, these rules +-- improve performance. The sole exception is that when using +-- 'Identity', deleting a key that is already absent takes longer +-- than it would without the rules. If you expect this to occur +-- a very large fraction of the time, you might consider using a +-- private copy of the 'Identity' type. +-- +-- Note: Unlike @Data.IntMap.alterF@ for 'IntMap', 'alterF' is /not/ a flipped +-- version of the 'Control.Lens.At.at' combinator from "Control.Lens.At". +-- However, it match the shape expected from most functions expecting +-- lenses, getters, and setters, so can be thought of as a "psuedo-lens", +-- with virtually the same practical applications as a legitimate lens. +alterF :: + Functor f => + (Maybe a -> f (Maybe a)) -> + Key -> + NEIntMap a -> + f (IntMap a) +alterF f k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> flip (maybe id (insertMinMap k)) (toMap n) <$> f Nothing + EQ -> flip (maybe id (insertMinMap k0)) m <$> f (Just v) + GT -> insertMinMap k0 v <$> M.alterF f k m +{-# INLINEABLE [2] alterF #-} + +-- if f ~ Const b, it's a lookup +{-# RULES +"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)). + alterF f k = + Const . getConst . f . lookup k + #-} + +-- if f ~ Identity, it's an 'alter' +{-# RULES +"alterF/Identity" forall k (f :: Maybe a -> Identity (Maybe a)). + alterF f k = + Identity . alter (runIdentity . f) k + #-} + +-- | /O(log n)/. Variant of 'alter' that disallows deletion. Allows us to +-- guarantee that the result is also a non-empty IntMap. +alter' :: + (Maybe a -> a) -> + Key -> + NEIntMap a -> + NEIntMap a +alter' f k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> NEIntMap k (f Nothing) . toMap $ n + EQ -> NEIntMap k0 (f (Just v)) m + GT -> NEIntMap k0 v . M.alter (Just . f) k $ m +{-# INLINE alter' #-} + +-- | /O(log n)/. Variant of 'alterF' that disallows deletion. Allows us to +-- guarantee that the result is also a non-empty IntMap. +-- +-- Like @Data.IntMap.alterF@ for 'IntMap', can be used to generalize and unify +-- 'lookup' and 'insert'. However, because it disallows deletion, it +-- cannot be used to implement 'delete'. +-- +-- See 'alterF' for usage information and caveats. +-- +-- Note: Neither 'alterF' nor 'alterF'' can be considered flipped versions +-- of the 'Control.Lens.At.at' combinator from "Control.Lens.At". However, +-- this can match the shape expected from most functions expecting lenses, +-- getters, and setters, so can be thought of as a "psuedo-lens", with +-- virtually the same practical applications as a legitimate lens. +-- +-- __WARNING__: The rewrite rule for 'Identity' exposes an inconsistency in +-- undefined behavior for "Data.IntMap". @Data.IntMap.alterF@ will actually +-- /maintain/ the original key in the map when used with 'Identity'; +-- however, @Data.IntMap.insertWith@ will /replace/ the orginal key in the +-- map. The rewrite rule for 'alterF'' has chosen to be faithful to +-- @Data.IntMap.insertWith@, and /not/ @Data.IntMap.alterF@, for the sake of +-- a cleaner implementation. +alterF' :: + Functor f => + (Maybe a -> f a) -> + Key -> + NEIntMap a -> + f (NEIntMap a) +alterF' f k n@(NEIntMap k0 v m) = case compare k k0 of + LT -> flip (NEIntMap k) (toMap n) <$> f Nothing + EQ -> flip (NEIntMap k0) m <$> f (Just v) + GT -> NEIntMap k0 v <$> M.alterF (fmap Just . f) k m +{-# INLINEABLE [2] alterF' #-} + +-- if f ~ Const b, it's a lookup +{-# RULES +"alterF'/Const" forall k (f :: Maybe a -> Const b a). + alterF' f k = + Const . getConst . f . lookup k + #-} + +-- if f ~ Identity, it's an insertWith +{-# RULES +"alterF'/Identity" forall k (f :: Maybe a -> Identity a). + alterF' f k = + Identity . insertWith (\_ -> runIdentity . f . Just) k (runIdentity (f Nothing)) + #-} + +-- | /O(log n)/. Lookup the value at a key in the map. +-- +-- The function will return the corresponding value as @('Just' value)@, +-- or 'Nothing' if the key isn't in the map. +-- +-- An example of using @lookup@: +-- +-- > import Prelude hiding (lookup) +-- > import Data.Map.NonEmpty +-- > +-- > employeeDept = fromList (("John","Sales") :| [("Bob","IT")]) +-- > deptCountry = fromList (("IT","USA") :| [("Sales","France")]) +-- > countryCurrency = fromList (("USA", "Dollar") :| [("France", "Euro")]) +-- > +-- > employeeCurrency :: String -> Maybe String +-- > employeeCurrency name = do +-- > dept <- lookup name employeeDept +-- > country <- lookup dept deptCountry +-- > lookup country countryCurrency +-- > +-- > main = do +-- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John")) +-- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete")) +-- +-- The output of this program: +-- +-- > John's currency: Just "Euro" +-- > Pete's currency: Nothing +lookup :: + Key -> + NEIntMap a -> + Maybe a +lookup k (NEIntMap k0 v m) = case compare k k0 of + LT -> Nothing + EQ -> Just v + GT -> M.lookup k m +{-# INLINE lookup #-} + +-- | /O(log n)/. Find the value at a key. Returns 'Nothing' when the +-- element can not be found. +-- +-- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 1 == Nothing +-- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 5 == Just 'a' +(!?) :: NEIntMap a -> Key -> Maybe a +(!?) = flip lookup +{-# INLINE (!?) #-} + +-- | /O(log n)/. Find the value at a key. Calls 'error' when the element +-- can not be found. +-- +-- > fromList ((5,'a') :| [(3,'b')]) ! 1 Error: element not in the map +-- > fromList ((5,'a') :| [(3,'b')]) ! 5 == 'a' +(!) :: NEIntMap a -> Key -> a +(!) m k = fromMaybe e $ m !? k + where + e = error "NEIntMap.!: given key is not an element in the map" +{-# INLINE (!) #-} + +infixl 9 !? +infixl 9 ! + +-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns +-- the value at key @k@ or returns default value @def@ +-- when the key is not in the map. +-- +-- > findWithDefault 'x' 1 (fromList ((5,'a') :| [(3,'b')])) == 'x' +-- > findWithDefault 'x' 5 (fromList ((5,'a') :| [(3,'b')])) == 'a' +findWithDefault :: + a -> + Key -> + NEIntMap a -> + a +findWithDefault def k (NEIntMap k0 v m) = case compare k k0 of + LT -> def + EQ -> v + GT -> M.findWithDefault def k m +{-# INLINE findWithDefault #-} + +-- | /O(log n)/. Is the key a member of the map? See also 'notMember'. +-- +-- > member 5 (fromList ((5,'a') :| [(3,'b')])) == True +-- > member 1 (fromList ((5,'a') :| [(3,'b')])) == False +member :: Key -> NEIntMap a -> Bool +member k (NEIntMap k0 _ m) = case compare k k0 of + LT -> False + EQ -> True + GT -> M.member k m +{-# INLINE member #-} + +-- | /O(log n)/. Is the key not a member of the map? See also 'member'. +-- +-- > notMember 5 (fromList ((5,'a') :| [(3,'b')])) == False +-- > notMember 1 (fromList ((5,'a') :| [(3,'b')])) == True +notMember :: Key -> NEIntMap a -> Bool +notMember k (NEIntMap k0 _ m) = case compare k k0 of + LT -> True + EQ -> False + GT -> M.notMember k m +{-# INLINE notMember #-} + +-- | /O(log n)/. Find largest key smaller than the given one and return the +-- corresponding (key, value) pair. +-- +-- > lookupLT 3 (fromList ((3,'a') :| [(5,'b')])) == Nothing +-- > lookupLT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') +lookupLT :: Key -> NEIntMap a -> Maybe (Key, a) +lookupLT k (NEIntMap k0 v m) = case compare k k0 of + LT -> Nothing + EQ -> Nothing + GT -> M.lookupLT k m <|> Just (k0, v) +{-# INLINE lookupLT #-} + +-- | /O(log n)/. Find smallest key greater than the given one and return the +-- corresponding (key, value) pair. +-- +-- > lookupGT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') +-- > lookupGT 5 (fromList ((3,'a') :| [(5,'b')])) == Nothing +lookupGT :: Key -> NEIntMap a -> Maybe (Key, a) +lookupGT k (NEIntMap k0 v m) = case compare k k0 of + LT -> Just (k0, v) + EQ -> M.lookupMin m + GT -> M.lookupGT k m +{-# INLINE lookupGT #-} + +-- | /O(log n)/. Find largest key smaller or equal to the given one and return +-- the corresponding (key, value) pair. +-- +-- > lookupLE 2 (fromList ((3,'a') :| [(5,'b')])) == Nothing +-- > lookupLE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') +-- > lookupLE 5 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') +lookupLE :: Key -> NEIntMap a -> Maybe (Key, a) +lookupLE k (NEIntMap k0 v m) = case compare k k0 of + LT -> Nothing + EQ -> Just (k0, v) + GT -> M.lookupLE k m <|> Just (k0, v) +{-# INLINE lookupLE #-} + +-- | /O(log n)/. Find smallest key greater or equal to the given one and return +-- the corresponding (key, value) pair. +-- +-- > lookupGE 3 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') +-- > lookupGE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') +-- > lookupGE 6 (fromList ((3,'a') :| [(5,'b')])) == Nothing +lookupGE :: Key -> NEIntMap a -> Maybe (Key, a) +lookupGE k (NEIntMap k0 v m) = case compare k k0 of + LT -> Just (k0, v) + EQ -> Just (k0, v) + GT -> M.lookupGE k m +{-# INLINE lookupGE #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function. +-- +-- > unionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "aA"), (7, "C")]) +unionWith :: + (a -> a -> a) -> + NEIntMap a -> + NEIntMap a -> + NEIntMap a +unionWith f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of + LT -> NEIntMap k1 v1 . M.unionWith f m1 . toMap $ n2 + EQ -> NEIntMap k1 (f v1 v2) . M.unionWith f m1 $ m2 + GT -> NEIntMap k2 v2 . M.unionWith f (toMap n1) $ m2 +{-# INLINE unionWith #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. +-- Union with a combining function, given the matching key. +-- +-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value +-- > unionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "5:a|A"), (7, "C")]) +unionWithKey :: + (Key -> a -> a -> a) -> + NEIntMap a -> + NEIntMap a -> + NEIntMap a +unionWithKey f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of + LT -> NEIntMap k1 v1 . M.unionWithKey f m1 . toMap $ n2 + EQ -> NEIntMap k1 (f k1 v1 v2) . M.unionWithKey f m1 $ m2 + GT -> NEIntMap k2 v2 . M.unionWithKey f (toMap n1) $ m2 +{-# INLINE unionWithKey #-} + +-- | The union of a non-empty list of maps, with a combining operation: +-- (@'unionsWith' f == 'Data.Foldable.foldl1' ('unionWith' f)@). +-- +-- > unionsWith (++) (fromList ((5, "a") :| [(3, "b")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "A3") :| [(3, "B3")])]) +-- > == fromList ((3, "bB3") :| [(5, "aAA3"), (7, "C")]) +unionsWith :: + Foldable1 f => + (a -> a -> a) -> + f (NEIntMap a) -> + NEIntMap a +unionsWith f (F1.toNonEmpty -> (m :| ms)) = F.foldl' (unionWith f) m ms +{-# INLINE unionsWith #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps. +-- Return elements of the first map not existing in the second map. +-- +-- Returns a potentially empty map ('IntMap'), in case the first map is +-- a subset of the second map. +-- +-- > difference (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 3 "b" +difference :: + NEIntMap a -> + NEIntMap b -> + IntMap a +difference n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 _ m2) = case compare k1 k2 of + -- k1 is not in n2, so cannot be deleted + LT -> insertMinMap k1 v1 $ m1 `M.difference` toMap n2 + -- k2 deletes k1, and only k1 + EQ -> m1 `M.difference` m2 + -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. + GT -> toMap n1 `M.difference` m2 +{-# INLINE difference #-} + +-- | Same as 'difference'. +(\\) :: + NEIntMap a -> + NEIntMap b -> + IntMap a +(\\) = difference +{-# INLINE (\\) #-} + +-- | /O(n+m)/. Difference with a combining function. +-- When two equal keys are +-- encountered, the combining function is applied to the values of these keys. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- Returns a potentially empty map ('IntMap'), in case the first map is +-- a subset of the second map and the function returns 'Nothing' for every +-- pair. +-- +-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing +-- > differenceWith f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (7, "C")])) +-- > == Data.IntMap.singleton 3 "b:B" +differenceWith :: + (a -> b -> Maybe a) -> + NEIntMap a -> + NEIntMap b -> + IntMap a +differenceWith f = differenceWithKey (const f) +{-# INLINE differenceWith #-} + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- Returns a potentially empty map ('IntMap'), in case the first map is +-- a subset of the second map and the function returns 'Nothing' for every +-- pair. +-- +-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing +-- > differenceWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (10, "C")])) +-- > == Data.IntMap.singleton 3 "3:b|B" +differenceWithKey :: + (Key -> a -> b -> Maybe a) -> + NEIntMap a -> + NEIntMap b -> + IntMap a +differenceWithKey f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of + -- k1 is not in n2, so cannot be deleted + LT -> insertMinMap k1 v1 $ M.differenceWithKey f m1 (toMap n2) + -- k2 deletes k1, and only k1 + EQ -> maybe id (insertMinMap k1) (f k1 v1 v2) (M.differenceWithKey f m1 m2) + -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. + GT -> M.differenceWithKey f (toMap n1) m2 +{-# INLINE differenceWithKey #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps. +-- Return data in the first map for the keys existing in both maps. +-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). +-- +-- Returns a potentially empty map ('IntMap'), in case the two maps share no +-- keys in common. +-- +-- > intersection (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 5 "a" +intersection :: + NEIntMap a -> + NEIntMap b -> + IntMap a +intersection n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 _ m2) = case compare k1 k2 of + -- k1 is not in n2 + LT -> m1 `M.intersection` toMap n2 + -- k1 and k2 are a part of the result + EQ -> insertMinMap k1 v1 $ m1 `M.intersection` m2 + -- k2 is not in n1 + GT -> toMap n1 `M.intersection` m2 +{-# INLINE intersection #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- +-- Returns a potentially empty map ('IntMap'), in case the two maps share no +-- keys in common. +-- +-- > intersectionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 5 "aA" +intersectionWith :: + (a -> b -> c) -> + NEIntMap a -> + NEIntMap b -> + IntMap c +intersectionWith f = intersectionWithKey (const f) +{-# INLINE intersectionWith #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- +-- Returns a potentially empty map ('IntMap'), in case the two maps share no +-- keys in common. +-- +-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar +-- > intersectionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.IntMap.singleton 5 "5:a|A" +intersectionWithKey :: + (Key -> a -> b -> c) -> + NEIntMap a -> + NEIntMap b -> + IntMap c +intersectionWithKey f n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of + -- k1 is not in n2 + LT -> M.intersectionWithKey f m1 (toMap n2) + -- k1 and k2 are a part of the result + EQ -> insertMinMap k1 (f k1 v1 v2) $ M.intersectionWithKey f m1 m2 + -- k2 is not in n1 + GT -> M.intersectionWithKey f (toMap n1) m2 +{-# INLINE intersectionWithKey #-} + +-- | /O(n)/. IntMap a function over all values in the map. +-- +-- > let f key x = (show key) ++ ":" ++ x +-- > mapWithKey f (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "3:b") :| [(5, "5:a")]) +mapWithKey :: (Key -> a -> b) -> NEIntMap a -> NEIntMap b +mapWithKey f (NEIntMap k v m) = NEIntMap k (f k v) (M.mapWithKey f m) +{-# NOINLINE [1] mapWithKey #-} + +{-# RULES +"mapWithKey/mapWithKey" forall f g xs. + mapWithKey f (mapWithKey g xs) = + mapWithKey (\k a -> f k (g k a)) xs +"mapWithKey/map" forall f g xs. + mapWithKey f (map g xs) = + mapWithKey (\k a -> f k (g a)) xs +"map/mapWithKey" forall f g xs. + map f (mapWithKey g xs) = + mapWithKey (\k a -> f (g k a)) xs + #-} + +-- | /O(n)/. The function 'mapAccum' threads an accumulating argument +-- through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList ((5,"a") :| [(3,"b")])) == ("Everything: ba", fromList ((3, "bX") :| [(5, "aX")])) +mapAccum :: + (a -> b -> (a, c)) -> + a -> + NEIntMap b -> + (a, NEIntMap c) +mapAccum f = mapAccumWithKey (\x _ -> f x) +{-# INLINE mapAccum #-} + +-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList ((5,"a") :| [(3,"b")])) == ("Everything: 3-b 5-a", fromList ((3, "bX") :| [(5, "aX")])) +mapAccumWithKey :: + (a -> Key -> b -> (a, c)) -> + a -> + NEIntMap b -> + (a, NEIntMap c) +mapAccumWithKey f z0 (NEIntMap k v m) = (z2, NEIntMap k v' m') + where + ~(z1, v') = f z0 k v + ~(z2, m') = M.mapAccumWithKey f z1 m +{-# INLINE mapAccumWithKey #-} + +-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: + (a -> Key -> b -> (a, c)) -> + a -> + NEIntMap b -> + (a, NEIntMap c) +mapAccumRWithKey f z0 (NEIntMap k v m) = (z2, NEIntMap k v' m') + where + ~(z1, m') = M.mapAccumRWithKey f z0 m + ~(z2, v') = f z1 k v +{-# INLINE mapAccumRWithKey #-} + +-- | /O(n*log n)/. +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the value at the greatest of the +-- original keys is retained. +-- +-- While the size of the result map may be smaller than the input map, the +-- output map is still guaranteed to be non-empty if the input map is +-- non-empty. +-- +-- > mapKeys (+ 1) (fromList ((5,"a") :| [(3,"b")])) == fromList ((4, "b") :| [(6, "a")]) +-- > mapKeys (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "c" +-- > mapKeys (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "c" +mapKeys :: + (Key -> Key) -> + NEIntMap a -> + NEIntMap a +mapKeys f (NEIntMap k0 v0 m) = + fromListWith const + . ((f k0, v0) :|) + . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] + $ m +{-# INLINEABLE mapKeys #-} + +-- | /O(n*log n)/. +-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. The value at the greater of the two original keys +-- is used as the first argument to @c@. +-- +-- While the size of the result map may be smaller than the input map, the +-- output map is still guaranteed to be non-empty if the input map is +-- non-empty. +-- +-- > mapKeysWith (++) (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "cdab" +-- > mapKeysWith (++) (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "cdab" +mapKeysWith :: + (a -> a -> a) -> + (Key -> Key) -> + NEIntMap a -> + NEIntMap a +mapKeysWith c f (NEIntMap k0 v0 m) = + fromListWith c + . ((f k0, v0) :|) + . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] + $ m +{-# INLINEABLE mapKeysWith #-} + +-- | /O(n)/. +-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s +-- > where ls = keys s +-- +-- This means that @f@ maps distinct original keys to distinct resulting keys. +-- This function has better performance than 'mapKeys'. +-- +-- While the size of the result map may be smaller than the input map, the +-- output map is still guaranteed to be non-empty if the input map is +-- non-empty. +-- +-- > mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")])) == fromList ((6, "b") :| [(10, "a")]) +-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")]))) == True +-- > valid (mapKeysMonotonic (\ _ -> 1) (fromList ((5,"a") :| [(3,"b")]))) == False +mapKeysMonotonic :: + (Key -> Key) -> + NEIntMap a -> + NEIntMap a +mapKeysMonotonic f (NEIntMap k v m) = + NEIntMap (f k) v + . M.mapKeysMonotonic f + $ m +{-# INLINE mapKeysMonotonic #-} + +-- | /O(n)/. Fold the keys and values in the map using the given right-associative +-- binary operator, such that +-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +-- +-- For example, +-- +-- > keysList map = foldrWithKey (\k x ks -> k:ks) [] map +foldrWithKey :: (Key -> a -> b -> b) -> b -> NEIntMap a -> b +foldrWithKey f z (NEIntMap k v m) = f k v . M.foldrWithKey f z $ m +{-# INLINE foldrWithKey #-} + +-- | /O(n)/. Fold the keys and values in the map using the given left-associative +-- binary operator, such that +-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. +-- +-- For example, +-- +-- > keysList = reverse . foldlWithKey (\ks k x -> k:ks) [] +foldlWithKey :: (a -> Key -> b -> a) -> a -> NEIntMap b -> a +foldlWithKey f z (NEIntMap k v m) = M.foldlWithKey f (f z k v) m +{-# INLINE foldlWithKey #-} + +-- | /O(n)/. A strict version of 'foldr1'. Each application of the operator +-- is evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr1' :: (a -> a -> a) -> NEIntMap a -> a +foldr1' f (NEIntMap _ v m) = case M.maxView m of + Nothing -> v + Just (y, m') -> let !z = M.foldr' f y m' in v `f` z +{-# INLINE foldr1' #-} + +-- | /O(n)/. A strict version of 'foldl1'. Each application of the operator +-- is evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl1' :: (a -> a -> a) -> NEIntMap a -> a +foldl1' f (NEIntMap _ v m) = M.foldl' f v m +{-# INLINE foldl1' #-} + +-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldrWithKey' :: (Key -> a -> b -> b) -> b -> NEIntMap a -> b +foldrWithKey' f z (NEIntMap k v m) = f k v y + where + !y = M.foldrWithKey f z m +{-# INLINE foldrWithKey' #-} + +-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldlWithKey' :: (a -> Key -> b -> a) -> a -> NEIntMap b -> a +foldlWithKey' f z (NEIntMap k v m) = M.foldlWithKey' f x m + where + !x = f z k v +{-# INLINE foldlWithKey' #-} + +-- | /O(n)/. Return all keys of the map in ascending order. +-- +-- > keys (fromList ((5,"a") :| [(3,"b")])) == (3 :| [5]) +keys :: NEIntMap a -> NonEmpty Key +keys (NEIntMap k _ m) = k :| M.keys m +{-# INLINE keys #-} + +-- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map +-- in ascending key order. +-- +-- > assocs (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) +assocs :: NEIntMap a -> NonEmpty (Key, a) +assocs = toList +{-# INLINE assocs #-} + +-- | /O(n)/. The non-empty set of all keys of the map. +-- +-- > keysSet (fromList ((5,"a") :| [(3,"b")])) == Data.Set.NonEmpty.fromList (3 :| [5]) +keysSet :: NEIntMap a -> NEIntSet +keysSet (NEIntMap k _ m) = NEIntSet k (M.keysSet m) +{-# INLINE keysSet #-} + +-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are +-- in ascending order. +-- +-- > toAscList (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) +toAscList :: NEIntMap a -> NonEmpty (Key, a) +toAscList = toList +{-# INLINE toAscList #-} + +-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys +-- are in descending order. +-- +-- > toDescList (fromList ((5,"a") :| [(3,"b")])) == ((5,"a") :| [(3,"b")]) +toDescList :: NEIntMap a -> NonEmpty (Key, a) +toDescList (NEIntMap k0 v0 m) = M.foldlWithKey' go ((k0, v0) :| []) m + where + go xs k v = (k, v) NE.<| xs +{-# INLINE toDescList #-} + +-- | /O(n)/. Filter all values that satisfy the predicate. +-- +-- Returns a potentially empty map ('IntMap'), because we could +-- potentailly filter out all items in the original 'NEIntMap'. +-- +-- > filter (> "a") (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" +-- > filter (> "x") (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.empty +-- > filter (< "a") (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.empty +filter :: + (a -> Bool) -> + NEIntMap a -> + IntMap a +filter f (NEIntMap k v m) + | f v = insertMinMap k v . M.filter f $ m + | otherwise = M.filter f m +{-# INLINE filter #-} + +-- | /O(n)/. Filter all keys\/values that satisfy the predicate. +-- +-- Returns a potentially empty map ('IntMap'), because we could +-- potentailly filter out all items in the original 'NEIntMap'. +-- +-- > filterWithKey (\k _ -> k > 4) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" +filterWithKey :: + (Key -> a -> Bool) -> + NEIntMap a -> + IntMap a +filterWithKey f (NEIntMap k v m) + | f k v = insertMinMap k v . M.filterWithKey f $ m + | otherwise = M.filterWithKey f m +{-# INLINE filterWithKey #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Restrict an 'NEIntMap' to only those keys +-- found in a 'Data.Set.Set'. +-- +-- @ +-- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m +-- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s +-- @ +restrictKeys :: + NEIntMap a -> + IntSet -> + IntMap a +restrictKeys n@(NEIntMap k v m) xs = case S.minView xs of + Nothing -> M.empty + Just (y, ys) -> case compare k y of + -- k is not in xs + LT -> m `M.restrictKeys` xs + -- k and y are a part of the result + EQ -> insertMinMap k v $ m `M.restrictKeys` ys + -- y is not in m + GT -> toMap n `M.restrictKeys` ys +{-# INLINE restrictKeys #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Data.Set.Set' from +-- an 'NEIntMap'. +-- +-- @ +-- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m +-- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s +-- @ +withoutKeys :: + NEIntMap a -> + IntSet -> + IntMap a +withoutKeys n@(NEIntMap k v m) xs = case S.minView xs of + Nothing -> toMap n + Just (y, ys) -> case compare k y of + -- k is not in xs, so cannot be deleted + LT -> insertMinMap k v $ m `M.withoutKeys` xs + -- y deletes k, and only k + EQ -> m `M.withoutKeys` ys + -- y is not in n, so cannot delete anything, so we can just difference n and ys + GT -> toMap n `M.withoutKeys` ys +{-# INLINE withoutKeys #-} + +-- | /O(n)/. Partition the map according to a predicate. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the predicate was true for all items. +-- * @'That' n2@ means that the predicate was false for all items. +-- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the +-- predicate) and @n2@ (all of the items that were false for the +-- predicate). +-- +-- See also 'split'. +-- +-- > partition (> "a") (fromList ((5,"a") :| [(3,"b")])) == These (singleton 3 "b") (singleton 5 "a") +-- > partition (< "x") (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) +-- > partition (> "x") (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) +partition :: + (a -> Bool) -> + NEIntMap a -> + These (NEIntMap a) (NEIntMap a) +partition f = partitionWithKey (const f) +{-# INLINE partition #-} + +-- | /O(n)/. Partition the map according to a predicate. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the predicate was true for all items, +-- returning the original map. +-- * @'That' n2@ means that the predicate was false for all items, +-- returning the original map. +-- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the +-- predicate) and @n2@ (all of the items that were false for the +-- predicate). +-- +-- See also 'split'. +-- +-- > partitionWithKey (\ k _ -> k > 3) (fromList ((5,"a") :| [(3,"b")])) == These (singleton 5 "a") (singleton 3 "b") +-- > partitionWithKey (\ k _ -> k < 7) (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) +-- > partitionWithKey (\ k _ -> k > 7) (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) +partitionWithKey :: + (Key -> a -> Bool) -> + NEIntMap a -> + These (NEIntMap a) (NEIntMap a) +partitionWithKey f n@(NEIntMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) + | f k v -> This n + | otherwise -> That n + (Just n1, Nothing) + | f k v -> This n + | otherwise -> These n1 (singleton k v) + (Nothing, Just n2) + | f k v -> These (singleton k v) n2 + | otherwise -> That n + (Just n1, Just n2) + | f k v -> These (insertMapMin k v m1) n2 + | otherwise -> These n1 (insertMapMin k v m2) + where + (m1, m2) = M.partitionWithKey f m0 +{-# INLINEABLE partitionWithKey #-} + +-- | /O(n)/. Map values and collect the 'Just' results. +-- +-- Returns a potentially empty map ('IntMap'), because the function could +-- potentially return 'Nothing' on all items in the 'NEIntMap'. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > mapMaybe f (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "new a" +mapMaybe :: + (a -> Maybe b) -> + NEIntMap a -> + IntMap b +mapMaybe f = mapMaybeWithKey (const f) +{-# INLINE mapMaybe #-} + +-- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- +-- Returns a potentially empty map ('IntMap'), because the function could +-- potentially return 'Nothing' on all items in the 'NEIntMap'. +-- +-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing +-- > mapMaybeWithKey f (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "key : 3" +mapMaybeWithKey :: + (Key -> a -> Maybe b) -> + NEIntMap a -> + IntMap b +mapMaybeWithKey f (NEIntMap k v m) = maybe id (insertMinMap k) (f k v) (M.mapMaybeWithKey f m) +{-# INLINE mapMaybeWithKey #-} + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the results were all 'Left'. +-- * @'That' n2@ means that the results were all 'Right'. +-- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') +-- and @n2@ (the map where the results were 'Right') +-- +-- > let f a = if a < "c" then Left a else Right a +-- > mapEither f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == These (fromList ((3,"b") :| [(5,"a")])) (fromList ((1,"x") :| [(7,"z")])) +-- > +-- > mapEither (\ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == That (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +mapEither :: + (a -> Either b c) -> + NEIntMap a -> + These (NEIntMap b) (NEIntMap c) +mapEither f = mapEitherWithKey (const f) +{-# INLINE mapEither #-} + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the results were all 'Left'. +-- * @'That' n2@ means that the results were all 'Right'. +-- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') +-- and @n2@ (the map where the results were 'Right') +-- +-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- > mapEitherWithKey f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == These (fromList ((1,2) :| [(3,6)])) (fromList ((5,"aa") :| [(7,"zz")])) +-- > +-- > mapEitherWithKey (\_ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == That (fromList ((1,"x") :| [(3,"b"), (5,"a"), (7,"z")])) +mapEitherWithKey :: + (Key -> a -> Either b c) -> + NEIntMap a -> + These (NEIntMap b) (NEIntMap c) +mapEitherWithKey f (NEIntMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> case f k v of + Left v' -> This (singleton k v') + Right v' -> That (singleton k v') + (Just n1, Nothing) -> case f k v of + Left v' -> This (insertMapMin k v' m1) + Right v' -> These n1 (singleton k v') + (Nothing, Just n2) -> case f k v of + Left v' -> These (singleton k v') n2 + Right v' -> That (insertMapMin k v' m2) + (Just n1, Just n2) -> case f k v of + Left v' -> These (insertMapMin k v' m1) n2 + Right v' -> These n1 (insertMapMin k v' m2) + where + (m1, m2) = M.mapEitherWithKey f m0 +{-# INLINEABLE mapEitherWithKey #-} + +-- | /O(log n)/. The expression (@'split' k map@) is potentially a 'These' +-- containing up to two 'NEIntMap's based on splitting the map into maps +-- containing items before and after the given key @k@. It will never +-- return a map that contains @k@ itself. +-- +-- * 'Nothing' means that @k@ was the only key in the the original map, +-- and so there are no items before or after it. +-- * @'Just' ('This' n1)@ means @k@ was larger than or equal to all items +-- in the map, and @n1@ is the entire original map (minus @k@, if it was +-- present) +-- * @'Just' ('That' n2)@ means @k@ was smaller than or equal to all +-- items in the map, and @n2@ is the entire original map (minus @k@, if +-- it was present) +-- * @'Just' ('These' n1 n2)@ gives @n1@ (the map of all keys from the +-- original map less than @k@) and @n2@ (the map of all keys from the +-- original map greater than @k@) +-- +-- > split 2 (fromList ((5,"a") :| [(3,"b")])) == Just (That (fromList ((3,"b") :| [(5,"a")])) ) +-- > split 3 (fromList ((5,"a") :| [(3,"b")])) == Just (That (singleton 5 "a") ) +-- > split 4 (fromList ((5,"a") :| [(3,"b")])) == Just (These (singleton 3 "b") (singleton 5 "a")) +-- > split 5 (fromList ((5,"a") :| [(3,"b")])) == Just (This (singleton 3 "b") ) +-- > split 6 (fromList ((5,"a") :| [(3,"b")])) == Just (This (fromList ((3,"b") :| [(5,"a")])) ) +-- > split 5 (singleton 5 "a") == Nothing +split :: + Key -> + NEIntMap a -> + Maybe (These (NEIntMap a) (NEIntMap a)) +split k n@(NEIntMap k0 v m0) = case compare k k0 of + LT -> Just $ That n + EQ -> That <$> nonEmptyMap m0 + 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 +{-# INLINEABLE split #-} + +-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just +-- like 'split' but also returns @'lookup' k map@, as the first field in +-- the 'These': +-- +-- > 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 -> + These a (These (NEIntMap a) (NEIntMap a)) +splitLookup k n@(NEIntMap k0 v0 m0) = case compare k k0 of + 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 +{-# INLINEABLE splitLookup #-} + +-- | /O(1)/. Decompose a map into pieces based on the structure of the +-- underlying tree. This function is useful for consuming a map in +-- parallel. +-- +-- No guarantee is made as to the sizes of the pieces; an internal, but +-- deterministic process determines this. However, it is guaranteed that +-- the pieces returned will be in ascending order (all elements in the +-- first submap less than all elements in the second, and so on). +-- +-- Note that the current implementation does not return more than four +-- submaps, but you should not depend on this behaviour because it can +-- change in the future without notice. +splitRoot :: + NEIntMap a -> + NonEmpty (NEIntMap a) +splitRoot (NEIntMap k v m) = + singleton k v + :| Maybe.mapMaybe nonEmptyMap (M.splitRoot m) +{-# INLINE splitRoot #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. +-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). +isSubmapOf :: Eq a => NEIntMap a -> NEIntMap a -> Bool +isSubmapOf = isSubmapOfBy (==) +{-# INLINE isSubmapOf #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. +-- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if +-- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when +-- applied to their respective values. For example, the following +-- expressions are all 'True': +-- +-- > isSubmapOfBy (==) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (<=) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (fromList (('a',1) :| [('b',2)])) +-- +-- But the following are all 'False': +-- +-- > isSubmapOfBy (==) (singleton 'a' 2) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (<) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (singleton 'a' 1) +isSubmapOfBy :: + (a -> b -> Bool) -> + NEIntMap a -> + NEIntMap b -> + Bool +isSubmapOfBy f (NEIntMap k v m0) (toMap -> m1) = + kvSub + && M.isSubmapOfBy f m0 m1 + where + kvSub = case M.lookup k m1 of + Just v0 -> f v v0 + Nothing -> False +{-# INLINE isSubmapOfBy #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap +-- but not equal). Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' +-- (==)@). +isProperSubmapOf :: Eq a => NEIntMap a -> NEIntMap a -> Bool +isProperSubmapOf = isProperSubmapOfBy (==) +{-# INLINE isProperSubmapOf #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap +-- but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns +-- 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, +-- and when @f@ returns 'True' when applied to their respective values. For +-- example, the following expressions are all 'True': +-- +-- > isProperSubmapOfBy (==) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) +-- > isProperSubmapOfBy (<=) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) +-- +-- But the following are all 'False': +-- +-- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (fromList ((1,1) :| [(2,2)])) +-- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (singleton 1 1)) +-- > isProperSubmapOfBy (<) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) +isProperSubmapOfBy :: + (a -> b -> Bool) -> + NEIntMap a -> + NEIntMap b -> + Bool +isProperSubmapOfBy f m1 m2 = + M.size (neimIntMap m1) < M.size (neimIntMap m2) + && isSubmapOfBy f m1 m2 +{-# INLINE isProperSubmapOfBy #-} + +-- | /O(1)/. The minimal key of the map. Note that this is total, making +-- 'Data.IntMap.lookupMin' obsolete. It is constant-time, so has better +-- asymptotics than @Data.IntMap.lookupMin@ and @Data.IntMap.findMin@, as well. +-- +-- > findMin (fromList ((5,"a") :| [(3,"b")])) == (3,"b") +findMin :: NEIntMap a -> (Key, a) +findMin (NEIntMap k v _) = (k, v) +{-# INLINE findMin #-} + +-- | /O(log n)/. The maximal key of the map. Note that this is total, making +-- 'Data.IntMap.lookupMin' obsolete. +-- +-- > findMax (fromList ((5,"a") :| [(3,"b")])) == (5,"a") +findMax :: NEIntMap a -> (Key, a) +findMax (NEIntMap k v m) = fromMaybe (k, v) . M.lookupMax $ m +{-# INLINE findMax #-} + +-- | /O(1)/. Delete the minimal key. Returns a potentially empty map +-- ('IntMap'), because we might end up deleting the final key in a singleton +-- map. It is constant-time, so has better asymptotics than +-- 'Data.IntMap.deleteMin'. +-- +-- > deleteMin (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.IntMap.fromList [(5,"a"), (7,"c")] +-- > deleteMin (singleton 5 "a") == Data.IntMap.empty +deleteMin :: NEIntMap a -> IntMap a +deleteMin (NEIntMap _ _ m) = m +{-# INLINE deleteMin #-} + +-- | /O(log n)/. Delete the maximal key. Returns a potentially empty map +-- ('IntMap'), because we might end up deleting the final key in a singleton +-- map. +-- +-- > deleteMax (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.IntMap.fromList [(3,"b"), (5,"a")] +-- > deleteMax (singleton 5 "a") == Data.IntMap.empty +deleteMax :: NEIntMap a -> IntMap a +deleteMax (NEIntMap k v m) = case M.maxView m of + Nothing -> M.empty + Just (_, m') -> insertMinMap k v m' +{-# INLINE deleteMax #-} + +-- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the +-- minimal key. Returns a potentially empty map ('IntMap'), because we might +-- end up deleting the final key in the map if the function returns +-- 'Nothing'. See 'adjustMin' for a version that can guaruntee that we +-- return a non-empty map. +-- +-- > updateMin (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "Xb"), (5, "a")] +-- > updateMin (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" +updateMin :: (a -> Maybe a) -> NEIntMap a -> IntMap a +updateMin f = updateMinWithKey (const f) +{-# INLINE updateMin #-} + +-- | /O(1)/. A version of 'updateMin' that disallows deletion, allowing us +-- to guarantee that the result is also non-empty. +adjustMin :: (a -> a) -> NEIntMap a -> NEIntMap a +adjustMin f = adjustMinWithKey (const f) +{-# INLINE adjustMin #-} + +-- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the +-- minimal key. Returns a potentially empty map ('IntMap'), because we might +-- end up deleting the final key in the map if the function returns +-- 'Nothing'. See 'adjustMinWithKey' for a version that guaruntees +-- a non-empty map. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" +updateMinWithKey :: (Key -> a -> Maybe a) -> NEIntMap a -> IntMap a +updateMinWithKey f (NEIntMap k v m) = maybe id (insertMinMap k) (f k v) m +{-# INLINE updateMinWithKey #-} + +-- | /O(1)/. A version of 'adjustMaxWithKey' that disallows deletion, +-- allowing us to guarantee that the result is also non-empty. Note that +-- it also is able to have better asymptotics than 'updateMinWithKey' in +-- general. +adjustMinWithKey :: (Key -> a -> a) -> NEIntMap a -> NEIntMap a +adjustMinWithKey f (NEIntMap k v m) = NEIntMap k (f k v) m +{-# INLINE adjustMinWithKey #-} + +-- | /O(log n)/. Update the value at the maximal key. Returns +-- a potentially empty map ('IntMap'), because we might end up deleting the +-- final key in the map if the function returns 'Nothing'. See 'adjustMax' +-- for a version that can guarantee that we return a non-empty map. +-- +-- > updateMax (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3, "b"), (5, "Xa")] +-- > updateMax (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 3 "b" +updateMax :: (a -> Maybe a) -> NEIntMap a -> IntMap a +updateMax f = updateMaxWithKey (const f) +{-# INLINE updateMax #-} + +-- | /O(log n)/. A version of 'updateMax' that disallows deletion, allowing +-- us to guarantee that the result is also non-empty. +adjustMax :: (a -> a) -> NEIntMap a -> NEIntMap a +adjustMax f = adjustMaxWithKey (const f) +{-# INLINE adjustMax #-} + +-- | /O(log n)/. Update the value at the maximal key. Returns +-- a potentially empty map ('IntMap'), because we might end up deleting the +-- final key in the map if the function returns 'Nothing'. See +-- 'adjustMaxWithKey' for a version that guaruntees a non-empty map. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.IntMap.singleton 5 "a" +updateMaxWithKey :: (Key -> a -> Maybe a) -> NEIntMap a -> IntMap a +updateMaxWithKey f (NEIntMap k v m) + | M.null m = maybe m (M.singleton k) $ f k v + | otherwise = + insertMinMap k v + . M.updateMaxWithKey f + $ m +{-# INLINE updateMaxWithKey #-} + +-- | /O(log n)/. A version of 'updateMaxWithKey' that disallows deletion, +-- allowing us to guarantee that the result is also non-empty. +adjustMaxWithKey :: (Key -> a -> a) -> NEIntMap a -> NEIntMap a +adjustMaxWithKey f (NEIntMap k0 v m) + | M.null m = NEIntMap k0 (f k0 v) m + | otherwise = + insertMapMin k0 v + . M.updateMaxWithKey (\k -> Just . f k) + $ m +{-# INLINE adjustMaxWithKey #-} + +-- | /O(1)/. Retrieves the value associated with minimal key of the +-- map, and the map stripped of that element. It is constant-time, so has +-- better asymptotics than @Data.IntMap.minView@ for 'IntMap'. +-- +-- Note that unlike @Data.IntMap.minView@ for 'IntMap', this cannot ever fail, +-- so doesn't need to return in a 'Maybe'. However, the result 'IntMap' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > minView (fromList ((5,"a") :| [(3,"b")])) == ("b", Data.IntMap.singleton 5 "a") +minView :: NEIntMap a -> (a, IntMap a) +minView = first snd . deleteFindMin +{-# INLINE minView #-} + +-- | /O(1)/. Delete and find the minimal key-value pair. It is +-- constant-time, so has better asymptotics that @Data.IntMap.minView@ for +-- 'IntMap'. +-- +-- Note that unlike @Data.IntMap.deleteFindMin@ for 'IntMap', this cannot ever +-- fail, and so is a total function. However, the result 'IntMap' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > deleteFindMin (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((3,"b"), Data.IntMap.fromList [(5,"a"), (10,"c")]) +deleteFindMin :: NEIntMap a -> ((Key, a), IntMap a) +deleteFindMin (NEIntMap k v m) = ((k, v), m) +{-# INLINE deleteFindMin #-} + +-- | /O(log n)/. Retrieves the value associated with maximal key of the +-- map, and the map stripped of that element. +-- +-- Note that unlike @Data.IntMap.maxView@ from 'IntMap', this cannot ever fail, +-- so doesn't need to return in a 'Maybe'. However, the result 'IntMap' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > maxView (fromList ((5,"a") :| [(3,"b")])) == ("a", Data.IntMap.singleton 3 "b") +maxView :: NEIntMap a -> (a, IntMap a) +maxView = first snd . deleteFindMax +{-# INLINE maxView #-} + +-- | /O(log n)/. Delete and find the minimal key-value pair. +-- +-- Note that unlike @Data.IntMap.deleteFindMax@ for 'IntMap', this cannot ever +-- fail, and so is a total function. However, the result 'IntMap' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > deleteFindMax (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((10,"c"), Data.IntMap.fromList [(3,"b"), (5,"a")]) +deleteFindMax :: NEIntMap a -> ((Key, a), IntMap a) +deleteFindMax (NEIntMap k v m) = + maybe ((k, v), M.empty) (second (insertMinMap k v)) + . M.maxViewWithKey + $ m +{-# INLINE deleteFindMax #-} + +-- --------------------------- +-- Combining functions +-- --------------------------- +-- +-- Code comes from "Data.Map.Internal" from containers, modified slightly +-- to work with NonEmpty +-- +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 + +combineEq :: NonEmpty (Key, b) -> NonEmpty (Key, b) +combineEq = \case + x :| [] -> x :| [] + x :| xx@(_ : _) -> go x xx + where + go z [] = z :| [] + go z@(kz, _) (x@(kx, xx) : xs') + | kx == kz = go (kx, xx) xs' + | otherwise = z NE.<| go x xs' + +combineEqWith :: + (Key -> b -> b -> b) -> + NonEmpty (Key, b) -> + NonEmpty (Key, b) +combineEqWith f = \case + x :| [] -> x :| [] + x :| xx@(_ : _) -> go x xx + where + go z [] = z :| [] + go z@(kz, zz) (x@(kx, xx) : xs') + | kx == kz = let yy = f kx xx zz in go (kx, yy) xs' | otherwise = z NE.<| go x xs' diff --git a/src/Data/IntMap/NonEmpty/Internal.hs b/src/Data/IntMap/NonEmpty/Internal.hs --- a/src/Data/IntMap/NonEmpty/Internal.hs +++ b/src/Data/IntMap/NonEmpty/Internal.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : Data.IntMap.NonEmpty.Internal @@ -19,65 +19,65 @@ -- wary! module Data.IntMap.NonEmpty.Internal ( -- * Non-Empty IntMap type - NEIntMap(..) - , Key - , singleton - , nonEmptyMap - , withNonEmpty - , fromList - , toList - , map - , insertWith - , union - , unions - , elems - , size - , toMap + NEIntMap (..), + Key, + singleton, + nonEmptyMap, + withNonEmpty, + fromList, + toList, + map, + insertWith, + union, + unions, + elems, + size, + toMap, + -- * Folds - , foldr - , foldr' - , foldr1 - , foldl - , foldl' - , foldl1 + foldr, + foldr', + foldr1, + foldl, + foldl', + foldl1, + -- * Traversals - , traverseWithKey - , traverseWithKey1 - , foldMapWithKey - , traverseMapWithKey + traverseWithKey, + traverseWithKey1, + foldMapWithKey, + -- * Unsafe IntMap Functions - , insertMinMap - , insertMaxMap + insertMinMap, + insertMaxMap, + -- * Debug - , valid - -- * CPP compatibility - , lookupMinMap - , lookupMaxMap - ) where + valid, +) where -import Control.Applicative -import Control.Comonad -import Control.DeepSeq -import Control.Monad -import Data.Coerce -import Data.Data -import Data.Function -import Data.Functor.Alt -import Data.Functor.Classes -import Data.Functor.Invariant -import Data.IntMap.Internal (IntMap(..), Key) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe -import Data.Semigroup -import Data.Semigroup.Foldable (Foldable1(fold1)) -import Data.Semigroup.Traversable (Traversable1(..)) -import Prelude hiding (Foldable(..), map) -import Text.Read -import qualified Data.Aeson as A -import qualified Data.Foldable as F -import qualified Data.IntMap as M -import qualified Data.List as L -import qualified Data.Semigroup.Foldable as F1 +import Control.Applicative +import Control.Comonad +import Control.DeepSeq +import Control.Monad +import qualified Data.Aeson as A +import Data.Coerce +import Data.Data +import qualified Data.Foldable as F +import Data.Function +import Data.Functor.Alt +import Data.Functor.Classes +import Data.Functor.Invariant +import qualified Data.IntMap as M +import Data.IntMap.Internal (IntMap (..), Key) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Semigroup +import Data.Semigroup.Foldable (Foldable1 (fold1)) +import qualified Data.Semigroup.Foldable as F1 +import Data.Semigroup.Traversable (Traversable1 (..)) +import Text.Read +import Prelude hiding (Foldable (..), map) -- | A non-empty (by construction) map from integer keys to values @a@. At -- least one key-value pair exists in an @'NEIntMap' v@ at all times. @@ -115,73 +115,92 @@ -- You can convert an 'NEIntMap' into a 'IntMap' with 'toMap' or -- 'Data.IntMap.NonEmpty.IsNonEmpty', essentially "obscuring" the non-empty -- property from the type. -data NEIntMap a = - NEIntMap { neimK0 :: !Key -- ^ invariant: must be smaller than smallest key in map - , neimV0 :: a - , neimIntMap :: !(IntMap a) - } +data NEIntMap a + = NEIntMap + { neimK0 :: !Key + -- ^ invariant: must be smaller than smallest key in map + , neimV0 :: a + , neimIntMap :: !(IntMap a) + } deriving (Typeable) instance Eq a => Eq (NEIntMap a) where - t1 == t2 = M.size (neimIntMap t1) == M.size (neimIntMap t2) - && toList t1 == toList t2 + t1 == t2 = + M.size (neimIntMap t1) == M.size (neimIntMap t2) + && toList t1 == toList t2 instance Ord a => Ord (NEIntMap a) where - compare = compare `on` toList - (<) = (<) `on` toList - (>) = (>) `on` toList - (<=) = (<=) `on` toList - (>=) = (>=) `on` toList + compare = compare `on` toList + (<) = (<) `on` toList + (>) = (>) `on` toList + (<=) = (<=) `on` toList + (>=) = (>=) `on` toList instance Eq1 NEIntMap where - liftEq eq m1 m2 = M.size (neimIntMap m1) == M.size (neimIntMap m2) - && liftEq (liftEq eq) (toList m1) (toList m2) + liftEq eq m1 m2 = + M.size (neimIntMap m1) == M.size (neimIntMap m2) + && liftEq (liftEq eq) (toList m1) (toList m2) instance Ord1 NEIntMap where - liftCompare cmp m n = - liftCompare (liftCompare cmp) (toList m) (toList n) + liftCompare cmp m n = + liftCompare (liftCompare cmp) (toList m) (toList n) instance Show1 NEIntMap where - liftShowsPrec sp sl d m = - showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m) - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl + liftShowsPrec sp sl d m = + showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m) + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl instance Read1 NEIntMap where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl + liftReadsPrec rp rl = + readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl instance Read e => Read (NEIntMap e) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- parens . prec 10 $ readPrec - return (fromList xs) - readListPrec = readListPrecDefault + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- parens . prec 10 $ readPrec + return (fromList xs) + readListPrec = readListPrecDefault instance Show a => Show (NEIntMap a) where - showsPrec d m = showParen (d > 10) $ + showsPrec d m = + showParen (d > 10) $ showString "fromList (" . shows (toList m) . showString ")" instance NFData a => NFData (NEIntMap a) where - rnf (NEIntMap k v a) = rnf k `seq` rnf v `seq` rnf a + rnf (NEIntMap k v a) = rnf k `seq` rnf v `seq` rnf a -- Data instance code from Data.IntMap.Internal -- -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 -- (c) wren romano 2016 +#if MIN_VERSION_base(4,16,0) instance Data a => Data (NEIntMap a) where gfoldl f z im = z fromList `f` toList im - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" - dataTypeOf _ = intMapDataType - dataCast1 f = gcast1 f + dataTypeOf _ = intMapDataType + dataCast1 = gcast1 +#else +#ifndef __HLINT__ +instance Data a => Data (NEIntMap a) where + gfoldl f z im = z fromList `f` toList im + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + dataTypeOf _ = intMapDataType + dataCast1 f = gcast1 f +#endif +#endif fromListConstr :: Constr fromListConstr = mkConstr intMapDataType "fromList" [] Prefix @@ -190,18 +209,19 @@ intMapDataType = mkDataType "Data.IntMap.NonEmpty.Internal.NEIntMap" [fromListConstr] instance A.ToJSON a => A.ToJSON (NEIntMap a) where - toJSON = A.toJSON . toMap - toEncoding = A.toEncoding . toMap + toJSON = A.toJSON . toMap + toEncoding = A.toEncoding . toMap instance A.FromJSON a => A.FromJSON (NEIntMap a) where - parseJSON = withNonEmpty (fail err) pure - <=< A.parseJSON - where - err = "NEIntMap: Non-empty map expected, but empty map found" + parseJSON = + withNonEmpty (fail err) pure + <=< A.parseJSON + where + err = "NEIntMap: Non-empty map expected, but empty map found" -- | @since 0.3.4.4 instance Alt NEIntMap where - () = union + () = union -- | /O(n)/. Fold the values in the map using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. @@ -229,9 +249,10 @@ -- Note that, unlike 'Data.Foldable.foldr1' for 'IntMap', this function is -- total if the input function is total. foldr1 :: (a -> a -> a) -> NEIntMap a -> a -foldr1 f (NEIntMap _ v m) = maybe v (f v . uncurry (M.foldr f)) - . M.maxView - $ m +foldr1 f (NEIntMap _ v m) = + maybe v (f v . uncurry (M.foldr f)) + . M.maxView + $ m {-# INLINE foldr1 #-} -- | /O(n)/. Fold the values in the map using the given left-associative @@ -276,11 +297,11 @@ -- some monoids. -- TODO: benchmark against maxView method -foldMapWithKey - :: Semigroup m - => (Key -> a -> m) - -> NEIntMap a - -> m +foldMapWithKey :: + Semigroup m => + (Key -> a -> m) -> + NEIntMap a -> + m foldMapWithKey f = F1.foldMap1 (uncurry f) . toList {-# INLINE foldMapWithKey #-} @@ -290,12 +311,13 @@ map :: (a -> b) -> NEIntMap a -> NEIntMap b map f (NEIntMap k0 v m) = NEIntMap k0 (f v) (M.map f m) {-# NOINLINE [1] map #-} + {-# RULES -"map/map" forall f g xs . map f (map g xs) = map (f . g) xs - #-} +"map/map" forall f g xs. map f (map g xs) = map (f . g) xs + #-} {-# RULES "map/coerce" map coerce = coerce - #-} + #-} -- | /O(m*log(n\/m + 1)), m <= n/. -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @@ -303,14 +325,14 @@ -- (@'union' == 'Data.IntMap.NonEmpty.unionWith' 'const'@). -- -- > union (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "a"), (7, "C")]) -union - :: NEIntMap a - -> NEIntMap a - -> NEIntMap a +union :: + NEIntMap a -> + NEIntMap a -> + NEIntMap a union n1@(NEIntMap k1 v1 m1) n2@(NEIntMap k2 v2 m2) = case compare k1 k2 of - LT -> NEIntMap k1 v1 . M.union m1 . toMap $ n2 - EQ -> NEIntMap k1 v1 . M.union m1 $ m2 - GT -> NEIntMap k2 v2 . M.union (toMap n1) $ m2 + LT -> NEIntMap k1 v1 . M.union m1 . toMap $ n2 + EQ -> NEIntMap k1 v1 . M.union m1 $ m2 + GT -> NEIntMap k2 v2 . M.union (toMap n1) $ m2 {-# INLINE union #-} -- | The left-biased union of a non-empty list of maps. @@ -319,11 +341,11 @@ -- > == fromList [(3, "b"), (5, "a"), (7, "C")] -- > unions (fromList ((5, "A3") :| [(3, "B3")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "a") :| [(3, "b")])]) -- > == fromList ((3, "B3") :| [(5, "A3"), (7, "C")]) -unions - :: Foldable1 f - => f (NEIntMap a) - -> NEIntMap a -unions (F1.toNonEmpty->(m :| ms)) = F.foldl' union m ms +unions :: + Foldable1 f => + f (NEIntMap a) -> + NEIntMap a +unions (F1.toNonEmpty -> (m :| ms)) = F.foldl' union m ms {-# INLINE unions #-} -- | /O(n)/. @@ -374,14 +396,15 @@ -- @ -- 'traverseWithKey' f = 'unwrapApplicative' . 'traverseWithKey1' (\\k -> WrapApplicative . f k) -- @ -traverseWithKey - :: Applicative t - => (Key -> a -> t b) - -> NEIntMap a - -> t (NEIntMap b) +traverseWithKey :: + Applicative t => + (Key -> a -> t b) -> + NEIntMap a -> + t (NEIntMap b) traverseWithKey f (NEIntMap k v m0) = - NEIntMap k <$> f k v - <*> traverseMapWithKey f m0 + NEIntMap k + <$> f k v + <*> M.traverseWithKey f m0 {-# INLINE traverseWithKey #-} -- | /O(n)/. @@ -397,23 +420,23 @@ -- and not just 'Applicative'. -- TODO: benchmark against maxView-based methods -traverseWithKey1 - :: Apply t - => (Key -> a -> t b) - -> NEIntMap a - -> t (NEIntMap b) +traverseWithKey1 :: + Apply t => + (Key -> a -> t b) -> + NEIntMap a -> + t (NEIntMap b) traverseWithKey1 f (NEIntMap k0 v m0) = case runMaybeApply m1 of - Left m2 -> NEIntMap k0 <$> f k0 v <.> m2 - Right m2 -> flip (NEIntMap k0) m2 <$> f k0 v + Left m2 -> NEIntMap k0 <$> f k0 v <.> m2 + Right m2 -> flip (NEIntMap k0) m2 <$> f k0 v where - m1 = traverseMapWithKey (\k -> MaybeApply . Left . f k) m0 -{-# INLINABLE traverseWithKey1 #-} + m1 = M.traverseWithKey (\k -> MaybeApply . Left . f k) m0 +{-# INLINEABLE traverseWithKey1 #-} -- | /O(n)/. Convert the map to a non-empty list of key\/value pairs. -- -- > toList (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) toList :: NEIntMap a -> NonEmpty (Key, a) -toList (NEIntMap k v m) = (k,v) :| M.toList m +toList (NEIntMap k v m) = (k, v) :| M.toList m {-# INLINE toList #-} -- | /O(log n)/. Smart constructor for an 'NEIntMap' from a 'IntMap'. Returns @@ -438,11 +461,13 @@ -- will be fed to the function @f@ instead. -- -- @'nonEmptyMap' == 'withNonEmpty' 'Nothing' 'Just'@ -withNonEmpty - :: r -- ^ value to return if map is empty - -> (NEIntMap a -> r) -- ^ function to apply if map is not empty - -> IntMap a - -> r +withNonEmpty :: + -- | value to return if map is empty + r -> + -- | function to apply if map is not empty + (NEIntMap a -> r) -> + IntMap a -> + r withNonEmpty def f = maybe def f . nonEmptyMap {-# INLINE withNonEmpty #-} @@ -458,9 +483,10 @@ -- 'fromDistinctAscList' if items are ordered, just like the actual -- 'M.fromList'. fromList :: NonEmpty (Key, a) -> NEIntMap a -fromList ((k, v) :| xs) = withNonEmpty (singleton k v) (insertWith (const id) k v) - . M.fromList - $ xs +fromList ((k, v) :| xs) = + withNonEmpty (singleton k v) (insertWith (const id) k v) + . M.fromList + $ xs {-# INLINE fromList #-} -- | /O(1)/. A map with a single element. @@ -481,36 +507,35 @@ -- -- > insertWith (++) 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "xxxa")]) -- > insertWith (++) 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) -insertWith - :: (a -> a -> a) - -> Key - -> a - -> NEIntMap a - -> NEIntMap a +insertWith :: + (a -> a -> a) -> + Key -> + a -> + NEIntMap a -> + NEIntMap a insertWith f k v n@(NEIntMap k0 v0 m) = case compare k k0 of - LT -> NEIntMap k v . toMap $ n - EQ -> NEIntMap k (f v v0) m - GT -> NEIntMap k0 v0 $ M.insertWith f k v m + LT -> NEIntMap k v . toMap $ n + EQ -> NEIntMap k (f v v0) m + GT -> NEIntMap k0 v0 $ M.insertWith f k v m {-# INLINE insertWith #-} - -- | Left-biased union instance Semigroup (NEIntMap a) where - (<>) = union - {-# INLINE (<>) #-} - sconcat = unions - {-# INLINE sconcat #-} + (<>) = union + {-# INLINE (<>) #-} + sconcat = unions + {-# INLINE sconcat #-} instance Functor NEIntMap where - fmap = map - {-# INLINE fmap #-} - x <$ NEIntMap k _ m = NEIntMap k x (x <$ m) - {-# INLINE (<$) #-} + fmap = map + {-# INLINE fmap #-} + x <$ NEIntMap k _ m = NEIntMap k x (x <$ m) + {-# INLINE (<$) #-} -- | @since 0.3.4.4 instance Invariant NEIntMap where - invmap f _ = fmap f - {-# INLINE invmap #-} + invmap f _ = fmap f + {-# INLINE invmap #-} -- | Traverses elements in order of ascending keys. -- @@ -520,18 +545,40 @@ -- -- 'Data.Foldable.foldr1', 'Data.Foldable.foldl1', 'Data.Foldable.minimum', -- 'Data.Foldable.maximum' are all total. -instance F.Foldable NEIntMap where #if MIN_VERSION_base(4,11,0) +instance F.Foldable NEIntMap where fold (NEIntMap _ v m) = v <> F.fold (M.elems m) {-# INLINE fold #-} foldMap f (NEIntMap _ v m) = f v <> F.foldMap f (M.elems m) {-# INLINE foldMap #-} + foldr = foldr + {-# INLINE foldr #-} + foldr' = foldr' + {-# INLINE foldr' #-} + foldr1 = foldr1 + {-# INLINE foldr1 #-} + foldl = foldl + {-# INLINE foldl #-} + foldl' = foldl' + {-# INLINE foldl' #-} + foldl1 = foldl1 + {-# INLINE foldl1 #-} + null _ = False + {-# INLINE null #-} + length = size + {-# INLINE length #-} + elem x (NEIntMap _ v m) = F.elem x m + || x == v + {-# INLINE elem #-} + -- TODO: use build + toList = F.toList . elems + {-# INLINE toList #-} #else +instance F.Foldable NEIntMap where fold (NEIntMap _ v m) = v `mappend` F.fold (M.elems m) {-# INLINE fold #-} foldMap f (NEIntMap _ v m) = f v `mappend` F.foldMap f (M.elems m) {-# INLINE foldMap #-} -#endif foldr = foldr {-# INLINE foldr #-} foldr' = foldr' @@ -554,6 +601,7 @@ -- TODO: use build toList = F.toList . elems {-# INLINE toList #-} +#endif -- | Traverses elements in order of ascending keys -- @@ -561,8 +609,8 @@ -- elements in order of ascending keys, while 'IntMap' traverses positive -- keys first, then negative keys. instance Traversable NEIntMap where - traverse f = traverseWithKey (const f) - {-# INLINE traverse #-} + traverse f = traverseWithKey (const f) + {-# INLINE traverse #-} -- | Traverses elements in order of ascending keys -- @@ -570,23 +618,29 @@ -- 'F.foldMap' for the 'IntMap' instance of 'Foldable'. They traverse -- elements in order of ascending keys, while 'IntMap' traverses positive -- keys first, then negative keys. -instance Foldable1 NEIntMap where #if MIN_VERSION_base(4,11,0) +instance Foldable1 NEIntMap where fold1 (NEIntMap _ v m) = maybe v (v <>) . F.foldMap Just . M.elems $ m + {-# INLINE fold1 #-} + foldMap1 f = foldMapWithKey (const f) + {-# INLINE foldMap1 #-} + toNonEmpty = elems + {-# INLINE toNonEmpty #-} #else +instance Foldable1 NEIntMap where fold1 (NEIntMap _ v m) = option v (v <>) . F.foldMap (Option . Just) . M.elems $ m -#endif {-# INLINE fold1 #-} foldMap1 f = foldMapWithKey (const f) {-# INLINE foldMap1 #-} toNonEmpty = elems {-# INLINE toNonEmpty #-} +#endif -- | Traverses elements in order of ascending keys -- @@ -595,8 +649,8 @@ -- elements in order of ascending keys, while 'IntMap' traverses positive -- keys first, then negative keys. instance Traversable1 NEIntMap where - traverse1 f = traverseWithKey1 (const f) - {-# INLINE traverse1 #-} + traverse1 f = traverseWithKey1 (const f) + {-# INLINE traverse1 #-} -- | 'extract' gets the value at the minimal key, and 'duplicate' produces -- a map of maps comprised of all keys from the original map greater than @@ -604,30 +658,28 @@ -- -- @since 0.1.1.0 instance Comonad NEIntMap where - extract = neimV0 - {-# INLINE extract #-} - -- We'd like to use 'M.mapAccumWithKey', but it traverses things in the - -- wrong order. - duplicate n0@(NEIntMap k0 _ m0) = NEIntMap k0 n0 - . M.fromDistinctAscList - . snd - . L.mapAccumL go m0 - . M.toList - $ m0 - where - go m (k, v) = (m', (k, NEIntMap k v m')) - where - !m' = M.deleteMin m - {-# INLINE duplicate #-} + extract = neimV0 + {-# INLINE extract #-} + -- We'd like to use 'M.mapAccumWithKey', but it traverses things in the + -- wrong order. + duplicate n0@(NEIntMap k0 _ m0) = + NEIntMap k0 n0 + . M.fromDistinctAscList + . snd + . L.mapAccumL go m0 + . M.toList + $ m0 + where + go m (k, v) = (m', (k, NEIntMap k v m')) + where + !m' = M.deleteMin m + {-# INLINE duplicate #-} + -- | /O(n)/. Test if the internal map structure is valid. valid :: NEIntMap a -> Bool valid (NEIntMap k _ m) = all ((k <) . fst . fst) (M.minViewWithKey m) - - - - -- | /O(log n)/. Insert new key and value into a map where keys are -- /strictly greater than/ the new key. That is, the new key must be -- /strictly less than/ all keys present in the 'IntMap'. /The precondition @@ -640,7 +692,7 @@ -- TODO: implementation insertMinMap :: Key -> a -> IntMap a -> IntMap a insertMinMap = M.insert -{-# INLINABLE insertMinMap #-} +{-# INLINEABLE insertMinMap #-} -- | /O(log n)/. Insert new key and value into a map where keys are -- /strictly less than/ the new key. That is, the new key must be @@ -654,37 +706,4 @@ -- TODO: implementation insertMaxMap :: Key -> a -> IntMap a -> IntMap a insertMaxMap = M.insert -{-# INLINABLE insertMaxMap #-} - --- | /O(n)/. A fixed version of 'Data.IntMap.traverseWithKey' that --- traverses items in ascending order of keys. -traverseMapWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b) -traverseMapWithKey f = go - where - go Nil = pure Nil - go (Tip k v) = Tip k <$> f k v - go (Bin p m l r) = liftA2 (flip (Bin p m)) (go r) (go l) -{-# INLINE traverseMapWithKey #-} - --- --------------------------------------------- --- | CPP for new functions not in old containers --- --------------------------------------------- - --- | Compatibility layer for 'Data.IntMap.Lazy.lookupMinMap'. -lookupMinMap :: IntMap a -> Maybe (Key, a) -#if MIN_VERSION_containers(0,5,11) -lookupMinMap = M.lookupMin -#else -lookupMinMap = fmap fst . M.minViewWithKey -#endif -{-# INLINE lookupMinMap #-} - --- | Compatibility layer for 'Data.IntMap.Lazy.lookupMaxMap'. -lookupMaxMap :: IntMap a -> Maybe (Key, a) -#if MIN_VERSION_containers(0,5,11) -lookupMaxMap = M.lookupMax -#else -lookupMaxMap = fmap fst . M.maxViewWithKey -#endif -{-# INLINE lookupMaxMap #-} - +{-# INLINEABLE insertMaxMap #-} diff --git a/src/Data/IntSet/NonEmpty.hs b/src/Data/IntSet/NonEmpty.hs --- a/src/Data/IntSet/NonEmpty.hs +++ b/src/Data/IntSet/NonEmpty.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.IntSet.NonEmpty @@ -48,103 +48,103 @@ -- constant-time. module Data.IntSet.NonEmpty ( -- * Non-Empty Set Type - NEIntSet - , Key + NEIntSet, + Key, -- ** Conversions between empty and non-empty sets - , pattern IsNonEmpty - , pattern IsEmpty - , nonEmptySet - , toSet - , withNonEmpty - , insertSet - , insertSetMin - , insertSetMax - , unsafeFromSet + pattern IsNonEmpty, + pattern IsEmpty, + nonEmptySet, + toSet, + withNonEmpty, + insertSet, + insertSetMin, + insertSetMax, + unsafeFromSet, -- * Construction - , singleton - , fromList - , fromAscList - , fromDistinctAscList + singleton, + fromList, + fromAscList, + fromDistinctAscList, -- * Insertion - , insert + insert, -- * Deletion - , delete + delete, -- * Query - , member - , notMember - , lookupLT - , lookupGT - , lookupLE - , lookupGE - , size - , isSubsetOf - , isProperSubsetOf - , disjoint + member, + notMember, + lookupLT, + lookupGT, + lookupLE, + lookupGE, + size, + isSubsetOf, + isProperSubsetOf, + disjoint, -- * Combine - , union - , unions - , difference - , (\\) - , intersection + union, + unions, + difference, + (\\), + intersection, -- * Filter - , filter - , partition - , split - , splitMember - , splitRoot + filter, + partition, + split, + splitMember, + splitRoot, -- * Map - , map + map, -- * Folds - , foldr - , foldl - , foldr1 - , foldl1 + foldr, + foldl, + foldr1, + foldl1, + -- ** Strict folds - , foldr' - , foldl' - , foldr1' - , foldl1' + foldr', + foldl', + foldr1', + foldl1', -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax + findMin, + findMax, + deleteMin, + deleteMax, + deleteFindMin, + deleteFindMax, -- * Conversion -- ** List - , elems - , toList - , toAscList - , toDescList + elems, + toList, + toAscList, + toDescList, -- * Debugging - , valid - ) where - + valid, +) where -import Control.Applicative -import Data.Bifunctor -import Data.IntSet (IntSet) -import Data.IntSet.NonEmpty.Internal -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe -import Data.These -import Prelude hiding (Foldable(..), filter, map) -import qualified Data.IntSet as S -import qualified Data.List.NonEmpty as NE +import Control.Applicative +import Data.Bifunctor +import Data.IntSet (IntSet) +import qualified Data.IntSet as S +import Data.IntSet.NonEmpty.Internal +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.These +import Prelude hiding (Foldable (..), filter, map) -- | /O(1)/ match, /O(log n)/ usage of contents. The 'IsNonEmpty' and -- 'IsEmpty' patterns allow you to treat a 'IntSet' as if it were either @@ -172,7 +172,7 @@ -- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert -- a 'NEIntSet' back into a 'IntSet', obscuring its non-emptiness (see 'toSet'). pattern IsNonEmpty :: NEIntSet -> IntSet -pattern IsNonEmpty n <- (nonEmptySet->Just n) +pattern IsNonEmpty n <- (nonEmptySet -> Just n) where IsNonEmpty n = toSet n @@ -190,7 +190,7 @@ -- -- See 'IsNonEmpty' for more information. pattern IsEmpty :: IntSet -pattern IsEmpty <- (S.null->True) +pattern IsEmpty <- (S.null -> True) where IsEmpty = S.empty @@ -247,9 +247,9 @@ -- | /O(log n)/. Unsafe version of 'nonEmptySet'. Coerces a 'IntSet' -- into an 'NEIntSet', but is undefined (throws a runtime exception when -- evaluation is attempted) for an empty 'IntSet'. -unsafeFromSet - :: IntSet - -> NEIntSet +unsafeFromSet :: + IntSet -> + NEIntSet unsafeFromSet = withNonEmpty e id where e = errorWithoutStackTrace "NEIntSet.unsafeFromSet: empty set" @@ -264,9 +264,10 @@ -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. -- /The precondition (input list is strictly ascending) is not checked./ fromDistinctAscList :: NonEmpty Key -> NEIntSet -fromDistinctAscList (x :| xs) = insertSetMin x - . S.fromDistinctAscList - $ xs +fromDistinctAscList (x :| xs) = + insertSetMin x + . S.fromDistinctAscList + $ xs {-# INLINE fromDistinctAscList #-} -- | /O(log n)/. Insert an element in a set. @@ -274,33 +275,33 @@ -- it is replaced with the new value. insert :: Key -> NEIntSet -> NEIntSet insert x n@(NEIntSet x0 s) = case compare x x0 of - LT -> NEIntSet x $ toSet n - EQ -> NEIntSet x s - GT -> NEIntSet x0 $ S.insert x s + LT -> NEIntSet x $ toSet n + EQ -> NEIntSet x s + GT -> NEIntSet x0 $ S.insert x s {-# INLINE insert #-} -- | /O(log n)/. Delete an element from a set. delete :: Key -> NEIntSet -> IntSet delete x n@(NEIntSet x0 s) = case compare x x0 of - LT -> toSet n - EQ -> s - GT -> insertMinSet x0 . S.delete x $ s + LT -> toSet n + EQ -> s + GT -> insertMinSet x0 . S.delete x $ s {-# INLINE delete #-} -- | /O(log n)/. Is the element in the set? member :: Key -> NEIntSet -> Bool member x (NEIntSet x0 s) = case compare x x0 of - LT -> False - EQ -> True - GT -> S.member x s + LT -> False + EQ -> True + GT -> S.member x s {-# INLINE member #-} -- | /O(log n)/. Is the element not in the set? notMember :: Key -> NEIntSet -> Bool notMember x (NEIntSet x0 s) = case compare x x0 of - LT -> True - EQ -> False - GT -> S.notMember x s + LT -> True + EQ -> False + GT -> S.notMember x s {-# INLINE notMember #-} -- | /O(log n)/. Find largest element smaller than the given one. @@ -309,9 +310,9 @@ -- > lookupLT 5 (fromList (3 :| [5])) == Just 3 lookupLT :: Key -> NEIntSet -> Maybe Key lookupLT x (NEIntSet x0 s) = case compare x x0 of - LT -> Nothing - EQ -> Nothing - GT -> S.lookupLT x s <|> Just x0 + LT -> Nothing + EQ -> Nothing + GT -> S.lookupLT x s <|> Just x0 {-# INLINE lookupLT #-} -- | /O(log n)/. Find smallest element greater than the given one. @@ -320,9 +321,9 @@ -- > lookupLT 5 (fromList (3 :| [5])) == Nothing lookupGT :: Key -> NEIntSet -> Maybe Key lookupGT x (NEIntSet x0 s) = case compare x x0 of - LT -> Just x0 - EQ -> fst <$> S.minView s - GT -> S.lookupGT x s + LT -> Just x0 + EQ -> fst <$> S.minView s + GT -> S.lookupGT x s {-# INLINE lookupGT #-} -- | /O(log n)/. Find largest element smaller or equal to the given one. @@ -332,9 +333,9 @@ -- > lookupLT 5 (fromList (3 :| [5])) == Just 5 lookupLE :: Key -> NEIntSet -> Maybe Key lookupLE x (NEIntSet x0 s) = case compare x x0 of - LT -> Nothing - EQ -> Just x0 - GT -> S.lookupLE x s <|> Just x0 + LT -> Nothing + EQ -> Just x0 + GT -> S.lookupLE x s <|> Just x0 {-# INLINE lookupLE #-} -- | /O(log n)/. Find smallest element greater or equal to the given one. @@ -344,9 +345,9 @@ -- > lookupLT 6 (fromList (3 :| [5])) == Nothing lookupGE :: Key -> NEIntSet -> Maybe Key lookupGE x (NEIntSet x0 s) = case compare x x0 of - LT -> Just x0 - EQ -> Just x0 - GT -> S.lookupGE x s + LT -> Just x0 + EQ -> Just x0 + GT -> S.lookupGE x s {-# INLINE lookupGE #-} -- | /O(n)/. Fold the elements in the set using the given right-associative @@ -374,9 +375,10 @@ -- Note that, unlike 'Data.Foldable.foldr1' for 'IntSet', this function is -- total if the input function is total. foldr1 :: (Key -> Key -> Key) -> NEIntSet -> Key -foldr1 f (NEIntSet x s) = maybe x (f x . uncurry (S.foldr f)) - . S.maxView - $ s +foldr1 f (NEIntSet x s) = + maybe x (f x . uncurry (S.foldr f)) + . S.maxView + $ s {-# INLINE foldr1 #-} -- | /O(n)/. Fold the elements in the set using the given left-associative @@ -412,8 +414,8 @@ -- function is strict in the starting value. foldr1' :: (Key -> Key -> Key) -> NEIntSet -> Key foldr1' f (NEIntSet x s) = case S.maxView s of - Nothing -> x - Just (y, s') -> let !z = S.foldr' f y s' in x `f` z + Nothing -> x + Just (y, s') -> let !z = S.foldr' f y s' in x `f` z {-# INLINE foldr1' #-} -- | /O(n)/. A strict version of 'foldl1'. Each application of the operator @@ -431,21 +433,23 @@ -- | /O(n+m)/. Is this a subset? -- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@. -isSubsetOf - :: NEIntSet - -> NEIntSet - -> Bool -isSubsetOf (NEIntSet x s0) (toSet->s1) = x `S.member` s1 - && s0 `S.isSubsetOf` s1 +isSubsetOf :: + NEIntSet -> + NEIntSet -> + Bool +isSubsetOf (NEIntSet x s0) (toSet -> s1) = + x `S.member` s1 + && s0 `S.isSubsetOf` s1 {-# INLINE isSubsetOf #-} -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). -isProperSubsetOf - :: NEIntSet - -> NEIntSet - -> Bool -isProperSubsetOf s0 s1 = S.size (neisIntSet s0) < S.size (neisIntSet s1) - && s0 `isSubsetOf` s1 +isProperSubsetOf :: + NEIntSet -> + NEIntSet -> + Bool +isProperSubsetOf s0 s1 = + S.size (neisIntSet s0) < S.size (neisIntSet s1) + && s0 `isSubsetOf` s1 {-# INLINE isProperSubsetOf #-} -- | /O(n+m)/. Check whether two sets are disjoint (i.e. their intersection @@ -454,17 +458,17 @@ -- > disjoint (fromList (2:|[4,6])) (fromList (1:|[3])) == True -- > disjoint (fromList (2:|[4,6,8])) (fromList (2:|[3,5,7])) == False -- > disjoint (fromList (1:|[2])) (fromList (1:|[2,3,4])) == False -disjoint - :: NEIntSet - -> NEIntSet - -> Bool +disjoint :: + NEIntSet -> + NEIntSet -> + Bool disjoint n1@(NEIntSet x1 s1) n2@(NEIntSet x2 s2) = case compare x1 x2 of - -- x1 is not in n2 - LT -> s1 `disjointSet` toSet n2 - -- k1 and k2 are a part of the result - EQ -> False - -- k2 is not in n1 - GT -> toSet n1 `disjointSet` s2 + -- x1 is not in n2 + LT -> s1 `S.disjoint` toSet n2 + -- k1 and k2 are a part of the result + EQ -> False + -- k2 is not in n1 + GT -> toSet n1 `S.disjoint` s2 {-# INLINE disjoint #-} -- | /O(m*log(n\/m + 1)), m <= n/. Difference of two sets. @@ -472,24 +476,24 @@ -- Returns a potentially empty set ('IntSet') because the first set might be -- a subset of the second set, and therefore have all of its elements -- removed. -difference - :: NEIntSet - -> NEIntSet - -> IntSet +difference :: + NEIntSet -> + NEIntSet -> + IntSet difference n1@(NEIntSet x1 s1) n2@(NEIntSet x2 s2) = case compare x1 x2 of - -- x1 is not in n2, so cannot be deleted - LT -> insertMinSet x1 $ s1 `S.difference` toSet n2 - -- x2 deletes x1, and only x1 - EQ -> s1 `S.difference` s2 - -- x2 is not in n1, so cannot delete anything, so we can just difference n1 // s2. - GT -> toSet n1 `S.difference` s2 + -- x1 is not in n2, so cannot be deleted + LT -> insertMinSet x1 $ s1 `S.difference` toSet n2 + -- x2 deletes x1, and only x1 + EQ -> s1 `S.difference` s2 + -- x2 is not in n1, so cannot delete anything, so we can just difference n1 // s2. + GT -> toSet n1 `S.difference` s2 {-# INLINE difference #-} -- | Same as 'difference'. -(\\) - :: NEIntSet - -> NEIntSet - -> IntSet +(\\) :: + NEIntSet -> + NEIntSet -> + IntSet (\\) = difference {-# INLINE (\\) #-} @@ -508,30 +512,30 @@ -- > NES.singleton B `NES.intersection` NES.singleton A) -- -- prints @(fromList (A:|[]),fromList (B:|[]))@. -intersection - :: NEIntSet - -> NEIntSet - -> IntSet +intersection :: + NEIntSet -> + NEIntSet -> + IntSet intersection n1@(NEIntSet x1 s1) n2@(NEIntSet x2 s2) = case compare x1 x2 of - -- x1 is not in n2 - LT -> s1 `S.intersection` toSet n2 - -- x1 and x2 are a part of the result - EQ -> insertMinSet x1 $ s1 `S.intersection` s2 - -- x2 is not in n1 - GT -> toSet n1 `S.intersection` s2 + -- x1 is not in n2 + LT -> s1 `S.intersection` toSet n2 + -- x1 and x2 are a part of the result + EQ -> insertMinSet x1 $ s1 `S.intersection` s2 + -- x2 is not in n1 + GT -> toSet n1 `S.intersection` s2 {-# INLINE intersection #-} -- | /O(n)/. Filter all elements that satisfy the predicate. -- -- Returns a potentially empty set ('IntSet') because the predicate might -- filter out all items in the original non-empty set. -filter - :: (Key -> Bool) - -> NEIntSet - -> IntSet +filter :: + (Key -> Bool) -> + NEIntSet -> + IntSet filter f (NEIntSet x s1) - | f x = insertMinSet x . S.filter f $ s1 - | otherwise = S.filter f s1 + | f x = insertMinSet x . S.filter f $ s1 + | otherwise = S.filter f s1 {-# INLINE filter #-} -- | /O(n)/. Partition the map according to a predicate. @@ -549,26 +553,26 @@ -- > partition (> 3) (fromList (5 :| [3])) == These (singleton 5) (singleton 3) -- > partition (< 7) (fromList (5 :| [3])) == This (fromList (3 :| [5])) -- > partition (> 7) (fromList (5 :| [3])) == That (fromList (3 :| [5])) -partition - :: (Key -> Bool) - -> NEIntSet - -> These NEIntSet NEIntSet +partition :: + (Key -> Bool) -> + NEIntSet -> + These NEIntSet NEIntSet partition f n@(NEIntSet x s0) = case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) - | f x -> This n - | otherwise -> That n - (Just n1, Nothing) - | f x -> This n - | otherwise -> These n1 (singleton x) - (Nothing, Just n2) - | f x -> These (singleton x) n2 - | otherwise -> That n - (Just n1, Just n2) - | f x -> These (insertSetMin x s1) n2 - | otherwise -> These n1 (insertSetMin x s2) + (Nothing, Nothing) + | f x -> This n + | otherwise -> That n + (Just n1, Nothing) + | f x -> This n + | otherwise -> These n1 (singleton x) + (Nothing, Just n2) + | f x -> These (singleton x) n2 + | otherwise -> That n + (Just n1, Just n2) + | f x -> These (insertSetMin x s1) n2 + | otherwise -> These n1 (insertSetMin x s2) where (s1, s2) = S.partition f s0 -{-# INLINABLE partition #-} +{-# INLINEABLE partition #-} -- | /O(log n)/. The expression (@'split' x set@) is potentially a 'These' -- containing up to two 'NEIntSet's based on splitting the set into sets @@ -593,21 +597,21 @@ -- > split 5 (fromList (5 :| [3])) == Just (This (singleton 3) ) -- > split 6 (fromList (5 :| [3])) == Just (This (fromList (3 :| [5])) ) -- > split 5 (singleton 5) == Nothing -split - :: Key - -> NEIntSet - -> Maybe (These NEIntSet NEIntSet) +split :: + Key -> + NEIntSet -> + Maybe (These NEIntSet NEIntSet) split x n@(NEIntSet x0 s0) = case compare x x0 of - LT -> Just $ That n - EQ -> That <$> nonEmptySet s0 - GT -> case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) -> Just $ This (singleton x0) - (Just _ , Nothing) -> Just $ This (insertSetMin x0 s1) - (Nothing, Just n2) -> Just $ These (singleton x0) n2 - (Just _ , Just n2) -> Just $ These (insertSetMin x0 s1) n2 + LT -> Just $ That n + EQ -> That <$> nonEmptySet s0 + GT -> case (nonEmptySet s1, nonEmptySet s2) of + (Nothing, Nothing) -> Just $ This (singleton x0) + (Just _, Nothing) -> Just $ This (insertSetMin x0 s1) + (Nothing, Just n2) -> Just $ These (singleton x0) n2 + (Just _, Just n2) -> Just $ These (insertSetMin x0 s1) n2 where (s1, s2) = S.split x s0 -{-# INLINABLE split #-} +{-# INLINEABLE split #-} -- | /O(log n)/. The expression (@'splitMember' x set@) splits a set just -- like 'split' but also returns @'member' x set@ (whether or not @x@ was @@ -619,21 +623,21 @@ -- > splitMember 5 (fromList (5 :| [3])) == (True , Just (This (singleton 3)) -- > splitMember 6 (fromList (5 :| [3])) == (False, Just (This (fromList (3 :| [5]))) -- > splitMember 5 (singleton 5) == (True , Nothing) -splitMember - :: Key - -> NEIntSet - -> (Bool, Maybe (These NEIntSet NEIntSet)) +splitMember :: + Key -> + NEIntSet -> + (Bool, Maybe (These NEIntSet NEIntSet)) splitMember x n@(NEIntSet x0 s0) = case compare x x0 of - LT -> (False, Just $ That n) - EQ -> (True , That <$> nonEmptySet s0) - GT -> (mem ,) $ case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) -> Just $ This (singleton x0) - (Just _ , Nothing) -> Just $ This (insertSetMin x0 s1) - (Nothing, Just n2) -> Just $ These (singleton x0) n2 - (Just _ , Just n2) -> Just $ These (insertSetMin x0 s1) n2 + LT -> (False, Just $ That n) + EQ -> (True, That <$> nonEmptySet s0) + GT -> (mem,) $ case (nonEmptySet s1, nonEmptySet s2) of + (Nothing, Nothing) -> Just $ This (singleton x0) + (Just _, Nothing) -> Just $ This (insertSetMin x0 s1) + (Nothing, Just n2) -> Just $ These (singleton x0) n2 + (Just _, Just n2) -> Just $ These (insertSetMin x0 s1) n2 where (s1, mem, s2) = S.splitMember x s0 -{-# INLINABLE splitMember #-} +{-# INLINEABLE splitMember #-} -- | /O(1)/. Decompose a set into pieces based on the structure of the underlying -- tree. This function is useful for consuming a set in parallel. @@ -646,11 +650,12 @@ -- Note that the current implementation does not return more than four -- subsets, but you should not depend on this behaviour because it can -- change in the future without notice. -splitRoot - :: NEIntSet - -> NonEmpty NEIntSet -splitRoot (NEIntSet x s) = singleton x - :| mapMaybe nonEmptySet (S.splitRoot s) +splitRoot :: + NEIntSet -> + NonEmpty NEIntSet +splitRoot (NEIntSet x s) = + singleton x + :| mapMaybe nonEmptySet (S.splitRoot s) {-# INLINE splitRoot #-} -- | /O(n*log n)/. @@ -658,13 +663,15 @@ -- -- It's worth noting that the size of the result may be smaller if, -- for some @(x,y)@, @x \/= y && f x == f y@ -map :: (Key -> Key) - -> NEIntSet - -> NEIntSet -map f (NEIntSet x0 s) = fromList - . (f x0 :|) - . S.foldr (\x xs -> f x : xs) [] - $ s +map :: + (Key -> Key) -> + NEIntSet -> + NEIntSet +map f (NEIntSet x0 s) = + fromList + . (f x0 :|) + . S.foldr (\x xs -> f x : xs) [] + $ s {-# INLINE map #-} -- | /O(1)/. The minimal element of a set. Note that this is total, making @@ -701,8 +708,8 @@ -- > deleteMax (singleton 5) == Data.IntSet.empty deleteMax :: NEIntSet -> IntSet deleteMax (NEIntSet x s) = case S.maxView s of - Nothing -> S.empty - Just (_, s') -> insertMinSet x s' + Nothing -> S.empty + Just (_, s') -> insertMinSet x s' {-# INLINE deleteMax #-} -- | /O(1)/. Delete and find the minimal element. It is constant-time, so @@ -727,9 +734,10 @@ -- -- > deleteFindMax (fromList (5 :| [3, 10])) == (10, Data.IntSet.fromList [3, 5]) deleteFindMax :: NEIntSet -> (Key, IntSet) -deleteFindMax (NEIntSet x s) = maybe (x, S.empty) (second (insertMinSet x)) - . S.maxView - $ s +deleteFindMax (NEIntSet x s) = + maybe (x, S.empty) (second (insertMinSet x)) + . S.maxView + $ s {-# INLINE deleteFindMax #-} -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending @@ -752,6 +760,6 @@ combineEq (x :| xs) = go x xs where go z [] = z :| [] - go z (y:ys) - | z == y = go z ys + go z (y : ys) + | z == y = go z ys | otherwise = z NE.<| go y ys 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 @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : Data.IntSet.NonEmpty.Internal @@ -16,35 +15,34 @@ -- "Data.IntSet.NonEmpty". These functions can potentially be used to break -- the abstraction of 'NEIntSet' and produce unsound sets, so be wary! module Data.IntSet.NonEmpty.Internal ( - NEIntSet(..) - , Key - , nonEmptySet - , withNonEmpty - , toSet - , singleton - , fromList - , toList - , union - , unions - , valid - , insertMinSet - , insertMaxSet - , disjointSet - ) where + NEIntSet (..), + Key, + nonEmptySet, + withNonEmpty, + toSet, + singleton, + fromList, + toList, + union, + unions, + valid, + insertMinSet, + insertMaxSet, +) where -import Control.DeepSeq -import Control.Monad -import Data.Data -import Data.Function -import Data.IntSet.Internal (IntSet(..), Key) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup -import Data.Semigroup.Foldable (Foldable1) -import Text.Read -import qualified Data.Aeson as A -import qualified Data.Foldable as F -import qualified Data.IntSet as S +import Control.DeepSeq +import Control.Monad +import qualified Data.Aeson as A +import Data.Data +import qualified Data.Foldable as F +import Data.Function +import qualified Data.IntSet as S +import Data.IntSet.Internal (IntSet (..), Key) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup +import Data.Semigroup.Foldable (Foldable1) import qualified Data.Semigroup.Foldable as F1 +import Text.Read -- | A non-empty (by construction) set of integers. At least one value -- exists in an @'NEIntSet' a@ at all times. @@ -81,49 +79,53 @@ -- You can convert an 'NEIntSet' into a 'IntSet' with 'toSet' or -- 'Data.IntSet.NonEmpty.IsNonEmpty', essentially "obscuring" the non-empty -- property from the type. -data NEIntSet = - NEIntSet { neisV0 :: !Key -- ^ invariant: must be smaller than smallest value in set - , neisIntSet :: !IntSet - } +data NEIntSet + = NEIntSet + { neisV0 :: !Key + -- ^ invariant: must be smaller than smallest value in set + , neisIntSet :: !IntSet + } deriving (Typeable) instance Eq NEIntSet where - t1 == t2 = S.size (neisIntSet t1) == S.size (neisIntSet t2) - && toList t1 == toList t2 + t1 == t2 = + S.size (neisIntSet t1) == S.size (neisIntSet t2) + && toList t1 == toList t2 instance Ord NEIntSet where - compare = compare `on` toList - (<) = (<) `on` toList - (>) = (>) `on` toList - (<=) = (<=) `on` toList - (>=) = (>=) `on` toList + compare = compare `on` toList + (<) = (<) `on` toList + (>) = (>) `on` toList + (<=) = (<=) `on` toList + (>=) = (>=) `on` toList instance Show NEIntSet where - showsPrec p xs = showParen (p > 10) $ + showsPrec p xs = + showParen (p > 10) $ showString "fromList (" . shows (toList xs) . showString ")" instance Read NEIntSet where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- parens . prec 10 $ readPrec - return (fromList xs) + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- parens . prec 10 $ readPrec + return (fromList xs) - readListPrec = readListPrecDefault + readListPrec = readListPrecDefault instance NFData NEIntSet where - rnf (NEIntSet x s) = rnf x `seq` rnf s + rnf (NEIntSet x s) = rnf x `seq` rnf s -- Data instance code from Data.IntSet.Internal -- -- Copyright : (c) Daan Leijen 2002 -- (c) Joachim Breitner 2011 instance Data NEIntSet where - gfoldl f z is = z fromList `f` (toList is) - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of + gfoldl f z is = z fromList `f` toList is + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" - dataTypeOf _ = intSetDataType + dataTypeOf _ = intSetDataType fromListConstr :: Constr fromListConstr = mkConstr intSetDataType "fromList" [] Prefix @@ -131,17 +133,16 @@ intSetDataType :: DataType intSetDataType = mkDataType "Data.IntSet.NonEmpty.Internal.NEIntSet" [fromListConstr] - instance A.ToJSON NEIntSet where - toJSON = A.toJSON . toSet - toEncoding = A.toEncoding . toSet + toJSON = A.toJSON . toSet + toEncoding = A.toEncoding . toSet instance A.FromJSON NEIntSet where - parseJSON = withNonEmpty (fail err) pure - <=< A.parseJSON - where - err = "NEIntSet: Non-empty set expected, but empty set found" - + parseJSON = + withNonEmpty (fail err) pure + <=< A.parseJSON + where + err = "NEIntSet: Non-empty set expected, but empty set found" -- | /O(log n)/. Smart constructor for an 'NEIntSet' from a 'IntSet'. Returns -- 'Nothing' if the 'IntSet' was originally actually empty, and @'Just' n@ @@ -165,11 +166,13 @@ -- will be fed to the function @f@ instead. -- -- @'nonEmptySet' == 'withNonEmpty' 'Nothing' 'Just'@ -withNonEmpty - :: r -- ^ value to return if set is empty - -> (NEIntSet -> r) -- ^ function to apply if set is not empty - -> IntSet - -> r +withNonEmpty :: + -- | value to return if set is empty + r -> + -- | function to apply if set is not empty + (NEIntSet -> r) -> + IntSet -> + r withNonEmpty def f = maybe def f . nonEmptySet {-# INLINE withNonEmpty #-} @@ -200,9 +203,10 @@ -- 'fromDistinctAscList' if items are ordered, just like the actual -- 'S.fromList'. fromList :: NonEmpty Key -> NEIntSet -fromList (x :| s) = withNonEmpty (singleton x) (<> singleton x) - . S.fromList - $ s +fromList (x :| s) = + withNonEmpty (singleton x) (<> singleton x) + . S.fromList + $ s {-# INLINE fromList #-} -- | /O(n)/. Convert the set to a non-empty list of elements. @@ -212,41 +216,35 @@ -- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when -- equal elements are encountered. -union - :: NEIntSet - -> NEIntSet - -> NEIntSet +union :: + NEIntSet -> + NEIntSet -> + NEIntSet union n1@(NEIntSet x1 s1) n2@(NEIntSet x2 s2) = case compare x1 x2 of - LT -> NEIntSet x1 . S.union s1 . toSet $ n2 - EQ -> NEIntSet x1 . S.union s1 $ s2 - GT -> NEIntSet x2 . S.union (toSet n1) $ s2 + LT -> NEIntSet x1 . S.union s1 . toSet $ n2 + EQ -> NEIntSet x1 . S.union s1 $ s2 + GT -> NEIntSet x2 . S.union (toSet n1) $ s2 {-# INLINE union #-} -- | The union of a non-empty list of sets -unions - :: Foldable1 f - => f NEIntSet - -> NEIntSet -unions (F1.toNonEmpty->(s :| ss)) = F.foldl' union s ss +unions :: + Foldable1 f => + f NEIntSet -> + NEIntSet +unions (F1.toNonEmpty -> (s :| ss)) = F.foldl' union s ss {-# INLINE unions #-} -- | Left-biased union instance Semigroup NEIntSet where - (<>) = union - {-# INLINE (<>) #-} - sconcat = unions - {-# INLINE sconcat #-} + (<>) = union + {-# INLINE (<>) #-} + sconcat = unions + {-# INLINE sconcat #-} -- | /O(n)/. Test if the internal set structure is valid. valid :: NEIntSet -> Bool valid (NEIntSet x s) = all ((x <) . fst) (S.minView s) - - - - - - -- | /O(log n)/. Insert new value into a set where values are -- /strictly greater than/ the new values That is, the new value must be -- /strictly less than/ all values present in the 'IntSet'. /The precondition @@ -259,7 +257,7 @@ -- TODO: implementation insertMinSet :: Key -> IntSet -> IntSet insertMinSet = S.insert -{-# INLINABLE insertMinSet #-} +{-# INLINEABLE insertMinSet #-} -- | /O(log n)/. Insert new value into a set where values are /strictly -- less than/ the new value. That is, the new value must be /strictly @@ -273,18 +271,4 @@ -- TODO: implementation insertMaxSet :: Key -> IntSet -> IntSet insertMaxSet = S.insert -{-# INLINABLE insertMaxSet #-} - --- --------------------------------------------- --- | CPP for new functions not in old containers --- --------------------------------------------- - --- | Comptability layer for 'Data.IntSet.disjoint'. -disjointSet :: IntSet -> IntSet -> Bool -#if MIN_VERSION_containers(0,5,11) -disjointSet = S.disjoint -#else -disjointSet xs = S.null . S.intersection xs -#endif -{-# INLINE disjointSet #-} - +{-# INLINEABLE insertMaxSet #-} 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 @@ -1,2389 +1,2415 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Data.Map.NonEmpty --- Copyright : (c) Justin Le 2018 --- License : BSD3 --- --- Maintainer : justin@jle.im --- Stability : experimental --- Portability : non-portable --- --- = Non-Empty Finite Maps (lazy interface) --- --- The @'NEMap' k v@ type represents a non-empty finite map (sometimes --- called a dictionary) from keys of type @k@ to values of type @v@. --- An 'NEMap' is strict in its keys but lazy in its values. --- --- See documentation for 'NEMap' for information on how to convert and --- manipulate such non-empty maps. --- --- This module essentially re-imports the API of "Data.Map.Lazy" and its --- 'Map' type, along with semantics and asymptotics. In most situations, --- asymptotics are different only by a constant factor. In some --- situations, asmyptotics are even better (constant-time instead of --- log-time). All typeclass constraints are identical to their "Data.Map" --- counterparts. --- --- Because 'NEMap' is implemented using 'Map', all of the caveats of using --- 'Map' apply (such as the limitation of the maximum size of maps). --- --- All functions take non-empty maps as inputs. In situations where their --- results can be guarunteed to also be non-empty, they also return --- non-empty maps. In situations where their results could potentially be --- empty, 'Map' is returned instead. --- --- Some variants of functions (like 'alter'', 'alterF'', 'adjustAt', --- 'adjustMin', 'adjustMax', 'adjustMinWithKey', 'adjustMaxWithKey') are --- provided in a way restructured to preserve guaruntees of non-empty maps --- being returned. --- --- Some functions (like 'mapEither', 'partition', 'spanAntitone', 'split') --- have modified return types to account for possible configurations of --- non-emptiness. --- --- This module is intended to be imported qualified, to avoid name clashes with --- "Prelude" and "Data.Map" functions: --- --- > import qualified Data.Map.NonEmpty as NEM --- --- At the moment, this package does not provide a variant strict on values --- for these functions, like /containers/ does. This is a planned future --- implementation (PR's are appreciated). For now, you can simulate --- a strict interface by manually forcing values before returning results. -module Data.Map.NonEmpty ( - -- * Non-Empty Map type - NEMap - -- ** Conversions between empty and non-empty maps - , pattern IsNonEmpty - , pattern IsEmpty - , nonEmptyMap - , toMap - , withNonEmpty - , insertMap - , insertMapWith - , insertMapWithKey - , insertMapMin - , insertMapMax - , unsafeFromMap - - -- * Construction - , singleton - , fromSet - - -- ** From Unordered Lists - , fromList - , fromListWith - , fromListWithKey - - -- ** From Ascending Lists - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- ** From Descending Lists - , fromDescList - , fromDescListWith - , fromDescListWithKey - , fromDistinctDescList - - -- * Insertion - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - - -- * Deletion\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - , alterF - , alter' - , alterF' - - -- * Query - -- ** Lookup - , lookup - , (!?) - , (!) - , findWithDefault - , member - , notMember - , lookupLT - , lookupGT - , lookupLE - , lookupGE - , absurdNEMap - - -- ** Size - , size - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - , unionsWith - - -- ** Difference - , difference - , (\\) - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- -- ** Unsafe general combining function - -- , mergeWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , traverseWithKey1 - , traverseWithKey - , traverseMaybeWithKey1 - , traverseMaybeWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeys - , mapKeysWith - , mapKeysMonotonic - - -- * Folds - , foldr - , foldl - , foldr1 - , foldl1 - , foldrWithKey - , foldlWithKey - , foldMapWithKey - - -- ** Strict folds - , foldr' - , foldr1' - , foldl' - , foldl1' - , foldrWithKey' - , foldlWithKey' - - -- * Conversion - , elems - , keys - , assocs - , keysSet - - -- ** Lists - , toList - - -- ** Ordered lists - , toAscList - , toDescList - - -- * Filter - , filter - , filterWithKey - , restrictKeys - , withoutKeys - , partition - , partitionWithKey - , takeWhileAntitone - , dropWhileAntitone - , spanAntitone - - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - - , split - , splitLookup - , splitRoot - - -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy - - -- * Indexed - , lookupIndex - , findIndex - , elemAt - , updateAt - , adjustAt - , deleteAt - , take - , drop - , splitAt - - -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , updateMin - , updateMax - , adjustMin - , adjustMax - , updateMinWithKey - , updateMaxWithKey - , adjustMinWithKey - , adjustMaxWithKey - , minView - , maxView - - -- * Debugging - , valid - ) where - -import Control.Applicative -import Data.Bifunctor -import Data.Function -import Data.Functor.Apply -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map (Map) -import Data.Map.NonEmpty.Internal -import Data.Maybe hiding (mapMaybe) -import Data.Semigroup.Foldable (Foldable1) -import Data.Set (Set) -import Data.Set.NonEmpty.Internal (NESet(..)) -import Data.These -import Data.Void -import Prelude hiding (Foldable(..), lookup, filter, map, take, drop, splitAt) -import qualified Data.Foldable as F -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import qualified Data.Semigroup.Foldable as F1 -import qualified Data.Set as S - --- | /O(1)/ match, /O(log n)/ usage of contents. The 'IsNonEmpty' and --- 'IsEmpty' patterns allow you to treat a 'Map' as if it were either --- a @'IsNonEmpty' n@ (where @n@ is a 'NEMap') or an 'IsEmpty'. --- --- For example, you can pattern match on a 'Map': --- --- @ --- myFunc :: 'Map' K X -> Y --- myFunc ('IsNonEmpty' n) = -- here, the user provided a non-empty map, and @n@ is the 'NEMap' --- myFunc 'IsEmpty' = -- here, the user provided an empty map. --- @ --- --- Matching on @'IsNonEmpty' n@ means that the original 'Map' was /not/ --- empty, and you have a verified-non-empty 'NEMap' @n@ to use. --- --- Note that patching on this pattern is /O(1)/. However, using the --- contents requires a /O(log n)/ cost that is deferred until after the --- pattern is matched on (and is not incurred at all if the contents are --- never used). --- --- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides --- complete coverage. --- --- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert --- a 'NEMap' back into a 'Map', obscuring its non-emptiness (see 'toMap'). -pattern IsNonEmpty :: NEMap k a -> Map k a -pattern IsNonEmpty n <- (nonEmptyMap->Just n) - where - IsNonEmpty n = toMap n - --- | /O(1)/. The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat --- a 'Map' as if it were either a @'IsNonEmpty' n@ (where @n@ is --- a 'NEMap') or an 'IsEmpty'. --- --- Matching on 'IsEmpty' means that the original 'Map' was empty. --- --- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides --- complete coverage. --- --- This is a bidirectional pattern, so you can use 'IsEmpty' as an --- expression, and it will be interpreted as 'Data.Map.empty'. --- --- See 'IsNonEmpty' for more information. -pattern IsEmpty :: Map k a -pattern IsEmpty <- (M.null->True) - where - IsEmpty = M.empty - -{-# COMPLETE IsNonEmpty, IsEmpty #-} - --- | /O(log n)/. Unsafe version of 'nonEmptyMap'. Coerces a 'Map' into an --- 'NEMap', but is undefined (throws a runtime exception when evaluation is --- attempted) for an empty 'Map'. -unsafeFromMap - :: Map k a - -> NEMap k a -unsafeFromMap = withNonEmpty e id - where - e = errorWithoutStackTrace "NEMap.unsafeFromMap: empty map" -{-# INLINE unsafeFromMap #-} - --- | /O(n)/. Build a non-empty map from a non-empty set of keys and --- a function which for each key computes its value. --- --- > fromSet (\k -> replicate k 'a') (Data.Set.NonEmpty.fromList (3 :| [5])) == fromList ((5,"aaaaa") :| [(3,"aaa")]) -fromSet - :: (k -> a) - -> NESet k - -> NEMap k a -fromSet f (NESet k ks) = NEMap k (f k) (M.fromSet f ks) -{-# INLINE fromSet #-} - --- | /O(log n)/. Lookup the value at a key in the map. --- --- The function will return the corresponding value as @('Just' value)@, --- or 'Nothing' if the key isn't in the map. --- --- An example of using @lookup@: --- --- > import Prelude hiding (lookup) --- > import Data.Map.NonEmpty --- > --- > employeeDept = fromList (("John","Sales") :| [("Bob","IT")]) --- > deptCountry = fromList (("IT","USA") :| [("Sales","France")]) --- > countryCurrency = fromList (("USA", "Dollar") :| [("France", "Euro")]) --- > --- > employeeCurrency :: String -> Maybe String --- > employeeCurrency name = do --- > dept <- lookup name employeeDept --- > country <- lookup dept deptCountry --- > lookup country countryCurrency --- > --- > main = do --- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John")) --- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete")) --- --- The output of this program: --- --- > John's currency: Just "Euro" --- > Pete's currency: Nothing -lookup - :: Ord k - => k - -> NEMap k a - -> Maybe a -lookup k (NEMap k0 v m) = case compare k k0 of - LT -> Nothing - EQ -> Just v - GT -> M.lookup k m -{-# INLINE lookup #-} - --- | /O(log n)/. Find the value at a key. Returns 'Nothing' when the --- element can not be found. --- --- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 1 == Nothing --- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 5 == Just 'a' -(!?) :: Ord k => NEMap k a -> k -> Maybe a -(!?) = flip lookup -{-# INLINE (!?) #-} - --- | /O(log n)/. Find the value at a key. Calls 'error' when the element --- can not be found. --- --- > fromList ((5,'a') :| [(3,'b')]) ! 1 Error: element not in the map --- > fromList ((5,'a') :| [(3,'b')]) ! 5 == 'a' -(!) :: Ord k => NEMap k a -> k -> a -(!) m k = fromMaybe e $ m !? k - where - e = error "NEMap.!: given key is not an element in the map" -{-# INLINE (!) #-} - -infixl 9 !? -infixl 9 ! - --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns --- the value at key @k@ or returns default value @def@ --- when the key is not in the map. --- --- > findWithDefault 'x' 1 (fromList ((5,'a') :| [(3,'b')])) == 'x' --- > findWithDefault 'x' 5 (fromList ((5,'a') :| [(3,'b')])) == 'a' -findWithDefault - :: Ord k - => a - -> k - -> NEMap k a - -> a -findWithDefault def k (NEMap k0 v m) = case compare k k0 of - LT -> def - EQ -> v - GT -> M.findWithDefault def k m -{-# INLINE findWithDefault #-} - --- | /O(log n)/. Is the key a member of the map? See also 'notMember'. --- --- > member 5 (fromList ((5,'a') :| [(3,'b')])) == True --- > member 1 (fromList ((5,'a') :| [(3,'b')])) == False -member :: Ord k => k -> NEMap k a -> Bool -member k (NEMap k0 _ m) = case compare k k0 of - LT -> False - EQ -> True - GT -> M.member k m -{-# INLINE member #-} - --- | /O(log n)/. Is the key not a member of the map? See also 'member'. --- --- > notMember 5 (fromList ((5,'a') :| [(3,'b')])) == False --- > notMember 1 (fromList ((5,'a') :| [(3,'b')])) == True -notMember :: Ord k => k -> NEMap k a -> Bool -notMember k (NEMap k0 _ m) = case compare k k0 of - LT -> True - EQ -> False - GT -> M.notMember k m -{-# INLINE notMember #-} - --- | /O(log n)/. Find largest key smaller than the given one and return the --- corresponding (key, value) pair. --- --- > lookupLT 3 (fromList ((3,'a') :| [(5,'b')])) == Nothing --- > lookupLT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') -lookupLT :: Ord k => k -> NEMap k a -> Maybe (k, a) -lookupLT k (NEMap k0 v m) = case compare k k0 of - LT -> Nothing - EQ -> Nothing - GT -> M.lookupLT k m <|> Just (k0, v) -{-# INLINE lookupLT #-} - --- | /O(log n)/. Find smallest key greater than the given one and return the --- corresponding (key, value) pair. --- --- > lookupGT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') --- > lookupGT 5 (fromList ((3,'a') :| [(5,'b')])) == Nothing -lookupGT :: Ord k => k -> NEMap k a -> Maybe (k, a) -lookupGT k (NEMap k0 v m) = case compare k k0 of - LT -> Just (k0, v) - EQ -> M.lookupMin m - GT -> M.lookupGT k m -{-# INLINE lookupGT #-} - --- | /O(log n)/. Find largest key smaller or equal to the given one and return --- the corresponding (key, value) pair. --- --- > lookupLE 2 (fromList ((3,'a') :| [(5,'b')])) == Nothing --- > lookupLE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') --- > lookupLE 5 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') -lookupLE :: Ord k => k -> NEMap k a -> Maybe (k, a) -lookupLE k (NEMap k0 v m) = case compare k k0 of - LT -> Nothing - EQ -> Just (k0, v) - GT -> M.lookupLE k m <|> Just (k0, v) -{-# INLINE lookupLE #-} - --- | /O(log n)/. Find smallest key greater or equal to the given one and return --- the corresponding (key, value) pair. --- --- > lookupGE 3 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') --- > lookupGE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') --- > lookupGE 6 (fromList ((3,'a') :| [(5,'b')])) == Nothing -lookupGE :: Ord k => k -> NEMap k a -> Maybe (k, a) -lookupGE k (NEMap k0 v m) = case compare k k0 of - LT -> Just (k0, v) - EQ -> Just (k0, v) - GT -> M.lookupGE k m -{-# INLINE lookupGE #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function. --- --- > unionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "aA"), (7, "C")]) -unionWith - :: Ord k - => (a -> a -> a) - -> NEMap k a - -> NEMap k a - -> NEMap k a -unionWith f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of - LT -> NEMap k1 v1 . M.unionWith f m1 . toMap $ n2 - EQ -> NEMap k1 (f v1 v2) . M.unionWith f m1 $ m2 - GT -> NEMap k2 v2 . M.unionWith f (toMap n1) $ m2 -{-# INLINE unionWith #-} - --- | /O(m*log(n\/m + 1)), m <= n/. --- Union with a combining function, given the matching key. --- --- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value --- > unionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "5:a|A"), (7, "C")]) -unionWithKey - :: Ord k - => (k -> a -> a -> a) - -> NEMap k a - -> NEMap k a - -> NEMap k a -unionWithKey f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of - LT -> NEMap k1 v1 . M.unionWithKey f m1 . toMap $ n2 - EQ -> NEMap k1 (f k1 v1 v2) . M.unionWithKey f m1 $ m2 - GT -> NEMap k2 v2 . M.unionWithKey f (toMap n1) $ m2 -{-# INLINE unionWithKey #-} - --- | The union of a non-empty list of maps, with a combining operation: --- (@'unionsWith' f == 'Data.Foldable.foldl1' ('unionWith' f)@). --- --- > unionsWith (++) (fromList ((5, "a") :| [(3, "b")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "A3") :| [(3, "B3")])]) --- > == fromList ((3, "bB3") :| [(5, "aAA3"), (7, "C")]) -unionsWith - :: (Foldable1 f, Ord k) - => (a -> a -> a) - -> f (NEMap k a) - -> NEMap k a -unionsWith f (F1.toNonEmpty->(m :| ms)) = F.foldl' (unionWith f) m ms -{-# INLINE unionsWith #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps. --- Return elements of the first map not existing in the second map. --- --- Returns a potentially empty map ('Map'), in case the first map is --- a subset of the second map. --- --- > difference (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 3 "b" -difference - :: Ord k - => NEMap k a - -> NEMap k b - -> Map k a -difference n1@(NEMap k1 v1 m1) n2@(NEMap k2 _ m2) = case compare k1 k2 of - -- k1 is not in n2, so cannot be deleted - LT -> insertMinMap k1 v1 $ m1 `M.difference` toMap n2 - -- k2 deletes k1, and only k1 - EQ -> m1 `M.difference` m2 - -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. - GT -> toMap n1 `M.difference` m2 -{-# INLINE difference #-} - --- | Same as 'difference'. -(\\) - :: Ord k - => NEMap k a - -> NEMap k b - -> Map k a -(\\) = difference -{-# INLINE (\\) #-} - --- | /O(n+m)/. Difference with a combining function. --- When two equal keys are --- encountered, the combining function is applied to the values of these keys. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- --- Returns a potentially empty map ('Map'), in case the first map is --- a subset of the second map and the function returns 'Nothing' for every --- pair. --- --- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing --- > differenceWith f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (7, "C")])) --- > == Data.Map.singleton 3 "b:B" -differenceWith - :: Ord k - => (a -> b -> Maybe a) - -> NEMap k a - -> NEMap k b - -> Map k a -differenceWith f = differenceWithKey (const f) -{-# INLINE differenceWith #-} - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- --- Returns a potentially empty map ('Map'), in case the first map is --- a subset of the second map and the function returns 'Nothing' for every --- pair. --- --- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing --- > differenceWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (10, "C")])) --- > == Data.Map.singleton 3 "3:b|B" -differenceWithKey - :: Ord k - => (k -> a -> b -> Maybe a) - -> NEMap k a - -> NEMap k b - -> Map k a -differenceWithKey f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of - -- k1 is not in n2, so cannot be deleted - LT -> insertMinMap k1 v1 $ M.differenceWithKey f m1 (toMap n2) - -- k2 deletes k1, and only k1 - EQ -> ($ M.differenceWithKey f m1 m2) . maybe id (insertMinMap k1) $ f k1 v1 v2 - -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. - GT -> M.differenceWithKey f (toMap n1) m2 -{-# INLINE differenceWithKey #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps. --- Return data in the first map for the keys existing in both maps. --- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). --- --- Returns a potentially empty map ('Map'), in case the two maps share no --- keys in common. --- --- > intersection (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 5 "a" -intersection - :: Ord k - => NEMap k a - -> NEMap k b - -> Map k a -intersection n1@(NEMap k1 v1 m1) n2@(NEMap k2 _ m2) = case compare k1 k2 of - -- k1 is not in n2 - LT -> m1 `M.intersection` toMap n2 - -- k1 and k2 are a part of the result - EQ -> insertMinMap k1 v1 $ m1 `M.intersection` m2 - -- k2 is not in n1 - GT -> toMap n1 `M.intersection` m2 -{-# INLINE intersection #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. --- --- Returns a potentially empty map ('Map'), in case the two maps share no --- keys in common. --- --- > intersectionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 5 "aA" -intersectionWith - :: Ord k - => (a -> b -> c) - -> NEMap k a - -> NEMap k b - -> Map k c -intersectionWith f = intersectionWithKey (const f) -{-# INLINE intersectionWith #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. --- --- Returns a potentially empty map ('Map'), in case the two maps share no --- keys in common. --- --- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar --- > intersectionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 5 "5:a|A" -intersectionWithKey - :: Ord k - => (k -> a -> b -> c) - -> NEMap k a - -> NEMap k b - -> Map k c -intersectionWithKey f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of - -- k1 is not in n2 - LT -> M.intersectionWithKey f m1 (toMap n2) - -- k1 and k2 are a part of the result - EQ -> insertMinMap k1 (f k1 v1 v2) $ M.intersectionWithKey f m1 m2 - -- k2 is not in n1 - GT -> M.intersectionWithKey f (toMap n1) m2 -{-# INLINE intersectionWithKey #-} - --- | /O(n)/. A strict version of 'foldr1'. Each application of the operator --- is evaluated before using the result in the next application. This --- function is strict in the starting value. -foldr1' :: (a -> a -> a) -> NEMap k a -> a -foldr1' f (NEMap _ v m) = case M.maxView m of - Nothing -> v - Just (y, m') -> let !z = M.foldr' f y m' in v `f` z -{-# INLINE foldr1' #-} - --- | /O(n)/. A strict version of 'foldl1'. Each application of the operator --- is evaluated before using the result in the next application. This --- function is strict in the starting value. -foldl1' :: (a -> a -> a) -> NEMap k a -> a -foldl1' f (NEMap _ v m) = M.foldl' f v m -{-# INLINE foldl1' #-} - --- | /O(n)/. Fold the keys and values in the map using the given right-associative --- binary operator, such that --- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. --- --- For example, --- --- > keysList map = foldrWithKey (\k x ks -> k:ks) [] map -foldrWithKey :: (k -> a -> b -> b) -> b -> NEMap k a -> b -foldrWithKey f z (NEMap k v m) = f k v . M.foldrWithKey f z $ m -{-# INLINE foldrWithKey #-} - --- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldrWithKey' :: (k -> a -> b -> b) -> b -> NEMap k a -> b -foldrWithKey' f z (NEMap k v m) = f k v y - where - !y = M.foldrWithKey f z m -{-# INLINE foldrWithKey' #-} - --- | /O(n)/. Fold the keys and values in the map using the given left-associative --- binary operator, such that --- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. --- --- For example, --- --- > keysList = reverse . foldlWithKey (\ks k x -> k:ks) [] -foldlWithKey :: (a -> k -> b -> a) -> a -> NEMap k b -> a -foldlWithKey f z (NEMap k v m) = M.foldlWithKey f (f z k v) m -{-# INLINE foldlWithKey #-} - --- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldlWithKey' :: (a -> k -> b -> a) -> a -> NEMap k b -> a -foldlWithKey' f z (NEMap k v m) = M.foldlWithKey' f x m - where - !x = f z k v -{-# INLINE foldlWithKey' #-} - --- | /O(n)/. Return all keys of the map in ascending order. --- --- > keys (fromList ((5,"a") :| [(3,"b")])) == (3 :| [5]) -keys :: NEMap k a -> NonEmpty k -keys (NEMap k _ m) = k :| M.keys m -{-# INLINE keys #-} - --- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map --- in ascending key order. --- --- > assocs (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) -assocs :: NEMap k a -> NonEmpty (k, a) -assocs = toList -{-# INLINE assocs #-} - --- | /O(n)/. The non-empty set of all keys of the map. --- --- > keysSet (fromList ((5,"a") :| [(3,"b")])) == Data.Set.NonEmpty.fromList (3 :| [5]) -keysSet :: NEMap k a -> NESet k -keysSet (NEMap k _ m) = NESet k (M.keysSet m) -{-# INLINE keysSet #-} - --- | /O(n)/. Map a function over all values in the map. --- --- > let f key x = (show key) ++ ":" ++ x --- > mapWithKey f (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "3:b") :| [(5, "5:a")]) -mapWithKey :: (k -> a -> b) -> NEMap k a -> NEMap k b -mapWithKey f (NEMap k v m) = NEMap k (f k v) (M.mapWithKey f m) -{-# NOINLINE [1] mapWithKey #-} -{-# RULES -"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) = - mapWithKey (\k a -> f k (g k a)) xs -"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) = - mapWithKey (\k a -> f k (g a)) xs -"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) = - mapWithKey (\k a -> f (g k a)) xs - #-} - --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are --- in ascending order. --- --- > toAscList (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) -toAscList :: NEMap k a -> NonEmpty (k, a) -toAscList = toList -{-# INLINE toAscList #-} - --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys --- are in descending order. --- --- > toDescList (fromList ((5,"a") :| [(3,"b")])) == ((5,"a") :| [(3,"b")]) -toDescList :: NEMap k a -> NonEmpty (k, a) -toDescList (NEMap k0 v0 m) = M.foldlWithKey' go ((k0, v0) :| []) m - where - go xs k v = (k, v) NE.<| xs -{-# INLINE toDescList #-} - --- | /O(log n)/. Convert a 'Map' into an 'NEMap' by adding a key-value --- pair. Because of this, we know that the map must have at least one --- element, and so therefore cannot be empty. If key is already present, --- will overwrite the original value. --- --- See 'insertMapMin' for a version that is constant-time if the new key is --- /strictly smaller than/ all keys in the original map. --- --- > insertMap 4 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) --- > insertMap 4 "c" Data.Map.empty == singleton 4 "c" -insertMap :: Ord k => k -> a -> Map k a -> NEMap k a -insertMap k v = withNonEmpty (singleton k v) (insert k v) -{-# INLINE insertMap #-} - --- | /O(log n)/. Convert a 'Map' into an 'NEMap' by adding a key-value --- pair. Because of this, we know that the map must have at least one --- element, and so therefore cannot be empty. Uses a combining function --- with the new value as the first argument if the key is already present. --- --- > insertMapWith (++) 4 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) --- > insertMapWith (++) 5 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"ca")]) -insertMapWith - :: Ord k - => (a -> a -> a) - -> k - -> a - -> Map k a - -> NEMap k a -insertMapWith f k v = withNonEmpty (singleton k v) (insertWith f k v) -{-# INLINE insertMapWith #-} - --- | /O(log n)/. Convert a 'Map' into an 'NEMap' by adding a key-value --- pair. Because of this, we know that the map must have at least one --- element, and so therefore cannot be empty. Uses a combining function --- with the key and new value as the first and second arguments if the key --- is already present. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "5:xxx|a")]) --- > insertWithKey f 7 "xxx" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) --- > insertWithKey f 5 "xxx" Data.Map.empty == singleton 5 "xxx" -insertMapWithKey - :: Ord k - => (k -> a -> a -> a) - -> k - -> a - -> Map k a - -> NEMap k a -insertMapWithKey f k v = withNonEmpty (singleton k v) (insertWithKey f k v) -{-# INLINE insertMapWithKey #-} - --- | /O(1)/ Convert a 'Map' into an 'NEMap' by adding a key-value pair --- where the key is /strictly less than/ all keys in the input map. The --- keys in the original map must all be /strictly greater than/ the new --- key. /The precondition is not checked./ --- --- > insertMapMin 2 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((2,"c") :| [(3,"b"), (5,"a")]) --- > valid (insertMapMin 2 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == True --- > valid (insertMapMin 7 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False --- > valid (insertMapMin 3 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False -insertMapMin - :: k - -> a - -> Map k a - -> NEMap k a -insertMapMin = NEMap -{-# INLINE insertMapMin #-} - --- | /O(log n)/ Convert a 'Map' into an 'NEMap' by adding a key-value pair --- where the key is /strictly greater than/ all keys in the input map. The --- keys in the original map must all be /strictly less than/ the new --- key. /The precondition is not checked./ --- --- While this has the same asymptotics as 'insertMap', it saves a constant --- factor for key comparison (so may be helpful if comparison is expensive) --- and also does not require an 'Ord' instance for the key type. --- --- > insertMap 7 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"a"), (7,"c")]) --- > valid (insertMap 7 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == True --- > valid (insertMap 2 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False --- > valid (insertMap 5 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False -insertMapMax - :: k - -> a - -> Map k a - -> NEMap k a -insertMapMax k v = withNonEmpty (singleton k v) go - where - go (NEMap k0 v0 m0) = NEMap k0 v0 . insertMaxMap k v $ m0 -{-# INLINE insertMapMax #-} - - --- | /O(log n)/. Insert a new key and value in the map. --- If the key is already present in the map, the associated value is --- replaced with the supplied value. 'insert' is equivalent to --- @'insertWith' 'const'@. --- --- See 'insertMap' for a version where the first argument is a 'Map'. --- --- > insert 5 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'x')]) --- > insert 7 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'a'), (7, 'x')]) -insert - :: Ord k - => k - -> a - -> NEMap k a - -> NEMap k a -insert k v n@(NEMap k0 v0 m) = case compare k k0 of - LT -> NEMap k v . toMap $ n - EQ -> NEMap k v m - GT -> NEMap k0 v0 . M.insert k v $ m -{-# INLINE insert #-} - --- | /O(log n)/. Insert with a function, combining key, new value and old --- value. @'insertWithKey' f key value mp@ will insert the pair (key, --- value) into @mp@ if key does not exist in the map. If the key does --- exist, the function will insert the pair @(key,f key new_value --- old_value)@. Note that the key passed to f is the same key passed to --- 'insertWithKey'. --- --- See 'insertMapWithKey' for a version where the first argument is a 'Map'. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:xxx|a")]) --- > insertWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) -insertWithKey - :: Ord k - => (k -> a -> a -> a) - -> k - -> a - -> NEMap k a - -> NEMap k a -insertWithKey f k v n@(NEMap k0 v0 m) = case compare k k0 of - LT -> NEMap k v . toMap $ n - EQ -> NEMap k (f k v v0) m - GT -> NEMap k0 v0 $ M.insertWithKey f k v m -{-# INLINE insertWithKey #-} - --- | /O(log n)/. Combines insert operation with old value retrieval. The --- expression (@'insertLookupWithKey' f k x map@) is a pair where the first --- element is equal to (@'lookup' k map@) and the second element equal to --- (@'insertWithKey' f k x map@). --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertLookupWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "5:xxx|a")])) --- > insertLookupWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "xxx")])) --- --- This is how to define @insertLookup@ using @insertLookupWithKey@: --- --- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t --- > insertLookup 5 "x" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "x")])) --- > insertLookup 7 "x" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "x")])) -insertLookupWithKey - :: Ord k - => (k -> a -> a -> a) - -> k - -> a - -> NEMap k a - -> (Maybe a, NEMap k a) -insertLookupWithKey f k v n@(NEMap k0 v0 m) = case compare k k0 of - LT -> (Nothing, NEMap k v . toMap $ n ) - EQ -> (Just v , NEMap k (f k v v0) m ) - GT -> NEMap k0 v0 <$> M.insertLookupWithKey f k v m -{-# INLINE insertLookupWithKey #-} - --- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs --- with a combining function. See also 'fromAscListWith'. --- --- > fromListWith (++) ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "ab") :| [(5, "aba")]) -fromListWith - :: Ord k - => (a -> a -> a) - -> NonEmpty (k, a) - -> NEMap k a -fromListWith f = fromListWithKey (const f) -{-# INLINE fromListWith #-} - --- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs --- with a combining function. See also 'fromAscListWithKey'. --- --- > let f k a1 a2 = (show k) ++ a1 ++ a2 --- > fromListWithKey f ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "3ab") :| [(5, "5a5ba")]) -fromListWithKey - :: Ord k - => (k -> a -> a -> a) - -> NonEmpty (k, a) - -> NEMap k a -fromListWithKey f ((k0, v0) :| xs) = F.foldl' go (singleton k0 v0) xs - where - go m (k, v) = insertWithKey f k v m - {-# INLINE go #-} -{-# INLINE fromListWithKey #-} - --- | /O(n)/. Build a map from an ascending non-empty list in linear time. --- /The precondition (input list is ascending) is not checked./ --- --- > fromAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) --- > fromAscList ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "b")]) --- > valid (fromAscList ((3,"b") :| [(5,"a"), (5,"b")])) == True --- > valid (fromAscList ((5,"a") :| [(3,"b"), (5,"b")])) == False -fromAscList - :: Eq k - => NonEmpty (k, a) - -> NEMap k a -fromAscList = fromDistinctAscList . combineEq -{-# INLINE fromAscList #-} - --- | /O(n)/. Build a map from an ascending non-empty list in linear time --- with a combining function for equal keys. /The precondition (input list --- is ascending) is not checked./ --- --- > fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "ba")]) --- > valid (fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b"))]) == True --- > valid (fromAscListWith (++) ((5,"a") :| [(3,"b"), (5,"b"))]) == False -fromAscListWith - :: Eq k - => (a -> a -> a) - -> NonEmpty (k, a) - -> NEMap k a -fromAscListWith f = fromAscListWithKey (const f) -{-# INLINE fromAscListWith #-} - --- | /O(n)/. Build a map from an ascending non-empty list in linear time --- with a combining function for equal keys. /The precondition (input list --- is ascending) is not checked./ --- --- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 --- > fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")]) == fromList ((3, "b") :| [(5, "5:b5:ba")]) --- > valid (fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")])) == True --- > valid (fromAscListWithKey f ((5,"a") :| [(3,"b"), (5,"b"), (5,"b")])) == False -fromAscListWithKey - :: Eq k - => (k -> a -> a -> a) - -> NonEmpty (k, a) - -> NEMap k a -fromAscListWithKey f = fromDistinctAscList . combineEqWith f -{-# INLINE fromAscListWithKey #-} - --- | /O(n)/. Build a map from an ascending non-empty list of distinct --- elements in linear time. /The precondition is not checked./ --- --- > fromDistinctAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) --- > valid (fromDistinctAscList ((3,"b") :| [(5,"a")])) == True --- > valid (fromDistinctAscList ((3,"b") :| [(5,"a"), (5,"b")])) == False -fromDistinctAscList :: NonEmpty (k, a) -> NEMap k a -fromDistinctAscList ((k, v) :| xs) = insertMapMin k v - . M.fromDistinctAscList - $ xs -{-# INLINE fromDistinctAscList #-} - --- | /O(n)/. Build a map from a descending non-empty list in linear time. --- /The precondition (input list is descending) is not checked./ --- --- > fromDescList ((5,"a") :| [(3,"b")]) == fromList ((3, "b") :| [(5, "a")]) --- > fromDescList ((5,"a") :| [(5,"b"), (3,"b")]) == fromList ((3, "b") :| [(5, "b")]) --- > valid (fromDescList ((5,"a") :| [(5,"b"), (3,"b")])) == True --- > valid (fromDescList ((5,"a") :| [(3,"b"), (5,"b")])) == False -fromDescList - :: Eq k - => NonEmpty (k, a) - -> NEMap k a -fromDescList = fromDistinctDescList . combineEq -{-# INLINE fromDescList #-} - --- | /O(n)/. Build a map from a descending non-empty list in linear time --- with a combining function for equal keys. /The precondition (input list --- is descending) is not checked./ --- --- > fromDescListWith (++) ((5,"a") :| [(5,"b"), (3,"b")]) == fromList ((3, "b") :| [(5, "ba")]) --- > valid (fromDescListWith (++) ((5,"a") :| [(5,"b"), (3,"b")])) == True --- > valid (fromDescListWith (++) ((5,"a") :| [(3,"b"), (5,"b")])) == False -fromDescListWith - :: Eq k - => (a -> a -> a) - -> NonEmpty (k, a) - -> NEMap k a -fromDescListWith f = fromDescListWithKey (const f) -{-# INLINE fromDescListWith #-} - --- | /O(n)/. Build a map from a descending non-empty list in linear time --- with a combining function for equal keys. /The precondition (input list --- is descending) is not checked./ --- --- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 --- > fromDescListWithKey f ((5,"a") :| [(5,"b"), (5,"b"), (3,"b")]) == fromList ((3, "b") :| [(5, "5:b5:ba")]) --- > valid (fromDescListWithKey f ((5,"a") :| [(5,"b"), (5,"b"), (3,"b")])) == True --- > valid (fromDescListWithKey f ((5,"a") :| [(3,"b"), (5,"b"), (5,"b")])) == False -fromDescListWithKey - :: Eq k - => (k -> a -> a -> a) - -> NonEmpty (k, a) - -> NEMap k a -fromDescListWithKey f = fromDistinctDescList . combineEqWith f -{-# INLINE fromDescListWithKey #-} - --- | /O(n)/. Build a map from a descending list of distinct elements in linear time. --- /The precondition is not checked./ --- --- > fromDistinctDescList ((5,"a") :| [(3,"b")]) == fromList ((3, "b") :| [(5, "a")]) --- > valid (fromDistinctDescList ((5,"a") :| [(3,"b")])) == True --- > valid (fromDistinctDescList ((5,"a") :| [(5,"b"), (3,"b")])) == False --- --- @since 0.5.8 -fromDistinctDescList :: NonEmpty (k, a) -> NEMap k a -fromDistinctDescList ((k, v) :| xs) = insertMapMax k v - . M.fromDistinctDescList - $ xs -{-# INLINE fromDistinctDescList #-} - --- | /O(log n)/. Delete a key and its value from the non-empty map. --- A potentially empty map ('Map') is returned, since this might delete the --- last item in the 'NEMap'. When the key is not a member of the map, is --- equivalent to 'toMap'. --- --- > delete 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" --- > delete 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.Singleton [(3, "b"), (5, "a")] -delete :: Ord k => k -> NEMap k a -> Map k a -delete k n@(NEMap k0 v m) = case compare k k0 of - LT -> toMap n - EQ -> m - GT -> insertMinMap k0 v . M.delete k $ m -{-# INLINE delete #-} - --- | /O(log n)/. Update a value at a specific key with the result of the --- provided function. When the key is not a member of the map, the original --- map is returned. --- --- > adjust ("new " ++) 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "new a")]) --- > adjust ("new " ++) 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) -adjust - :: Ord k - => (a -> a) - -> k - -> NEMap k a - -> NEMap k a -adjust f = adjustWithKey (const f) -{-# INLINE adjust #-} - --- | /O(log n)/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > let f key x = (show key) ++ ":new " ++ x --- > adjustWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:new a")]) --- > adjustWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) -adjustWithKey - :: Ord k - => (k -> a -> a) - -> k - -> NEMap k a - -> NEMap k a -adjustWithKey f k n@(NEMap k0 v m) = case compare k k0 of - LT -> n - EQ -> NEMap k0 (f k0 v) m - GT -> NEMap k0 v . M.adjustWithKey f k $ m -{-# INLINE adjustWithKey #-} - --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- Returns a potentially empty map ('Map'), because we can't know ahead of --- time if the function returns 'Nothing' and deletes the final item in the --- 'NEMap'. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > update f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "new a")] --- > update f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a")] --- > update f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" -update - :: Ord k - => (a -> Maybe a) - -> k - -> NEMap k a - -> Map k a -update f = updateWithKey (const f) -{-# INLINE update #-} - --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the --- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', --- the element is deleted. If it is (@'Just' y@), the key @k@ is bound --- to the new value @y@. --- --- Returns a potentially empty map ('Map'), because we can't know ahead of --- time if the function returns 'Nothing' and deletes the final item in the --- 'NEMap'. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "5:new a")] --- > updateWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a")] --- > updateWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" -updateWithKey - :: Ord k - => (k -> a -> Maybe a) - -> k - -> NEMap k a - -> Map k a -updateWithKey f k n@(NEMap k0 v m) = case compare k k0 of - LT -> toMap n - EQ -> maybe m (flip (insertMinMap k0) m) . f k0 $ v - GT -> insertMinMap k0 v . M.updateWithKey f k $ m -{-# INLINE updateWithKey #-} - --- | /O(log n)/. Lookup and update. See also 'updateWithKey'. --- The function returns changed value, if it is updated. --- Returns the original key value if the map entry is deleted. --- --- Returns a potentially empty map ('Map') in the case that we delete the --- final key of a singleton map. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateLookupWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == (Just "5:new a", Data.Map.fromList ((3, "b") :| [(5, "5:new a")])) --- > updateLookupWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == (Nothing, Data.Map.fromList ((3, "b") :| [(5, "a")])) --- > updateLookupWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == (Just "b", Data.Map.singleton 5 "a") -updateLookupWithKey - :: Ord k - => (k -> a -> Maybe a) - -> k - -> NEMap k a - -> (Maybe a, Map k a) -updateLookupWithKey f k n@(NEMap k0 v m) = case compare k k0 of - LT -> (Nothing, toMap n) - EQ -> let u = f k0 v - in (u <|> Just v, maybe m (flip (insertMinMap k0) m) u) - GT -> fmap (insertMinMap k0 v) . M.updateLookupWithKey f k $ m -{-# INLINE updateLookupWithKey #-} - --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at --- @k@, or absence thereof. 'alter' can be used to insert, delete, or --- update a value in a 'Map'. In short : @Data.Map.lookup k ('alter' --- f k m) = f ('lookup' k m)@. --- --- Returns a potentially empty map ('Map'), because we can't know ahead of --- time if the function returns 'Nothing' and deletes the final item in the --- 'NEMap'. --- --- See 'alterF'' for a version that disallows deletion, and so therefore --- can return 'NEMap'. --- --- > let f _ = Nothing --- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a")] --- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" --- > --- > let f _ = Just "c" --- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a"), (7, "c")] --- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "c")] -alter - :: Ord k - => (Maybe a -> Maybe a) - -> k - -> NEMap k a - -> Map k a -alter f k n@(NEMap k0 v m) = case compare k k0 of - LT -> ($ toMap n) . maybe id (insertMinMap k ) $ f Nothing - EQ -> ($ m ) . maybe id (insertMinMap k0) $ f (Just v) - GT -> insertMinMap k0 v . M.alter f k $ m -{-# INLINE alter #-} - --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ --- at @k@, or absence thereof. 'alterF' can be used to inspect, insert, --- delete, or update a value in a 'Map'. In short: @Data.Map.lookup --- k \<$\> 'alterF' f k m = f ('lookup' k m)@. --- --- Example: --- --- @ --- interactiveAlter :: Int -> NEMap Int String -> IO (Map Int String) --- interactiveAlter k m = alterF f k m where --- f Nothing = do --- putStrLn $ show k ++ --- " was not found in the map. Would you like to add it?" --- getUserResponse1 :: IO (Maybe String) --- f (Just old) = do --- putStrLn $ "The key is currently bound to " ++ show old ++ --- ". Would you like to change or delete it?" --- getUserResponse2 :: IO (Maybe String) --- @ --- --- Like @Data.Map.alterF@ for 'Map', 'alterF' can be considered --- to be a unifying generalization of 'lookup' and 'delete'; however, as --- a constrast, it cannot be used to implement 'insert', because it must --- return a 'Map' instead of an 'NEMap' (because the function might delete --- the final item in the 'NEMap'). When used with trivial functors like --- 'Identity' and 'Const', it is often slightly slower than --- specialized 'lookup' and 'delete'. However, when the functor is --- non-trivial and key comparison is not particularly cheap, it is the --- fastest way. --- --- See 'alterF'' for a version that disallows deletion, and so therefore --- can return 'NEMap' and be used to implement 'insert' --- --- Note on rewrite rules: --- --- This module includes GHC rewrite rules to optimize 'alterF' for --- the 'Const' and 'Identity' functors. In general, these rules --- improve performance. The sole exception is that when using --- 'Identity', deleting a key that is already absent takes longer --- than it would without the rules. If you expect this to occur --- a very large fraction of the time, you might consider using a --- private copy of the 'Identity' type. --- --- Note: Unlike @Data.Map.alterF@ for 'Map', 'alterF' is /not/ a flipped --- version of the 'Control.Lens.At.at' combinator from "Control.Lens.At". --- However, it match the shape expected from most functions expecting --- lenses, getters, and setters, so can be thought of as a "psuedo-lens", --- with virtually the same practical applications as a legitimate lens. -alterF - :: (Ord k, Functor f) - => (Maybe a -> f (Maybe a)) - -> k - -> NEMap k a - -> f (Map k a) -alterF f k n@(NEMap k0 v m) = case compare k k0 of - LT -> ($ toMap n) . maybe id (insertMinMap k ) <$> f Nothing - EQ -> ($ m ) . maybe id (insertMinMap k0) <$> f (Just v) - GT -> insertMinMap k0 v <$> M.alterF f k m -{-# INLINABLE [2] alterF #-} - --- if f ~ Const b, it's a lookup -{-# RULES -"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m - #-} --- if f ~ Identity, it's an 'alter' -{-# RULES -"alterF/Identity" forall k (f :: Maybe a -> Identity (Maybe a)) . alterF f k = Identity . alter (runIdentity . f) k - #-} - --- | /O(log n)/. Variant of 'alter' that disallows deletion. Allows us to --- guarantee that the result is also a non-empty Map. -alter' - :: Ord k - => (Maybe a -> a) - -> k - -> NEMap k a - -> NEMap k a -alter' f k n@(NEMap k0 v m) = case compare k k0 of - LT -> NEMap k (f Nothing) . toMap $ n - EQ -> NEMap k0 (f (Just v)) $ m - GT -> NEMap k0 v . M.alter (Just . f) k $ m -{-# INLINE alter' #-} - --- | /O(log n)/. Variant of 'alterF' that disallows deletion. Allows us to --- guarantee that the result is also a non-empty Map. --- --- Like @Data.Map.alterF@ for 'Map', can be used to generalize and unify --- 'lookup' and 'insert'. However, because it disallows deletion, it --- cannot be used to implement 'delete'. --- --- See 'alterF' for usage information and caveats. --- --- Note: Neither 'alterF' nor 'alterF'' can be considered flipped versions --- of the 'Control.Lens.At.at' combinator from "Control.Lens.At". However, --- this can match the shape expected from most functions expecting lenses, --- getters, and setters, so can be thought of as a "psuedo-lens", with --- virtually the same practical applications as a legitimate lens. --- --- __WARNING__: The rewrite rule for 'Identity' exposes an inconsistency in --- undefined behavior for "Data.Map". @Data.Map.alterF@ will actually --- /maintain/ the original key in the map when used with 'Identity'; --- however, @Data.Map.insertWith@ will /replace/ the orginal key in the --- map. The rewrite rule for 'alterF'' has chosen to be faithful to --- @Data.Map.insertWith@, and /not/ @Data.Map.alterF@, for the sake of --- a cleaner implementation. -alterF' - :: (Ord k, Functor f) - => (Maybe a -> f a) - -> k - -> NEMap k a - -> f (NEMap k a) -alterF' f k n@(NEMap k0 v m) = case compare k k0 of - LT -> flip (NEMap k ) (toMap n) <$> f Nothing - EQ -> flip (NEMap k0) m <$> f (Just v) - GT -> NEMap k0 v <$> M.alterF (fmap Just . f) k m -{-# INLINABLE [2] alterF' #-} - --- if f ~ Const b, it's a lookup -{-# RULES -"alterF'/Const" forall k (f :: Maybe a -> Const b a) . alterF' f k = \m -> Const . getConst . f $ lookup k m - #-} --- if f ~ Identity, it's an insertWith -{-# RULES -"alterF'/Identity" forall k (f :: Maybe a -> Identity a) . alterF' f k = Identity . insertWith (\_ -> runIdentity . f . Just) k (runIdentity (f Nothing)) - #-} - --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. --- --- Returns a potentially empty map ('Map'), our function might return --- 'Nothing' on every item in the 'NEMap'. --- --- /Use 'traverseMaybeWithKey1'/ whenever possible (if your 'Applicative' --- also has 'Apply' instance). This version is provided only for types --- that do not have 'Apply' instance, since 'Apply' is not at the moment --- (and might not ever be) an official superclass of 'Applicative'. -traverseMaybeWithKey - :: Applicative t - => (k -> a -> t (Maybe b)) - -> NEMap k a - -> t (Map k b) -traverseMaybeWithKey f (NEMap k0 v m0) = - combine <$> f k0 v <*> M.traverseMaybeWithKey f m0 - where - combine Nothing = id - combine (Just v') = insertMinMap k0 v' -{-# INLINE traverseMaybeWithKey #-} - --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. --- --- Returns a potentially empty map ('Map'), our function might return --- 'Nothing' on every item in the 'NEMap'. --- --- Is more general than 'traverseWithKey', since works with all 'Apply', --- and not just 'Applicative'. - --- TODO: benchmark against M.maxView version -traverseMaybeWithKey1 - :: Apply t - => (k -> a -> t (Maybe b)) - -> NEMap k a - -> t (Map k b) -traverseMaybeWithKey1 f (NEMap k0 v m0) = case runMaybeApply m1 of - Left m2 -> combine <$> f k0 v <.> m2 - Right m2 -> (`combine` m2) <$> f k0 v - where - m1 = M.traverseMaybeWithKey (\k -> MaybeApply . Left . f k) m0 - combine Nothing = id - combine (Just v') = insertMinMap k0 v' -{-# INLINE traverseMaybeWithKey1 #-} - --- | /O(n)/. The function 'mapAccum' threads an accumulating argument --- through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList ((5,"a") :| [(3,"b")])) == ("Everything: ba", fromList ((3, "bX") :| [(5, "aX")])) -mapAccum - :: (a -> b -> (a, c)) - -> a - -> NEMap k b - -> (a, NEMap k c) -mapAccum f = mapAccumWithKey (\x _ -> f x) -{-# INLINE mapAccum #-} - --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList ((5,"a") :| [(3,"b")])) == ("Everything: 3-b 5-a", fromList ((3, "bX") :| [(5, "aX")])) -mapAccumWithKey - :: (a -> k -> b -> (a, c)) - -> a - -> NEMap k b - -> (a, NEMap k c) -mapAccumWithKey f z0 (NEMap k v m) = (z2, NEMap k v' m') - where - ~(z1, v') = f z0 k v - ~(z2, m') = M.mapAccumWithKey f z1 m -{-# INLINE mapAccumWithKey #-} - --- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey - :: (a -> k -> b -> (a, c)) - -> a - -> NEMap k b - -> (a, NEMap k c) -mapAccumRWithKey f z0 (NEMap k v m) = (z2, NEMap k v' m') - where - ~(z1, m') = M.mapAccumRWithKey f z0 m - ~(z2, v') = f z1 k v -{-# INLINE mapAccumRWithKey #-} --- TODO: what other situations can we take advantage of lazy tuple pattern --- matching? - --- | /O(n*log n)/. --- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the value at the greatest of the --- original keys is retained. --- --- While the size of the result map may be smaller than the input map, the --- output map is still guaranteed to be non-empty if the input map is --- non-empty. --- --- > mapKeys (+ 1) (fromList ((5,"a") :| [(3,"b")])) == fromList ((4, "b") :| [(6, "a")]) --- > mapKeys (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "c" --- > mapKeys (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "c" -mapKeys - :: Ord k2 - => (k1 -> k2) - -> NEMap k1 a - -> NEMap k2 a -mapKeys f (NEMap k0 v0 m) = fromListWith const - . ((f k0, v0) :|) - . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] - $ m -{-# INLINABLE mapKeys #-} - --- | /O(n*log n)/. --- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. The value at the greater of the two original keys --- is used as the first argument to @c@. --- --- While the size of the result map may be smaller than the input map, the --- output map is still guaranteed to be non-empty if the input map is --- non-empty. --- --- > mapKeysWith (++) (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "cdab" --- > mapKeysWith (++) (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "cdab" -mapKeysWith - :: Ord k2 - => (a -> a -> a) - -> (k1 -> k2) - -> NEMap k1 a - -> NEMap k2 a -mapKeysWith c f (NEMap k0 v0 m) = fromListWith c - . ((f k0, v0) :|) - . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] - $ m -{-# INLINABLE mapKeysWith #-} - --- | /O(n)/. --- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ --- is strictly monotonic. --- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. --- /The precondition is not checked./ --- Semi-formally, we have: --- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- > ==> mapKeysMonotonic f s == mapKeys f s --- > where ls = keys s --- --- This means that @f@ maps distinct original keys to distinct resulting keys. --- This function has better performance than 'mapKeys'. --- --- While the size of the result map may be smaller than the input map, the --- output map is still guaranteed to be non-empty if the input map is --- non-empty. --- --- > mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")])) == fromList ((6, "b") :| [(10, "a")]) --- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")]))) == True --- > valid (mapKeysMonotonic (\ _ -> 1) (fromList ((5,"a") :| [(3,"b")]))) == False -mapKeysMonotonic - :: (k1 -> k2) - -> NEMap k1 a - -> NEMap k2 a -mapKeysMonotonic f (NEMap k v m) = NEMap (f k) v - . M.mapKeysMonotonic f - $ m -{-# INLINE mapKeysMonotonic #-} - --- | /O(n)/. Filter all values that satisfy the predicate. --- --- Returns a potentially empty map ('Map'), because we could --- potentailly filter out all items in the original 'NEMap'. --- --- > filter (> "a") (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" --- > filter (> "x") (fromList ((5,"a") :| [(3,"b")])) == Data.Map.empty --- > filter (< "a") (fromList ((5,"a") :| [(3,"b")])) == Data.Map.empty -filter - :: (a -> Bool) - -> NEMap k a - -> Map k a -filter f (NEMap k v m) - | f v = insertMinMap k v . M.filter f $ m - | otherwise = M.filter f m -{-# INLINE filter #-} - --- | /O(n)/. Filter all keys\/values that satisfy the predicate. --- --- Returns a potentially empty map ('Map'), because we could --- potentailly filter out all items in the original 'NEMap'. --- --- > filterWithKey (\k _ -> k > 4) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" -filterWithKey - :: (k -> a -> Bool) - -> NEMap k a - -> Map k a -filterWithKey f (NEMap k v m) - | f k v = insertMinMap k v . M.filterWithKey f $ m - | otherwise = M.filterWithKey f m -{-# INLINE filterWithKey #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Restrict an 'NEMap' to only those keys --- found in a 'Data.Set.Set'. --- --- @ --- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m --- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s --- @ -restrictKeys - :: Ord k - => NEMap k a - -> Set k - -> Map k a -restrictKeys n@(NEMap k v m) xs = case S.minView xs of - Nothing -> M.empty - Just (y, ys) -> case compare k y of - -- k is not in xs - LT -> m `M.restrictKeys` xs - -- k and y are a part of the result - EQ -> insertMinMap k v $ m `M.restrictKeys` ys - -- y is not in m - GT -> toMap n `M.restrictKeys` ys -{-# INLINE restrictKeys #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Data.Set.Set' from --- an 'NEMap'. --- --- @ --- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m --- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s --- @ -withoutKeys - :: Ord k - => NEMap k a - -> Set k - -> Map k a -withoutKeys n@(NEMap k v m) xs = case S.minView xs of - Nothing -> toMap n - Just (y, ys) -> case compare k y of - -- k is not in xs, so cannot be deleted - LT -> insertMinMap k v $ m `M.withoutKeys` xs - -- y deletes k, and only k - EQ -> m `M.withoutKeys` ys - -- y is not in n, so cannot delete anything, so we can just difference n and ys - GT -> toMap n `M.withoutKeys` ys -{-# INLINE withoutKeys #-} - --- | /O(n)/. Partition the map according to a predicate. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the predicate was true for all items. --- * @'That' n2@ means that the predicate was false for all items. --- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the --- predicate) and @n2@ (all of the items that were false for the --- predicate). --- --- See also 'split'. --- --- > partition (> "a") (fromList ((5,"a") :| [(3,"b")])) == These (singleton 3 "b") (singleton 5 "a") --- > partition (< "x") (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) --- > partition (> "x") (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) -partition - :: (a -> Bool) - -> NEMap k a - -> These (NEMap k a) (NEMap k a) -partition f = partitionWithKey (const f) -{-# INLINE partition #-} - --- | /O(n)/. Partition the map according to a predicate. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the predicate was true for all items, --- returning the original map. --- * @'That' n2@ means that the predicate was false for all items, --- returning the original map. --- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the --- predicate) and @n2@ (all of the items that were false for the --- predicate). --- --- See also 'split'. --- --- > partitionWithKey (\ k _ -> k > 3) (fromList ((5,"a") :| [(3,"b")])) == These (singleton 5 "a") (singleton 3 "b") --- > partitionWithKey (\ k _ -> k < 7) (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) --- > partitionWithKey (\ k _ -> k > 7) (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) -partitionWithKey - :: (k -> a -> Bool) - -> NEMap k a - -> These (NEMap k a) (NEMap k a) -partitionWithKey f n@(NEMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) - | f k v -> This n - | otherwise -> That n - (Just n1, Nothing) - | f k v -> This n - | otherwise -> These n1 (singleton k v) - (Nothing, Just n2) - | f k v -> These (singleton k v) n2 - | otherwise -> That n - (Just n1, Just n2) - | f k v -> These (insertMapMin k v m1) n2 - | otherwise -> These n1 (insertMapMin k v m2) - where - (m1, m2) = M.partitionWithKey f m0 -{-# INLINABLE partitionWithKey #-} - --- | /O(log n)/. Take while a predicate on the keys holds. --- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, --- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. --- --- Returns a potentially empty map ('Map'), because the predicate might --- fail on the first input. --- --- @ --- takeWhileAntitone p = Data.Map.fromDistinctAscList . Data.List.takeWhile (p . fst) . Data.Foldable.toList --- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k) --- @ -takeWhileAntitone - :: (k -> Bool) - -> NEMap k a - -> Map k a -takeWhileAntitone f (NEMap k v m) - | f k = insertMinMap k v . M.takeWhileAntitone f $ m - | otherwise = M.empty -{-# INLINE takeWhileAntitone #-} - --- | /O(log n)/. Drop while a predicate on the keys holds. --- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, --- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. --- --- @ --- dropWhileAntitone p = Data.Map.fromDistinctAscList . Data.List.dropWhile (p . fst) . Data.Foldable.toList --- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k)) --- @ -dropWhileAntitone - :: (k -> Bool) - -> NEMap k a - -> Map k a -dropWhileAntitone f n@(NEMap k _ m) - | f k = M.dropWhileAntitone f m - | otherwise = toMap n -{-# INLINE dropWhileAntitone #-} - --- | /O(log n)/. Divide a map at the point where a predicate on the keys stops holding. --- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, --- @j \< k ==\> p j \>= p k@. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the predicate never failed for any item, --- returning the original map. --- * @'That' n2@ means that the predicate failed for the first item, --- returning the original map. --- * @'These' n1 n2@ gives @n1@ (the map up to the point where the --- predicate on the keys stops holding) and @n2@ (the map starting from --- the point where the predicate stops holding) --- --- @ --- spanAntitone p xs = partitionWithKey (\k _ -> p k) xs --- @ --- --- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map --- at some /unspecified/ point where the predicate switches from holding to not --- holding (where the predicate is seen to hold before the first key and to fail --- after the last key). -spanAntitone - :: (k -> Bool) - -> NEMap k a - -> These (NEMap k a) (NEMap k a) -spanAntitone f n@(NEMap k v m0) - | f k = case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> This n - (Just _ , Nothing) -> This n - (Nothing, Just n2) -> These (singleton k v) n2 - (Just _ , Just n2) -> These (insertMapMin k v m1) n2 - | otherwise = That n - where - (m1, m2) = M.spanAntitone f m0 -{-# INLINABLE spanAntitone #-} - --- | /O(n)/. Map values and collect the 'Just' results. --- --- Returns a potentially empty map ('Map'), because the function could --- potentially return 'Nothing' on all items in the 'NEMap'. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > mapMaybe f (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "new a" -mapMaybe - :: (a -> Maybe b) - -> NEMap k a - -> Map k b -mapMaybe f = mapMaybeWithKey (const f) -{-# INLINE mapMaybe #-} - --- | /O(n)/. Map keys\/values and collect the 'Just' results. --- --- Returns a potentially empty map ('Map'), because the function could --- potentially return 'Nothing' on all items in the 'NEMap'. --- --- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing --- > mapMaybeWithKey f (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "key : 3" -mapMaybeWithKey - :: (k -> a -> Maybe b) - -> NEMap k a - -> Map k b -mapMaybeWithKey f (NEMap k v m) = ($ M.mapMaybeWithKey f m) - . maybe id (insertMinMap k) - $ f k v -{-# INLINE mapMaybeWithKey #-} - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the results were all 'Left'. --- * @'That' n2@ means that the results were all 'Right'. --- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') --- and @n2@ (the map where the results were 'Right') --- --- > let f a = if a < "c" then Left a else Right a --- > mapEither f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == These (fromList ((3,"b") :| [(5,"a")])) (fromList ((1,"x") :| [(7,"z")])) --- > --- > mapEither (\ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == That (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) -mapEither - :: (a -> Either b c) - -> NEMap k a - -> These (NEMap k b) (NEMap k c) -mapEither f = mapEitherWithKey (const f) -{-# INLINE mapEither #-} - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. --- --- Returns a 'These' with potentially two non-empty maps: --- --- * @'This' n1@ means that the results were all 'Left'. --- * @'That' n2@ means that the results were all 'Right'. --- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') --- and @n2@ (the map where the results were 'Right') --- --- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) --- > mapEitherWithKey f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == These (fromList ((1,2) :| [(3,6)])) (fromList ((5,"aa") :| [(7,"zz")])) --- > --- > mapEitherWithKey (\_ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) --- > == That (fromList ((1,"x") :| [(3,"b"), (5,"a"), (7,"z")])) -mapEitherWithKey - :: (k -> a -> Either b c) - -> NEMap k a - -> These (NEMap k b) (NEMap k c) -mapEitherWithKey f (NEMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> case f k v of - Left v' -> This (singleton k v') - Right v' -> That (singleton k v') - (Just n1, Nothing) -> case f k v of - Left v' -> This (insertMapMin k v' m1) - Right v' -> These n1 (singleton k v') - (Nothing, Just n2) -> case f k v of - Left v' -> These (singleton k v') n2 - Right v' -> That (insertMapMin k v' m2) - (Just n1, Just n2) -> case f k v of - Left v' -> These (insertMapMin k v' m1) n2 - Right v' -> These n1 (insertMapMin k v' m2) - where - (m1, m2) = M.mapEitherWithKey f m0 -{-# INLINABLE mapEitherWithKey #-} - --- | /O(log n)/. The expression (@'split' k map@) is potentially a 'These' --- containing up to two 'NEMap's based on splitting the map into maps --- containing items before and after the given key @k@. It will never --- return a map that contains @k@ itself. --- --- * 'Nothing' means that @k@ was the only key in the the original map, --- and so there are no items before or after it. --- * @'Just' ('This' n1)@ means @k@ was larger than or equal to all items --- in the map, and @n1@ is the entire original map (minus @k@, if it was --- present) --- * @'Just' ('That' n2)@ means @k@ was smaller than or equal to all --- items in the map, and @n2@ is the entire original map (minus @k@, if --- it was present) --- * @'Just' ('These' n1 n2)@ gives @n1@ (the map of all keys from the --- original map less than @k@) and @n2@ (the map of all keys from the --- original map greater than @k@) --- --- > split 2 (fromList ((5,"a") :| [(3,"b")])) == Just (That (fromList ((3,"b") :| [(5,"a")])) ) --- > split 3 (fromList ((5,"a") :| [(3,"b")])) == Just (That (singleton 5 "a") ) --- > split 4 (fromList ((5,"a") :| [(3,"b")])) == Just (These (singleton 3 "b") (singleton 5 "a")) --- > split 5 (fromList ((5,"a") :| [(3,"b")])) == Just (This (singleton 3 "b") ) --- > split 6 (fromList ((5,"a") :| [(3,"b")])) == Just (This (fromList ((3,"b") :| [(5,"a")])) ) --- > split 5 (singleton 5 "a") == Nothing -split - :: Ord k - => k - -> NEMap k a - -> Maybe (These (NEMap k a) (NEMap k a)) -split k n@(NEMap k0 v m0) = case compare k k0 of - LT -> Just $ That n - EQ -> That <$> nonEmptyMap m0 - 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 the first field in --- the 'These': --- --- > 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 - -> These a (These (NEMap k a) (NEMap k a)) -splitLookup k n@(NEMap k0 v0 m0) = case compare k k0 of - 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 #-} - --- | /O(1)/. Decompose a map into pieces based on the structure of the --- underlying tree. This function is useful for consuming a map in --- parallel. --- --- No guarantee is made as to the sizes of the pieces; an internal, but --- deterministic process determines this. However, it is guaranteed that --- the pieces returned will be in ascending order (all elements in the --- first submap less than all elements in the second, and so on). --- --- Note that the current implementation does not return more than four --- submaps, but you should not depend on this behaviour because it can --- change in the future without notice. -splitRoot - :: NEMap k a - -> NonEmpty (NEMap k a) -splitRoot (NEMap k v m) = singleton k v - :| Maybe.mapMaybe nonEmptyMap (M.splitRoot m) -{-# INLINE splitRoot #-} - --- | /O(m*log(n\/m + 1)), m <= n/. --- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -isSubmapOf :: (Ord k, Eq a) => NEMap k a -> NEMap k a -> Bool -isSubmapOf = isSubmapOfBy (==) -{-# INLINE isSubmapOf #-} - --- | /O(m*log(n\/m + 1)), m <= n/. --- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if --- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when --- applied to their respective values. For example, the following --- expressions are all 'True': --- --- > isSubmapOfBy (==) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (<=) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (fromList (('a',1) :| [('b',2)])) --- --- But the following are all 'False': --- --- > isSubmapOfBy (==) (singleton 'a' 2) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (<) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) --- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (singleton 'a' 1) -isSubmapOfBy - :: Ord k - => (a -> b -> Bool) - -> NEMap k a - -> NEMap k b - -> Bool -isSubmapOfBy f (NEMap k v m0) (toMap->m1) = kvSub - && M.isSubmapOfBy f m0 m1 - where - kvSub = case M.lookup k m1 of - Just v0 -> f v v0 - Nothing -> False -{-# INLINE isSubmapOfBy #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap --- but not equal). Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' --- (==)@). -isProperSubmapOf :: (Ord k, Eq a) => NEMap k a -> NEMap k a -> Bool -isProperSubmapOf = isProperSubmapOfBy (==) -{-# INLINE isProperSubmapOf #-} - --- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap --- but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns --- 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, --- and when @f@ returns 'True' when applied to their respective values. For --- example, the following expressions are all 'True': --- --- > isProperSubmapOfBy (==) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) --- > isProperSubmapOfBy (<=) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) --- --- But the following are all 'False': --- --- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (fromList ((1,1) :| [(2,2)])) --- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (singleton 1 1)) --- > isProperSubmapOfBy (<) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) -isProperSubmapOfBy - :: Ord k - => (a -> b -> Bool) - -> NEMap k a - -> NEMap k b - -> Bool -isProperSubmapOfBy f m1 m2 = M.size (nemMap m1) < M.size (nemMap m2) - && isSubmapOfBy f m1 m2 -{-# INLINE isProperSubmapOfBy #-} - --- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index --- in the sequence sorted by keys. The index is a number from /0/ up to, --- but not including, the 'size' of the map. --- --- > isJust (lookupIndex 2 (fromList ((5,"a") :| [(3,"b")]))) == False --- > fromJust (lookupIndex 3 (fromList ((5,"a") :| [(3,"b")]))) == 0 --- > fromJust (lookupIndex 5 (fromList ((5,"a") :| [(3,"b")]))) == 1 --- > isJust (lookupIndex 6 (fromList ((5,"a") :| [(3,"b")]))) == False -lookupIndex - :: Ord k - => k - -> NEMap k a - -> Maybe Int -lookupIndex k (NEMap k0 _ m) = case compare k k0 of - LT -> Nothing - EQ -> Just 0 - GT -> (+ 1) <$> M.lookupIndex k m -{-# INLINE lookupIndex #-} - --- | /O(log n)/. Return the /index/ of a key, which is its zero-based index --- in the sequence sorted by keys. The index is a number from /0/ up to, --- but not including, the 'size' of the map. Calls 'error' when the key is --- not a 'member' of the map. --- --- > findIndex 2 (fromList ((5,"a") :| [(3,"b")])) Error: element is not in the map --- > findIndex 3 (fromList ((5,"a") :| [(3,"b")])) == 0 --- > findIndex 5 (fromList ((5,"a") :| [(3,"b")])) == 1 --- > findIndex 6 (fromList ((5,"a") :| [(3,"b")])) Error: element is not in the map -findIndex - :: Ord k - => k - -> NEMap k a - -> Int -findIndex k = fromMaybe e . lookupIndex k - where - e = error "NEMap.findIndex: element is not in the map" -{-# INLINE findIndex #-} - --- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based --- index in the sequence sorted by keys. If the /index/ is out of range --- (less than zero, greater or equal to 'size' of the map), 'error' is --- called. --- --- > elemAt 0 (fromList ((5,"a") :| [(3,"b")])) == (3,"b") --- > elemAt 1 (fromList ((5,"a") :| [(3,"b")])) == (5, "a") --- > elemAt 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range -elemAt - :: Int - -> NEMap k a - -> (k, a) -elemAt 0 (NEMap k v _) = (k, v) -elemAt i (NEMap _ _ m) = M.elemAt (i - 1) m -{-# INLINABLE elemAt #-} - --- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in --- the sequence sorted by keys. If the /index/ is out of range (less than zero, --- greater or equal to 'size' of the map), 'error' is called. --- --- Returns a possibly empty map ('Map'), because the function might end up --- deleting the last key in the map. See 'adjustAt' for a version that --- disallows deletion, guaranteeing that the result is also a non-empty --- Map. --- --- > updateAt (\ _ _ -> Just "x") 0 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "x"), (5, "a")] --- > updateAt (\ _ _ -> Just "x") 1 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "x")] --- > updateAt (\ _ _ -> Just "x") 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range --- > updateAt (\ _ _ -> Just "x") (-1) (fromList ((5,"a") :| [(3,"b")])) Error: index out of range --- > updateAt (\_ _ -> Nothing) 0 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" --- > updateAt (\_ _ -> Nothing) 1 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" --- > updateAt (\_ _ -> Nothing) 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range --- > updateAt (\_ _ -> Nothing) (-1) (fromList ((5,"a") :| [(3,"b")])) Error: index out of range -updateAt - :: (k -> a -> Maybe a) - -> Int - -> NEMap k a - -> Map k a -updateAt f 0 (NEMap k v m) = maybe m (flip (insertMinMap k) m) $ f k v -updateAt f i (NEMap k v m) = insertMinMap k v . M.updateAt f (i - 1) $ m -{-# INLINABLE updateAt #-} - --- | /O(log n)/. Variant of 'updateAt' that disallows deletion. Allows us --- to guarantee that the result is also a non-empty Map. -adjustAt - :: (k -> a -> a) - -> Int - -> NEMap k a - -> NEMap k a -adjustAt f 0 (NEMap k0 v m) = NEMap k0 (f k0 v) m -adjustAt f i (NEMap k0 v m) = NEMap k0 v - . M.updateAt (\k -> Just . f k) (i - 1) - $ m -{-# INLINABLE adjustAt #-} - --- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based --- index in the sequence sorted by keys. If the /index/ is out of range --- (less than zero, greater or equal to 'size' of the map), 'error' is --- called. --- --- Returns a potentially empty map ('Map') because of the possibility of --- deleting the last item in a map. --- --- > deleteAt 0 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" --- > deleteAt 1 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" --- > deleteAt 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range --- > deleteAt (-1) (fromList ((5,"a") :| [(3,"b")])) Error: index out of range -deleteAt - :: Int - -> NEMap k a - -> Map k a -deleteAt 0 (NEMap _ _ m) = m -deleteAt i (NEMap k v m) = insertMinMap k v . M.deleteAt (i - 1) $ m -{-# INLINABLE deleteAt #-} - --- | Take a given number of entries in key order, beginning with the --- smallest keys. --- --- Returns a possibly empty map ('Map'), which can only happen if we call --- @take 0@. --- --- @ --- take n = Data.Map.fromDistinctAscList . Data.List.NonEmpty.take n . 'toList' --- @ -take - :: Int - -> NEMap k a - -> Map k a -take 0 NEMap{} = M.empty -take i (NEMap k v m) = insertMinMap k v . M.take (i - 1) $ m -{-# INLINABLE take #-} - --- | Drop a given number of entries in key order, beginning --- with the smallest keys. --- --- Returns a possibly empty map ('Map'), in case we drop all of the --- elements (which can happen if we drop a number greater than or equal to --- the number of items in the map) --- --- @ --- drop n = Data.Map.fromDistinctAscList . Data.List.NonEmpty.drop' n . 'toList' --- @ -drop - :: Int - -> NEMap k a - -> Map k a -drop 0 n = toMap n -drop i (NEMap _ _ m) = M.drop (i - 1) m -{-# INLINABLE drop #-} - --- | /O(log n)/. Split a map at a particular index @i@. --- --- * @'This' n1@ means that there are less than @i@ items in the map, and --- @n1@ is the original map. --- * @'That' n2@ means @i@ was 0; we dropped 0 items, so @n2@ is the --- original map. --- * @'These' n1 n2@ gives @n1@ (taking @i@ items from the original map) --- and @n2@ (dropping @i@ items from the original map)) -splitAt - :: Int - -> NEMap k a - -> These (NEMap k a) (NEMap k a) -splitAt 0 n = That n -splitAt i n@(NEMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of - (Nothing, Nothing) -> This (singleton k v) - (Just _ , Nothing) -> This n - (Nothing, Just n2) -> These (singleton k v) n2 - (Just _ , Just n2) -> These (insertMapMin k v m1) n2 - where - (m1, m2) = M.splitAt (i - 1) m0 -{-# INLINABLE splitAt #-} - --- | /O(1)/. The minimal key of the map. Note that this is total, making --- 'Data.Map.lookupMin' obsolete. It is constant-time, so has better --- asymptotics than @Data.Map.lookupMin@ and @Data.Map.findMin@, as well. --- --- > findMin (fromList ((5,"a") :| [(3,"b")])) == (3,"b") -findMin :: NEMap k a -> (k, a) -findMin (NEMap k v _) = (k, v) -{-# INLINE findMin #-} - --- | /O(log n)/. The maximal key of the map. Note that this is total, making --- 'Data.Map.lookupMin' obsolete. --- --- > findMax (fromList ((5,"a") :| [(3,"b")])) == (5,"a") -findMax :: NEMap k a -> (k, a) -findMax (NEMap k v m) = fromMaybe (k, v) . M.lookupMax $ m -{-# INLINE findMax #-} - --- | /O(1)/. Delete the minimal key. Returns a potentially empty map --- ('Map'), because we might end up deleting the final key in a singleton --- map. It is constant-time, so has better asymptotics than --- 'Data.Map.deleteMin'. --- --- > deleteMin (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.Map.fromList [(5,"a"), (7,"c")] --- > deleteMin (singleton 5 "a") == Data.Map.empty -deleteMin :: NEMap k a -> Map k a -deleteMin (NEMap _ _ m) = m -{-# INLINE deleteMin #-} - --- | /O(log n)/. Delete the maximal key. Returns a potentially empty map --- ('Map'), because we might end up deleting the final key in a singleton --- map. --- --- > deleteMax (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.Map.fromList [(3,"b"), (5,"a")] --- > deleteMax (singleton 5 "a") == Data.Map.empty -deleteMax :: NEMap k a -> Map k a -deleteMax (NEMap k v m) = case M.maxView m of - Nothing -> M.empty - Just (_, m') -> insertMinMap k v m' -{-# INLINE deleteMax #-} - --- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the --- minimal key. Returns a potentially empty map ('Map'), because we might --- end up deleting the final key in the map if the function returns --- 'Nothing'. See 'adjustMin' for a version that can guaruntee that we --- return a non-empty map. --- --- > updateMin (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "Xb"), (5, "a")] --- > updateMin (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" -updateMin :: (a -> Maybe a) -> NEMap k a -> Map k a -updateMin f = updateMinWithKey (const f) -{-# INLINE updateMin #-} - --- | /O(1)/. A version of 'updateMin' that disallows deletion, allowing us --- to guarantee that the result is also non-empty. -adjustMin :: (a -> a) -> NEMap k a -> NEMap k a -adjustMin f = adjustMinWithKey (const f) -{-# INLINE adjustMin #-} - --- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the --- minimal key. Returns a potentially empty map ('Map'), because we might --- end up deleting the final key in the map if the function returns --- 'Nothing'. See 'adjustMinWithKey' for a version that guaruntees --- a non-empty map. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" -updateMinWithKey :: (k -> a -> Maybe a) -> NEMap k a -> Map k a -updateMinWithKey f (NEMap k v m) = ($ m) . maybe id (insertMinMap k) $ f k v -{-# INLINE updateMinWithKey #-} - --- | /O(1)/. A version of 'adjustMaxWithKey' that disallows deletion, --- allowing us to guarantee that the result is also non-empty. Note that --- it also is able to have better asymptotics than 'updateMinWithKey' in --- general. -adjustMinWithKey :: (k -> a -> a) -> NEMap k a -> NEMap k a -adjustMinWithKey f (NEMap k v m) = NEMap k (f k v) m -{-# INLINE adjustMinWithKey #-} - --- | /O(log n)/. Update the value at the maximal key. Returns --- a potentially empty map ('Map'), because we might end up deleting the --- final key in the map if the function returns 'Nothing'. See 'adjustMax' --- for a version that can guarantee that we return a non-empty map. --- --- > updateMax (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "Xa")] --- > updateMax (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" -updateMax :: (a -> Maybe a) -> NEMap k a -> Map k a -updateMax f = updateMaxWithKey (const f) -{-# INLINE updateMax #-} - --- | /O(log n)/. A version of 'updateMax' that disallows deletion, allowing --- us to guarantee that the result is also non-empty. -adjustMax :: (a -> a) -> NEMap k a -> NEMap k a -adjustMax f = adjustMaxWithKey (const f) -{-# INLINE adjustMax #-} - --- | /O(log n)/. Update the value at the maximal key. Returns --- a potentially empty map ('Map'), because we might end up deleting the --- final key in the map if the function returns 'Nothing'. See --- 'adjustMaxWithKey' for a version that guaruntees a non-empty map. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" -updateMaxWithKey :: (k -> a -> Maybe a) -> NEMap k a -> Map k a -updateMaxWithKey f (NEMap k v m) - | M.null m = maybe m (M.singleton k) $ f k v - | otherwise = insertMinMap k v - . M.updateMaxWithKey f - $ m -{-# INLINE updateMaxWithKey #-} - --- | /O(log n)/. A version of 'updateMaxWithKey' that disallows deletion, --- allowing us to guarantee that the result is also non-empty. -adjustMaxWithKey :: (k -> a -> a) -> NEMap k a -> NEMap k a -adjustMaxWithKey f (NEMap k0 v m) - | M.null m = NEMap k0 (f k0 v) m - | otherwise = insertMapMin k0 v - . M.updateMaxWithKey (\k -> Just . f k) - $ m -{-# INLINE adjustMaxWithKey #-} - --- | /O(1)/. Retrieves the value associated with minimal key of the --- map, and the map stripped of that element. It is constant-time, so has --- better asymptotics than @Data.Map.minView@ for 'Map'. --- --- Note that unlike @Data.Map.minView@ for 'Map', this cannot ever fail, --- so doesn't need to return in a 'Maybe'. However, the result 'Map' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > minView (fromList ((5,"a") :| [(3,"b")])) == ("b", Data.Map.singleton 5 "a") -minView :: NEMap k a -> (a, Map k a) -minView = first snd . deleteFindMin -{-# INLINE minView #-} - --- | /O(1)/. Delete and find the minimal key-value pair. It is --- constant-time, so has better asymptotics that @Data.Map.minView@ for --- 'Map'. --- --- Note that unlike @Data.Map.deleteFindMin@ for 'Map', this cannot ever --- fail, and so is a total function. However, the result 'Map' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > deleteFindMin (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((3,"b"), Data.Map.fromList [(5,"a"), (10,"c")]) -deleteFindMin :: NEMap k a -> ((k, a), Map k a) -deleteFindMin (NEMap k v m) = ((k, v), m) -{-# INLINE deleteFindMin #-} - --- | /O(log n)/. Retrieves the value associated with maximal key of the --- map, and the map stripped of that element. --- --- Note that unlike @Data.Map.maxView@ from 'Map', this cannot ever fail, --- so doesn't need to return in a 'Maybe'. However, the result 'Map' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > maxView (fromList ((5,"a") :| [(3,"b")])) == ("a", Data.Map.singleton 3 "b") -maxView :: NEMap k a -> (a, Map k a) -maxView = first snd . deleteFindMax -{-# INLINE maxView #-} - --- | /O(log n)/. Delete and find the minimal key-value pair. --- --- Note that unlike @Data.Map.deleteFindMax@ for 'Map', this cannot ever --- fail, and so is a total function. However, the result 'Map' is --- potentially empty, since the original map might have contained just --- a single item. --- --- > deleteFindMax (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((10,"c"), Data.Map.fromList [(3,"b"), (5,"a")]) -deleteFindMax :: NEMap k a -> ((k, a), Map k a) -deleteFindMax (NEMap k v m) = maybe ((k, v), M.empty) (second (insertMinMap k v)) - . M.maxViewWithKey - $ m -{-# INLINE deleteFindMax #-} - --- | Special property of non-empty maps: The type of non-empty maps over --- uninhabited keys is itself uninhabited. --- --- This property also exists for /values/ inside a non-empty container --- (like for 'NESet', 'NESeq', and 'NEIntMap'); this can be witnessed using --- the function @'absurd' . 'fold1'@. --- --- @since 0.3.1.0 -absurdNEMap :: NEMap Void a -> b -absurdNEMap = \case {} - --- --------------------------- --- Combining functions --- --------------------------- --- --- Code comes from "Data.Map.Internal" from containers, modified slightly --- to work with NonEmpty --- --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 - -combineEq :: Eq a => NonEmpty (a, b) -> NonEmpty (a, b) -combineEq = \case - x :| [] -> x :| [] - x :| xx@(_:_) -> go x xx - where - go z [] = z :| [] - go z@(kz,_) (x@(kx,xx):xs') - | kx==kz = go (kx,xx) xs' - | otherwise = z NE.<| go x xs' - -combineEqWith - :: Eq a - => (a -> b -> b -> b) - -> NonEmpty (a, b) - -> NonEmpty (a, b) -combineEqWith f = \case - x :| [] -> x :| [] - x :| xx@(_:_) -> go x xx - where - go z [] = z :| [] - go z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in go (kx,yy) xs' +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Data.Map.NonEmpty +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- = Non-Empty Finite Maps (lazy interface) +-- +-- The @'NEMap' k v@ type represents a non-empty finite map (sometimes +-- called a dictionary) from keys of type @k@ to values of type @v@. +-- An 'NEMap' is strict in its keys but lazy in its values. +-- +-- See documentation for 'NEMap' for information on how to convert and +-- manipulate such non-empty maps. +-- +-- This module essentially re-imports the API of "Data.Map.Lazy" and its +-- 'Map' type, along with semantics and asymptotics. In most situations, +-- asymptotics are different only by a constant factor. In some +-- situations, asmyptotics are even better (constant-time instead of +-- log-time). All typeclass constraints are identical to their "Data.Map" +-- counterparts. +-- +-- Because 'NEMap' is implemented using 'Map', all of the caveats of using +-- 'Map' apply (such as the limitation of the maximum size of maps). +-- +-- All functions take non-empty maps as inputs. In situations where their +-- results can be guarunteed to also be non-empty, they also return +-- non-empty maps. In situations where their results could potentially be +-- empty, 'Map' is returned instead. +-- +-- Some variants of functions (like 'alter'', 'alterF'', 'adjustAt', +-- 'adjustMin', 'adjustMax', 'adjustMinWithKey', 'adjustMaxWithKey') are +-- provided in a way restructured to preserve guaruntees of non-empty maps +-- being returned. +-- +-- Some functions (like 'mapEither', 'partition', 'spanAntitone', 'split') +-- have modified return types to account for possible configurations of +-- non-emptiness. +-- +-- This module is intended to be imported qualified, to avoid name clashes with +-- "Prelude" and "Data.Map" functions: +-- +-- > import qualified Data.Map.NonEmpty as NEM +-- +-- At the moment, this package does not provide a variant strict on values +-- for these functions, like /containers/ does. This is a planned future +-- implementation (PR's are appreciated). For now, you can simulate +-- a strict interface by manually forcing values before returning results. +module Data.Map.NonEmpty ( + -- * Non-Empty Map type + NEMap, + + -- ** Conversions between empty and non-empty maps + pattern IsNonEmpty, + pattern IsEmpty, + nonEmptyMap, + toMap, + withNonEmpty, + insertMap, + insertMapWith, + insertMapWithKey, + insertMapMin, + insertMapMax, + unsafeFromMap, + + -- * Construction + singleton, + fromSet, + + -- ** From Unordered Lists + fromList, + fromListWith, + fromListWithKey, + + -- ** From Ascending Lists + fromAscList, + fromAscListWith, + fromAscListWithKey, + fromDistinctAscList, + + -- ** From Descending Lists + fromDescList, + fromDescListWith, + fromDescListWithKey, + fromDistinctDescList, + + -- * Insertion + insert, + insertWith, + insertWithKey, + insertLookupWithKey, + + -- * Deletion\/Update + delete, + adjust, + adjustWithKey, + update, + updateWithKey, + updateLookupWithKey, + alter, + alterF, + alter', + alterF', + + -- * Query + + -- ** Lookup + lookup, + (!?), + (!), + findWithDefault, + member, + notMember, + lookupLT, + lookupGT, + lookupLE, + lookupGE, + absurdNEMap, + + -- ** Size + size, + + -- * Combine + + -- ** Union + union, + unionWith, + unionWithKey, + unions, + unionsWith, + + -- ** Difference + difference, + (\\), + differenceWith, + differenceWithKey, + + -- ** Intersection + intersection, + intersectionWith, + intersectionWithKey, + -- -- ** Unsafe general combining function + -- , mergeWithKey + + -- * Traversal + + -- ** Map + map, + mapWithKey, + traverseWithKey1, + traverseWithKey, + traverseMaybeWithKey1, + traverseMaybeWithKey, + mapAccum, + mapAccumWithKey, + mapAccumRWithKey, + mapKeys, + mapKeysWith, + mapKeysMonotonic, + + -- * Folds + foldr, + foldl, + foldr1, + foldl1, + foldrWithKey, + foldlWithKey, + foldMapWithKey, + + -- ** Strict folds + foldr', + foldr1', + foldl', + foldl1', + foldrWithKey', + foldlWithKey', + + -- * Conversion + elems, + keys, + assocs, + keysSet, + + -- ** Lists + toList, + + -- ** Ordered lists + toAscList, + toDescList, + + -- * Filter + filter, + filterWithKey, + restrictKeys, + withoutKeys, + partition, + partitionWithKey, + takeWhileAntitone, + dropWhileAntitone, + spanAntitone, + mapMaybe, + mapMaybeWithKey, + mapEither, + mapEitherWithKey, + split, + splitLookup, + splitRoot, + + -- * Submap + isSubmapOf, + isSubmapOfBy, + isProperSubmapOf, + isProperSubmapOfBy, + + -- * Indexed + lookupIndex, + findIndex, + elemAt, + updateAt, + adjustAt, + deleteAt, + take, + drop, + splitAt, + + -- * Min\/Max + findMin, + findMax, + deleteMin, + deleteMax, + deleteFindMin, + deleteFindMax, + updateMin, + updateMax, + adjustMin, + adjustMax, + updateMinWithKey, + updateMaxWithKey, + adjustMinWithKey, + adjustMaxWithKey, + minView, + maxView, + + -- * Debugging + valid, +) where + +import Control.Applicative +import Data.Bifunctor +import qualified Data.Foldable as F +import Data.Function +import Data.Functor.Apply +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as M +import Data.Map.NonEmpty.Internal +import Data.Maybe hiding (mapMaybe) +import qualified Data.Maybe as Maybe +import Data.Semigroup.Foldable (Foldable1) +import qualified Data.Semigroup.Foldable as F1 +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.NonEmpty.Internal (NESet (..)) +import Data.These +import Data.Void +import Prelude hiding (Foldable (..), drop, filter, lookup, map, splitAt, take) + +-- | /O(1)/ match, /O(log n)/ usage of contents. The 'IsNonEmpty' and +-- 'IsEmpty' patterns allow you to treat a 'Map' as if it were either +-- a @'IsNonEmpty' n@ (where @n@ is a 'NEMap') or an 'IsEmpty'. +-- +-- For example, you can pattern match on a 'Map': +-- +-- @ +-- myFunc :: 'Map' K X -> Y +-- myFunc ('IsNonEmpty' n) = -- here, the user provided a non-empty map, and @n@ is the 'NEMap' +-- myFunc 'IsEmpty' = -- here, the user provided an empty map. +-- @ +-- +-- Matching on @'IsNonEmpty' n@ means that the original 'Map' was /not/ +-- empty, and you have a verified-non-empty 'NEMap' @n@ to use. +-- +-- Note that patching on this pattern is /O(1)/. However, using the +-- contents requires a /O(log n)/ cost that is deferred until after the +-- pattern is matched on (and is not incurred at all if the contents are +-- never used). +-- +-- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides +-- complete coverage. +-- +-- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert +-- a 'NEMap' back into a 'Map', obscuring its non-emptiness (see 'toMap'). +pattern IsNonEmpty :: NEMap k a -> Map k a +pattern IsNonEmpty n <- (nonEmptyMap -> Just n) + where + IsNonEmpty n = toMap n + +-- | /O(1)/. The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat +-- a 'Map' as if it were either a @'IsNonEmpty' n@ (where @n@ is +-- a 'NEMap') or an 'IsEmpty'. +-- +-- Matching on 'IsEmpty' means that the original 'Map' was empty. +-- +-- A case statement handling both 'IsNonEmpty' and 'IsEmpty' provides +-- complete coverage. +-- +-- This is a bidirectional pattern, so you can use 'IsEmpty' as an +-- expression, and it will be interpreted as 'Data.Map.empty'. +-- +-- See 'IsNonEmpty' for more information. +pattern IsEmpty :: Map k a +pattern IsEmpty <- (M.null -> True) + where + IsEmpty = M.empty + +{-# COMPLETE IsNonEmpty, IsEmpty #-} + +-- | /O(log n)/. Unsafe version of 'nonEmptyMap'. Coerces a 'Map' into an +-- 'NEMap', but is undefined (throws a runtime exception when evaluation is +-- attempted) for an empty 'Map'. +unsafeFromMap :: + Map k a -> + NEMap k a +unsafeFromMap = withNonEmpty e id + where + e = errorWithoutStackTrace "NEMap.unsafeFromMap: empty map" +{-# INLINE unsafeFromMap #-} + +-- | /O(n)/. Build a non-empty map from a non-empty set of keys and +-- a function which for each key computes its value. +-- +-- > fromSet (\k -> replicate k 'a') (Data.Set.NonEmpty.fromList (3 :| [5])) == fromList ((5,"aaaaa") :| [(3,"aaa")]) +fromSet :: + (k -> a) -> + NESet k -> + NEMap k a +fromSet f (NESet k ks) = NEMap k (f k) (M.fromSet f ks) +{-# INLINE fromSet #-} + +-- | /O(log n)/. Lookup the value at a key in the map. +-- +-- The function will return the corresponding value as @('Just' value)@, +-- or 'Nothing' if the key isn't in the map. +-- +-- An example of using @lookup@: +-- +-- > import Prelude hiding (lookup) +-- > import Data.Map.NonEmpty +-- > +-- > employeeDept = fromList (("John","Sales") :| [("Bob","IT")]) +-- > deptCountry = fromList (("IT","USA") :| [("Sales","France")]) +-- > countryCurrency = fromList (("USA", "Dollar") :| [("France", "Euro")]) +-- > +-- > employeeCurrency :: String -> Maybe String +-- > employeeCurrency name = do +-- > dept <- lookup name employeeDept +-- > country <- lookup dept deptCountry +-- > lookup country countryCurrency +-- > +-- > main = do +-- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John")) +-- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete")) +-- +-- The output of this program: +-- +-- > John's currency: Just "Euro" +-- > Pete's currency: Nothing +lookup :: + Ord k => + k -> + NEMap k a -> + Maybe a +lookup k (NEMap k0 v m) = case compare k k0 of + LT -> Nothing + EQ -> Just v + GT -> M.lookup k m +{-# INLINE lookup #-} + +-- | /O(log n)/. Find the value at a key. Returns 'Nothing' when the +-- element can not be found. +-- +-- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 1 == Nothing +-- prop> fromList ((5, 'a') :| [(3, 'b')]) !? 5 == Just 'a' +(!?) :: Ord k => NEMap k a -> k -> Maybe a +(!?) = flip lookup +{-# INLINE (!?) #-} + +-- | /O(log n)/. Find the value at a key. Calls 'error' when the element +-- can not be found. +-- +-- > fromList ((5,'a') :| [(3,'b')]) ! 1 Error: element not in the map +-- > fromList ((5,'a') :| [(3,'b')]) ! 5 == 'a' +(!) :: Ord k => NEMap k a -> k -> a +(!) m k = fromMaybe e $ m !? k + where + e = error "NEMap.!: given key is not an element in the map" +{-# INLINE (!) #-} + +infixl 9 !? +infixl 9 ! + +-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns +-- the value at key @k@ or returns default value @def@ +-- when the key is not in the map. +-- +-- > findWithDefault 'x' 1 (fromList ((5,'a') :| [(3,'b')])) == 'x' +-- > findWithDefault 'x' 5 (fromList ((5,'a') :| [(3,'b')])) == 'a' +findWithDefault :: + Ord k => + a -> + k -> + NEMap k a -> + a +findWithDefault def k (NEMap k0 v m) = case compare k k0 of + LT -> def + EQ -> v + GT -> M.findWithDefault def k m +{-# INLINE findWithDefault #-} + +-- | /O(log n)/. Is the key a member of the map? See also 'notMember'. +-- +-- > member 5 (fromList ((5,'a') :| [(3,'b')])) == True +-- > member 1 (fromList ((5,'a') :| [(3,'b')])) == False +member :: Ord k => k -> NEMap k a -> Bool +member k (NEMap k0 _ m) = case compare k k0 of + LT -> False + EQ -> True + GT -> M.member k m +{-# INLINE member #-} + +-- | /O(log n)/. Is the key not a member of the map? See also 'member'. +-- +-- > notMember 5 (fromList ((5,'a') :| [(3,'b')])) == False +-- > notMember 1 (fromList ((5,'a') :| [(3,'b')])) == True +notMember :: Ord k => k -> NEMap k a -> Bool +notMember k (NEMap k0 _ m) = case compare k k0 of + LT -> True + EQ -> False + GT -> M.notMember k m +{-# INLINE notMember #-} + +-- | /O(log n)/. Find largest key smaller than the given one and return the +-- corresponding (key, value) pair. +-- +-- > lookupLT 3 (fromList ((3,'a') :| [(5,'b')])) == Nothing +-- > lookupLT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') +lookupLT :: Ord k => k -> NEMap k a -> Maybe (k, a) +lookupLT k (NEMap k0 v m) = case compare k k0 of + LT -> Nothing + EQ -> Nothing + GT -> M.lookupLT k m <|> Just (k0, v) +{-# INLINE lookupLT #-} + +-- | /O(log n)/. Find smallest key greater than the given one and return the +-- corresponding (key, value) pair. +-- +-- > lookupGT 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') +-- > lookupGT 5 (fromList ((3,'a') :| [(5,'b')])) == Nothing +lookupGT :: Ord k => k -> NEMap k a -> Maybe (k, a) +lookupGT k (NEMap k0 v m) = case compare k k0 of + LT -> Just (k0, v) + EQ -> M.lookupMin m + GT -> M.lookupGT k m +{-# INLINE lookupGT #-} + +-- | /O(log n)/. Find largest key smaller or equal to the given one and return +-- the corresponding (key, value) pair. +-- +-- > lookupLE 2 (fromList ((3,'a') :| [(5,'b')])) == Nothing +-- > lookupLE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') +-- > lookupLE 5 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') +lookupLE :: Ord k => k -> NEMap k a -> Maybe (k, a) +lookupLE k (NEMap k0 v m) = case compare k k0 of + LT -> Nothing + EQ -> Just (k0, v) + GT -> M.lookupLE k m <|> Just (k0, v) +{-# INLINE lookupLE #-} + +-- | /O(log n)/. Find smallest key greater or equal to the given one and return +-- the corresponding (key, value) pair. +-- +-- > lookupGE 3 (fromList ((3,'a') :| [(5,'b')])) == Just (3, 'a') +-- > lookupGE 4 (fromList ((3,'a') :| [(5,'b')])) == Just (5, 'b') +-- > lookupGE 6 (fromList ((3,'a') :| [(5,'b')])) == Nothing +lookupGE :: Ord k => k -> NEMap k a -> Maybe (k, a) +lookupGE k (NEMap k0 v m) = case compare k k0 of + LT -> Just (k0, v) + EQ -> Just (k0, v) + GT -> M.lookupGE k m +{-# INLINE lookupGE #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function. +-- +-- > unionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "aA"), (7, "C")]) +unionWith :: + Ord k => + (a -> a -> a) -> + NEMap k a -> + NEMap k a -> + NEMap k a +unionWith f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of + LT -> NEMap k1 v1 . M.unionWith f m1 . toMap $ n2 + EQ -> NEMap k1 (f v1 v2) . M.unionWith f m1 $ m2 + GT -> NEMap k2 v2 . M.unionWith f (toMap n1) $ m2 +{-# INLINE unionWith #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. +-- Union with a combining function, given the matching key. +-- +-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value +-- > unionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "5:a|A"), (7, "C")]) +unionWithKey :: + Ord k => + (k -> a -> a -> a) -> + NEMap k a -> + NEMap k a -> + NEMap k a +unionWithKey f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of + LT -> NEMap k1 v1 . M.unionWithKey f m1 . toMap $ n2 + EQ -> NEMap k1 (f k1 v1 v2) . M.unionWithKey f m1 $ m2 + GT -> NEMap k2 v2 . M.unionWithKey f (toMap n1) $ m2 +{-# INLINE unionWithKey #-} + +-- | The union of a non-empty list of maps, with a combining operation: +-- (@'unionsWith' f == 'Data.Foldable.foldl1' ('unionWith' f)@). +-- +-- > unionsWith (++) (fromList ((5, "a") :| [(3, "b")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "A3") :| [(3, "B3")])]) +-- > == fromList ((3, "bB3") :| [(5, "aAA3"), (7, "C")]) +unionsWith :: + (Foldable1 f, Ord k) => + (a -> a -> a) -> + f (NEMap k a) -> + NEMap k a +unionsWith f (F1.toNonEmpty -> (m :| ms)) = F.foldl' (unionWith f) m ms +{-# INLINE unionsWith #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps. +-- Return elements of the first map not existing in the second map. +-- +-- Returns a potentially empty map ('Map'), in case the first map is +-- a subset of the second map. +-- +-- > difference (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 3 "b" +difference :: + Ord k => + NEMap k a -> + NEMap k b -> + Map k a +difference n1@(NEMap k1 v1 m1) n2@(NEMap k2 _ m2) = case compare k1 k2 of + -- k1 is not in n2, so cannot be deleted + LT -> insertMinMap k1 v1 $ m1 `M.difference` toMap n2 + -- k2 deletes k1, and only k1 + EQ -> m1 `M.difference` m2 + -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. + GT -> toMap n1 `M.difference` m2 +{-# INLINE difference #-} + +-- | Same as 'difference'. +(\\) :: + Ord k => + NEMap k a -> + NEMap k b -> + Map k a +(\\) = difference +{-# INLINE (\\) #-} + +-- | /O(n+m)/. Difference with a combining function. +-- When two equal keys are +-- encountered, the combining function is applied to the values of these keys. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- Returns a potentially empty map ('Map'), in case the first map is +-- a subset of the second map and the function returns 'Nothing' for every +-- pair. +-- +-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing +-- > differenceWith f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (7, "C")])) +-- > == Data.Map.singleton 3 "b:B" +differenceWith :: + Ord k => + (a -> b -> Maybe a) -> + NEMap k a -> + NEMap k b -> + Map k a +differenceWith f = differenceWithKey (const f) +{-# INLINE differenceWith #-} + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- Returns a potentially empty map ('Map'), in case the first map is +-- a subset of the second map and the function returns 'Nothing' for every +-- pair. +-- +-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing +-- > differenceWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(3, "B"), (10, "C")])) +-- > == Data.Map.singleton 3 "3:b|B" +differenceWithKey :: + Ord k => + (k -> a -> b -> Maybe a) -> + NEMap k a -> + NEMap k b -> + Map k a +differenceWithKey f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of + -- k1 is not in n2, so cannot be deleted + LT -> insertMinMap k1 v1 $ M.differenceWithKey f m1 (toMap n2) + -- k2 deletes k1, and only k1 + EQ -> maybe id (insertMinMap k1) (f k1 v1 v2) (M.differenceWithKey f m1 m2) + -- k2 is not in n1, so cannot delete anything, so we can just difference n1 // m2. + GT -> M.differenceWithKey f (toMap n1) m2 +{-# INLINE differenceWithKey #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps. +-- Return data in the first map for the keys existing in both maps. +-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). +-- +-- Returns a potentially empty map ('Map'), in case the two maps share no +-- keys in common. +-- +-- > intersection (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 5 "a" +intersection :: + Ord k => + NEMap k a -> + NEMap k b -> + Map k a +intersection n1@(NEMap k1 v1 m1) n2@(NEMap k2 _ m2) = case compare k1 k2 of + -- k1 is not in n2 + LT -> m1 `M.intersection` toMap n2 + -- k1 and k2 are a part of the result + EQ -> insertMinMap k1 v1 $ m1 `M.intersection` m2 + -- k2 is not in n1 + GT -> toMap n1 `M.intersection` m2 +{-# INLINE intersection #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- +-- Returns a potentially empty map ('Map'), in case the two maps share no +-- keys in common. +-- +-- > intersectionWith (++) (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 5 "aA" +intersectionWith :: + Ord k => + (a -> b -> c) -> + NEMap k a -> + NEMap k b -> + Map k c +intersectionWith f = intersectionWithKey (const f) +{-# INLINE intersectionWith #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- +-- Returns a potentially empty map ('Map'), in case the two maps share no +-- keys in common. +-- +-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar +-- > intersectionWithKey f (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == Data.Map.singleton 5 "5:a|A" +intersectionWithKey :: + Ord k => + (k -> a -> b -> c) -> + NEMap k a -> + NEMap k b -> + Map k c +intersectionWithKey f n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of + -- k1 is not in n2 + LT -> M.intersectionWithKey f m1 (toMap n2) + -- k1 and k2 are a part of the result + EQ -> insertMinMap k1 (f k1 v1 v2) $ M.intersectionWithKey f m1 m2 + -- k2 is not in n1 + GT -> M.intersectionWithKey f (toMap n1) m2 +{-# INLINE intersectionWithKey #-} + +-- | /O(n)/. A strict version of 'foldr1'. Each application of the operator +-- is evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr1' :: (a -> a -> a) -> NEMap k a -> a +foldr1' f (NEMap _ v m) = case M.maxView m of + Nothing -> v + Just (y, m') -> let !z = M.foldr' f y m' in v `f` z +{-# INLINE foldr1' #-} + +-- | /O(n)/. A strict version of 'foldl1'. Each application of the operator +-- is evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl1' :: (a -> a -> a) -> NEMap k a -> a +foldl1' f (NEMap _ v m) = M.foldl' f v m +{-# INLINE foldl1' #-} + +-- | /O(n)/. Fold the keys and values in the map using the given right-associative +-- binary operator, such that +-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +-- +-- For example, +-- +-- > keysList map = foldrWithKey (\k x ks -> k:ks) [] map +foldrWithKey :: (k -> a -> b -> b) -> b -> NEMap k a -> b +foldrWithKey f z (NEMap k v m) = f k v . M.foldrWithKey f z $ m +{-# INLINE foldrWithKey #-} + +-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldrWithKey' :: (k -> a -> b -> b) -> b -> NEMap k a -> b +foldrWithKey' f z (NEMap k v m) = f k v y + where + !y = M.foldrWithKey f z m +{-# INLINE foldrWithKey' #-} + +-- | /O(n)/. Fold the keys and values in the map using the given left-associative +-- binary operator, such that +-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. +-- +-- For example, +-- +-- > keysList = reverse . foldlWithKey (\ks k x -> k:ks) [] +foldlWithKey :: (a -> k -> b -> a) -> a -> NEMap k b -> a +foldlWithKey f z (NEMap k v m) = M.foldlWithKey f (f z k v) m +{-# INLINE foldlWithKey #-} + +-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldlWithKey' :: (a -> k -> b -> a) -> a -> NEMap k b -> a +foldlWithKey' f z (NEMap k v m) = M.foldlWithKey' f x m + where + !x = f z k v +{-# INLINE foldlWithKey' #-} + +-- | /O(n)/. Return all keys of the map in ascending order. +-- +-- > keys (fromList ((5,"a") :| [(3,"b")])) == (3 :| [5]) +keys :: NEMap k a -> NonEmpty k +keys (NEMap k _ m) = k :| M.keys m +{-# INLINE keys #-} + +-- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map +-- in ascending key order. +-- +-- > assocs (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) +assocs :: NEMap k a -> NonEmpty (k, a) +assocs = toList +{-# INLINE assocs #-} + +-- | /O(n)/. The non-empty set of all keys of the map. +-- +-- > keysSet (fromList ((5,"a") :| [(3,"b")])) == Data.Set.NonEmpty.fromList (3 :| [5]) +keysSet :: NEMap k a -> NESet k +keysSet (NEMap k _ m) = NESet k (M.keysSet m) +{-# INLINE keysSet #-} + +-- | /O(n)/. Map a function over all values in the map. +-- +-- > let f key x = (show key) ++ ":" ++ x +-- > mapWithKey f (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "3:b") :| [(5, "5:a")]) +mapWithKey :: (k -> a -> b) -> NEMap k a -> NEMap k b +mapWithKey f (NEMap k v m) = NEMap k (f k v) (M.mapWithKey f m) +{-# NOINLINE [1] mapWithKey #-} + +{-# RULES +"mapWithKey/mapWithKey" forall f g xs. + mapWithKey f (mapWithKey g xs) = + mapWithKey (\k a -> f k (g k a)) xs +"mapWithKey/map" forall f g xs. + mapWithKey f (map g xs) = + mapWithKey (\k a -> f k (g a)) xs +"map/mapWithKey" forall f g xs. + map f (mapWithKey g xs) = + mapWithKey (\k a -> f (g k a)) xs + #-} + +-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are +-- in ascending order. +-- +-- > toAscList (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) +toAscList :: NEMap k a -> NonEmpty (k, a) +toAscList = toList +{-# INLINE toAscList #-} + +-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys +-- are in descending order. +-- +-- > toDescList (fromList ((5,"a") :| [(3,"b")])) == ((5,"a") :| [(3,"b")]) +toDescList :: NEMap k a -> NonEmpty (k, a) +toDescList (NEMap k0 v0 m) = M.foldlWithKey' go ((k0, v0) :| []) m + where + go xs k v = (k, v) NE.<| xs +{-# INLINE toDescList #-} + +-- | /O(log n)/. Convert a 'Map' into an 'NEMap' by adding a key-value +-- pair. Because of this, we know that the map must have at least one +-- element, and so therefore cannot be empty. If key is already present, +-- will overwrite the original value. +-- +-- See 'insertMapMin' for a version that is constant-time if the new key is +-- /strictly smaller than/ all keys in the original map. +-- +-- > insertMap 4 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) +-- > insertMap 4 "c" Data.Map.empty == singleton 4 "c" +insertMap :: Ord k => k -> a -> Map k a -> NEMap k a +insertMap k v = withNonEmpty (singleton k v) (insert k v) +{-# INLINE insertMap #-} + +-- | /O(log n)/. Convert a 'Map' into an 'NEMap' by adding a key-value +-- pair. Because of this, we know that the map must have at least one +-- element, and so therefore cannot be empty. Uses a combining function +-- with the new value as the first argument if the key is already present. +-- +-- > insertMapWith (++) 4 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(4,"c"), (5,"a")]) +-- > insertMapWith (++) 5 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"ca")]) +insertMapWith :: + Ord k => + (a -> a -> a) -> + k -> + a -> + Map k a -> + NEMap k a +insertMapWith f k v = withNonEmpty (singleton k v) (insertWith f k v) +{-# INLINE insertMapWith #-} + +-- | /O(log n)/. Convert a 'Map' into an 'NEMap' by adding a key-value +-- pair. Because of this, we know that the map must have at least one +-- element, and so therefore cannot be empty. Uses a combining function +-- with the key and new value as the first and second arguments if the key +-- is already present. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "5:xxx|a")]) +-- > insertWithKey f 7 "xxx" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) +-- > insertWithKey f 5 "xxx" Data.Map.empty == singleton 5 "xxx" +insertMapWithKey :: + Ord k => + (k -> a -> a -> a) -> + k -> + a -> + Map k a -> + NEMap k a +insertMapWithKey f k v = withNonEmpty (singleton k v) (insertWithKey f k v) +{-# INLINE insertMapWithKey #-} + +-- | /O(1)/ Convert a 'Map' into an 'NEMap' by adding a key-value pair +-- where the key is /strictly less than/ all keys in the input map. The +-- keys in the original map must all be /strictly greater than/ the new +-- key. /The precondition is not checked./ +-- +-- > insertMapMin 2 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((2,"c") :| [(3,"b"), (5,"a")]) +-- > valid (insertMapMin 2 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == True +-- > valid (insertMapMin 7 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False +-- > valid (insertMapMin 3 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False +insertMapMin :: + k -> + a -> + Map k a -> + NEMap k a +insertMapMin = NEMap +{-# INLINE insertMapMin #-} + +-- | /O(log n)/ Convert a 'Map' into an 'NEMap' by adding a key-value pair +-- where the key is /strictly greater than/ all keys in the input map. The +-- keys in the original map must all be /strictly less than/ the new +-- key. /The precondition is not checked./ +-- +-- While this has the same asymptotics as 'insertMap', it saves a constant +-- factor for key comparison (so may be helpful if comparison is expensive) +-- and also does not require an 'Ord' instance for the key type. +-- +-- > insertMap 7 "c" (Data.Map.fromList [(5,"a"), (3,"b")]) == fromList ((3,"b") :| [(5,"a"), (7,"c")]) +-- > valid (insertMap 7 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == True +-- > valid (insertMap 2 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False +-- > valid (insertMap 5 "c" (Data.Map.fromList [(5,"a"), (3,"b")])) == False +insertMapMax :: + k -> + a -> + Map k a -> + NEMap k a +insertMapMax k v = withNonEmpty (singleton k v) go + where + go (NEMap k0 v0 m0) = NEMap k0 v0 . insertMaxMap k v $ m0 +{-# INLINE insertMapMax #-} + +-- | /O(log n)/. Insert a new key and value in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value. 'insert' is equivalent to +-- @'insertWith' 'const'@. +-- +-- See 'insertMap' for a version where the first argument is a 'Map'. +-- +-- > insert 5 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'x')]) +-- > insert 7 'x' (fromList ((5,'a') :| [(3,'b')])) == fromList ((3, 'b') :| [(5, 'a'), (7, 'x')]) +insert :: + Ord k => + k -> + a -> + NEMap k a -> + NEMap k a +insert k v n@(NEMap k0 v0 m) = case compare k k0 of + LT -> NEMap k v . toMap $ n + EQ -> NEMap k v m + GT -> NEMap k0 v0 . M.insert k v $ m +{-# INLINE insert #-} + +-- | /O(log n)/. Insert with a function, combining key, new value and old +-- value. @'insertWithKey' f key value mp@ will insert the pair (key, +-- value) into @mp@ if key does not exist in the map. If the key does +-- exist, the function will insert the pair @(key,f key new_value +-- old_value)@. Note that the key passed to f is the same key passed to +-- 'insertWithKey'. +-- +-- See 'insertMapWithKey' for a version where the first argument is a 'Map'. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:xxx|a")]) +-- > insertWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) +insertWithKey :: + Ord k => + (k -> a -> a -> a) -> + k -> + a -> + NEMap k a -> + NEMap k a +insertWithKey f k v n@(NEMap k0 v0 m) = case compare k k0 of + LT -> NEMap k v . toMap $ n + EQ -> NEMap k (f k v v0) m + GT -> NEMap k0 v0 $ M.insertWithKey f k v m +{-# INLINE insertWithKey #-} + +-- | /O(log n)/. Combines insert operation with old value retrieval. The +-- expression (@'insertLookupWithKey' f k x map@) is a pair where the first +-- element is equal to (@'lookup' k map@) and the second element equal to +-- (@'insertWithKey' f k x map@). +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertLookupWithKey f 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "5:xxx|a")])) +-- > insertLookupWithKey f 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "xxx")])) +-- +-- This is how to define @insertLookup@ using @insertLookupWithKey@: +-- +-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t +-- > insertLookup 5 "x" (fromList ((5,"a") :| [(3,"b")])) == (Just "a", fromList ((3, "b") :| [(5, "x")])) +-- > insertLookup 7 "x" (fromList ((5,"a") :| [(3,"b")])) == (Nothing, fromList ((3, "b") :| [(5, "a"), (7, "x")])) +insertLookupWithKey :: + Ord k => + (k -> a -> a -> a) -> + k -> + a -> + NEMap k a -> + (Maybe a, NEMap k a) +insertLookupWithKey f k v n@(NEMap k0 v0 m) = case compare k k0 of + LT -> (Nothing, NEMap k v . toMap $ n) + EQ -> (Just v, NEMap k (f k v v0) m) + GT -> NEMap k0 v0 <$> M.insertLookupWithKey f k v m +{-# INLINE insertLookupWithKey #-} + +-- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs +-- with a combining function. See also 'fromAscListWith'. +-- +-- > fromListWith (++) ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "ab") :| [(5, "aba")]) +fromListWith :: + Ord k => + (a -> a -> a) -> + NonEmpty (k, a) -> + NEMap k a +fromListWith f = fromListWithKey (const f) +{-# INLINE fromListWith #-} + +-- | /O(n*log n)/. Build a map from a non-empty list of key\/value pairs +-- with a combining function. See also 'fromAscListWithKey'. +-- +-- > let f k a1 a2 = (show k) ++ a1 ++ a2 +-- > fromListWithKey f ((5,"a") :| [(5,"b"), (3,"b"), (3,"a"), (5,"a")]) == fromList ((3, "3ab") :| [(5, "5a5ba")]) +fromListWithKey :: + Ord k => + (k -> a -> a -> a) -> + NonEmpty (k, a) -> + NEMap k a +fromListWithKey f ((k0, v0) :| xs) = F.foldl' go (singleton k0 v0) xs + where + go m (k, v) = insertWithKey f k v m + {-# INLINE go #-} +{-# INLINE fromListWithKey #-} + +-- | /O(n)/. Build a map from an ascending non-empty list in linear time. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > fromAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) +-- > fromAscList ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "b")]) +-- > valid (fromAscList ((3,"b") :| [(5,"a"), (5,"b")])) == True +-- > valid (fromAscList ((5,"a") :| [(3,"b"), (5,"b")])) == False +fromAscList :: + Eq k => + NonEmpty (k, a) -> + NEMap k a +fromAscList = fromDistinctAscList . combineEq +{-# INLINE fromAscList #-} + +-- | /O(n)/. Build a map from an ascending non-empty list in linear time +-- with a combining function for equal keys. /The precondition (input list +-- is ascending) is not checked./ +-- +-- > fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b")]) == fromList ((3, "b") :| [(5, "ba")]) +-- > valid (fromAscListWith (++) ((3,"b") :| [(5,"a"), (5,"b"))]) == True +-- > valid (fromAscListWith (++) ((5,"a") :| [(3,"b"), (5,"b"))]) == False +fromAscListWith :: + Eq k => + (a -> a -> a) -> + NonEmpty (k, a) -> + NEMap k a +fromAscListWith f = fromAscListWithKey (const f) +{-# INLINE fromAscListWith #-} + +-- | /O(n)/. Build a map from an ascending non-empty list in linear time +-- with a combining function for equal keys. /The precondition (input list +-- is ascending) is not checked./ +-- +-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 +-- > fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")]) == fromList ((3, "b") :| [(5, "5:b5:ba")]) +-- > valid (fromAscListWithKey f ((3,"b") :| [(5,"a"), (5,"b"), (5,"b")])) == True +-- > valid (fromAscListWithKey f ((5,"a") :| [(3,"b"), (5,"b"), (5,"b")])) == False +fromAscListWithKey :: + Eq k => + (k -> a -> a -> a) -> + NonEmpty (k, a) -> + NEMap k a +fromAscListWithKey f = fromDistinctAscList . combineEqWith f +{-# INLINE fromAscListWithKey #-} + +-- | /O(n)/. Build a map from an ascending non-empty list of distinct +-- elements in linear time. /The precondition is not checked./ +-- +-- > fromDistinctAscList ((3,"b") :| [(5,"a")]) == fromList ((3, "b") :| [(5, "a")]) +-- > valid (fromDistinctAscList ((3,"b") :| [(5,"a")])) == True +-- > valid (fromDistinctAscList ((3,"b") :| [(5,"a"), (5,"b")])) == False +fromDistinctAscList :: NonEmpty (k, a) -> NEMap k a +fromDistinctAscList ((k, v) :| xs) = + insertMapMin k v + . M.fromDistinctAscList + $ xs +{-# INLINE fromDistinctAscList #-} + +-- | /O(n)/. Build a map from a descending non-empty list in linear time. +-- /The precondition (input list is descending) is not checked./ +-- +-- > fromDescList ((5,"a") :| [(3,"b")]) == fromList ((3, "b") :| [(5, "a")]) +-- > fromDescList ((5,"a") :| [(5,"b"), (3,"b")]) == fromList ((3, "b") :| [(5, "b")]) +-- > valid (fromDescList ((5,"a") :| [(5,"b"), (3,"b")])) == True +-- > valid (fromDescList ((5,"a") :| [(3,"b"), (5,"b")])) == False +fromDescList :: + Eq k => + NonEmpty (k, a) -> + NEMap k a +fromDescList = fromDistinctDescList . combineEq +{-# INLINE fromDescList #-} + +-- | /O(n)/. Build a map from a descending non-empty list in linear time +-- with a combining function for equal keys. /The precondition (input list +-- is descending) is not checked./ +-- +-- > fromDescListWith (++) ((5,"a") :| [(5,"b"), (3,"b")]) == fromList ((3, "b") :| [(5, "ba")]) +-- > valid (fromDescListWith (++) ((5,"a") :| [(5,"b"), (3,"b")])) == True +-- > valid (fromDescListWith (++) ((5,"a") :| [(3,"b"), (5,"b")])) == False +fromDescListWith :: + Eq k => + (a -> a -> a) -> + NonEmpty (k, a) -> + NEMap k a +fromDescListWith f = fromDescListWithKey (const f) +{-# INLINE fromDescListWith #-} + +-- | /O(n)/. Build a map from a descending non-empty list in linear time +-- with a combining function for equal keys. /The precondition (input list +-- is descending) is not checked./ +-- +-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 +-- > fromDescListWithKey f ((5,"a") :| [(5,"b"), (5,"b"), (3,"b")]) == fromList ((3, "b") :| [(5, "5:b5:ba")]) +-- > valid (fromDescListWithKey f ((5,"a") :| [(5,"b"), (5,"b"), (3,"b")])) == True +-- > valid (fromDescListWithKey f ((5,"a") :| [(3,"b"), (5,"b"), (5,"b")])) == False +fromDescListWithKey :: + Eq k => + (k -> a -> a -> a) -> + NonEmpty (k, a) -> + NEMap k a +fromDescListWithKey f = fromDistinctDescList . combineEqWith f +{-# INLINE fromDescListWithKey #-} + +-- | /O(n)/. Build a map from a descending list of distinct elements in linear time. +-- /The precondition is not checked./ +-- +-- > fromDistinctDescList ((5,"a") :| [(3,"b")]) == fromList ((3, "b") :| [(5, "a")]) +-- > valid (fromDistinctDescList ((5,"a") :| [(3,"b")])) == True +-- > valid (fromDistinctDescList ((5,"a") :| [(5,"b"), (3,"b")])) == False +-- +-- @since 0.5.8 +fromDistinctDescList :: NonEmpty (k, a) -> NEMap k a +fromDistinctDescList ((k, v) :| xs) = + insertMapMax k v + . M.fromDistinctDescList + $ xs +{-# INLINE fromDistinctDescList #-} + +-- | /O(log n)/. Delete a key and its value from the non-empty map. +-- A potentially empty map ('Map') is returned, since this might delete the +-- last item in the 'NEMap'. When the key is not a member of the map, is +-- equivalent to 'toMap'. +-- +-- > delete 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" +-- > delete 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.Singleton [(3, "b"), (5, "a")] +delete :: Ord k => k -> NEMap k a -> Map k a +delete k n@(NEMap k0 v m) = case compare k k0 of + LT -> toMap n + EQ -> m + GT -> insertMinMap k0 v . M.delete k $ m +{-# INLINE delete #-} + +-- | /O(log n)/. Update a value at a specific key with the result of the +-- provided function. When the key is not a member of the map, the original +-- map is returned. +-- +-- > adjust ("new " ++) 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "new a")]) +-- > adjust ("new " ++) 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) +adjust :: + Ord k => + (a -> a) -> + k -> + NEMap k a -> + NEMap k a +adjust f = adjustWithKey (const f) +{-# INLINE adjust #-} + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > let f key x = (show key) ++ ":new " ++ x +-- > adjustWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "5:new a")]) +-- > adjustWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a")]) +adjustWithKey :: + Ord k => + (k -> a -> a) -> + k -> + NEMap k a -> + NEMap k a +adjustWithKey f k n@(NEMap k0 v m) = case compare k k0 of + LT -> n + EQ -> NEMap k0 (f k0 v) m + GT -> NEMap k0 v . M.adjustWithKey f k $ m +{-# INLINE adjustWithKey #-} + +-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- Returns a potentially empty map ('Map'), because we can't know ahead of +-- time if the function returns 'Nothing' and deletes the final item in the +-- 'NEMap'. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > update f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "new a")] +-- > update f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a")] +-- > update f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +update :: + Ord k => + (a -> Maybe a) -> + k -> + NEMap k a -> + Map k a +update f = updateWithKey (const f) +{-# INLINE update #-} + +-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the +-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', +-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound +-- to the new value @y@. +-- +-- Returns a potentially empty map ('Map'), because we can't know ahead of +-- time if the function returns 'Nothing' and deletes the final item in the +-- 'NEMap'. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "5:new a")] +-- > updateWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a")] +-- > updateWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +updateWithKey :: + Ord k => + (k -> a -> Maybe a) -> + k -> + NEMap k a -> + Map k a +updateWithKey f k n@(NEMap k0 v m) = case compare k k0 of + LT -> toMap n + EQ -> maybe m (flip (insertMinMap k0) m) . f k0 $ v + GT -> insertMinMap k0 v . M.updateWithKey f k $ m +{-# INLINE updateWithKey #-} + +-- | /O(log n)/. Lookup and update. See also 'updateWithKey'. +-- The function returns changed value, if it is updated. +-- Returns the original key value if the map entry is deleted. +-- +-- Returns a potentially empty map ('Map') in the case that we delete the +-- final key of a singleton map. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateLookupWithKey f 5 (fromList ((5,"a") :| [(3,"b")])) == (Just "5:new a", Data.Map.fromList ((3, "b") :| [(5, "5:new a")])) +-- > updateLookupWithKey f 7 (fromList ((5,"a") :| [(3,"b")])) == (Nothing, Data.Map.fromList ((3, "b") :| [(5, "a")])) +-- > updateLookupWithKey f 3 (fromList ((5,"a") :| [(3,"b")])) == (Just "b", Data.Map.singleton 5 "a") +updateLookupWithKey :: + Ord k => + (k -> a -> Maybe a) -> + k -> + NEMap k a -> + (Maybe a, Map k a) +updateLookupWithKey f k n@(NEMap k0 v m) = case compare k k0 of + LT -> (Nothing, toMap n) + EQ -> + let u = f k0 v + in (u <|> Just v, maybe m (flip (insertMinMap k0) m) u) + GT -> fmap (insertMinMap k0 v) . M.updateLookupWithKey f k $ m +{-# INLINE updateLookupWithKey #-} + +-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at +-- @k@, or absence thereof. 'alter' can be used to insert, delete, or +-- update a value in a 'Map'. In short : @Data.Map.lookup k ('alter' +-- f k m) = f ('lookup' k m)@. +-- +-- Returns a potentially empty map ('Map'), because we can't know ahead of +-- time if the function returns 'Nothing' and deletes the final item in the +-- 'NEMap'. +-- +-- See 'alterF'' for a version that disallows deletion, and so therefore +-- can return 'NEMap'. +-- +-- > let f _ = Nothing +-- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a")] +-- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" +-- > +-- > let f _ = Just "c" +-- > alter f 7 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "a"), (7, "c")] +-- > alter f 5 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "c")] +alter :: + Ord k => + (Maybe a -> Maybe a) -> + k -> + NEMap k a -> + Map k a +alter f k n@(NEMap k0 v m) = case compare k k0 of + LT -> maybe id (insertMinMap k) (f Nothing) (toMap n) + EQ -> maybe id (insertMinMap k0) (f (Just v)) m + GT -> insertMinMap k0 v . M.alter f k $ m +{-# INLINE alter #-} + +-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ +-- at @k@, or absence thereof. 'alterF' can be used to inspect, insert, +-- delete, or update a value in a 'Map'. In short: @Data.Map.lookup +-- k \<$\> 'alterF' f k m = f ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Int -> NEMap Int String -> IO (Map Int String) +-- interactiveAlter k m = alterF f k m where +-- f Nothing = do +-- putStrLn $ show k ++ +-- " was not found in the map. Would you like to add it?" +-- getUserResponse1 :: IO (Maybe String) +-- f (Just old) = do +-- putStrLn $ "The key is currently bound to " ++ show old ++ +-- ". Would you like to change or delete it?" +-- getUserResponse2 :: IO (Maybe String) +-- @ +-- +-- Like @Data.Map.alterF@ for 'Map', 'alterF' can be considered +-- to be a unifying generalization of 'lookup' and 'delete'; however, as +-- a constrast, it cannot be used to implement 'insert', because it must +-- return a 'Map' instead of an 'NEMap' (because the function might delete +-- the final item in the 'NEMap'). When used with trivial functors like +-- 'Identity' and 'Const', it is often slightly slower than +-- specialized 'lookup' and 'delete'. However, when the functor is +-- non-trivial and key comparison is not particularly cheap, it is the +-- fastest way. +-- +-- See 'alterF'' for a version that disallows deletion, and so therefore +-- can return 'NEMap' and be used to implement 'insert' +-- +-- Note on rewrite rules: +-- +-- This module includes GHC rewrite rules to optimize 'alterF' for +-- the 'Const' and 'Identity' functors. In general, these rules +-- improve performance. The sole exception is that when using +-- 'Identity', deleting a key that is already absent takes longer +-- than it would without the rules. If you expect this to occur +-- a very large fraction of the time, you might consider using a +-- private copy of the 'Identity' type. +-- +-- Note: Unlike @Data.Map.alterF@ for 'Map', 'alterF' is /not/ a flipped +-- version of the 'Control.Lens.At.at' combinator from "Control.Lens.At". +-- However, it match the shape expected from most functions expecting +-- lenses, getters, and setters, so can be thought of as a "psuedo-lens", +-- with virtually the same practical applications as a legitimate lens. +alterF :: + (Ord k, Functor f) => + (Maybe a -> f (Maybe a)) -> + k -> + NEMap k a -> + f (Map k a) +alterF f k n@(NEMap k0 v m) = case compare k k0 of + LT -> flip (maybe id (insertMinMap k)) (toMap n) <$> f Nothing + EQ -> flip (maybe id (insertMinMap k0)) m <$> f (Just v) + GT -> insertMinMap k0 v <$> M.alterF f k m +{-# INLINEABLE [2] alterF #-} + +-- if f ~ Const b, it's a lookup +{-# RULES +"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)). + alterF f k = + Const . getConst . f . lookup k + #-} + +-- if f ~ Identity, it's an 'alter' +{-# RULES +"alterF/Identity" forall k (f :: Maybe a -> Identity (Maybe a)). + alterF f k = + Identity . alter (runIdentity . f) k + #-} + +-- | /O(log n)/. Variant of 'alter' that disallows deletion. Allows us to +-- guarantee that the result is also a non-empty Map. +alter' :: + Ord k => + (Maybe a -> a) -> + k -> + NEMap k a -> + NEMap k a +alter' f k n@(NEMap k0 v m) = case compare k k0 of + LT -> NEMap k (f Nothing) . toMap $ n + EQ -> NEMap k0 (f (Just v)) m + GT -> NEMap k0 v . M.alter (Just . f) k $ m +{-# INLINE alter' #-} + +-- | /O(log n)/. Variant of 'alterF' that disallows deletion. Allows us to +-- guarantee that the result is also a non-empty Map. +-- +-- Like @Data.Map.alterF@ for 'Map', can be used to generalize and unify +-- 'lookup' and 'insert'. However, because it disallows deletion, it +-- cannot be used to implement 'delete'. +-- +-- See 'alterF' for usage information and caveats. +-- +-- Note: Neither 'alterF' nor 'alterF'' can be considered flipped versions +-- of the 'Control.Lens.At.at' combinator from "Control.Lens.At". However, +-- this can match the shape expected from most functions expecting lenses, +-- getters, and setters, so can be thought of as a "psuedo-lens", with +-- virtually the same practical applications as a legitimate lens. +-- +-- __WARNING__: The rewrite rule for 'Identity' exposes an inconsistency in +-- undefined behavior for "Data.Map". @Data.Map.alterF@ will actually +-- /maintain/ the original key in the map when used with 'Identity'; +-- however, @Data.Map.insertWith@ will /replace/ the orginal key in the +-- map. The rewrite rule for 'alterF'' has chosen to be faithful to +-- @Data.Map.insertWith@, and /not/ @Data.Map.alterF@, for the sake of +-- a cleaner implementation. +alterF' :: + (Ord k, Functor f) => + (Maybe a -> f a) -> + k -> + NEMap k a -> + f (NEMap k a) +alterF' f k n@(NEMap k0 v m) = case compare k k0 of + LT -> flip (NEMap k) (toMap n) <$> f Nothing + EQ -> flip (NEMap k0) m <$> f (Just v) + GT -> NEMap k0 v <$> M.alterF (fmap Just . f) k m +{-# INLINEABLE [2] alterF' #-} + +-- if f ~ Const b, it's a lookup +{-# RULES +"alterF'/Const" forall k (f :: Maybe a -> Const b a). + alterF' f k = + Const . getConst . f . lookup k + #-} + +-- if f ~ Identity, it's an insertWith +{-# RULES +"alterF'/Identity" forall k (f :: Maybe a -> Identity a). + alterF' f k = + Identity . insertWith (\_ -> runIdentity . f . Just) k (runIdentity (f Nothing)) + #-} + +-- | /O(n)/. Traverse keys\/values and collect the 'Just' results. +-- +-- Returns a potentially empty map ('Map'), our function might return +-- 'Nothing' on every item in the 'NEMap'. +-- +-- /Use 'traverseMaybeWithKey1'/ whenever possible (if your 'Applicative' +-- also has 'Apply' instance). This version is provided only for types +-- that do not have 'Apply' instance, since 'Apply' is not at the moment +-- (and might not ever be) an official superclass of 'Applicative'. +traverseMaybeWithKey :: + Applicative t => + (k -> a -> t (Maybe b)) -> + NEMap k a -> + t (Map k b) +traverseMaybeWithKey f (NEMap k0 v m0) = + combine <$> f k0 v <*> M.traverseMaybeWithKey f m0 + where + combine Nothing = id + combine (Just v') = insertMinMap k0 v' +{-# INLINE traverseMaybeWithKey #-} + +-- | /O(n)/. Traverse keys\/values and collect the 'Just' results. +-- +-- Returns a potentially empty map ('Map'), our function might return +-- 'Nothing' on every item in the 'NEMap'. +-- +-- Is more general than 'traverseWithKey', since works with all 'Apply', +-- and not just 'Applicative'. + +-- TODO: benchmark against M.maxView version +traverseMaybeWithKey1 :: + Apply t => + (k -> a -> t (Maybe b)) -> + NEMap k a -> + t (Map k b) +traverseMaybeWithKey1 f (NEMap k0 v m0) = case runMaybeApply m1 of + Left m2 -> combine <$> f k0 v <.> m2 + Right m2 -> (`combine` m2) <$> f k0 v + where + m1 = M.traverseMaybeWithKey (\k -> MaybeApply . Left . f k) m0 + combine Nothing = id + combine (Just v') = insertMinMap k0 v' +{-# INLINE traverseMaybeWithKey1 #-} + +-- | /O(n)/. The function 'mapAccum' threads an accumulating argument +-- through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList ((5,"a") :| [(3,"b")])) == ("Everything: ba", fromList ((3, "bX") :| [(5, "aX")])) +mapAccum :: + (a -> b -> (a, c)) -> + a -> + NEMap k b -> + (a, NEMap k c) +mapAccum f = mapAccumWithKey (\x _ -> f x) +{-# INLINE mapAccum #-} + +-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList ((5,"a") :| [(3,"b")])) == ("Everything: 3-b 5-a", fromList ((3, "bX") :| [(5, "aX")])) +mapAccumWithKey :: + (a -> k -> b -> (a, c)) -> + a -> + NEMap k b -> + (a, NEMap k c) +mapAccumWithKey f z0 (NEMap k v m) = (z2, NEMap k v' m') + where + ~(z1, v') = f z0 k v + ~(z2, m') = M.mapAccumWithKey f z1 m +{-# INLINE mapAccumWithKey #-} + +-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: + (a -> k -> b -> (a, c)) -> + a -> + NEMap k b -> + (a, NEMap k c) +mapAccumRWithKey f z0 (NEMap k v m) = (z2, NEMap k v' m') + where + ~(z1, m') = M.mapAccumRWithKey f z0 m + ~(z2, v') = f z1 k v +{-# INLINE mapAccumRWithKey #-} + +-- TODO: what other situations can we take advantage of lazy tuple pattern +-- matching? + +-- | /O(n*log n)/. +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the value at the greatest of the +-- original keys is retained. +-- +-- While the size of the result map may be smaller than the input map, the +-- output map is still guaranteed to be non-empty if the input map is +-- non-empty. +-- +-- > mapKeys (+ 1) (fromList ((5,"a") :| [(3,"b")])) == fromList ((4, "b") :| [(6, "a")]) +-- > mapKeys (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "c" +-- > mapKeys (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "c" +mapKeys :: + Ord k2 => + (k1 -> k2) -> + NEMap k1 a -> + NEMap k2 a +mapKeys f (NEMap k0 v0 m) = + fromListWith const + . ((f k0, v0) :|) + . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] + $ m +{-# INLINEABLE mapKeys #-} + +-- | /O(n*log n)/. +-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. The value at the greater of the two original keys +-- is used as the first argument to @c@. +-- +-- While the size of the result map may be smaller than the input map, the +-- output map is still guaranteed to be non-empty if the input map is +-- non-empty. +-- +-- > mapKeysWith (++) (\ _ -> 1) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 1 "cdab" +-- > mapKeysWith (++) (\ _ -> 3) (fromList ((1,"b") :| [(2,"a"), (3,"d"), (4,"c")])) == singleton 3 "cdab" +mapKeysWith :: + Ord k2 => + (a -> a -> a) -> + (k1 -> k2) -> + NEMap k1 a -> + NEMap k2 a +mapKeysWith c f (NEMap k0 v0 m) = + fromListWith c + . ((f k0, v0) :|) + . M.foldrWithKey (\k v kvs -> (f k, v) : kvs) [] + $ m +{-# INLINEABLE mapKeysWith #-} + +-- | /O(n)/. +-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s +-- > where ls = keys s +-- +-- This means that @f@ maps distinct original keys to distinct resulting keys. +-- This function has better performance than 'mapKeys'. +-- +-- While the size of the result map may be smaller than the input map, the +-- output map is still guaranteed to be non-empty if the input map is +-- non-empty. +-- +-- > mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")])) == fromList ((6, "b") :| [(10, "a")]) +-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList ((5,"a") :| [(3,"b")]))) == True +-- > valid (mapKeysMonotonic (\ _ -> 1) (fromList ((5,"a") :| [(3,"b")]))) == False +mapKeysMonotonic :: + (k1 -> k2) -> + NEMap k1 a -> + NEMap k2 a +mapKeysMonotonic f (NEMap k v m) = + NEMap (f k) v + . M.mapKeysMonotonic f + $ m +{-# INLINE mapKeysMonotonic #-} + +-- | /O(n)/. Filter all values that satisfy the predicate. +-- +-- Returns a potentially empty map ('Map'), because we could +-- potentailly filter out all items in the original 'NEMap'. +-- +-- > filter (> "a") (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" +-- > filter (> "x") (fromList ((5,"a") :| [(3,"b")])) == Data.Map.empty +-- > filter (< "a") (fromList ((5,"a") :| [(3,"b")])) == Data.Map.empty +filter :: + (a -> Bool) -> + NEMap k a -> + Map k a +filter f (NEMap k v m) + | f v = insertMinMap k v . M.filter f $ m + | otherwise = M.filter f m +{-# INLINE filter #-} + +-- | /O(n)/. Filter all keys\/values that satisfy the predicate. +-- +-- Returns a potentially empty map ('Map'), because we could +-- potentailly filter out all items in the original 'NEMap'. +-- +-- > filterWithKey (\k _ -> k > 4) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +filterWithKey :: + (k -> a -> Bool) -> + NEMap k a -> + Map k a +filterWithKey f (NEMap k v m) + | f k v = insertMinMap k v . M.filterWithKey f $ m + | otherwise = M.filterWithKey f m +{-# INLINE filterWithKey #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Restrict an 'NEMap' to only those keys +-- found in a 'Data.Set.Set'. +-- +-- @ +-- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m +-- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s +-- @ +restrictKeys :: + Ord k => + NEMap k a -> + Set k -> + Map k a +restrictKeys n@(NEMap k v m) xs = case S.minView xs of + Nothing -> M.empty + Just (y, ys) -> case compare k y of + -- k is not in xs + LT -> m `M.restrictKeys` xs + -- k and y are a part of the result + EQ -> insertMinMap k v $ m `M.restrictKeys` ys + -- y is not in m + GT -> toMap n `M.restrictKeys` ys +{-# INLINE restrictKeys #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Data.Set.Set' from +-- an 'NEMap'. +-- +-- @ +-- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m +-- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s +-- @ +withoutKeys :: + Ord k => + NEMap k a -> + Set k -> + Map k a +withoutKeys n@(NEMap k v m) xs = case S.minView xs of + Nothing -> toMap n + Just (y, ys) -> case compare k y of + -- k is not in xs, so cannot be deleted + LT -> insertMinMap k v $ m `M.withoutKeys` xs + -- y deletes k, and only k + EQ -> m `M.withoutKeys` ys + -- y is not in n, so cannot delete anything, so we can just difference n and ys + GT -> toMap n `M.withoutKeys` ys +{-# INLINE withoutKeys #-} + +-- | /O(n)/. Partition the map according to a predicate. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the predicate was true for all items. +-- * @'That' n2@ means that the predicate was false for all items. +-- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the +-- predicate) and @n2@ (all of the items that were false for the +-- predicate). +-- +-- See also 'split'. +-- +-- > partition (> "a") (fromList ((5,"a") :| [(3,"b")])) == These (singleton 3 "b") (singleton 5 "a") +-- > partition (< "x") (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) +-- > partition (> "x") (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) +partition :: + (a -> Bool) -> + NEMap k a -> + These (NEMap k a) (NEMap k a) +partition f = partitionWithKey (const f) +{-# INLINE partition #-} + +-- | /O(n)/. Partition the map according to a predicate. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the predicate was true for all items, +-- returning the original map. +-- * @'That' n2@ means that the predicate was false for all items, +-- returning the original map. +-- * @'These' n1 n2@ gives @n1@ (all of the items that were true for the +-- predicate) and @n2@ (all of the items that were false for the +-- predicate). +-- +-- See also 'split'. +-- +-- > partitionWithKey (\ k _ -> k > 3) (fromList ((5,"a") :| [(3,"b")])) == These (singleton 5 "a") (singleton 3 "b") +-- > partitionWithKey (\ k _ -> k < 7) (fromList ((5,"a") :| [(3,"b")])) == This (fromList ((3, "b") :| [(5, "a")])) +-- > partitionWithKey (\ k _ -> k > 7) (fromList ((5,"a") :| [(3,"b")])) == That (fromList ((3, "b") :| [(5, "a")])) +partitionWithKey :: + (k -> a -> Bool) -> + NEMap k a -> + These (NEMap k a) (NEMap k a) +partitionWithKey f n@(NEMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) + | f k v -> This n + | otherwise -> That n + (Just n1, Nothing) + | f k v -> This n + | otherwise -> These n1 (singleton k v) + (Nothing, Just n2) + | f k v -> These (singleton k v) n2 + | otherwise -> That n + (Just n1, Just n2) + | f k v -> These (insertMapMin k v m1) n2 + | otherwise -> These n1 (insertMapMin k v m2) + where + (m1, m2) = M.partitionWithKey f m0 +{-# INLINEABLE partitionWithKey #-} + +-- | /O(log n)/. Take while a predicate on the keys holds. +-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, +-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. +-- +-- Returns a potentially empty map ('Map'), because the predicate might +-- fail on the first input. +-- +-- @ +-- takeWhileAntitone p = Data.Map.fromDistinctAscList . Data.List.takeWhile (p . fst) . Data.Foldable.toList +-- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k) +-- @ +takeWhileAntitone :: + (k -> Bool) -> + NEMap k a -> + Map k a +takeWhileAntitone f (NEMap k v m) + | f k = insertMinMap k v . M.takeWhileAntitone f $ m + | otherwise = M.empty +{-# INLINE takeWhileAntitone #-} + +-- | /O(log n)/. Drop while a predicate on the keys holds. +-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, +-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. +-- +-- @ +-- dropWhileAntitone p = Data.Map.fromDistinctAscList . Data.List.dropWhile (p . fst) . Data.Foldable.toList +-- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k)) +-- @ +dropWhileAntitone :: + (k -> Bool) -> + NEMap k a -> + Map k a +dropWhileAntitone f n@(NEMap k _ m) + | f k = M.dropWhileAntitone f m + | otherwise = toMap n +{-# INLINE dropWhileAntitone #-} + +-- | /O(log n)/. Divide a map at the point where a predicate on the keys stops holding. +-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, +-- @j \< k ==\> p j \>= p k@. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the predicate never failed for any item, +-- returning the original map. +-- * @'That' n2@ means that the predicate failed for the first item, +-- returning the original map. +-- * @'These' n1 n2@ gives @n1@ (the map up to the point where the +-- predicate on the keys stops holding) and @n2@ (the map starting from +-- the point where the predicate stops holding) +-- +-- @ +-- spanAntitone p xs = partitionWithKey (\k _ -> p k) xs +-- @ +-- +-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map +-- at some /unspecified/ point where the predicate switches from holding to not +-- holding (where the predicate is seen to hold before the first key and to fail +-- after the last key). +spanAntitone :: + (k -> Bool) -> + NEMap k a -> + These (NEMap k a) (NEMap k a) +spanAntitone f n@(NEMap k v m0) + | f k = case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> This n + (Just _, Nothing) -> This n + (Nothing, Just n2) -> These (singleton k v) n2 + (Just _, Just n2) -> These (insertMapMin k v m1) n2 + | otherwise = That n + where + (m1, m2) = M.spanAntitone f m0 +{-# INLINEABLE spanAntitone #-} + +-- | /O(n)/. Map values and collect the 'Just' results. +-- +-- Returns a potentially empty map ('Map'), because the function could +-- potentially return 'Nothing' on all items in the 'NEMap'. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > mapMaybe f (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "new a" +mapMaybe :: + (a -> Maybe b) -> + NEMap k a -> + Map k b +mapMaybe f = mapMaybeWithKey (const f) +{-# INLINE mapMaybe #-} + +-- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- +-- Returns a potentially empty map ('Map'), because the function could +-- potentially return 'Nothing' on all items in the 'NEMap'. +-- +-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing +-- > mapMaybeWithKey f (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "key : 3" +mapMaybeWithKey :: + (k -> a -> Maybe b) -> + NEMap k a -> + Map k b +mapMaybeWithKey f (NEMap k v m) = maybe id (insertMinMap k) (f k v) (M.mapMaybeWithKey f m) +{-# INLINE mapMaybeWithKey #-} + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the results were all 'Left'. +-- * @'That' n2@ means that the results were all 'Right'. +-- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') +-- and @n2@ (the map where the results were 'Right') +-- +-- > let f a = if a < "c" then Left a else Right a +-- > mapEither f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == These (fromList ((3,"b") :| [(5,"a")])) (fromList ((1,"x") :| [(7,"z")])) +-- > +-- > mapEither (\ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == That (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +mapEither :: + (a -> Either b c) -> + NEMap k a -> + These (NEMap k b) (NEMap k c) +mapEither f = mapEitherWithKey (const f) +{-# INLINE mapEither #-} + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- Returns a 'These' with potentially two non-empty maps: +-- +-- * @'This' n1@ means that the results were all 'Left'. +-- * @'That' n2@ means that the results were all 'Right'. +-- * @'These' n1 n2@ gives @n1@ (the map where the results were 'Left') +-- and @n2@ (the map where the results were 'Right') +-- +-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- > mapEitherWithKey f (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == These (fromList ((1,2) :| [(3,6)])) (fromList ((5,"aa") :| [(7,"zz")])) +-- > +-- > mapEitherWithKey (\_ a -> Right a) (fromList ((5,"a") :| [(3,"b"), (1,"x"), (7,"z")])) +-- > == That (fromList ((1,"x") :| [(3,"b"), (5,"a"), (7,"z")])) +mapEitherWithKey :: + (k -> a -> Either b c) -> + NEMap k a -> + These (NEMap k b) (NEMap k c) +mapEitherWithKey f (NEMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> case f k v of + Left v' -> This (singleton k v') + Right v' -> That (singleton k v') + (Just n1, Nothing) -> case f k v of + Left v' -> This (insertMapMin k v' m1) + Right v' -> These n1 (singleton k v') + (Nothing, Just n2) -> case f k v of + Left v' -> These (singleton k v') n2 + Right v' -> That (insertMapMin k v' m2) + (Just n1, Just n2) -> case f k v of + Left v' -> These (insertMapMin k v' m1) n2 + Right v' -> These n1 (insertMapMin k v' m2) + where + (m1, m2) = M.mapEitherWithKey f m0 +{-# INLINEABLE mapEitherWithKey #-} + +-- | /O(log n)/. The expression (@'split' k map@) is potentially a 'These' +-- containing up to two 'NEMap's based on splitting the map into maps +-- containing items before and after the given key @k@. It will never +-- return a map that contains @k@ itself. +-- +-- * 'Nothing' means that @k@ was the only key in the the original map, +-- and so there are no items before or after it. +-- * @'Just' ('This' n1)@ means @k@ was larger than or equal to all items +-- in the map, and @n1@ is the entire original map (minus @k@, if it was +-- present) +-- * @'Just' ('That' n2)@ means @k@ was smaller than or equal to all +-- items in the map, and @n2@ is the entire original map (minus @k@, if +-- it was present) +-- * @'Just' ('These' n1 n2)@ gives @n1@ (the map of all keys from the +-- original map less than @k@) and @n2@ (the map of all keys from the +-- original map greater than @k@) +-- +-- > split 2 (fromList ((5,"a") :| [(3,"b")])) == Just (That (fromList ((3,"b") :| [(5,"a")])) ) +-- > split 3 (fromList ((5,"a") :| [(3,"b")])) == Just (That (singleton 5 "a") ) +-- > split 4 (fromList ((5,"a") :| [(3,"b")])) == Just (These (singleton 3 "b") (singleton 5 "a")) +-- > split 5 (fromList ((5,"a") :| [(3,"b")])) == Just (This (singleton 3 "b") ) +-- > split 6 (fromList ((5,"a") :| [(3,"b")])) == Just (This (fromList ((3,"b") :| [(5,"a")])) ) +-- > split 5 (singleton 5 "a") == Nothing +split :: + Ord k => + k -> + NEMap k a -> + Maybe (These (NEMap k a) (NEMap k a)) +split k n@(NEMap k0 v m0) = case compare k k0 of + LT -> Just $ That n + EQ -> That <$> nonEmptyMap m0 + 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 +{-# INLINEABLE split #-} + +-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just +-- like 'split' but also returns @'lookup' k map@, as the first field in +-- the 'These': +-- +-- > 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 -> + These a (These (NEMap k a) (NEMap k a)) +splitLookup k n@(NEMap k0 v0 m0) = case compare k k0 of + 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 +{-# INLINEABLE splitLookup #-} + +-- | /O(1)/. Decompose a map into pieces based on the structure of the +-- underlying tree. This function is useful for consuming a map in +-- parallel. +-- +-- No guarantee is made as to the sizes of the pieces; an internal, but +-- deterministic process determines this. However, it is guaranteed that +-- the pieces returned will be in ascending order (all elements in the +-- first submap less than all elements in the second, and so on). +-- +-- Note that the current implementation does not return more than four +-- submaps, but you should not depend on this behaviour because it can +-- change in the future without notice. +splitRoot :: + NEMap k a -> + NonEmpty (NEMap k a) +splitRoot (NEMap k v m) = + singleton k v + :| Maybe.mapMaybe nonEmptyMap (M.splitRoot m) +{-# INLINE splitRoot #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. +-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). +isSubmapOf :: (Ord k, Eq a) => NEMap k a -> NEMap k a -> Bool +isSubmapOf = isSubmapOfBy (==) +{-# INLINE isSubmapOf #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. +-- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if +-- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when +-- applied to their respective values. For example, the following +-- expressions are all 'True': +-- +-- > isSubmapOfBy (==) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (<=) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (fromList (('a',1) :| [('b',2)])) +-- +-- But the following are all 'False': +-- +-- > isSubmapOfBy (==) (singleton 'a' 2) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (<) (singleton 'a' 1) (fromList (('a',1) :| [('b',2)])) +-- > isSubmapOfBy (==) (fromList (('a',1) :| [('b',2)])) (singleton 'a' 1) +isSubmapOfBy :: + Ord k => + (a -> b -> Bool) -> + NEMap k a -> + NEMap k b -> + Bool +isSubmapOfBy f (NEMap k v m0) (toMap -> m1) = + kvSub + && M.isSubmapOfBy f m0 m1 + where + kvSub = case M.lookup k m1 of + Just v0 -> f v v0 + Nothing -> False +{-# INLINE isSubmapOfBy #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap +-- but not equal). Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' +-- (==)@). +isProperSubmapOf :: (Ord k, Eq a) => NEMap k a -> NEMap k a -> Bool +isProperSubmapOf = isProperSubmapOfBy (==) +{-# INLINE isProperSubmapOf #-} + +-- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap +-- but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns +-- 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, +-- and when @f@ returns 'True' when applied to their respective values. For +-- example, the following expressions are all 'True': +-- +-- > isProperSubmapOfBy (==) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) +-- > isProperSubmapOfBy (<=) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) +-- +-- But the following are all 'False': +-- +-- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (fromList ((1,1) :| [(2,2)])) +-- > isProperSubmapOfBy (==) (fromList ((1,1) :| [(2,2)])) (singleton 1 1)) +-- > isProperSubmapOfBy (<) (singleton 1 1) (fromList ((1,1) :| [(2,2)])) +isProperSubmapOfBy :: + Ord k => + (a -> b -> Bool) -> + NEMap k a -> + NEMap k b -> + Bool +isProperSubmapOfBy f m1 m2 = + M.size (nemMap m1) < M.size (nemMap m2) + && isSubmapOfBy f m1 m2 +{-# INLINE isProperSubmapOfBy #-} + +-- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index +-- in the sequence sorted by keys. The index is a number from /0/ up to, +-- but not including, the 'size' of the map. +-- +-- > isJust (lookupIndex 2 (fromList ((5,"a") :| [(3,"b")]))) == False +-- > fromJust (lookupIndex 3 (fromList ((5,"a") :| [(3,"b")]))) == 0 +-- > fromJust (lookupIndex 5 (fromList ((5,"a") :| [(3,"b")]))) == 1 +-- > isJust (lookupIndex 6 (fromList ((5,"a") :| [(3,"b")]))) == False +lookupIndex :: + Ord k => + k -> + NEMap k a -> + Maybe Int +lookupIndex k (NEMap k0 _ m) = case compare k k0 of + LT -> Nothing + EQ -> Just 0 + GT -> (+ 1) <$> M.lookupIndex k m +{-# INLINE lookupIndex #-} + +-- | /O(log n)/. Return the /index/ of a key, which is its zero-based index +-- in the sequence sorted by keys. The index is a number from /0/ up to, +-- but not including, the 'size' of the map. Calls 'error' when the key is +-- not a 'member' of the map. +-- +-- > findIndex 2 (fromList ((5,"a") :| [(3,"b")])) Error: element is not in the map +-- > findIndex 3 (fromList ((5,"a") :| [(3,"b")])) == 0 +-- > findIndex 5 (fromList ((5,"a") :| [(3,"b")])) == 1 +-- > findIndex 6 (fromList ((5,"a") :| [(3,"b")])) Error: element is not in the map +findIndex :: + Ord k => + k -> + NEMap k a -> + Int +findIndex k = fromMaybe e . lookupIndex k + where + e = error "NEMap.findIndex: element is not in the map" +{-# INLINE findIndex #-} + +-- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based +-- index in the sequence sorted by keys. If the /index/ is out of range +-- (less than zero, greater or equal to 'size' of the map), 'error' is +-- called. +-- +-- > elemAt 0 (fromList ((5,"a") :| [(3,"b")])) == (3,"b") +-- > elemAt 1 (fromList ((5,"a") :| [(3,"b")])) == (5, "a") +-- > elemAt 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range +elemAt :: + Int -> + NEMap k a -> + (k, a) +elemAt 0 (NEMap k v _) = (k, v) +elemAt i (NEMap _ _ m) = M.elemAt (i - 1) m +{-# INLINEABLE elemAt #-} + +-- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in +-- the sequence sorted by keys. If the /index/ is out of range (less than zero, +-- greater or equal to 'size' of the map), 'error' is called. +-- +-- Returns a possibly empty map ('Map'), because the function might end up +-- deleting the last key in the map. See 'adjustAt' for a version that +-- disallows deletion, guaranteeing that the result is also a non-empty +-- Map. +-- +-- > updateAt (\ _ _ -> Just "x") 0 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "x"), (5, "a")] +-- > updateAt (\ _ _ -> Just "x") 1 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "x")] +-- > updateAt (\ _ _ -> Just "x") 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range +-- > updateAt (\ _ _ -> Just "x") (-1) (fromList ((5,"a") :| [(3,"b")])) Error: index out of range +-- > updateAt (\_ _ -> Nothing) 0 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +-- > updateAt (\_ _ -> Nothing) 1 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" +-- > updateAt (\_ _ -> Nothing) 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range +-- > updateAt (\_ _ -> Nothing) (-1) (fromList ((5,"a") :| [(3,"b")])) Error: index out of range +updateAt :: + (k -> a -> Maybe a) -> + Int -> + NEMap k a -> + Map k a +updateAt f 0 (NEMap k v m) = maybe m (flip (insertMinMap k) m) $ f k v +updateAt f i (NEMap k v m) = insertMinMap k v . M.updateAt f (i - 1) $ m +{-# INLINEABLE updateAt #-} + +-- | /O(log n)/. Variant of 'updateAt' that disallows deletion. Allows us +-- to guarantee that the result is also a non-empty Map. +adjustAt :: + (k -> a -> a) -> + Int -> + NEMap k a -> + NEMap k a +adjustAt f 0 (NEMap k0 v m) = NEMap k0 (f k0 v) m +adjustAt f i (NEMap k0 v m) = + NEMap k0 v + . M.updateAt (\k -> Just . f k) (i - 1) + $ m +{-# INLINEABLE adjustAt #-} + +-- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based +-- index in the sequence sorted by keys. If the /index/ is out of range +-- (less than zero, greater or equal to 'size' of the map), 'error' is +-- called. +-- +-- Returns a potentially empty map ('Map') because of the possibility of +-- deleting the last item in a map. +-- +-- > deleteAt 0 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +-- > deleteAt 1 (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" +-- > deleteAt 2 (fromList ((5,"a") :| [(3,"b")])) Error: index out of range +-- > deleteAt (-1) (fromList ((5,"a") :| [(3,"b")])) Error: index out of range +deleteAt :: + Int -> + NEMap k a -> + Map k a +deleteAt 0 (NEMap _ _ m) = m +deleteAt i (NEMap k v m) = insertMinMap k v . M.deleteAt (i - 1) $ m +{-# INLINEABLE deleteAt #-} + +-- | Take a given number of entries in key order, beginning with the +-- smallest keys. +-- +-- Returns a possibly empty map ('Map'), which can only happen if we call +-- @take 0@. +-- +-- @ +-- take n = Data.Map.fromDistinctAscList . Data.List.NonEmpty.take n . 'toList' +-- @ +take :: + Int -> + NEMap k a -> + Map k a +take 0 NEMap{} = M.empty +take i (NEMap k v m) = insertMinMap k v . M.take (i - 1) $ m +{-# INLINEABLE take #-} + +-- | Drop a given number of entries in key order, beginning +-- with the smallest keys. +-- +-- Returns a possibly empty map ('Map'), in case we drop all of the +-- elements (which can happen if we drop a number greater than or equal to +-- the number of items in the map) +-- +-- @ +-- drop n = Data.Map.fromDistinctAscList . Data.List.NonEmpty.drop' n . 'toList' +-- @ +drop :: + Int -> + NEMap k a -> + Map k a +drop 0 n = toMap n +drop i (NEMap _ _ m) = M.drop (i - 1) m +{-# INLINEABLE drop #-} + +-- | /O(log n)/. Split a map at a particular index @i@. +-- +-- * @'This' n1@ means that there are less than @i@ items in the map, and +-- @n1@ is the original map. +-- * @'That' n2@ means @i@ was 0; we dropped 0 items, so @n2@ is the +-- original map. +-- * @'These' n1 n2@ gives @n1@ (taking @i@ items from the original map) +-- and @n2@ (dropping @i@ items from the original map)) +splitAt :: + Int -> + NEMap k a -> + These (NEMap k a) (NEMap k a) +splitAt 0 n = That n +splitAt i n@(NEMap k v m0) = case (nonEmptyMap m1, nonEmptyMap m2) of + (Nothing, Nothing) -> This (singleton k v) + (Just _, Nothing) -> This n + (Nothing, Just n2) -> These (singleton k v) n2 + (Just _, Just n2) -> These (insertMapMin k v m1) n2 + where + (m1, m2) = M.splitAt (i - 1) m0 +{-# INLINEABLE splitAt #-} + +-- | /O(1)/. The minimal key of the map. Note that this is total, making +-- 'Data.Map.lookupMin' obsolete. It is constant-time, so has better +-- asymptotics than @Data.Map.lookupMin@ and @Data.Map.findMin@, as well. +-- +-- > findMin (fromList ((5,"a") :| [(3,"b")])) == (3,"b") +findMin :: NEMap k a -> (k, a) +findMin (NEMap k v _) = (k, v) +{-# INLINE findMin #-} + +-- | /O(log n)/. The maximal key of the map. Note that this is total, making +-- 'Data.Map.lookupMin' obsolete. +-- +-- > findMax (fromList ((5,"a") :| [(3,"b")])) == (5,"a") +findMax :: NEMap k a -> (k, a) +findMax (NEMap k v m) = fromMaybe (k, v) . M.lookupMax $ m +{-# INLINE findMax #-} + +-- | /O(1)/. Delete the minimal key. Returns a potentially empty map +-- ('Map'), because we might end up deleting the final key in a singleton +-- map. It is constant-time, so has better asymptotics than +-- 'Data.Map.deleteMin'. +-- +-- > deleteMin (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.Map.fromList [(5,"a"), (7,"c")] +-- > deleteMin (singleton 5 "a") == Data.Map.empty +deleteMin :: NEMap k a -> Map k a +deleteMin (NEMap _ _ m) = m +{-# INLINE deleteMin #-} + +-- | /O(log n)/. Delete the maximal key. Returns a potentially empty map +-- ('Map'), because we might end up deleting the final key in a singleton +-- map. +-- +-- > deleteMax (fromList ((5,"a") :| [(3,"b"), (7,"c")])) == Data.Map.fromList [(3,"b"), (5,"a")] +-- > deleteMax (singleton 5 "a") == Data.Map.empty +deleteMax :: NEMap k a -> Map k a +deleteMax (NEMap k v m) = case M.maxView m of + Nothing -> M.empty + Just (_, m') -> insertMinMap k v m' +{-# INLINE deleteMax #-} + +-- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the +-- minimal key. Returns a potentially empty map ('Map'), because we might +-- end up deleting the final key in the map if the function returns +-- 'Nothing'. See 'adjustMin' for a version that can guaruntee that we +-- return a non-empty map. +-- +-- > updateMin (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "Xb"), (5, "a")] +-- > updateMin (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +updateMin :: (a -> Maybe a) -> NEMap k a -> Map k a +updateMin f = updateMinWithKey (const f) +{-# INLINE updateMin #-} + +-- | /O(1)/. A version of 'updateMin' that disallows deletion, allowing us +-- to guarantee that the result is also non-empty. +adjustMin :: (a -> a) -> NEMap k a -> NEMap k a +adjustMin f = adjustMinWithKey (const f) +{-# INLINE adjustMin #-} + +-- | /O(1)/ if delete, /O(log n)/ otherwise. Update the value at the +-- minimal key. Returns a potentially empty map ('Map'), because we might +-- end up deleting the final key in the map if the function returns +-- 'Nothing'. See 'adjustMinWithKey' for a version that guaruntees +-- a non-empty map. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +updateMinWithKey :: (k -> a -> Maybe a) -> NEMap k a -> Map k a +updateMinWithKey f (NEMap k v m) = maybe id (insertMinMap k) (f k v) m +{-# INLINE updateMinWithKey #-} + +-- | /O(1)/. A version of 'adjustMaxWithKey' that disallows deletion, +-- allowing us to guarantee that the result is also non-empty. Note that +-- it also is able to have better asymptotics than 'updateMinWithKey' in +-- general. +adjustMinWithKey :: (k -> a -> a) -> NEMap k a -> NEMap k a +adjustMinWithKey f (NEMap k v m) = NEMap k (f k v) m +{-# INLINE adjustMinWithKey #-} + +-- | /O(log n)/. Update the value at the maximal key. Returns +-- a potentially empty map ('Map'), because we might end up deleting the +-- final key in the map if the function returns 'Nothing'. See 'adjustMax' +-- for a version that can guarantee that we return a non-empty map. +-- +-- > updateMax (\ a -> Just ("X" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3, "b"), (5, "Xa")] +-- > updateMax (\ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 3 "b" +updateMax :: (a -> Maybe a) -> NEMap k a -> Map k a +updateMax f = updateMaxWithKey (const f) +{-# INLINE updateMax #-} + +-- | /O(log n)/. A version of 'updateMax' that disallows deletion, allowing +-- us to guarantee that the result is also non-empty. +adjustMax :: (a -> a) -> NEMap k a -> NEMap k a +adjustMax f = adjustMaxWithKey (const f) +{-# INLINE adjustMax #-} + +-- | /O(log n)/. Update the value at the maximal key. Returns +-- a potentially empty map ('Map'), because we might end up deleting the +-- final key in the map if the function returns 'Nothing'. See +-- 'adjustMaxWithKey' for a version that guaruntees a non-empty map. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList ((5,"a") :| [(3,"b")])) == Data.Map.singleton 5 "a" +updateMaxWithKey :: (k -> a -> Maybe a) -> NEMap k a -> Map k a +updateMaxWithKey f (NEMap k v m) + | M.null m = maybe m (M.singleton k) $ f k v + | otherwise = + insertMinMap k v + . M.updateMaxWithKey f + $ m +{-# INLINE updateMaxWithKey #-} + +-- | /O(log n)/. A version of 'updateMaxWithKey' that disallows deletion, +-- allowing us to guarantee that the result is also non-empty. +adjustMaxWithKey :: (k -> a -> a) -> NEMap k a -> NEMap k a +adjustMaxWithKey f (NEMap k0 v m) + | M.null m = NEMap k0 (f k0 v) m + | otherwise = + insertMapMin k0 v + . M.updateMaxWithKey (\k -> Just . f k) + $ m +{-# INLINE adjustMaxWithKey #-} + +-- | /O(1)/. Retrieves the value associated with minimal key of the +-- map, and the map stripped of that element. It is constant-time, so has +-- better asymptotics than @Data.Map.minView@ for 'Map'. +-- +-- Note that unlike @Data.Map.minView@ for 'Map', this cannot ever fail, +-- so doesn't need to return in a 'Maybe'. However, the result 'Map' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > minView (fromList ((5,"a") :| [(3,"b")])) == ("b", Data.Map.singleton 5 "a") +minView :: NEMap k a -> (a, Map k a) +minView = first snd . deleteFindMin +{-# INLINE minView #-} + +-- | /O(1)/. Delete and find the minimal key-value pair. It is +-- constant-time, so has better asymptotics that @Data.Map.minView@ for +-- 'Map'. +-- +-- Note that unlike @Data.Map.deleteFindMin@ for 'Map', this cannot ever +-- fail, and so is a total function. However, the result 'Map' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > deleteFindMin (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((3,"b"), Data.Map.fromList [(5,"a"), (10,"c")]) +deleteFindMin :: NEMap k a -> ((k, a), Map k a) +deleteFindMin (NEMap k v m) = ((k, v), m) +{-# INLINE deleteFindMin #-} + +-- | /O(log n)/. Retrieves the value associated with maximal key of the +-- map, and the map stripped of that element. +-- +-- Note that unlike @Data.Map.maxView@ from 'Map', this cannot ever fail, +-- so doesn't need to return in a 'Maybe'. However, the result 'Map' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > maxView (fromList ((5,"a") :| [(3,"b")])) == ("a", Data.Map.singleton 3 "b") +maxView :: NEMap k a -> (a, Map k a) +maxView = first snd . deleteFindMax +{-# INLINE maxView #-} + +-- | /O(log n)/. Delete and find the minimal key-value pair. +-- +-- Note that unlike @Data.Map.deleteFindMax@ for 'Map', this cannot ever +-- fail, and so is a total function. However, the result 'Map' is +-- potentially empty, since the original map might have contained just +-- a single item. +-- +-- > deleteFindMax (fromList ((5,"a") :| [(3,"b"), (10,"c")])) == ((10,"c"), Data.Map.fromList [(3,"b"), (5,"a")]) +deleteFindMax :: NEMap k a -> ((k, a), Map k a) +deleteFindMax (NEMap k v m) = + maybe ((k, v), M.empty) (second (insertMinMap k v)) + . M.maxViewWithKey + $ m +{-# INLINE deleteFindMax #-} + +-- | Special property of non-empty maps: The type of non-empty maps over +-- uninhabited keys is itself uninhabited. +-- +-- This property also exists for /values/ inside a non-empty container +-- (like for 'NESet', 'NESeq', and 'NEIntMap'); this can be witnessed using +-- the function @'absurd' . 'fold1'@. +-- +-- @since 0.3.1.0 +absurdNEMap :: NEMap Void a -> b +absurdNEMap = \case {} + +-- --------------------------- +-- Combining functions +-- --------------------------- +-- +-- Code comes from "Data.Map.Internal" from containers, modified slightly +-- to work with NonEmpty +-- +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 + +combineEq :: Eq a => NonEmpty (a, b) -> NonEmpty (a, b) +combineEq = \case + x :| [] -> x :| [] + x :| xx@(_ : _) -> go x xx + where + go z [] = z :| [] + go z@(kz, _) (x@(kx, xx) : xs') + | kx == kz = go (kx, xx) xs' + | otherwise = z NE.<| go x xs' + +combineEqWith :: + Eq a => + (a -> b -> b -> b) -> + NonEmpty (a, b) -> + NonEmpty (a, b) +combineEqWith f = \case + x :| [] -> x :| [] + x :| xx@(_ : _) -> go x xx + where + go z [] = z :| [] + go z@(kz, zz) (x@(kx, xx) : xs') + | kx == kz = let yy = f kx xx zz in go (kx, yy) xs' | otherwise = z NE.<| go x xs' 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 @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : Data.Map.NonEmpty.Internal @@ -19,60 +19,64 @@ -- the abstraction of 'NEMap' and produce unsound maps, so be wary! module Data.Map.NonEmpty.Internal ( -- * Non-Empty Map type - NEMap(..) - , singleton - , nonEmptyMap - , withNonEmpty - , fromList - , toList - , map - , insertWith - , union - , unions - , elems - , size - , toMap + NEMap (..), + singleton, + nonEmptyMap, + withNonEmpty, + fromList, + toList, + map, + insertWith, + union, + unions, + elems, + size, + toMap, + -- * Folds - , foldr - , foldr' - , foldr1 - , foldl - , foldl' - , foldl1 + foldr, + foldr', + foldr1, + foldl, + foldl', + foldl1, + -- * Traversals - , traverseWithKey - , traverseWithKey1 - , foldMapWithKey + traverseWithKey, + traverseWithKey1, + foldMapWithKey, + -- * Unsafe Map Functions - , insertMinMap - , insertMaxMap + insertMinMap, + insertMaxMap, + -- * Debug - , valid - ) where + valid, +) where -import Control.Applicative -import Control.Comonad -import Control.DeepSeq -import Control.Monad -import Data.Coerce -import Data.Data -import Data.Function -import Data.Functor.Alt -import Data.Functor.Classes -import Data.Functor.Invariant -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map.Internal (Map(..)) -import Data.Maybe -import Data.Semigroup -import Data.Semigroup.Foldable (Foldable1(fold1)) -import Data.Semigroup.Traversable (Traversable1(..)) -import Prelude hiding (Foldable(..), map) -import Text.Read -import qualified Data.Aeson as A -import qualified Data.Foldable as F -import qualified Data.Map as M -import qualified Data.Map.Internal as M -import qualified Data.Semigroup.Foldable as F1 +import Control.Applicative +import Control.Comonad +import Control.DeepSeq +import Control.Monad +import qualified Data.Aeson as A +import Data.Coerce +import Data.Data +import qualified Data.Foldable as F +import Data.Function +import Data.Functor.Alt +import Data.Functor.Classes +import Data.Functor.Invariant +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as M +import Data.Map.Internal (Map (..)) +import qualified Data.Map.Internal as M +import Data.Maybe +import Data.Semigroup +import Data.Semigroup.Foldable (Foldable1 (fold1)) +import qualified Data.Semigroup.Foldable as F1 +import Data.Semigroup.Traversable (Traversable1 (..)) +import Text.Read +import Prelude hiding (Foldable (..), map) -- | A non-empty (by construction) map from keys @k@ to values @a@. At -- least one key-value pair exists in an @'NEMap' k v@ at all times. @@ -109,81 +113,99 @@ -- You can convert an 'NEMap' into a 'Map' with 'toMap' or -- 'Data.Map.NonEmpty.IsNonEmpty', essentially "obscuring" the non-empty -- property from the type. -data NEMap k a = - NEMap { nemK0 :: !k -- ^ invariant: must be smaller than smallest key in map - , nemV0 :: a - , nemMap :: !(Map k a) - } +data NEMap k a + = NEMap + { nemK0 :: !k + -- ^ invariant: must be smaller than smallest key in map + , nemV0 :: a + , nemMap :: !(Map k a) + } deriving (Typeable) instance (Eq k, Eq a) => Eq (NEMap k a) where - t1 == t2 = M.size (nemMap t1) == M.size (nemMap t2) - && toList t1 == toList t2 + t1 == t2 = + M.size (nemMap t1) == M.size (nemMap t2) + && toList t1 == toList t2 instance (Ord k, Ord a) => Ord (NEMap k a) where - compare = compare `on` toList - (<) = (<) `on` toList - (>) = (>) `on` toList - (<=) = (<=) `on` toList - (>=) = (>=) `on` toList + compare = compare `on` toList + (<) = (<) `on` toList + (>) = (>) `on` toList + (<=) = (<=) `on` toList + (>=) = (>=) `on` toList instance Eq2 NEMap where - liftEq2 eqk eqv m n = - size m == size n && liftEq (liftEq2 eqk eqv) (toList m) (toList n) + liftEq2 eqk eqv m n = + size m == size n && liftEq (liftEq2 eqk eqv) (toList m) (toList n) instance Eq k => Eq1 (NEMap k) where - liftEq = liftEq2 (==) + liftEq = liftEq2 (==) instance Ord2 NEMap where - liftCompare2 cmpk cmpv m n = - liftCompare (liftCompare2 cmpk cmpv) (toList m) (toList n) + liftCompare2 cmpk cmpv m n = + liftCompare (liftCompare2 cmpk cmpv) (toList m) (toList n) instance Ord k => Ord1 (NEMap k) where - liftCompare = liftCompare2 compare + liftCompare = liftCompare2 compare instance Show2 NEMap where - liftShowsPrec2 spk slk spv slv d m = - showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) - where - sp = liftShowsPrec2 spk slk spv slv - sl = liftShowList2 spk slk spv slv + liftShowsPrec2 spk slk spv slv d m = + showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) + where + sp = liftShowsPrec2 spk slk spv slv + sl = liftShowList2 spk slk spv slv instance Show k => Show1 (NEMap k) where - liftShowsPrec = liftShowsPrec2 showsPrec showList + liftShowsPrec = liftShowsPrec2 showsPrec showList instance (Ord k, Read k) => Read1 (NEMap k) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl + liftReadsPrec rp rl = + readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl instance (Ord k, Read k, Read e) => Read (NEMap k e) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- parens . prec 10 $ readPrec - return (fromList xs) - readListPrec = readListPrecDefault + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- parens . prec 10 $ readPrec + return (fromList xs) + readListPrec = readListPrecDefault instance (Show k, Show a) => Show (NEMap k a) where - showsPrec d m = showParen (d > 10) $ + showsPrec d m = + showParen (d > 10) $ showString "fromList (" . shows (toList m) . showString ")" instance (NFData k, NFData a) => NFData (NEMap k a) where - rnf (NEMap k v a) = rnf k `seq` rnf v `seq` rnf a + rnf (NEMap k v a) = rnf k `seq` rnf v `seq` rnf a -- Data instance code from Data.Map.Internal -- -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 +#if MIN_VERSION_base(4,16,0) instance (Data k, Data a, Ord k) => Data (NEMap k a) where - gfoldl f z m = z fromList `f` toList m - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - dataTypeOf _ = mapDataType - dataCast2 f = gcast2 f + gfoldl f z m = z fromList `f` toList m + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + dataTypeOf _ = mapDataType + dataCast2 = gcast2 +#else +#ifndef __HLINT__ +instance (Data k, Data a, Ord k) => Data (NEMap k a) where + gfoldl f z m = z fromList `f` toList m + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + dataTypeOf _ = mapDataType + dataCast2 f = gcast2 f +#endif +#endif fromListConstr :: Constr fromListConstr = mkConstr mapDataType "fromList" [] Prefix @@ -192,19 +214,20 @@ mapDataType = mkDataType "Data.Map.NonEmpty.NonEmpty.Internal.NEMap" [fromListConstr] instance (A.ToJSONKey k, A.ToJSON a) => A.ToJSON (NEMap k a) where - toJSON = A.toJSON . toMap - toEncoding = A.toEncoding . toMap + toJSON = A.toJSON . toMap + toEncoding = A.toEncoding . toMap instance (A.FromJSONKey k, Ord k, A.FromJSON a) => A.FromJSON (NEMap k a) where - parseJSON = withNonEmpty (fail err) pure - <=< A.parseJSON - where - err = "NEMap: Non-empty map expected, but empty map found" + parseJSON = + withNonEmpty (fail err) pure + <=< A.parseJSON + where + err = "NEMap: Non-empty map expected, but empty map found" -- | @since 0.3.4.4 instance Ord k => Alt (NEMap k) where - () = union - {-# INLINE () #-} + () = union + {-# INLINE () #-} -- | /O(n)/. Fold the values in the map using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. @@ -232,9 +255,10 @@ -- Note that, unlike 'Data.Foldable.foldr1' for 'Map', this function is -- total if the input function is total. foldr1 :: (a -> a -> a) -> NEMap k a -> a -foldr1 f (NEMap _ v m) = maybe v (f v . uncurry (M.foldr f)) - . M.maxView - $ m +foldr1 f (NEMap _ v m) = + maybe v (f v . uncurry (M.foldr f)) + . M.maxView + $ m {-# INLINE foldr1 #-} -- | /O(n)/. Fold the values in the map using the given left-associative @@ -276,11 +300,11 @@ -- some monoids. -- TODO: benchmark against maxView method -foldMapWithKey - :: Semigroup m - => (k -> a -> m) - -> NEMap k a - -> m +foldMapWithKey :: + Semigroup m => + (k -> a -> m) -> + NEMap k a -> + m #if MIN_VERSION_base(4,11,0) foldMapWithKey f (NEMap k0 v m) = maybe (f k0 v) (f k0 v <>) . M.foldMapWithKey (\k -> Just . f k) @@ -298,12 +322,13 @@ map :: (a -> b) -> NEMap k a -> NEMap k b map f (NEMap k0 v m) = NEMap k0 (f v) (M.map f m) {-# NOINLINE [1] map #-} + {-# RULES -"map/map" forall f g xs . map f (map g xs) = map (f . g) xs - #-} +"map/map" forall f g xs. map f (map g xs) = map (f . g) xs + #-} {-# RULES "map/coerce" map coerce = coerce - #-} + #-} -- | /O(m*log(n\/m + 1)), m <= n/. -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @@ -311,15 +336,15 @@ -- (@'union' == 'Data.Map.NonEmpty.unionWith' 'const'@). -- -- > union (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "a"), (7, "C")]) -union - :: Ord k - => NEMap k a - -> NEMap k a - -> NEMap k a +union :: + Ord k => + NEMap k a -> + NEMap k a -> + NEMap k a union n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of - LT -> NEMap k1 v1 . M.union m1 . toMap $ n2 - EQ -> NEMap k1 v1 . M.union m1 $ m2 - GT -> NEMap k2 v2 . M.union (toMap n1) $ m2 + LT -> NEMap k1 v1 . M.union m1 . toMap $ n2 + EQ -> NEMap k1 v1 . M.union m1 $ m2 + GT -> NEMap k2 v2 . M.union (toMap n1) $ m2 {-# INLINE union #-} -- | The left-biased union of a non-empty list of maps. @@ -328,11 +353,11 @@ -- > == fromList [(3, "b"), (5, "a"), (7, "C")] -- > unions (fromList ((5, "A3") :| [(3, "B3")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "a") :| [(3, "b")])]) -- > == fromList ((3, "B3") :| [(5, "A3"), (7, "C")]) -unions - :: (Foldable1 f, Ord k) - => f (NEMap k a) - -> NEMap k a -unions (F1.toNonEmpty->(m :| ms)) = F.foldl' union m ms +unions :: + (Foldable1 f, Ord k) => + f (NEMap k a) -> + NEMap k a +unions (F1.toNonEmpty -> (m :| ms)) = F.foldl' union m ms {-# INLINE unions #-} -- | /O(n)/. @@ -380,11 +405,11 @@ -- @ -- 'traverseWithKey' f = 'unwrapApplicative' . 'traverseWithKey1' (\\k -> WrapApplicative . f k) -- @ -traverseWithKey - :: Applicative t - => (k -> a -> t b) - -> NEMap k a - -> t (NEMap k b) +traverseWithKey :: + Applicative t => + (k -> a -> t b) -> + NEMap k a -> + t (NEMap k b) traverseWithKey f (NEMap k v m0) = NEMap k <$> f k v <*> M.traverseWithKey f m0 {-# INLINE traverseWithKey #-} @@ -398,23 +423,23 @@ -- and not just 'Applicative'. -- TODO: benchmark against maxView-based methods -traverseWithKey1 - :: Apply t - => (k -> a -> t b) - -> NEMap k a - -> t (NEMap k b) +traverseWithKey1 :: + Apply t => + (k -> a -> t b) -> + NEMap k a -> + t (NEMap k b) traverseWithKey1 f (NEMap k0 v m0) = case runMaybeApply m1 of - Left m2 -> NEMap k0 <$> f k0 v <.> m2 - Right m2 -> flip (NEMap k0) m2 <$> f k0 v + Left m2 -> NEMap k0 <$> f k0 v <.> m2 + Right m2 -> flip (NEMap k0) m2 <$> f k0 v where m1 = M.traverseWithKey (\k -> MaybeApply . Left . f k) m0 -{-# INLINABLE traverseWithKey1 #-} +{-# INLINEABLE traverseWithKey1 #-} -- | /O(n)/. Convert the map to a non-empty list of key\/value pairs. -- -- > toList (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) toList :: NEMap k a -> NonEmpty (k, a) -toList (NEMap k v m) = (k,v) :| M.toList m +toList (NEMap k v m) = (k, v) :| M.toList m {-# INLINE toList #-} -- | /O(log n)/. Smart constructor for an 'NEMap' from a 'Map'. Returns @@ -439,11 +464,13 @@ -- will be fed to the function @f@ instead. -- -- @'nonEmptyMap' == 'withNonEmpty' 'Nothing' 'Just'@ -withNonEmpty - :: r -- ^ value to return if map is empty - -> (NEMap k a -> r) -- ^ function to apply if map is not empty - -> Map k a - -> r +withNonEmpty :: + -- | value to return if map is empty + r -> + -- | function to apply if map is not empty + (NEMap k a -> r) -> + Map k a -> + r withNonEmpty def f = maybe def f . nonEmptyMap {-# INLINE withNonEmpty #-} @@ -459,9 +486,10 @@ -- 'fromDistinctAscList' if items are ordered, just like the actual -- 'M.fromList'. fromList :: Ord k => NonEmpty (k, a) -> NEMap k a -fromList ((k, v) :| xs) = withNonEmpty (singleton k v) (insertWith (const id) k v) - . M.fromList - $ xs +fromList ((k, v) :| xs) = + withNonEmpty (singleton k v) (insertWith (const id) k v) + . M.fromList + $ xs {-# INLINE fromList #-} -- | /O(1)/. A map with a single element. @@ -482,54 +510,75 @@ -- -- > insertWith (++) 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "xxxa")]) -- > insertWith (++) 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) -insertWith - :: Ord k - => (a -> a -> a) - -> k - -> a - -> NEMap k a - -> NEMap k a +insertWith :: + Ord k => + (a -> a -> a) -> + k -> + a -> + NEMap k a -> + NEMap k a insertWith f k v n@(NEMap k0 v0 m) = case compare k k0 of - LT -> NEMap k v . toMap $ n - EQ -> NEMap k (f v v0) m - GT -> NEMap k0 v0 $ M.insertWith f k v m + LT -> NEMap k v . toMap $ n + EQ -> NEMap k (f v v0) m + GT -> NEMap k0 v0 $ M.insertWith f k v m {-# INLINE insertWith #-} - -- | Left-biased union instance Ord k => Semigroup (NEMap k a) where - (<>) = union - {-# INLINE (<>) #-} - sconcat = unions - {-# INLINE sconcat #-} + (<>) = union + {-# INLINE (<>) #-} + sconcat = unions + {-# INLINE sconcat #-} instance Functor (NEMap k) where - fmap = map - {-# INLINE fmap #-} - x <$ NEMap k _ m = NEMap k x (x <$ m) - {-# INLINE (<$) #-} + fmap = map + {-# INLINE fmap #-} + x <$ NEMap k _ m = NEMap k x (x <$ m) + {-# INLINE (<$) #-} -- | @since 0.3.4.4 instance Invariant (NEMap k) where - invmap f _ = fmap f - {-# INLINE invmap #-} + invmap f _ = fmap f + {-# INLINE invmap #-} -- | Traverses elements in order of ascending keys -- -- 'Data.Foldable.foldr1', 'Data.Foldable.foldl1', 'Data.Foldable.minimum', -- 'Data.Foldable.maximum' are all total. -instance F.Foldable (NEMap k) where #if MIN_VERSION_base(4,11,0) +instance F.Foldable (NEMap k) where fold (NEMap _ v m) = v <> F.fold m {-# INLINE fold #-} foldMap f (NEMap _ v m) = f v <> F.foldMap f m {-# INLINE foldMap #-} + foldr = foldr + {-# INLINE foldr #-} + foldr' = foldr' + {-# INLINE foldr' #-} + foldr1 = foldr1 + {-# INLINE foldr1 #-} + foldl = foldl + {-# INLINE foldl #-} + foldl' = foldl' + {-# INLINE foldl' #-} + foldl1 = foldl1 + {-# INLINE foldl1 #-} + null _ = False + {-# INLINE null #-} + length = size + {-# INLINE length #-} + elem x (NEMap _ v m) = F.elem x m + || x == v + {-# INLINE elem #-} + -- TODO: use build + toList = F.toList . elems + {-# INLINE toList #-} #else +instance F.Foldable (NEMap k) where fold (NEMap _ v m) = v `mappend` F.fold m {-# INLINE fold #-} foldMap f (NEMap _ v m) = f v `mappend` F.foldMap f m {-# INLINE foldMap #-} -#endif foldr = foldr {-# INLINE foldr #-} foldr' = foldr' @@ -552,41 +601,48 @@ -- TODO: use build toList = F.toList . elems {-# INLINE toList #-} +#endif -- | Traverses elements in order of ascending keys instance Traversable (NEMap k) where - traverse f (NEMap k v m) = NEMap k <$> f v <*> traverse f m - {-# INLINE traverse #-} - sequenceA (NEMap k v m) = NEMap k <$> v <*> sequenceA m - {-# INLINE sequenceA #-} + traverse f (NEMap k v m) = NEMap k <$> f v <*> traverse f m + {-# INLINE traverse #-} + sequenceA (NEMap k v m) = NEMap k <$> v <*> sequenceA m + {-# INLINE sequenceA #-} -- | Traverses elements in order of ascending keys -instance Foldable1 (NEMap k) where #if MIN_VERSION_base(4,11,0) +instance Foldable1 (NEMap k) where fold1 (NEMap _ v m) = maybe v (v <>) . F.foldMap Just $ m + {-# INLINE fold1 #-} + foldMap1 f = foldMapWithKey (const f) + {-# INLINE foldMap1 #-} + toNonEmpty = elems + {-# INLINE toNonEmpty #-} #else +instance Foldable1 (NEMap k) where fold1 (NEMap _ v m) = option v (v <>) . F.foldMap (Option . Just) $ m -#endif {-# INLINE fold1 #-} foldMap1 f = foldMapWithKey (const f) {-# INLINE foldMap1 #-} toNonEmpty = elems {-# INLINE toNonEmpty #-} +#endif -- | Traverses elements in order of ascending keys instance Traversable1 (NEMap k) where - traverse1 f = traverseWithKey1 (const f) - {-# INLINE traverse1 #-} - sequence1 (NEMap k v m0) = case runMaybeApply m1 of - Left m2 -> NEMap k <$> v <.> m2 - Right m2 -> flip (NEMap k) m2 <$> v - where - m1 = traverse (MaybeApply . Left) m0 - {-# INLINABLE sequence1 #-} + traverse1 f = traverseWithKey1 (const f) + {-# INLINE traverse1 #-} + sequence1 (NEMap k v m0) = case runMaybeApply m1 of + Left m2 -> NEMap k <$> v <.> m2 + Right m2 -> flip (NEMap k) m2 <$> v + where + m1 = traverse (MaybeApply . Left) m0 + {-# INLINEABLE sequence1 #-} -- | 'extract' gets the value at the minimal key, and 'duplicate' produces -- a map of maps comprised of all keys from the original map greater than @@ -594,25 +650,24 @@ -- -- @since 0.1.1.0 instance Comonad (NEMap k) where - extract = nemV0 - {-# INLINE extract #-} - duplicate n0@(NEMap k0 _ m0) = NEMap k0 n0 . snd - . M.mapAccumWithKey go m0 - $ m0 - where - go m k v = (m', NEMap k v m') - where - !m' = M.deleteMin m - {-# INLINE duplicate #-} + extract = nemV0 + {-# INLINE extract #-} + duplicate n0@(NEMap k0 _ m0) = + NEMap k0 n0 + . snd + . M.mapAccumWithKey go m0 + $ m0 + where + go m k v = (m', NEMap k v m') + where + !m' = M.deleteMin m + {-# INLINE duplicate #-} -- | /O(n)/. Test if the internal map structure is valid. valid :: Ord k => NEMap k a -> Bool -valid (NEMap k _ m) = M.valid m - && all ((k <) . fst . fst) (M.minViewWithKey m) - - - - +valid (NEMap k _ m) = + M.valid m + && all ((k <) . fst . fst) (M.minViewWithKey m) -- | /O(log n)/. Insert new key and value into a map where keys are -- /strictly greater than/ the new key. That is, the new key must be @@ -624,9 +679,9 @@ -- expensive) and also does not require an 'Ord' instance for the key type. insertMinMap :: k -> a -> Map k a -> Map k a insertMinMap kx x = \case - Tip -> M.singleton kx x - Bin _ ky y l r -> M.balanceL ky y (insertMinMap kx x l) r -{-# INLINABLE insertMinMap #-} + Tip -> M.singleton kx x + Bin _ ky y l r -> M.balanceL ky y (insertMinMap kx x l) r +{-# INLINEABLE insertMinMap #-} -- | /O(log n)/. Insert new key and value into a map where keys are -- /strictly less than/ the new key. That is, the new key must be @@ -638,6 +693,6 @@ -- expensive) and also does not require an 'Ord' instance for the key type. insertMaxMap :: k -> a -> Map k a -> Map k a insertMaxMap kx x = \case - Tip -> M.singleton kx x - Bin _ ky y l r -> M.balanceR ky y l (insertMaxMap kx x r) -{-# INLINABLE insertMaxMap #-} + Tip -> M.singleton kx x + Bin _ ky y l r -> M.balanceR ky y l (insertMaxMap kx x r) +{-# INLINEABLE insertMaxMap #-} diff --git a/src/Data/Sequence/NonEmpty.hs b/src/Data/Sequence/NonEmpty.hs --- a/src/Data/Sequence/NonEmpty.hs +++ b/src/Data/Sequence/NonEmpty.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Sequence.NonEmpty @@ -57,126 +57,166 @@ -- > import qualified Data.Sequence.NonEmpty as NESeq module Data.Sequence.NonEmpty ( -- * Finite sequences - NESeq ((:<||), (:||>)) + NESeq ((:<||), (:||>)), + -- ** Conversions between empty and non-empty sequences - , pattern IsNonEmpty - , pattern IsEmpty - , nonEmptySeq - , toSeq - , withNonEmpty - , unsafeFromSeq - , insertSeqAt + pattern IsNonEmpty, + pattern IsEmpty, + nonEmptySeq, + toSeq, + withNonEmpty, + unsafeFromSeq, + insertSeqAt, + -- * Construction - , singleton - , (<|) - , (|>) - , (><) - , (|><) - , (><|) - , fromList - , fromFunction + singleton, + (<|), + (|>), + (><), + (|><), + (><|), + fromList, + fromFunction, + -- ** Repetition - , replicate - , replicateA - , replicateA1 - , replicateM - , cycleTaking + replicate, + replicateA, + replicateA1, + replicateM, + cycleTaking, + -- ** Iterative construction - , iterateN - , unfoldr - , unfoldl + iterateN, + unfoldr, + unfoldl, + -- * Deconstruction + -- | Additional functions for deconstructing sequences are available -- via the 'Foldable' instance of 'NESeq'. - , head - , tail - , last - , init + head, + tail, + last, + init, + -- ** Queries - , length + length, -- * Scans - , scanl - , scanl1 - , scanr - , scanr1 + scanl, + scanl1, + scanr, + scanr1, + -- * Sublists - , tails - , inits - , chunksOf + tails, + inits, + chunksOf, + -- ** Sequential searches - , takeWhileL - , takeWhileR - , dropWhileL - , dropWhileR - , spanl - , spanr - , breakl - , breakr - , partition - , filter + takeWhileL, + takeWhileR, + dropWhileL, + dropWhileR, + spanl, + spanr, + breakl, + breakr, + partition, + filter, + -- * Sorting - , sort - , sortBy - , sortOn - , unstableSort - , unstableSortBy - , unstableSortOn + sort, + sortBy, + sortOn, + unstableSort, + unstableSortBy, + unstableSortOn, + -- * Indexing - , lookup - , (!?) - , index - , adjust - , adjust' - , update - , take - , drop - , insertAt - , deleteAt - , splitAt + lookup, + (!?), + index, + adjust, + adjust', + update, + take, + drop, + insertAt, + deleteAt, + splitAt, + -- ** Indexing with predicates + -- | These functions perform sequential searches from the left -- or right ends of the sequence returning indices of matching -- elements. - , elemIndexL - , elemIndicesL - , elemIndexR - , elemIndicesR - , findIndexL - , findIndicesL - , findIndexR - , findIndicesR + elemIndexL, + elemIndicesL, + elemIndexR, + elemIndicesR, + findIndexL, + findIndicesL, + findIndexR, + findIndicesR, + -- * Folds + -- | General folds are available via the 'Foldable' instance of 'Seq'. - , foldMapWithIndex - , foldlWithIndex - , foldrWithIndex + foldMapWithIndex, + foldlWithIndex, + foldrWithIndex, + -- * Transformations - , mapWithIndex - , traverseWithIndex - , traverseWithIndex1 - , reverse - , intersperse + mapWithIndex, + traverseWithIndex, + traverseWithIndex1, + reverse, + intersperse, + -- ** Zips and unzip - , zip - , zipWith - , zip3 - , zipWith3 - , zip4 - , zipWith4 - , unzip - , unzipWith - ) where + zip, + zipWith, + zip3, + zipWith3, + zip4, + zipWith4, + unzip, + unzipWith, +) where -import Control.Applicative -import Control.Monad hiding (replicateM) -import Data.Bifunctor -import Data.Functor.Apply -import Data.Sequence (Seq(..)) -import Data.Sequence.NonEmpty.Internal -import Data.These -import Prelude hiding (length, scanl, scanl1, scanr, scanr1, splitAt, zip, zipWith, zip3, zipWith3, unzip, replicate, filter, reverse, lookup, take, drop, head, tail, init, last, map) -import qualified Data.Sequence as Seq +import Control.Applicative +import Control.Monad hiding (replicateM) +import Data.Bifunctor +import Data.Functor.Apply +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Sequence.NonEmpty.Internal +import Data.These +import Prelude hiding ( + drop, + filter, + head, + init, + last, + length, + lookup, + map, + replicate, + reverse, + scanl, + scanl1, + scanr, + scanr1, + splitAt, + tail, + take, + unzip, + zip, + zip3, + zipWith, + zipWith3, + ) -- | /O(1)/. The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat -- a 'Seq' as if it were either a @'IsNonEmpty' n@ (where @n@ is a 'NESeq') @@ -199,7 +239,7 @@ -- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert -- a 'NESeq' back into a 'Seq', obscuring its non-emptiness (see 'toSeq'). pattern IsNonEmpty :: NESeq a -> Seq a -pattern IsNonEmpty n <- (nonEmptySeq->Just n) +pattern IsNonEmpty n <- (nonEmptySeq -> Just n) where IsNonEmpty n = toSeq n @@ -217,7 +257,7 @@ -- -- See 'IsNonEmpty' for more information. pattern IsEmpty :: Seq a -pattern IsEmpty <- (Seq.null->True) +pattern IsEmpty <- (Seq.null -> True) where IsEmpty = Seq.empty @@ -237,7 +277,7 @@ -- > nonEmptySeq (Data.Sequence.fromList [1,2,3]) == Just (fromList (1) :| [2,3]) nonEmptySeq :: Seq a -> Maybe (NESeq a) nonEmptySeq (x :<| xs) = Just $ x :<|| xs -nonEmptySeq Empty = Nothing +nonEmptySeq Empty = Nothing {-# INLINE nonEmptySeq #-} -- | /O(1)/. Unsafe version of 'nonEmptySeq'. Coerces a 'Seq' into an @@ -245,7 +285,7 @@ -- attempted) for an empty 'Seq'. unsafeFromSeq :: Seq a -> NESeq a unsafeFromSeq (x :<| xs) = x :<|| xs -unsafeFromSeq Empty = errorWithoutStackTrace "NESeq.unsafeFromSeq: empty seq" +unsafeFromSeq Empty = errorWithoutStackTrace "NESeq.unsafeFromSeq: empty seq" {-# INLINE unsafeFromSeq #-} -- | Turn a 'Seq' into a guarantted non-empty 'NESeq' by adding an element @@ -254,10 +294,10 @@ -- > insertSeqAt 1 0 (Data.Sequence.fromList [1,2,3]) == fromList (1 :| [0,2,3]) insertSeqAt :: Int -> a -> Seq a -> NESeq a insertSeqAt i y - | i <= 0 = (y :<||) - | otherwise = \case - x :<| xs -> x :<|| Seq.insertAt (i - 1) y xs - Empty -> y :<|| Seq.empty + | i <= 0 = (y :<||) + | otherwise = \case + x :<| xs -> x :<|| Seq.insertAt (i - 1) y xs + Empty -> y :<|| Seq.empty {-# INLINE insertSeqAt #-} -- | \( O(1) \). Add an element to the right end of a non-empty sequence. @@ -287,8 +327,8 @@ -- preferred whenever possible. replicateA :: Applicative f => Int -> f a -> f (NESeq a) replicateA n x - | n < 1 = error "NESeq.replicateA: must take a positive integer argument" - | otherwise = liftA2 (:<||) x (Seq.replicateA (n - 1) x) + | n < 1 = error "NESeq.replicateA: must take a positive integer argument" + | otherwise = liftA2 (:<||) x (Seq.replicateA (n - 1) x) {-# INLINE replicateA #-} -- | 'replicateA' is an 'Apply' version of 'replicate', and makes \( O(\log @@ -297,10 +337,10 @@ -- > replicateA1 n x = sequence1 (replicate n x) replicateA1 :: Apply f => Int -> f a -> f (NESeq a) replicateA1 n x - | n < 1 = error "NESeq.replicateA1: must take a positive integer argument" - | otherwise = case runMaybeApply (Seq.replicateA (n - 1) (MaybeApply (Left x))) of - Left xs -> (:<||) <$> x <.> xs - Right xs -> (:<|| xs) <$> x + | n < 1 = error "NESeq.replicateA1: must take a positive integer argument" + | otherwise = case runMaybeApply (Seq.replicateA (n - 1) (MaybeApply (Left x))) of + Left xs -> (:<||) <$> x <.> xs + Right xs -> (:<|| xs) <$> x {-# INLINE replicateA1 #-} -- | An alias of 'replicateA'. @@ -319,9 +359,9 @@ -- @replicate k () *> xs@. cycleTaking :: Int -> NESeq a -> NESeq a cycleTaking n xs0@(x :<|| xs) - | n < 1 = error "NESeq.cycleTaking: must take a positive integer argument" - | n < Seq.length xs = x :<|| Seq.take (n - 1) xs - | otherwise = xs0 |>< Seq.cycleTaking (n - length xs0) (toSeq xs0) + | n < 1 = error "NESeq.cycleTaking: must take a positive integer argument" + | n < Seq.length xs = x :<|| Seq.take (n - 1) xs + | otherwise = xs0 |>< Seq.cycleTaking (n - length xs0) (toSeq xs0) {-# INLINE cycleTaking #-} -- | \( O(n) \). Constructs a sequence by repeated application of @@ -330,8 +370,8 @@ -- > iterateN n f x = fromList (fromJust (nonEmpty ((Prelude.take n (Prelude.iterate f x))))) iterateN :: Int -> (a -> a) -> a -> NESeq a iterateN n f x - | n < 1 = error "NESeq.iterateN: must take a positive integer argument" - | otherwise = x :<|| Seq.iterateN (n - 1) f (f x) + | n < 1 = error "NESeq.iterateN: must take a positive integer argument" + | otherwise = x :<|| Seq.iterateN (n - 1) f (f x) {-# INLINE iterateN #-} -- | Builds a sequence from a seed value. Takes time linear in the @@ -382,7 +422,6 @@ init (xs :||> _) = xs {-# INLINE init #-} - -- | 'scanl' is similar to 'foldl', but returns a sequence of reduced -- values from the left: -- @@ -419,7 +458,7 @@ -- TODO: is this true? inits :: NESeq a -> NESeq (NESeq a) inits xs@(ys :||> _) = withNonEmpty (singleton xs) ((|> xs) . inits) ys -{-# INLINABLE inits #-} +{-# INLINEABLE inits #-} -- | \(O \Bigl(\bigl(\frac{n}{c}\bigr) \log c\Bigr)\). @chunksOf c xs@ splits @xs@ into chunks of size @c>0@. -- If @c@ does not divide the length of @xs@ evenly, then the last element @@ -436,11 +475,11 @@ chunksOf n = go where go xs = case splitAt n xs of - This ys -> singleton ys - That _ -> e + This ys -> singleton ys + That _ -> e These ys zs -> ys <| go zs e = error "chunksOf: A non-empty sequence can only be broken up into positively-sized chunks." -{-# INLINABLE chunksOf #-} +{-# INLINEABLE chunksOf #-} -- | \( O(i) \) where \( i \) is the prefix length. 'takeWhileL', applied -- to a predicate @p@ and a sequence @xs@, returns the longest prefix @@ -450,8 +489,8 @@ -- fails on the first item. takeWhileL :: (a -> Bool) -> NESeq a -> Seq a takeWhileL p (x :<|| xs) - | p x = x Seq.<| Seq.takeWhileL p xs - | otherwise = Seq.empty + | p x = x Seq.<| Seq.takeWhileL p xs + | otherwise = Seq.empty {-# INLINE takeWhileL #-} -- | \( O(i) \) where \( i \) is the suffix length. 'takeWhileR', applied @@ -464,8 +503,8 @@ -- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@. takeWhileR :: (a -> Bool) -> NESeq a -> Seq a takeWhileR p (xs :||> x) - | p x = Seq.takeWhileR p xs Seq.|> x - | otherwise = Seq.empty + | p x = Seq.takeWhileR p xs Seq.|> x + | otherwise = Seq.empty {-# INLINE takeWhileR #-} -- | \( O(i) \) where \( i \) is the prefix length. @'dropWhileL' p xs@ returns @@ -475,8 +514,8 @@ -- passes for all items. dropWhileL :: (a -> Bool) -> NESeq a -> Seq a dropWhileL p xs0@(x :<|| xs) - | p x = Seq.dropWhileL p xs - | otherwise = toSeq xs0 + | p x = Seq.dropWhileL p xs + | otherwise = toSeq xs0 {-# INLINE dropWhileL #-} -- | \( O(i) \) where \( i \) is the suffix length. @'dropWhileR' p xs@ returns @@ -488,8 +527,8 @@ -- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@. dropWhileR :: (a -> Bool) -> NESeq a -> Seq a dropWhileR p xs0@(xs :||> x) - | p x = Seq.dropWhileR p xs - | otherwise = toSeq xs0 + | p x = Seq.dropWhileR p xs + | otherwise = toSeq xs0 {-# INLINE dropWhileR #-} -- | \( O(i) \) where \( i \) is the prefix length. 'spanl', applied to @@ -504,15 +543,15 @@ -- predicae) and @zs@ (the remainder of the sequence) spanl :: (a -> Bool) -> NESeq a -> These (NESeq a) (NESeq a) spanl p xs0@(x :<|| xs) - | p x = case (nonEmptySeq ys, nonEmptySeq zs) of - (Nothing , Nothing ) -> This (singleton x) - (Just _ , Nothing ) -> This xs0 - (Nothing , Just zs') -> These (singleton x) zs' - (Just ys', Just zs') -> These (x <| ys') zs' - | otherwise = That xs0 + | p x = case (nonEmptySeq ys, nonEmptySeq zs) of + (Nothing, Nothing) -> This (singleton x) + (Just _, Nothing) -> This xs0 + (Nothing, Just zs') -> These (singleton x) zs' + (Just ys', Just zs') -> These (x <| ys') zs' + | otherwise = That xs0 where (ys, zs) = Seq.spanl p xs -{-# INLINABLE spanl #-} +{-# INLINEABLE spanl #-} -- | \( O(i) \) where \( i \) is the suffix length. 'spanr', applied to -- a predicate @p@ and a sequence @xs@, returns a 'These' based on the @@ -526,15 +565,15 @@ -- predicae) and @zs@ (the remainder of the sequence, before the suffix) spanr :: (a -> Bool) -> NESeq a -> These (NESeq a) (NESeq a) spanr p xs0@(xs :||> x) - | p x = case (nonEmptySeq ys, nonEmptySeq zs) of - (Nothing , Nothing ) -> This (singleton x) - (Just _ , Nothing ) -> This xs0 - (Nothing , Just zs') -> These (singleton x) zs' - (Just ys', Just zs') -> These (ys' |> x ) zs' - | otherwise = That xs0 + | p x = case (nonEmptySeq ys, nonEmptySeq zs) of + (Nothing, Nothing) -> This (singleton x) + (Just _, Nothing) -> This xs0 + (Nothing, Just zs') -> These (singleton x) zs' + (Just ys', Just zs') -> These (ys' |> x) zs' + | otherwise = That xs0 where (ys, zs) = Seq.spanr p xs -{-# INLINABLE spanr #-} +{-# INLINEABLE spanr #-} -- | \( O(i) \) where \( i \) is the breakpoint index. -- @@ -563,21 +602,21 @@ -- predicate was false). partition :: (a -> Bool) -> NESeq a -> These (NESeq a) (NESeq a) partition p xs0@(x :<|| xs) = case (nonEmptySeq ys, nonEmptySeq zs) of - (Nothing , Nothing ) - | p x -> This (singleton x) - | otherwise -> That (singleton x) - (Just ys', Nothing ) - | p x -> This xs0 - | otherwise -> These ys' (singleton x) - (Nothing, Just zs' ) - | p x -> These (singleton x) zs' - | otherwise -> That xs0 - (Just ys', Just zs') - | p x -> These (x <| ys') zs' - | otherwise -> These ys' (x <| zs') + (Nothing, Nothing) + | p x -> This (singleton x) + | otherwise -> That (singleton x) + (Just ys', Nothing) + | p x -> This xs0 + | otherwise -> These ys' (singleton x) + (Nothing, Just zs') + | p x -> These (singleton x) zs' + | otherwise -> That xs0 + (Just ys', Just zs') + | p x -> These (x <| ys') zs' + | otherwise -> These ys' (x <| zs') where (ys, zs) = Seq.partition p xs -{-# INLINABLE partition #-} +{-# INLINEABLE partition #-} -- | \( O(n) \). The 'filter' function takes a predicate @p@ and a sequence -- @xs@ and returns a sequence of those elements which satisfy the @@ -587,8 +626,8 @@ -- predicate fails for all items in the sequence. filter :: (a -> Bool) -> NESeq a -> Seq a filter p (x :<|| xs) - | p x = x Seq.<| Seq.filter p xs - | otherwise = Seq.filter p xs + | p x = x Seq.<| Seq.filter p xs + | otherwise = Seq.filter p xs {-# INLINE filter #-} -- | \( O(n \log n) \). 'sort' sorts the specified 'NESeq' by the natural @@ -604,9 +643,10 @@ -- TODO: benchmark against just unsafe unwrapping and wrapping sortBy :: (a -> a -> Ordering) -> NESeq a -> NESeq a -sortBy c (x :<|| xs) = withNonEmpty (singleton x) (insertBy c x) - . Seq.sortBy c - $ xs +sortBy c (x :<|| xs) = + withNonEmpty (singleton x) (insertBy c x) + . Seq.sortBy c + $ xs {-# INLINE sortBy #-} -- | \( O(n \log n) \). 'sortOn' sorts the specified 'NESeq' by comparing @@ -631,9 +671,10 @@ -- TODO: benchmark against just unsafe unwrapping and wrapping sortOn :: Ord b => (a -> b) -> NESeq a -> NESeq a -sortOn f (x :<|| xs) = withNonEmpty (singleton x) (insertOn f x) - . sortOnSeq f - $ xs +sortOn f (x :<|| xs) = + withNonEmpty (singleton x) (insertOn f x) + . Seq.sortOn f + $ xs {-# INLINE sortOn #-} -- | \( O(n \log n) \). 'unstableSort' sorts the specified 'NESeq' by the @@ -680,7 +721,7 @@ -- TODO: figure out how to make it match 'Data.Sequence.unstableSortBy' -- without unsafe wrapping/unwrapping unstableSortOn :: Ord b => (a -> b) -> NESeq a -> NESeq a -unstableSortOn f = unsafeFromSeq . unstableSortOnSeq f . toSeq +unstableSortOn f = unsafeFromSeq . Seq.unstableSortOn f . toSeq -- unstableSortOn f (x :<|| xs) = withNonEmpty (singleton x) (insertOn f x) -- . Seq.unstableSortOn f -- $ xs @@ -688,22 +729,22 @@ insertBy :: (a -> a -> Ordering) -> a -> NESeq a -> NESeq a insertBy c x xs = case spanl ltx xs of - This ys -> ys |> x - That zs -> x <| zs - These ys zs -> ys >< (x <| zs) + This ys -> ys |> x + That zs -> x <| zs + These ys zs -> ys >< (x <| zs) where ltx y = c x y == GT -{-# INLINABLE insertBy #-} +{-# INLINEABLE insertBy #-} insertOn :: Ord b => (a -> b) -> a -> NESeq a -> NESeq a insertOn f x xs = case spanl ltx xs of - This ys -> ys |> x - That zs -> x <| zs - These ys zs -> ys >< (x <| zs) + This ys -> ys |> x + That zs -> x <| zs + These ys zs -> ys >< (x <| zs) where fx = f x ltx y = fx > f y -{-# INLINABLE insertOn #-} +{-# INLINEABLE insertOn #-} -- | \( O(\log(\min(i,n-i))) \). The element at the specified position, -- counting from 0. If the specified position is negative or at @@ -712,7 +753,7 @@ -- Unlike 'index', this can be used to retrieve an element without -- forcing it. lookup :: Int -> NESeq a -> Maybe a -lookup 0 (x :<|| _ ) = Just x +lookup 0 (x :<|| _) = Just x lookup i (_ :<|| xs) = Seq.lookup (i - 1) xs {-# INLINE lookup #-} @@ -743,7 +784,7 @@ -- in update i x' xs -- @ adjust' :: (a -> a) -> Int -> NESeq a -> NESeq a -adjust' f 0 (x :<|| xs) = let !y = f x in y :<|| xs +adjust' f 0 (x :<|| xs) = let !y = f x in y :<|| xs adjust' f i (x :<|| xs) = x :<|| Seq.adjust f (i - 1) xs {-# INLINE adjust' #-} @@ -760,8 +801,8 @@ -- is returned. take :: Int -> NESeq a -> Seq a take i (x :<|| xs) - | i <= 0 = Seq.empty - | otherwise = x Seq.<| Seq.take (i - 1) xs + | i <= 0 = Seq.empty + | otherwise = x Seq.<| Seq.take (i - 1) xs {-# INLINE take #-} -- | \( O(\log(\min(i,n-i))) \). Elements of a sequence after the first @i@. @@ -770,8 +811,8 @@ -- is returned. drop :: Int -> NESeq a -> Seq a drop i xs0@(_ :<|| xs) - | i <= 0 = toSeq xs0 - | otherwise = Seq.drop (i - 1) xs + | i <= 0 = toSeq xs0 + | otherwise = Seq.drop (i - 1) xs {-# INLINE drop #-} -- | \( O(\log(\min(i,n-i))) \). @'insertAt' i x xs@ inserts @x@ into @xs@ @@ -786,8 +827,8 @@ -- prop> insertAt i x xs = take i xs >< singleton x >< drop i xs insertAt :: Int -> a -> NESeq a -> NESeq a insertAt i y xs0@(x :<|| xs) - | i <= 0 = y <| xs0 - | otherwise = x :<|| Seq.insertAt (i - 1) y xs + | i <= 0 = y <| xs0 + | otherwise = x :<|| Seq.insertAt (i - 1) y xs {-# INLINE insertAt #-} -- | \( O(\log(\min(i,n-i))) \). Delete the element of a sequence at a given @@ -799,9 +840,9 @@ -- @ deleteAt :: Int -> NESeq a -> Seq a deleteAt i xs0@(x :<|| xs) = case compare i 0 of - LT -> toSeq xs0 - EQ -> xs - GT -> x Seq.<| Seq.deleteAt (i - 1) xs + LT -> toSeq xs0 + EQ -> xs + GT -> x Seq.<| Seq.deleteAt (i - 1) xs {-# INLINE deleteAt #-} -- | \( O(\log(\min(i,n-i))) \). Split a sequence at a given position. @@ -815,15 +856,15 @@ -- after the given position, @drop n xs@). splitAt :: Int -> NESeq a -> These (NESeq a) (NESeq a) splitAt n xs0@(x :<|| xs) - | n <= 0 = That xs0 - | otherwise = case (nonEmptySeq ys, nonEmptySeq zs) of - (Nothing , Nothing ) -> This (singleton x) - (Just _ , Nothing ) -> This xs0 - (Nothing , Just zs') -> These (singleton x) zs' - (Just ys', Just zs') -> These (x <| ys') zs' + | n <= 0 = That xs0 + | otherwise = case (nonEmptySeq ys, nonEmptySeq zs) of + (Nothing, Nothing) -> This (singleton x) + (Just _, Nothing) -> This xs0 + (Nothing, Just zs') -> These (singleton x) zs' + (Just ys', Just zs') -> These (x <| ys') zs' where (ys, zs) = Seq.splitAt (n - 1) xs -{-# INLINABLE splitAt #-} +{-# INLINEABLE splitAt #-} -- | 'elemIndexL' finds the leftmost index of the specified element, -- if it is present, and otherwise 'Nothing'. @@ -854,7 +895,7 @@ findIndexL :: (a -> Bool) -> NESeq a -> Maybe Int findIndexL p (x :<|| xs) = here_ <|> there_ where - here_ = 0 <$ guard (p x) + here_ = 0 <$ guard (p x) there_ = (+ 1) <$> Seq.findIndexL p xs {-# INLINE findIndexL #-} @@ -863,7 +904,7 @@ findIndexR :: (a -> Bool) -> NESeq a -> Maybe Int findIndexR p (xs :||> x) = here_ <|> there_ where - here_ = Seq.length xs <$ guard (p x) + here_ = Seq.length xs <$ guard (p x) there_ = Seq.findIndexR p xs {-# INLINE findIndexR #-} @@ -873,8 +914,8 @@ -- TODO: use build findIndicesL :: (a -> Bool) -> NESeq a -> [Int] findIndicesL p (x :<|| xs) - | p x = 0 : ixs - | otherwise = ixs + | p x = 0 : ixs + | otherwise = ixs where ixs = (+ 1) <$> Seq.findIndicesL p xs {-# INLINE findIndicesL #-} @@ -885,8 +926,8 @@ -- TODO: use build findIndicesR :: (a -> Bool) -> NESeq a -> [Int] findIndicesR p (xs :||> x) - | p x = Seq.length xs : ixs - | otherwise = ixs + | p x = Seq.length xs : ixs + | otherwise = ixs where ixs = Seq.findIndicesR p xs {-# INLINE findIndicesR #-} @@ -909,14 +950,18 @@ mapWithIndex :: (Int -> a -> b) -> NESeq a -> NESeq b mapWithIndex f (x :<|| xs) = f 0 x :<|| Seq.mapWithIndex (f . (+ 1)) xs {-# NOINLINE [1] mapWithIndex #-} + {-# RULES -"mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) = - mapWithIndex (\k a -> f k (g k a)) xs -"mapWithIndex/map" forall f g xs . mapWithIndex f (map g xs) = - mapWithIndex (\k a -> f k (g a)) xs -"map/mapWithIndex" forall f g xs . map f (mapWithIndex g xs) = - mapWithIndex (\k a -> f (g k a)) xs - #-} +"mapWithIndex/mapWithIndex" forall f g xs. + mapWithIndex f (mapWithIndex g xs) = + mapWithIndex (\k a -> f k (g k a)) xs +"mapWithIndex/map" forall f g xs. + mapWithIndex f (map g xs) = + mapWithIndex (\k a -> f k (g a)) xs +"map/mapWithIndex" forall f g xs. + map f (mapWithIndex g xs) = + mapWithIndex (\k a -> f (g k a)) xs + #-} -- | 'traverseWithIndex' is a version of 'traverse' that also offers -- access to the index of each element. @@ -926,12 +971,15 @@ traverseWithIndex :: Applicative f => (Int -> a -> f b) -> NESeq a -> f (NESeq b) traverseWithIndex f (x :<|| xs) = (:<||) <$> f 0 x <*> Seq.traverseWithIndex (f . (+ 1)) xs {-# NOINLINE [1] traverseWithIndex #-} + {-# RULES -"travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) = - traverseWithIndex (\k a -> f k (g k a)) xs -"travWithIndex/map" forall f g xs . traverseWithIndex f (map g xs) = - traverseWithIndex (\k a -> f k (g a)) xs - #-} +"travWithIndex/mapWithIndex" forall f g xs. + traverseWithIndex f (mapWithIndex g xs) = + traverseWithIndex (\k a -> f k (g k a)) xs +"travWithIndex/map" forall f g xs. + traverseWithIndex f (map g xs) = + traverseWithIndex (\k a -> f k (g a)) xs + #-} -- | \( O(n) \). The reverse of a sequence. reverse :: NESeq a -> NESeq a @@ -944,9 +992,9 @@ mapReverse f (x :<|| xs) = fmap f (Seq.reverse xs) :||> f x {-# RULES -"map/reverse" forall f xs . map f (reverse xs) = mapReverse f xs -"reverse/map" forall f xs . reverse (map f xs) = mapReverse f xs - #-} +"map/reverse" forall f xs. map f (reverse xs) = mapReverse f xs +"reverse/map" forall f xs. reverse (map f xs) = mapReverse f xs + #-} -- | \( O(n) \). Intersperse an element between the elements of a sequence. -- @@ -1003,12 +1051,13 @@ -- calculating the sequence of pairs and using 'fmap' to extract each -- component sequence. unzipWith :: (a -> (b, c)) -> NESeq a -> (NESeq b, NESeq c) -unzipWith f (x :<|| xs) = bimap (y :<||) (z :<||) . unzipWithSeq f $ xs +unzipWith f (x :<|| xs) = bimap (y :<||) (z :<||) . Seq.unzipWith f $ xs where ~(y, z) = f x {-# NOINLINE [1] unzipWith #-} {-# RULES -"unzipWith/map" forall f g xs. unzipWith f (map g xs) = - unzipWith (f . g) xs - #-} +"unzipWith/map" forall f g xs. + unzipWith f (map g xs) = + unzipWith (f . g) xs + #-} 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 @@ -1,11 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : Data.Sequence.NonEmpty.Internal @@ -21,55 +21,55 @@ -- break the abstraction of 'NESeq' and produce unsound sequences, so be -- wary! module Data.Sequence.NonEmpty.Internal ( - NESeq(..) - , pattern (:<||) - , pattern (:||>) - , withNonEmpty - , toSeq - , singleton - , length - , fromList - , fromFunction - , replicate - , index - , (<|), (><), (|><) - , map - , foldMapWithIndex - , traverseWithIndex1 - , tails - , zip - , zipWith - , unzip - , sortOnSeq - , unstableSortOnSeq - , unzipSeq - , unzipWithSeq - ) where + NESeq (..), + pattern (:<||), + pattern (:||>), + withNonEmpty, + toSeq, + singleton, + length, + fromList, + fromFunction, + replicate, + index, + (<|), + (><), + (|><), + map, + foldMapWithIndex, + traverseWithIndex1, + tails, + zip, + zipWith, + unzip, +) where -import Control.Comonad -import Control.DeepSeq -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Bifunctor -import Data.Coerce -import Data.Data -import Data.Functor.Alt -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Extend -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup -import Data.Functor.Invariant -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Data.Sequence (Seq(..)) -import Prelude hiding (length, zipWith, unzip, zip, map, replicate) -import Text.Read -import qualified Data.Aeson as A -import qualified Data.Foldable as F -import qualified Data.Sequence as Seq +import Control.Comonad +import Control.DeepSeq +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Zip +import qualified Data.Aeson as A +import Data.Bifunctor +import Data.Coerce +import Data.Data +import qualified Data.Foldable as F +import Data.Functor.Alt +import Data.Functor.Bind +import Data.Functor.Classes +import Data.Functor.Extend +import Data.Functor.Invariant +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Text.Read +import Prelude hiding (length, map, replicate, unzip, zip, zipWith) +{-# ANN module "HLint: ignore Avoid NonEmpty.unzip" #-} + -- | A general-purpose non-empty (by construction) finite sequence type. -- -- Non-emptiness means that: @@ -109,9 +109,10 @@ -- You can convert an 'NESeq' into a 'Seq' with 'toSeq' or -- 'Data.Sequence.NonEmpty.IsNonEmpty', essentially "obscuring" the -- non-empty property from the type. -data NESeq a = NESeq { nesHead :: a - , nesTail :: !(Seq a) - } +data NESeq a = NESeq + { nesHead :: a + , nesTail :: !(Seq a) + } deriving (Traversable, Typeable) -- | /O(1)/. An abstract constructor for an 'NESeq' that consists of @@ -122,11 +123,12 @@ -- a 'Seq', ensuring that the result is non-empty. pattern (:<||) :: a -> Seq a -> NESeq a pattern x :<|| xs = NESeq x xs + {-# COMPLETE (:<||) #-} unsnoc :: NESeq a -> (Seq a, a) unsnoc (x :<|| (xs :|> y)) = (x :<| xs, y) -unsnoc (x :<|| Empty ) = (Empty , x) +unsnoc (x :<|| Empty) = (Empty, x) {-# INLINE unsnoc #-} -- | /O(1)/. An abstract constructor for an 'NESeq' that consists of @@ -137,10 +139,11 @@ -- to /construct/ an 'NESeq' by snocing an item to the end of a 'Seq', -- ensuring that the result is non-empty. pattern (:||>) :: Seq a -> a -> NESeq a -pattern xs :||> x <- (unsnoc->(!xs, x)) +pattern xs :||> x <- (unsnoc -> (!xs, x)) where (x :<| xs) :||> y = x :<|| (xs :|> y) - Empty :||> y = y :<|| Empty + Empty :||> y = y :<|| Empty + {-# COMPLETE (:||>) #-} infixr 5 `NESeq` @@ -148,63 +151,75 @@ infixl 5 :||> instance Show a => Show (NESeq a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromList (" . shows (toNonEmpty xs) . showString ")" + showsPrec p xs = + showParen (p > 10) $ + showString "fromList (" . shows (toNonEmpty xs) . showString ")" instance Read a => Read (NESeq a) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- parens . prec 10 $ readPrec - return (fromList xs) - readListPrec = readListPrecDefault + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- parens . prec 10 $ readPrec + return (fromList xs) + readListPrec = readListPrecDefault instance Eq a => Eq (NESeq a) where - xs == ys = length xs == length ys - && toNonEmpty xs == toNonEmpty ys + xs == ys = + length xs == length ys + && toNonEmpty xs == toNonEmpty ys instance Ord a => Ord (NESeq a) where - compare xs ys = compare (F.toList xs) (F.toList ys) + compare xs ys = compare (F.toList xs) (F.toList ys) instance Show1 NESeq where - liftShowsPrec sp sl d m = - showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toNonEmpty m) + liftShowsPrec sp sl d m = + showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toNonEmpty m) instance Read1 NESeq where - liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do - ("fromList",s) <- lex r - (xs, t) <- liftReadsPrec _rp readLst 10 s - pure (fromList xs, t) + liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do + ("fromList", s) <- lex r + (xs, t) <- liftReadsPrec _rp readLst 10 s + pure (fromList xs, t) instance Eq1 NESeq where - liftEq eq xs ys = length xs == length ys && liftEq eq (toNonEmpty xs) (toNonEmpty ys) + liftEq eq xs ys = length xs == length ys && liftEq eq (toNonEmpty xs) (toNonEmpty ys) instance Ord1 NESeq where - liftCompare cmp xs ys = liftCompare cmp (toNonEmpty xs) (toNonEmpty ys) + liftCompare cmp xs ys = liftCompare cmp (toNonEmpty xs) (toNonEmpty ys) +#if MIN_VERSION_base(4,16,0) instance Data a => Data (NESeq a) where - gfoldl f z (x :<|| xs) = z (:<||) `f` x `f` xs - gunfold k z _ = k (k (z (:<||))) - toConstr _ = consConstr - dataTypeOf _ = seqDataType - dataCast1 f = gcast1 f + gfoldl f z (x :<|| xs) = z (:<||) `f` x `f` xs + gunfold k z _ = k (k (z (:<||))) + toConstr _ = consConstr + dataTypeOf _ = seqDataType + dataCast1 = gcast1 +#else +#ifndef __HLINT__ +instance Data a => Data (NESeq a) where + gfoldl f z (x :<|| xs) = z (:<||) `f` x `f` xs + gunfold k z _ = k (k (z (:<||))) + toConstr _ = consConstr + dataTypeOf _ = seqDataType + dataCast1 f = gcast1 f +#endif +#endif consConstr :: Constr -consConstr = mkConstr seqDataType ":<||" [] Infix +consConstr = mkConstr seqDataType ":<||" [] Infix seqDataType :: DataType seqDataType = mkDataType "Data.Sequence.NonEmpty.Internal.NESeq" [consConstr] - instance A.ToJSON a => A.ToJSON (NESeq a) where - toJSON = A.toJSON . toSeq - toEncoding = A.toEncoding . toSeq + toJSON = A.toJSON . toSeq + toEncoding = A.toEncoding . toSeq instance A.FromJSON a => A.FromJSON (NESeq a) where - parseJSON = withNonEmpty (fail err) pure - <=< A.parseJSON - where - err = "NESeq: Non-empty sequence expected, but empty sequence found" - + parseJSON = + withNonEmpty (fail err) pure + <=< A.parseJSON + where + err = "NESeq: Non-empty sequence expected, but empty sequence found" -- | /O(log n)/. A general continuation-based way to consume a 'Seq' as if -- it were an 'NESeq'. @'withNonEmpty' def f@ will take a 'Seq'. If map is @@ -214,8 +229,8 @@ -- @'Data.Sequence.NonEmpty.nonEmptySeq' == 'withNonEmpty' 'Nothing' 'Just'@ withNonEmpty :: r -> (NESeq a -> r) -> Seq a -> r withNonEmpty def f = \case - x :<| xs -> f (x :<|| xs) - Empty -> def + x :<| xs -> f (x :<|| xs) + Empty -> def {-# INLINE withNonEmpty #-} -- | /O(1)/. @@ -253,15 +268,15 @@ -- sequence into a sequence. fromFunction :: Int -> (Int -> a) -> NESeq a fromFunction n f - | n < 1 = error "NESeq.fromFunction: must take a positive integer argument" - | otherwise = f 0 :<|| Seq.fromFunction (n - 1) (f . (+ 1)) + | n < 1 = error "NESeq.fromFunction: must take a positive integer argument" + | otherwise = f 0 :<|| Seq.fromFunction (n - 1) (f . (+ 1)) -- | \( O(\log n) \). @replicate n x@ is a sequence consisting of @n@ -- copies of @x@. Is only defined when @n@ is positive. replicate :: Int -> a -> NESeq a replicate n x - | n < 1 = error "NESeq.replicate: must take a positive integer argument" - | otherwise = x :<|| Seq.replicate (n - 1) x + | n < 1 = error "NESeq.replicate: must take a positive integer argument" + | otherwise = x :<|| Seq.replicate (n - 1) x {-# INLINE replicate #-} -- | \( O(\log(\min(i,n-i))) \). The element at the specified position, @@ -276,7 +291,7 @@ -- leak if the result is stored, unforced, in another structure. To retrieve -- an element immediately without forcing it, use 'lookup' or '(!?)'. index :: NESeq a -> Int -> a -index (x :<|| _ ) 0 = x +index (x :<|| _) 0 = x index (_ :<|| xs) i = xs `Seq.index` (i - 1) {-# INLINE index #-} @@ -307,12 +322,13 @@ map :: (a -> b) -> NESeq a -> NESeq b map f (x :<|| xs) = f x :<|| fmap f xs {-# NOINLINE [1] map #-} + {-# RULES -"map/map" forall f g xs . map f (map g xs) = map (f . g) xs - #-} +"map/map" forall f g xs. map f (map g xs) = map (f . g) xs + #-} {-# RULES "map/coerce" map coerce = coerce - #-} + #-} -- | /O(n)/. A generalization of 'foldMap1', 'foldMapWithIndex' takes -- a folding function that also depends on the element's index, and applies @@ -333,11 +349,11 @@ -- offers access to the index of each element. traverseWithIndex1 :: Apply f => (Int -> a -> f b) -> NESeq a -> f (NESeq b) traverseWithIndex1 f (x :<|| xs) = case runMaybeApply xs' of - Left ys -> (:<||) <$> f 0 x <.> ys - Right ys -> (:<|| ys) <$> f 0 x + Left ys -> (:<||) <$> f 0 x <.> ys + Right ys -> (:<|| ys) <$> f 0 x where - xs' = Seq.traverseWithIndex (\i -> MaybeApply . Left . f (i+1)) xs -{-# INLINABLE traverseWithIndex1 #-} + xs' = Seq.traverseWithIndex (\i -> MaybeApply . Left . f (i + 1)) xs +{-# INLINEABLE traverseWithIndex1 #-} -- | \( O(n) \). Returns a sequence of all non-empty suffixes of this -- sequence, longest first. For example, @@ -350,7 +366,7 @@ -- TODO: is this true? tails :: NESeq a -> NESeq (NESeq a) tails xs@(_ :<|| ys) = withNonEmpty (singleton xs) ((xs <|) . tails) ys -{-# INLINABLE tails #-} +{-# INLINEABLE tails #-} -- | \( O(\min(n_1,n_2)) \). 'zip' takes two sequences and returns -- a sequence of corresponding pairs. If one input is short, excess @@ -382,81 +398,103 @@ -- -- See the note about efficiency at 'Data.Sequence.NonEmpty.unzipWith'. unzip :: NESeq (a, b) -> (NESeq a, NESeq b) -unzip ((x, y) :<|| xys) = bimap (x :<||) (y :<||) . unzipSeq $ xys +unzip ((x, y) :<|| xys) = bimap (x :<||) (y :<||) . Seq.unzip $ xys {-# INLINE unzip #-} instance Semigroup (NESeq a) where - (<>) = (><) - {-# INLINE (<>) #-} + (<>) = (><) + {-# INLINE (<>) #-} instance Functor NESeq where - fmap = map - {-# INLINE fmap #-} - x <$ xs = replicate (length xs) x - {-# INLINE (<$) #-} + fmap = map + {-# INLINE fmap #-} + x <$ xs = replicate (length xs) x + {-# INLINE (<$) #-} -- | @since 0.3.4.4 instance Invariant NESeq where - invmap f _ = fmap f - {-# INLINE invmap #-} + invmap f _ = fmap f + {-# INLINE invmap #-} instance Apply NESeq where - (f :<|| fs) <.> xs = fxs |>< fsxs - where - fxs = f <$> xs - fsxs = fs <.> toSeq xs - {-# INLINABLE (<.>) #-} + (f :<|| fs) <.> xs = fxs |>< fsxs + where + fxs = f <$> xs + fsxs = fs <.> toSeq xs + {-# INLINEABLE (<.>) #-} instance Applicative NESeq where - pure = singleton - {-# INLINE pure #-} - (<*>) = (<.>) - {-# INLINABLE (<*>) #-} + pure = singleton + {-# INLINE pure #-} + (<*>) = (<.>) + {-# INLINEABLE (<*>) #-} instance Alt NESeq where - () = (><) - {-# INLINE () #-} + () = (><) + {-# INLINE () #-} instance Bind NESeq where - NESeq x xs >>- f = withNonEmpty (f x) ((f x ><) . (>>- f)) xs - {-# INLINABLE (>>-) #-} + NESeq x xs >>- f = withNonEmpty (f x) ((f x ><) . (>>- f)) xs + {-# INLINEABLE (>>-) #-} instance Monad NESeq where - return = pure - {-# INLINE return #-} - (>>=) = (>>-) - {-# INLINABLE (>>=) #-} + return = pure + {-# INLINE return #-} + (>>=) = (>>-) + {-# INLINEABLE (>>=) #-} instance Extend NESeq where - duplicated = tails - {-# INLINE duplicated #-} - extended f xs0@(_ :<|| xs) = withNonEmpty (singleton (f xs0)) - ((f xs0 <|) . extend f) - xs - {-# INLINE extended #-} + duplicated = tails + {-# INLINE duplicated #-} + extended f xs0@(_ :<|| xs) = + withNonEmpty + (singleton (f xs0)) + ((f xs0 <|) . extend f) + xs + {-# INLINE extended #-} instance Comonad NESeq where - extract (x :<|| _) = x - {-# INLINE extract #-} - duplicate = duplicated - {-# INLINE duplicate #-} - extend = extended - {-# INLINE extend #-} + extract (x :<|| _) = x + {-# INLINE extract #-} + duplicate = duplicated + {-# INLINE duplicate #-} + extend = extended + {-# INLINE extend #-} -- | 'foldr1', 'foldl1', 'maximum', and 'minimum' are all total, unlike for -- 'Seq'. -instance Foldable NESeq where #if MIN_VERSION_base(4,11,0) +instance Foldable NESeq where fold (x :<|| xs) = x <> F.fold xs {-# INLINE fold #-} foldMap f (x :<|| xs) = f x <> F.foldMap f xs {-# INLINE foldMap #-} + foldr f z (x :<|| xs) = x `f` foldr f z xs + {-# INLINE foldr #-} + foldr' f z (xs :||> x) = F.foldr' f y xs + where + !y = f x z + {-# INLINE foldr' #-} + foldl f z (xs :||> x) = foldl f z xs `f` x + {-# INLINE foldl #-} + foldl' f z (x :<|| xs) = F.foldl' f y xs + where + !y = f z x + {-# INLINE foldl' #-} + foldr1 f (xs :||> x) = foldr f x xs + {-# INLINE foldr1 #-} + foldl1 f (x :<|| xs) = foldl f x xs + {-# INLINE foldl1 #-} + null _ = False + {-# INLINE null #-} + length = length + {-# INLINE length #-} #else +instance Foldable NESeq where fold (x :<|| xs) = x `mappend` F.fold xs {-# INLINE fold #-} foldMap f (x :<|| xs) = f x `mappend` F.foldMap f xs {-# INLINE foldMap #-} -#endif foldr f z (x :<|| xs) = x `f` foldr f z xs {-# INLINE foldr #-} foldr' f z (xs :||> x) = F.foldr' f y xs @@ -477,43 +515,51 @@ {-# INLINE null #-} length = length {-# INLINE length #-} +#endif -instance Foldable1 NESeq where #if MIN_VERSION_base(4,11,0) +instance Foldable1 NESeq where fold1 (x :<|| xs) = maybe x (x <>) . F.foldMap Just $ xs + {-# INLINE fold1 #-} + foldMap1 f = foldMapWithIndex (const f) + {-# INLINE foldMap1 #-} + -- TODO: use build + toNonEmpty (x :<|| xs) = x :| F.toList xs + {-# INLINE toNonEmpty #-} #else +instance Foldable1 NESeq where fold1 (x :<|| xs) = option x (x <>) . F.foldMap (Option . Just) $ xs -#endif {-# INLINE fold1 #-} foldMap1 f = foldMapWithIndex (const f) {-# INLINE foldMap1 #-} -- TODO: use build toNonEmpty (x :<|| xs) = x :| F.toList xs {-# INLINE toNonEmpty #-} +#endif instance Traversable1 NESeq where - traverse1 f = traverseWithIndex1 (const f) - {-# INLINE traverse1 #-} - sequence1 (x :<|| xs) = case runMaybeApply xs' of - Left ys -> (:<||) <$> x <.> ys - Right ys -> (:<|| ys) <$> x - where - xs' = traverse (MaybeApply . Left) xs - {-# INLINABLE sequence1 #-} + traverse1 f = traverseWithIndex1 (const f) + {-# INLINE traverse1 #-} + sequence1 (x :<|| xs) = case runMaybeApply xs' of + Left ys -> (:<||) <$> x <.> ys + Right ys -> (:<|| ys) <$> x + where + xs' = traverse (MaybeApply . Left) xs + {-# INLINEABLE sequence1 #-} -- | @mzipWith = zipWith@ -- -- @munzip = unzip@ instance MonadZip NESeq where - mzipWith = zipWith - munzip = unzip + mzipWith = zipWith + munzip = unzip instance MonadFix NESeq where - mfix = mfixSeq + mfix = mfixSeq mfixSeq :: (a -> NESeq a) -> NESeq a mfixSeq f = fromFunction (length (f err)) (\k -> fix (\xk -> f xk `index` k)) @@ -521,53 +567,4 @@ err = error "mfix for Data.Sequence.NonEmpty.NESeq applied to strict function" instance NFData a => NFData (NESeq a) where - rnf (x :<|| xs) = rnf x `seq` rnf xs `seq` () - --- --------------------------------------------- --- | CPP for new functions not in old containers --- --------------------------------------------- - --- | Compatibility layer for 'Data.Sequence.sortOn'. -sortOnSeq :: Ord b => (a -> b) -> Seq a -> Seq a -#if MIN_VERSION_containers(0,5,11) -sortOnSeq = Seq.sortOn -#else -sortOnSeq f = Seq.sortBy (\x y -> f x `compare` f y) -#endif -{-# INLINE sortOnSeq #-} - --- | Compatibility layer for 'Data.Sequence.unstableSortOn'. -unstableSortOnSeq :: Ord b => (a -> b) -> Seq a -> Seq a -#if MIN_VERSION_containers(0,5,11) -unstableSortOnSeq = Seq.unstableSortOn -#else -unstableSortOnSeq f = Seq.unstableSortBy (\x y -> f x `compare` f y) -#endif -{-# INLINE unstableSortOnSeq #-} - --- | Compatibility layer for 'Data.Sequence.unzip'. -unzipSeq :: Seq (a, b) -> (Seq a, Seq b) -#if MIN_VERSION_containers(0,5,11) -unzipSeq = Seq.unzip -{-# INLINE unzipSeq #-} -#else -unzipSeq = \case - (x, y) :<| xys -> bimap (x :<|) (y :<|) . unzipSeq $ xys - Empty -> (Empty, Empty) -{-# INLINABLE unzipSeq #-} -#endif - --- | Compatibility layer for 'Data.Sequence.unzipWith'. -unzipWithSeq :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c) -#if MIN_VERSION_containers(0,5,11) -unzipWithSeq = Seq.unzipWith -{-# INLINE unzipWithSeq #-} -#else -unzipWithSeq f = go - where - go = \case - x :<| xs -> let ~(y, z) = f x - in bimap (y :<|) (z :<|) . go $ xs - Empty -> (Empty, Empty) -{-# INLINABLE unzipWithSeq #-} -#endif + rnf (x :<|| xs) = rnf x `seq` rnf xs diff --git a/src/Data/Set/NonEmpty.hs b/src/Data/Set/NonEmpty.hs --- a/src/Data/Set/NonEmpty.hs +++ b/src/Data/Set/NonEmpty.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Set.NonEmpty @@ -46,120 +47,122 @@ -- > import qualified Data.Set.NonEmpty as NES module Data.Set.NonEmpty ( -- * Non-Empty Set Type - NESet + NESet, + -- ** Conversions between empty and non-empty sets - , pattern IsNonEmpty - , pattern IsEmpty - , nonEmptySet - , toSet - , withNonEmpty - , insertSet - , insertSetMin - , insertSetMax - , unsafeFromSet + pattern IsNonEmpty, + pattern IsEmpty, + nonEmptySet, + toSet, + withNonEmpty, + insertSet, + insertSetMin, + insertSetMax, + unsafeFromSet, -- * Construction - , singleton - , fromList - , fromAscList - , fromDescList - , fromDistinctAscList - , fromDistinctDescList - , powerSet + singleton, + fromList, + fromAscList, + fromDescList, + fromDistinctAscList, + fromDistinctDescList, + powerSet, -- * Insertion - , insert + insert, -- * Deletion - , delete + delete, -- * Query - , member - , notMember - , lookupLT - , lookupGT - , lookupLE - , lookupGE - , size - , isSubsetOf - , isProperSubsetOf - , disjoint + member, + notMember, + lookupLT, + lookupGT, + lookupLE, + lookupGE, + size, + isSubsetOf, + isProperSubsetOf, + disjoint, -- * Combine - , union - , unions - , difference - , (\\) - , intersection - , cartesianProduct - , disjointUnion + union, + unions, + difference, + (\\), + intersection, + cartesianProduct, + disjointUnion, -- * Filter - , filter - , takeWhileAntitone - , dropWhileAntitone - , spanAntitone - , partition - , split - , splitMember - , splitRoot + filter, + takeWhileAntitone, + dropWhileAntitone, + spanAntitone, + partition, + split, + splitMember, + splitRoot, -- * Indexed - , lookupIndex - , findIndex - , elemAt - , deleteAt - , take - , drop - , splitAt + lookupIndex, + findIndex, + elemAt, + deleteAt, + take, + drop, + splitAt, -- * Map - , map - , mapMonotonic + map, + mapMonotonic, -- * Folds - , foldr - , foldl - , F.foldr1 - , F.foldl1 + foldr, + foldl, + F.foldr1, + F.foldl1, + -- ** Strict folds - , foldr' - , foldl' - , foldr1' - , foldl1' + foldr', + foldl', + foldr1', + foldl1', -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax + findMin, + findMax, + deleteMin, + deleteMax, + deleteFindMin, + deleteFindMax, -- * Conversion -- ** List - , elems - , toList - , toAscList - , toDescList + elems, + toList, + toAscList, + toDescList, -- * Debugging - , valid - ) where + valid, +) where -import Control.Applicative -import Data.Bifunctor -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe -import Data.Set (Set) -import Data.Set.NonEmpty.Internal -import Data.These -import Prelude hiding (Foldable(..), filter, map, take, drop, splitAt) -import qualified Data.Foldable as F -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup.Foldable as F1 -import qualified Data.Set as S +import Control.Applicative +import Data.Bifunctor +import qualified Data.Foldable as F +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import qualified Data.Semigroup.Foldable as F1 +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.NonEmpty.Internal +import Data.These +import Prelude hiding (Foldable (..), drop, filter, map, splitAt, take) -- | /O(1)/ match, /O(log n)/ usage of contents. The 'IsNonEmpty' and -- 'IsEmpty' patterns allow you to treat a 'Set' as if it were either @@ -187,7 +190,7 @@ -- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert -- a 'NESet' back into a 'Set', obscuring its non-emptiness (see 'toSet'). pattern IsNonEmpty :: NESet a -> Set a -pattern IsNonEmpty n <- (nonEmptySet->Just n) +pattern IsNonEmpty n <- (nonEmptySet -> Just n) where IsNonEmpty n = toSet n @@ -205,7 +208,7 @@ -- -- See 'IsNonEmpty' for more information. pattern IsEmpty :: Set a -pattern IsEmpty <- (S.null->True) +pattern IsEmpty <- (S.null -> True) where IsEmpty = S.empty @@ -214,9 +217,9 @@ -- | /O(log n)/. Unsafe version of 'nonEmptySet'. Coerces a 'Set' into an -- 'NESet', but is undefined (throws a runtime exception when evaluation is -- attempted) for an empty 'Set'. -unsafeFromSet - :: Set a - -> NESet a +unsafeFromSet :: + Set a -> + NESet a unsafeFromSet = withNonEmpty e id where e = errorWithoutStackTrace "NESet.unsafeFromSet: empty set" @@ -276,9 +279,10 @@ -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. -- /The precondition (input list is strictly ascending) is not checked./ fromDistinctAscList :: NonEmpty a -> NESet a -fromDistinctAscList (x :| xs) = insertSetMin x - . S.fromDistinctAscList - $ xs +fromDistinctAscList (x :| xs) = + insertSetMin x + . S.fromDistinctAscList + $ xs {-# INLINE fromDistinctAscList #-} -- | /O(n)/. Build a set from a descending list in linear time. @@ -290,9 +294,10 @@ -- | /O(n)/. Build a set from a descending list of distinct elements in linear time. -- /The precondition (input list is strictly descending) is not checked./ fromDistinctDescList :: NonEmpty a -> NESet a -fromDistinctDescList (x :| xs) = insertSetMax x - . S.fromDistinctDescList - $ xs +fromDistinctDescList (x :| xs) = + insertSetMax x + . S.fromDistinctDescList + $ xs {-# INLINE fromDistinctDescList #-} -- | Calculate the power set of a non-empty: the set of all its (non-empty) @@ -318,58 +323,62 @@ -- -- We know that the result is non-empty because the result will always at -- least contain the original set. -powerSet - :: forall a. () - => NESet a - -> NESet (NESet a) +powerSet :: + forall a. + () => + NESet a -> + NESet (NESet a) powerSet (NESet x s0) = case nonEmptySet p1 of - -- s0 was empty originally - Nothing -> singleton (singleton x) - -- s1 was not empty originally - Just p2 -> mapMonotonic (insertSetMin x) p0 - `merge` p2 + -- s0 was empty originally + Nothing -> singleton (singleton x) + -- s1 was not empty originally + Just p2 -> + mapMonotonic (insertSetMin x) p0 + `merge` p2 where -- powerset should never be empty p0 :: NESet (Set a) - p0@(NESet _ p0s) = forSure $ powerSetSet s0 + p0@(NESet _ p0s) = forSure $ S.powerSet s0 p1 :: Set (NESet a) - p1 = S.mapMonotonic forSure p0s -- only minimal element is empty, so the rest aren't - forSure = withNonEmpty (errorWithoutStackTrace "NESet.powerSet: internal error") - id -{-# INLINABLE powerSet #-} + p1 = S.mapMonotonic forSure p0s -- only minimal element is empty, so the rest aren't + forSure = + withNonEmpty + (errorWithoutStackTrace "NESet.powerSet: internal error") + id +{-# INLINEABLE powerSet #-} -- | /O(log n)/. Insert an element in a set. -- If the set already contains an element equal to the given value, -- it is replaced with the new value. insert :: Ord a => a -> NESet a -> NESet a insert x n@(NESet x0 s) = case compare x x0 of - LT -> NESet x $ toSet n - EQ -> NESet x s - GT -> NESet x0 $ S.insert x s + LT -> NESet x $ toSet n + EQ -> NESet x s + GT -> NESet x0 $ S.insert x s {-# INLINE insert #-} -- | /O(log n)/. Delete an element from a set. delete :: Ord a => a -> NESet a -> Set a delete x n@(NESet x0 s) = case compare x x0 of - LT -> toSet n - EQ -> s - GT -> insertMinSet x0 . S.delete x $ s + LT -> toSet n + EQ -> s + GT -> insertMinSet x0 . S.delete x $ s {-# INLINE delete #-} -- | /O(log n)/. Is the element in the set? member :: Ord a => a -> NESet a -> Bool member x (NESet x0 s) = case compare x x0 of - LT -> False - EQ -> True - GT -> S.member x s + LT -> False + EQ -> True + GT -> S.member x s {-# INLINE member #-} -- | /O(log n)/. Is the element not in the set? notMember :: Ord a => a -> NESet a -> Bool notMember x (NESet x0 s) = case compare x x0 of - LT -> True - EQ -> False - GT -> S.notMember x s + LT -> True + EQ -> False + GT -> S.notMember x s {-# INLINE notMember #-} -- | /O(log n)/. Find largest element smaller than the given one. @@ -378,9 +387,9 @@ -- > lookupLT 5 (fromList (3 :| [5])) == Just 3 lookupLT :: Ord a => a -> NESet a -> Maybe a lookupLT x (NESet x0 s) = case compare x x0 of - LT -> Nothing - EQ -> Nothing - GT -> S.lookupLT x s <|> Just x0 + LT -> Nothing + EQ -> Nothing + GT -> S.lookupLT x s <|> Just x0 {-# INLINE lookupLT #-} -- | /O(log n)/. Find smallest element greater than the given one. @@ -389,9 +398,9 @@ -- > lookupLT 5 (fromList (3 :| [5])) == Nothing lookupGT :: Ord a => a -> NESet a -> Maybe a lookupGT x (NESet x0 s) = case compare x x0 of - LT -> Just x0 - EQ -> S.lookupMin s - GT -> S.lookupGT x s + LT -> Just x0 + EQ -> S.lookupMin s + GT -> S.lookupGT x s {-# INLINE lookupGT #-} -- | /O(log n)/. Find largest element smaller or equal to the given one. @@ -401,9 +410,9 @@ -- > lookupLT 5 (fromList (3 :| [5])) == Just 5 lookupLE :: Ord a => a -> NESet a -> Maybe a lookupLE x (NESet x0 s) = case compare x x0 of - LT -> Nothing - EQ -> Just x0 - GT -> S.lookupLE x s <|> Just x0 + LT -> Nothing + EQ -> Just x0 + GT -> S.lookupLE x s <|> Just x0 {-# INLINE lookupLE #-} -- | /O(log n)/. Find smallest element greater or equal to the given one. @@ -413,30 +422,32 @@ -- > lookupLT 6 (fromList (3 :| [5])) == Nothing lookupGE :: Ord a => a -> NESet a -> Maybe a lookupGE x (NESet x0 s) = case compare x x0 of - LT -> Just x0 - EQ -> Just x0 - GT -> S.lookupGE x s + LT -> Just x0 + EQ -> Just x0 + GT -> S.lookupGE x s {-# INLINE lookupGE #-} -- | /O(n+m)/. Is this a subset? -- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@. -isSubsetOf - :: Ord a - => NESet a - -> NESet a - -> Bool -isSubsetOf (NESet x s0) (toSet->s1) = x `S.member` s1 - && s0 `S.isSubsetOf` s1 +isSubsetOf :: + Ord a => + NESet a -> + NESet a -> + Bool +isSubsetOf (NESet x s0) (toSet -> s1) = + x `S.member` s1 + && s0 `S.isSubsetOf` s1 {-# INLINE isSubsetOf #-} -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). -isProperSubsetOf - :: Ord a - => NESet a - -> NESet a - -> Bool -isProperSubsetOf s0 s1 = S.size (nesSet s0) < S.size (nesSet s1) - && s0 `isSubsetOf` s1 +isProperSubsetOf :: + Ord a => + NESet a -> + NESet a -> + Bool +isProperSubsetOf s0 s1 = + S.size (nesSet s0) < S.size (nesSet s1) + && s0 `isSubsetOf` s1 {-# INLINE isProperSubsetOf #-} -- | /O(n+m)/. Check whether two sets are disjoint (i.e. their intersection @@ -445,18 +456,18 @@ -- > disjoint (fromList (2:|[4,6])) (fromList (1:|[3])) == True -- > disjoint (fromList (2:|[4,6,8])) (fromList (2:|[3,5,7])) == False -- > disjoint (fromList (1:|[2])) (fromList (1:|[2,3,4])) == False -disjoint - :: Ord a - => NESet a - -> NESet a - -> Bool +disjoint :: + Ord a => + NESet a -> + NESet a -> + Bool disjoint n1@(NESet x1 s1) n2@(NESet x2 s2) = case compare x1 x2 of - -- x1 is not in n2 - LT -> s1 `disjointSet` toSet n2 - -- k1 and k2 are a part of the result - EQ -> False - -- k2 is not in n1 - GT -> toSet n1 `disjointSet` s2 + -- x1 is not in n2 + LT -> s1 `S.disjoint` toSet n2 + -- k1 and k2 are a part of the result + EQ -> False + -- k2 is not in n1 + GT -> toSet n1 `S.disjoint` s2 {-# INLINE disjoint #-} -- | /O(m*log(n\/m + 1)), m <= n/. Difference of two sets. @@ -464,26 +475,26 @@ -- Returns a potentially empty set ('Set') because the first set might be -- a subset of the second set, and therefore have all of its elements -- removed. -difference - :: Ord a - => NESet a - -> NESet a - -> Set a +difference :: + Ord a => + NESet a -> + NESet a -> + Set a difference n1@(NESet x1 s1) n2@(NESet x2 s2) = case compare x1 x2 of - -- x1 is not in n2, so cannot be deleted - LT -> insertMinSet x1 $ s1 `S.difference` toSet n2 - -- x2 deletes x1, and only x1 - EQ -> s1 `S.difference` s2 - -- x2 is not in n1, so cannot delete anything, so we can just difference n1 // s2. - GT -> toSet n1 `S.difference` s2 + -- x1 is not in n2, so cannot be deleted + LT -> insertMinSet x1 $ s1 `S.difference` toSet n2 + -- x2 deletes x1, and only x1 + EQ -> s1 `S.difference` s2 + -- x2 is not in n1, so cannot delete anything, so we can just difference n1 // s2. + GT -> toSet n1 `S.difference` s2 {-# INLINE difference #-} -- | Same as 'difference'. -(\\) - :: Ord a - => NESet a - -> NESet a - -> Set a +(\\) :: + Ord a => + NESet a -> + NESet a -> + Set a (\\) = difference {-# INLINE (\\) #-} @@ -502,18 +513,18 @@ -- > NES.singleton B `NES.intersection` NES.singleton A) -- -- prints @(fromList (A:|[]),fromList (B:|[]))@. -intersection - :: Ord a - => NESet a - -> NESet a - -> Set a +intersection :: + Ord a => + NESet a -> + NESet a -> + Set a intersection n1@(NESet x1 s1) n2@(NESet x2 s2) = case compare x1 x2 of - -- x1 is not in n2 - LT -> s1 `S.intersection` toSet n2 - -- x1 and x2 are a part of the result - EQ -> insertMinSet x1 $ s1 `S.intersection` s2 - -- x2 is not in n1 - GT -> toSet n1 `S.intersection` s2 + -- x1 is not in n2 + LT -> s1 `S.intersection` toSet n2 + -- x1 and x2 are a part of the result + EQ -> insertMinSet x1 $ s1 `S.intersection` s2 + -- x2 is not in n1 + GT -> toSet n1 `S.intersection` s2 {-# INLINE intersection #-} -- | Calculate the Cartesian product of two sets. @@ -528,13 +539,14 @@ -- cartesianProduct (fromList (1:|[2])) (fromList (\'a\':|[\'b\'])) = -- fromList ((1,\'a\') :| [(1,\'b\'), (2,\'a\'), (2,\'b\')]) -- @ -cartesianProduct - :: NESet a - -> NESet b - -> NESet (a, b) -cartesianProduct n1 n2 = getMergeNESet - . F1.foldMap1 (\x -> MergeNESet $ mapMonotonic (x,) n2) - $ n1 +cartesianProduct :: + NESet a -> + NESet b -> + NESet (a, b) +cartesianProduct n1 n2 = + getMergeNESet + . F1.foldMap1 (\x -> MergeNESet $ mapMonotonic (x,) n2) + $ n1 {-# INLINE cartesianProduct #-} -- | Calculate the disjoint union of two sets. @@ -547,25 +559,27 @@ -- disjointUnion (fromList (1:|[2])) (fromList ("hi":|["bye"])) = -- fromList (Left 1 :| [Left 2, Right "hi", Right "bye"]) -- @ -disjointUnion - :: NESet a - -> NESet b - -> NESet (Either a b) -disjointUnion (NESet x1 s1) n2 = NESet (Left x1) - (s1 `disjointUnionSet` toSet n2) +disjointUnion :: + NESet a -> + NESet b -> + NESet (Either a b) +disjointUnion (NESet x1 s1) n2 = + NESet + (Left x1) + (s1 `S.disjointUnion` toSet n2) {-# INLINE disjointUnion #-} -- | /O(n)/. Filter all elements that satisfy the predicate. -- -- Returns a potentially empty set ('Set') because the predicate might -- filter out all items in the original non-empty set. -filter - :: (a -> Bool) - -> NESet a - -> Set a +filter :: + (a -> Bool) -> + NESet a -> + Set a filter f (NESet x s1) - | f x = insertMinSet x . S.filter f $ s1 - | otherwise = S.filter f s1 + | f x = insertMinSet x . S.filter f $ s1 + | otherwise = S.filter f s1 {-# INLINE filter #-} -- | /O(log n)/. Take while a predicate on the elements holds. The user is @@ -579,13 +593,13 @@ -- takeWhileAntitone p = Data.Set.fromDistinctAscList . Data.List.NonEmpty.takeWhile p . 'toList' -- takeWhileAntitone p = 'filter' p -- @ -takeWhileAntitone - :: (a -> Bool) - -> NESet a - -> Set a +takeWhileAntitone :: + (a -> Bool) -> + NESet a -> + Set a takeWhileAntitone f (NESet x s) - | f x = insertMinSet x . S.takeWhileAntitone f $ s - | otherwise = S.empty + | f x = insertMinSet x . S.takeWhileAntitone f $ s + | otherwise = S.empty {-# INLINE takeWhileAntitone #-} -- | /O(log n)/. Drop while a predicate on the elements holds. The user is @@ -599,13 +613,13 @@ -- dropWhileAntitone p = Data.Set.fromDistinctAscList . Data.List.NonEmpty.dropWhile p . 'toList' -- dropWhileAntitone p = 'filter' (not . p) -- @ -dropWhileAntitone - :: (a -> Bool) - -> NESet a - -> Set a +dropWhileAntitone :: + (a -> Bool) -> + NESet a -> + Set a dropWhileAntitone f n@(NESet x s) - | f x = S.dropWhileAntitone f s - | otherwise = toSet n + | f x = S.dropWhileAntitone f s + | otherwise = toSet n {-# INLINE dropWhileAntitone #-} -- | /O(log n)/. Divide a set at the point where a predicate on the @@ -630,20 +644,20 @@ -- at some /unspecified/ point where the predicate switches from holding to not -- holding (where the predicate is seen to hold before the first element and to fail -- after the last element). -spanAntitone - :: (a -> Bool) - -> NESet a - -> These (NESet a) (NESet a) +spanAntitone :: + (a -> Bool) -> + NESet a -> + These (NESet a) (NESet a) spanAntitone f n@(NESet x s0) - | f x = case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) -> This n - (Just _ , Nothing) -> This n - (Nothing, Just n2) -> These (singleton x) n2 - (Just _ , Just n2) -> These (insertSetMin x s1) n2 - | otherwise = That n + | f x = case (nonEmptySet s1, nonEmptySet s2) of + (Nothing, Nothing) -> This n + (Just _, Nothing) -> This n + (Nothing, Just n2) -> These (singleton x) n2 + (Just _, Just n2) -> These (insertSetMin x s1) n2 + | otherwise = That n where (s1, s2) = S.spanAntitone f s0 -{-# INLINABLE spanAntitone #-} +{-# INLINEABLE spanAntitone #-} -- | /O(n)/. Partition the map according to a predicate. -- @@ -660,26 +674,26 @@ -- > partition (> 3) (fromList (5 :| [3])) == These (singleton 5) (singleton 3) -- > partition (< 7) (fromList (5 :| [3])) == This (fromList (3 :| [5])) -- > partition (> 7) (fromList (5 :| [3])) == That (fromList (3 :| [5])) -partition - :: (a -> Bool) - -> NESet a - -> These (NESet a) (NESet a) +partition :: + (a -> Bool) -> + NESet a -> + These (NESet a) (NESet a) partition f n@(NESet x s0) = case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) - | f x -> This n - | otherwise -> That n - (Just n1, Nothing) - | f x -> This n - | otherwise -> These n1 (singleton x) - (Nothing, Just n2) - | f x -> These (singleton x) n2 - | otherwise -> That n - (Just n1, Just n2) - | f x -> These (insertSetMin x s1) n2 - | otherwise -> These n1 (insertSetMin x s2) + (Nothing, Nothing) + | f x -> This n + | otherwise -> That n + (Just n1, Nothing) + | f x -> This n + | otherwise -> These n1 (singleton x) + (Nothing, Just n2) + | f x -> These (singleton x) n2 + | otherwise -> That n + (Just n1, Just n2) + | f x -> These (insertSetMin x s1) n2 + | otherwise -> These n1 (insertSetMin x s2) where (s1, s2) = S.partition f s0 -{-# INLINABLE partition #-} +{-# INLINEABLE partition #-} -- | /O(log n)/. The expression (@'split' x set@) is potentially a 'These' -- containing up to two 'NESet's based on splitting the set into sets @@ -704,22 +718,22 @@ -- > split 5 (fromList (5 :| [3])) == Just (This (singleton 3) ) -- > split 6 (fromList (5 :| [3])) == Just (This (fromList (3 :| [5])) ) -- > split 5 (singleton 5) == Nothing -split - :: Ord a - => a - -> NESet a - -> Maybe (These (NESet a) (NESet a)) +split :: + Ord a => + a -> + NESet a -> + Maybe (These (NESet a) (NESet a)) split x n@(NESet x0 s0) = case compare x x0 of - LT -> Just $ That n - EQ -> That <$> nonEmptySet s0 - GT -> case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) -> Just $ This (singleton x0) - (Just _ , Nothing) -> Just $ This (insertSetMin x0 s1) - (Nothing, Just n2) -> Just $ These (singleton x0) n2 - (Just _ , Just n2) -> Just $ These (insertSetMin x0 s1) n2 + LT -> Just $ That n + EQ -> That <$> nonEmptySet s0 + GT -> case (nonEmptySet s1, nonEmptySet s2) of + (Nothing, Nothing) -> Just $ This (singleton x0) + (Just _, Nothing) -> Just $ This (insertSetMin x0 s1) + (Nothing, Just n2) -> Just $ These (singleton x0) n2 + (Just _, Just n2) -> Just $ These (insertSetMin x0 s1) n2 where (s1, s2) = S.split x s0 -{-# INLINABLE split #-} +{-# INLINEABLE split #-} -- | /O(log n)/. The expression (@'splitMember' x set@) splits a set just -- like 'split' but also returns @'member' x set@ (whether or not @x@ was @@ -731,22 +745,22 @@ -- > splitMember 5 (fromList (5 :| [3])) == (True , Just (This (singleton 3)) -- > splitMember 6 (fromList (5 :| [3])) == (False, Just (This (fromList (3 :| [5]))) -- > splitMember 5 (singleton 5) == (True , Nothing) -splitMember - :: Ord a - => a - -> NESet a - -> (Bool, Maybe (These (NESet a) (NESet a))) +splitMember :: + Ord a => + a -> + NESet a -> + (Bool, Maybe (These (NESet a) (NESet a))) splitMember x n@(NESet x0 s0) = case compare x x0 of - LT -> (False, Just $ That n) - EQ -> (True , That <$> nonEmptySet s0) - GT -> (mem ,) $ case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) -> Just $ This (singleton x0) - (Just _ , Nothing) -> Just $ This (insertSetMin x0 s1) - (Nothing, Just n2) -> Just $ These (singleton x0) n2 - (Just _ , Just n2) -> Just $ These (insertSetMin x0 s1) n2 + LT -> (False, Just $ That n) + EQ -> (True, That <$> nonEmptySet s0) + GT -> (mem,) $ case (nonEmptySet s1, nonEmptySet s2) of + (Nothing, Nothing) -> Just $ This (singleton x0) + (Just _, Nothing) -> Just $ This (insertSetMin x0 s1) + (Nothing, Just n2) -> Just $ These (singleton x0) n2 + (Just _, Just n2) -> Just $ These (insertSetMin x0 s1) n2 where (s1, mem, s2) = S.splitMember x s0 -{-# INLINABLE splitMember #-} +{-# INLINEABLE splitMember #-} -- | /O(1)/. Decompose a set into pieces based on the structure of the underlying -- tree. This function is useful for consuming a set in parallel. @@ -759,11 +773,12 @@ -- Note that the current implementation does not return more than four -- subsets, but you should not depend on this behaviour because it can -- change in the future without notice. -splitRoot - :: NESet a - -> NonEmpty (NESet a) -splitRoot (NESet x s) = singleton x - :| mapMaybe nonEmptySet (S.splitRoot s) +splitRoot :: + NESet a -> + NonEmpty (NESet a) +splitRoot (NESet x s) = + singleton x + :| mapMaybe nonEmptySet (S.splitRoot s) {-# INLINE splitRoot #-} -- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based @@ -774,15 +789,15 @@ -- > fromJust (lookupIndex 3 (fromList (5:|[3]))) == 0 -- > fromJust (lookupIndex 5 (fromList (5:|[3]))) == 1 -- > isJust (lookupIndex 6 (fromList (5:|[3]))) == False -lookupIndex - :: Ord a - => a - -> NESet a - -> Maybe Int +lookupIndex :: + Ord a => + a -> + NESet a -> + Maybe Int lookupIndex x (NESet x0 s) = case compare x x0 of - LT -> Nothing - EQ -> Just 0 - GT -> (+ 1) <$> S.lookupIndex x s + LT -> Nothing + EQ -> Just 0 + GT -> (+ 1) <$> S.lookupIndex x s {-# INLINE lookupIndex #-} -- | /O(log n)/. Return the /index/ of an element, which is its zero-based @@ -794,11 +809,11 @@ -- > findIndex 3 (fromList (5:|[3])) == 0 -- > findIndex 5 (fromList (5:|[3])) == 1 -- > findIndex 6 (fromList (5:|[3])) Error: element is not in the set -findIndex - :: Ord a - => a - -> NESet a - -> Int +findIndex :: + Ord a => + a -> + NESet a -> + Int findIndex k = fromMaybe e . lookupIndex k where e = error "NESet.findIndex: element is not in the set" @@ -812,10 +827,10 @@ -- > elemAt 0 (fromList (5:|[3])) == 3 -- > elemAt 1 (fromList (5:|[3])) == 5 -- > elemAt 2 (fromList (5:|[3])) Error: index out of range -elemAt - :: Int - -> NESet a - -> a +elemAt :: + Int -> + NESet a -> + a elemAt 0 (NESet x _) = x elemAt i (NESet _ s) = S.elemAt (i - 1) s {-# INLINE elemAt #-} @@ -832,13 +847,13 @@ -- > deleteAt 1 (fromList (5:|[3])) == singleton 3 -- > deleteAt 2 (fromList (5:|[3])) Error: index out of range -- > deleteAt (-1) (fromList (5:|[3])) Error: index out of range -deleteAt - :: Int - -> NESet a - -> Set a +deleteAt :: + Int -> + NESet a -> + Set a deleteAt 0 (NESet _ s) = s deleteAt i (NESet x s) = insertMinSet x . S.deleteAt (i - 1) $ s -{-# INLINABLE deleteAt #-} +{-# INLINEABLE deleteAt #-} -- | Take a given number of elements in order, beginning -- with the smallest ones. @@ -849,13 +864,13 @@ -- @ -- take n = Data.Set.fromDistinctAscList . Data.List.NonEmpty.take n . 'toAscList' -- @ -take - :: Int - -> NESet a - -> Set a +take :: + Int -> + NESet a -> + Set a take 0 (NESet _ _) = S.empty take i (NESet x s) = insertMinSet x . S.take (i - 1) $ s -{-# INLINABLE take #-} +{-# INLINEABLE take #-} -- | Drop a given number of elements in order, beginning -- with the smallest ones. @@ -867,13 +882,13 @@ -- @ -- drop n = Data.Set.fromDistinctAscList . Data.List.NonEmpty.drop n . 'toAscList' -- @ -drop - :: Int - -> NESet a - -> Set a -drop 0 n = toSet n +drop :: + Int -> + NESet a -> + Set a +drop 0 n = toSet n drop n (NESet _ s) = S.drop (n - 1) s -{-# INLINABLE drop #-} +{-# INLINEABLE drop #-} -- | /O(log n)/. Split a set at a particular index @i@. -- @@ -883,33 +898,35 @@ -- original set. -- * @'These' n1 n2@ gives @n1@ (taking @i@ items from the original set) -- and @n2@ (dropping @i@ items from the original set)) -splitAt - :: Int - -> NESet a - -> These (NESet a) (NESet a) -splitAt 0 n = That n +splitAt :: + Int -> + NESet a -> + These (NESet a) (NESet a) +splitAt 0 n = That n splitAt i n@(NESet x s0) = case (nonEmptySet s1, nonEmptySet s2) of - (Nothing, Nothing) -> This (singleton x) - (Just _ , Nothing) -> This n - (Nothing, Just n2) -> These (singleton x) n2 - (Just _ , Just n2) -> These (insertSetMin x s1) n2 + (Nothing, Nothing) -> This (singleton x) + (Just _, Nothing) -> This n + (Nothing, Just n2) -> These (singleton x) n2 + (Just _, Just n2) -> These (insertSetMin x s1) n2 where (s1, s2) = S.splitAt (i - 1) s0 -{-# INLINABLE splitAt #-} +{-# INLINEABLE splitAt #-} -- | /O(n*log n)/. -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. -- -- It's worth noting that the size of the result may be smaller if, -- for some @(x,y)@, @x \/= y && f x == f y@ -map :: Ord b - => (a -> b) - -> NESet a - -> NESet b -map f (NESet x0 s) = fromList - . (f x0 :|) - . S.foldr (\x xs -> f x : xs) [] - $ s +map :: + Ord b => + (a -> b) -> + NESet a -> + NESet b +map f (NESet x0 s) = + fromList + . (f x0 :|) + . S.foldr (\x xs -> f x : xs) [] + $ s {-# INLINE map #-} -- | /O(n)/. @@ -919,10 +936,10 @@ -- > and [x < y ==> f x < f y | x <- ls, y <- ls] -- > ==> mapMonotonic f s == map f s -- > where ls = Data.Foldable.toList s -mapMonotonic - :: (a -> b) - -> NESet a - -> NESet b +mapMonotonic :: + (a -> b) -> + NESet a -> + NESet b mapMonotonic f (NESet x s) = NESet (f x) (S.mapMonotonic f s) {-# INLINE mapMonotonic #-} @@ -931,8 +948,8 @@ -- function is strict in the starting value. foldr1' :: (a -> a -> a) -> NESet a -> a foldr1' f (NESet x s) = case S.maxView s of - Nothing -> x - Just (y, s') -> let !z = S.foldr' f y s' in x `f` z + Nothing -> x + Just (y, s') -> let !z = S.foldr' f y s' in x `f` z {-# INLINE foldr1' #-} -- | /O(n)/. A strict version of 'foldl1'. Each application of the operator @@ -976,8 +993,8 @@ -- > deleteMax (singleton 5) == Data.Set.empty deleteMax :: NESet a -> Set a deleteMax (NESet x s) = case S.maxView s of - Nothing -> S.empty - Just (_, s') -> insertMinSet x s' + Nothing -> S.empty + Just (_, s') -> insertMinSet x s' {-# INLINE deleteMax #-} -- | /O(1)/. Delete and find the minimal element. It is constant-time, so @@ -1002,9 +1019,10 @@ -- -- > deleteFindMax (fromList (5 :| [3, 10])) == (10, Data.Set.fromList [3, 5]) deleteFindMax :: NESet a -> (a, Set a) -deleteFindMax (NESet x s) = maybe (x, S.empty) (second (insertMinSet x)) - . S.maxView - $ s +deleteFindMax (NESet x s) = + maybe (x, S.empty) (second (insertMinSet x)) + . S.maxView + $ s {-# INLINE deleteFindMax #-} -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending @@ -1032,10 +1050,16 @@ -- -- Copyright : (c) Daan Leijen 2002 +{- ORMOLU_DISABLE -} combineEq :: Eq a => NonEmpty a -> NonEmpty a combineEq (x :| xs) = go x xs where go z [] = z :| [] - go z (y:ys) - | z == y = go z ys + go z (y : ys) +#if MIN_VERSION_containers(0,8,0) + | z == y = go y ys +#else + | z == y = go z ys +#endif | otherwise = z NE.<| go y ys +{- ORMOLU_ENABLE -} 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 @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : Data.Set.NonEmpty.Internal @@ -18,51 +18,43 @@ -- "Data.Set.NonEmpty". These functions can potentially be used to break -- the abstraction of 'NESet' and produce unsound sets, so be wary! module Data.Set.NonEmpty.Internal ( - NESet(..) - , nonEmptySet - , withNonEmpty - , toSet - , singleton - , fromList - , toList - , size - , union - , unions - , foldr - , foldl - , foldr' - , foldl' - , MergeNESet(..) - , merge - , valid - , insertMinSet - , insertMaxSet - , disjointSet - , powerSetSet - , disjointUnionSet - , cartesianProductSet - ) where + NESet (..), + nonEmptySet, + withNonEmpty, + toSet, + singleton, + fromList, + toList, + size, + union, + unions, + foldr, + foldl, + foldr', + foldl', + MergeNESet (..), + merge, + valid, + insertMinSet, + insertMaxSet, +) where -import Control.DeepSeq -import Control.Monad -import Data.Data -import Data.Function -import Data.Functor.Classes -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup -import Data.Semigroup.Foldable (Foldable1) -import Data.Set.Internal (Set(..)) -import Prelude hiding (Foldable(..)) -import Text.Read -import qualified Data.Aeson as A -import qualified Data.Foldable as F +import Control.DeepSeq +import Control.Monad +import qualified Data.Aeson as A +import Data.Data +import qualified Data.Foldable as F +import Data.Function +import Data.Functor.Classes +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup +import Data.Semigroup.Foldable (Foldable1) 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 -#endif +import qualified Data.Set as S +import Data.Set.Internal (Set (..)) +import qualified Data.Set.Internal as S +import Text.Read +import Prelude hiding (Foldable (..)) -- | A non-empty (by construction) set of values @a@. At least one value -- exists in an @'NESet' a@ at all times. @@ -99,61 +91,78 @@ -- You can convert an 'NESet' into a 'Set' with 'toSet' or -- 'Data.Set.NonEmpty.IsNonEmpty', essentially "obscuring" the non-empty -- property from the type. -data NESet a = - NESet { nesV0 :: !a -- ^ invariant: must be smaller than smallest value in set - , nesSet :: !(Set a) - } +data NESet a + = NESet + { nesV0 :: !a + -- ^ invariant: must be smaller than smallest value in set + , nesSet :: !(Set a) + } deriving (Typeable) instance Eq a => Eq (NESet a) where - t1 == t2 = S.size (nesSet t1) == S.size (nesSet t2) - && toList t1 == toList t2 + t1 == t2 = + S.size (nesSet t1) == S.size (nesSet t2) + && toList t1 == toList t2 instance Ord a => Ord (NESet a) where - compare = compare `on` toList - (<) = (<) `on` toList - (>) = (>) `on` toList - (<=) = (<=) `on` toList - (>=) = (>=) `on` toList + compare = compare `on` toList + (<) = (<) `on` toList + (>) = (>) `on` toList + (<=) = (<=) `on` toList + (>=) = (>=) `on` toList instance Show a => Show (NESet a) where - showsPrec p xs = showParen (p > 10) $ + showsPrec p xs = + showParen (p > 10) $ showString "fromList (" . shows (toList xs) . showString ")" instance (Read a, Ord a) => Read (NESet a) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- parens . prec 10 $ readPrec - return (fromList xs) + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- parens . prec 10 $ readPrec + return (fromList xs) - readListPrec = readListPrecDefault + readListPrec = readListPrecDefault instance Eq1 NESet where - liftEq eq m n = - size m == size n && liftEq eq (toList m) (toList n) + liftEq eq m n = + size m == size n && liftEq eq (toList m) (toList n) instance Ord1 NESet where - liftCompare cmp m n = - liftCompare cmp (toList m) (toList n) + liftCompare cmp m n = + liftCompare cmp (toList m) (toList n) instance Show1 NESet where - liftShowsPrec sp sl d m = - showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) + liftShowsPrec sp sl d m = + showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) instance NFData a => NFData (NESet a) where - rnf (NESet x s) = rnf x `seq` rnf s + rnf (NESet x s) = rnf x `seq` rnf s -- Data instance code from Data.Set.Internal -- -- Copyright : (c) Daan Leijen 2002 +#if MIN_VERSION_base(4,16,0) instance (Data a, Ord a) => Data (NESet a) where gfoldl f z set = z fromList `f` toList set - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" - dataTypeOf _ = setDataType - dataCast1 f = gcast1 f + dataTypeOf _ = setDataType + dataCast1 = gcast1 +#else +#ifndef __HLINT__ +instance (Data a, Ord a) => Data (NESet a) where + gfoldl f z set = z fromList `f` toList set + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + dataTypeOf _ = setDataType + dataCast1 f = gcast1 f +#endif +#endif fromListConstr :: Constr fromListConstr = mkConstr setDataType "fromList" [] Prefix @@ -161,17 +170,16 @@ setDataType :: DataType setDataType = mkDataType "Data.Set.NonEmpty.Internal.NESet" [fromListConstr] - instance A.ToJSON a => A.ToJSON (NESet a) where - toJSON = A.toJSON . toSet - toEncoding = A.toEncoding . toSet + toJSON = A.toJSON . toSet + toEncoding = A.toEncoding . toSet instance (A.FromJSON a, Ord a) => A.FromJSON (NESet a) where - parseJSON = withNonEmpty (fail err) pure - <=< A.parseJSON - where - err = "NESet: Non-empty set expected, but empty set found" - + parseJSON = + withNonEmpty (fail err) pure + <=< A.parseJSON + where + err = "NESet: Non-empty set expected, but empty set found" -- | /O(log n)/. Smart constructor for an 'NESet' from a 'Set'. Returns -- 'Nothing' if the 'Set' was originally actually empty, and @'Just' n@ @@ -195,11 +203,13 @@ -- will be fed to the function @f@ instead. -- -- @'nonEmptySet' == 'withNonEmpty' 'Nothing' 'Just'@ -withNonEmpty - :: r -- ^ value to return if set is empty - -> (NESet a -> r) -- ^ function to apply if set is not empty - -> Set a - -> r +withNonEmpty :: + -- | value to return if set is empty + r -> + -- | function to apply if set is not empty + (NESet a -> r) -> + Set a -> + r withNonEmpty def f = maybe def f . nonEmptySet {-# INLINE withNonEmpty #-} @@ -230,9 +240,10 @@ -- 'fromDistinctAscList' if items are ordered, just like the actual -- 'S.fromList'. fromList :: Ord a => NonEmpty a -> NESet a -fromList (x :| s) = withNonEmpty (singleton x) (<> singleton x) - . S.fromList - $ s +fromList (x :| s) = + withNonEmpty (singleton x) (<> singleton x) + . S.fromList + $ s {-# INLINE fromList #-} -- | /O(n)/. Convert the set to a non-empty list of elements. @@ -271,9 +282,10 @@ -- Note that, unlike 'Data.Foldable.foldr1' for 'Set', this function is -- total if the input function is total. foldr1 :: (a -> a -> a) -> NESet a -> a -foldr1 f (NESet x s) = maybe x (f x . uncurry (S.foldr f)) - . S.maxView - $ s +foldr1 f (NESet x s) = + maybe x (f x . uncurry (S.foldr f)) + . S.maxView + $ s {-# INLINE foldr1 #-} -- | /O(n)/. Fold the elements in the set using the given left-associative @@ -306,78 +318,109 @@ -- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when -- equal elements are encountered. -union - :: Ord a - => NESet a - -> NESet a - -> NESet a +union :: + Ord a => + NESet a -> + NESet a -> + NESet a union n1@(NESet x1 s1) n2@(NESet x2 s2) = case compare x1 x2 of - LT -> NESet x1 . S.union s1 . toSet $ n2 - EQ -> NESet x1 . S.union s1 $ s2 - GT -> NESet x2 . S.union (toSet n1) $ s2 + LT -> NESet x1 . S.union s1 . toSet $ n2 + EQ -> NESet x1 . S.union s1 $ s2 + GT -> NESet x2 . S.union (toSet n1) $ s2 {-# INLINE union #-} -- | The union of a non-empty list of sets -unions - :: (Foldable1 f, Ord a) - => f (NESet a) - -> NESet a -unions (F1.toNonEmpty->(s :| ss)) = F.foldl' union s ss +unions :: + (Foldable1 f, Ord a) => + f (NESet a) -> + NESet a +unions (F1.toNonEmpty -> (s :| ss)) = F.foldl' union s ss {-# INLINE unions #-} -- | Left-biased union instance Ord a => Semigroup (NESet a) where - (<>) = union - {-# INLINE (<>) #-} - sconcat = unions - {-# INLINE sconcat #-} + (<>) = union + {-# INLINE (<>) #-} + sconcat = unions + {-# INLINE sconcat #-} -- | Traverses elements in ascending order -- -- 'Data.Foldable.foldr1', 'Data.Foldable.foldl1', 'Data.Foldable.minimum', -- 'Data.Foldable.maximum' are all total. -instance F.Foldable NESet where #if MIN_VERSION_base(4,11,0) +instance F.Foldable NESet where fold (NESet x s) = x <> F.fold s {-# INLINE fold #-} foldMap f (NESet x s) = f x <> F.foldMap f s {-# INLINE foldMap #-} + foldr = foldr + {-# INLINE foldr #-} + foldr' = foldr' + {-# INLINE foldr' #-} + foldr1 = foldr1 + {-# INLINE foldr1 #-} + foldl = foldl + {-# INLINE foldl #-} + foldl' = foldl' + {-# INLINE foldl' #-} + foldl1 = foldl1 + {-# INLINE foldl1 #-} + null _ = False + {-# INLINE null #-} + length = size + {-# INLINE length #-} + elem x (NESet x0 s) = + F.elem x s + || x == x0 + {-# INLINE elem #-} + minimum (NESet x _) = x + {-# INLINE minimum #-} + maximum (NESet x s) = maybe x fst . S.maxView $ s + {-# INLINE maximum #-} + + -- TODO: use build + toList = F.toList . toList + {-# INLINE toList #-} #else +instance F.Foldable NESet where fold (NESet x s) = x `mappend` F.fold s {-# INLINE fold #-} foldMap f (NESet x s) = f x `mappend` F.foldMap f s {-# INLINE foldMap #-} -#endif - foldr = foldr + foldr = foldr {-# INLINE foldr #-} - foldr' = foldr' + foldr' = foldr' {-# INLINE foldr' #-} - foldr1 = foldr1 + foldr1 = foldr1 {-# INLINE foldr1 #-} - foldl = foldl + foldl = foldl {-# INLINE foldl #-} - foldl' = foldl' + foldl' = foldl' {-# INLINE foldl' #-} - foldl1 = foldl1 + foldl1 = foldl1 {-# INLINE foldl1 #-} - null _ = False + null _ = False {-# INLINE null #-} - length = size + length = size {-# INLINE length #-} - elem x (NESet x0 s) = F.elem x s - || x == x0 + elem x (NESet x0 s) = + F.elem x s + || x == x0 {-# INLINE elem #-} minimum (NESet x _) = x {-# INLINE minimum #-} maximum (NESet x s) = maybe x fst . S.maxView $ s {-# INLINE maximum #-} + -- TODO: use build - toList = F.toList . toList + toList = F.toList . toList {-# INLINE toList #-} +#endif -- | Traverses elements in ascending order -instance Foldable1 NESet where #if MIN_VERSION_base(4,11,0) +instance Foldable1 NESet where fold1 (NESet x s) = maybe x (x <>) . F.foldMap Just $ s @@ -387,7 +430,10 @@ . F.foldMap (Just . f) $ s {-# INLINE foldMap1 #-} + toNonEmpty = toList + {-# INLINE toNonEmpty #-} #else +instance Foldable1 NESet where fold1 (NESet x s) = option x (x <>) . F.foldMap (Option . Just) $ s @@ -397,17 +443,16 @@ . F.foldMap (Option . Just . f) $ s {-# INLINE foldMap1 #-} -#endif toNonEmpty = toList {-# INLINE toNonEmpty #-} - +#endif -- | Used for 'Data.Set.NonEmpty.cartesianProduct' -newtype MergeNESet a = MergeNESet { getMergeNESet :: NESet a } +newtype MergeNESet a = MergeNESet {getMergeNESet :: NESet a} instance Semigroup (MergeNESet a) where - MergeNESet n1 <> MergeNESet n2 = MergeNESet (merge n1 n2) - {-# INLINE (<>) #-} + MergeNESet n1 <> MergeNESet n2 = MergeNESet (merge n1 n2) + {-# INLINE (<>) #-} -- | Unsafely merge two disjoint sets. Only legal if all items in the -- first set are less than all items in the second set @@ -416,11 +461,9 @@ -- | /O(n)/. Test if the internal set structure is valid. valid :: Ord a => NESet a -> Bool -valid (NESet x s) = S.valid s - && all ((x <) . fst) (S.minView s) - - - +valid (NESet x s) = + S.valid s + && all ((x <) . fst) (S.minView s) -- | /O(log n)/. Insert new value into a set where values are -- /strictly greater than/ the new values That is, the new value must be @@ -433,9 +476,9 @@ -- type. insertMinSet :: a -> Set a -> Set a insertMinSet x = \case - Tip -> S.singleton x - Bin _ y l r -> balanceL y (insertMinSet x l) r -{-# INLINABLE insertMinSet #-} + Tip -> S.singleton x + Bin _ y l r -> balanceL y (insertMinSet x l) r +{-# INLINEABLE insertMinSet #-} -- | /O(log n)/. Insert new value into a set where values are /strictly -- less than/ the new value. That is, the new value must be /strictly @@ -448,133 +491,60 @@ -- type. insertMaxSet :: a -> Set a -> Set a insertMaxSet x = \case - Tip -> S.singleton x - Bin _ y l r -> balanceR y l (insertMaxSet x r) -{-# INLINABLE insertMaxSet #-} - --- --------------------------------------------- --- | CPP for new functions not in old containers --- --------------------------------------------- - --- | Comptability layer for 'Data.Set.disjoint'. -disjointSet :: Ord a => Set a -> Set a -> Bool -#if MIN_VERSION_containers(0,5,11) -disjointSet = S.disjoint -#else -disjointSet xs = S.null . S.intersection xs -#endif -{-# INLINE disjointSet #-} - --- | Comptability layer for 'Data.Set.powerSet'. -powerSetSet :: Set a -> Set (Set a) -#if MIN_VERSION_containers(0,5,11) -powerSetSet = S.powerSet -{-# INLINE powerSetSet #-} -#else -powerSetSet xs0 = insertMinSet S.empty (S.foldr' step' Tip xs0) where - step' x pxs = insertMinSet (S.singleton x) (insertMinSet x `S.mapMonotonic` pxs) `glue` pxs -{-# INLINABLE powerSetSet #-} - -minViewSure :: a -> Set a -> Set a -> StrictPair a (Set a) -minViewSure = go - where - go x Tip r = x :*: r - go x (Bin _ xl ll lr) r = - case go xl ll lr of - xm :*: l' -> xm :*: balanceR x l' r - -maxViewSure :: a -> Set a -> Set a -> StrictPair a (Set a) -maxViewSure = go - where - go x l Tip = x :*: l - go x l (Bin _ xr rl rr) = - case go xr rl rr of - xm :*: r' -> xm :*: balanceL x l r' - -glue :: Set a -> Set a -> Set a -glue Tip r = r -glue l Tip = l -glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr) - | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r - | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r' -#endif - --- | Comptability layer for 'Data.Set.disjointUnion'. -disjointUnionSet :: Set a -> Set b -> Set (Either a b) -#if MIN_VERSION_containers(0,5,11) -disjointUnionSet = S.disjointUnion -#else -disjointUnionSet as bs = S.merge (S.mapMonotonic Left as) (S.mapMonotonic Right bs) -#endif -{-# INLINE disjointUnionSet #-} - --- | Comptability layer for 'Data.Set.cartesianProduct'. -cartesianProductSet :: Set a -> Set b -> Set (a, b) -#if MIN_VERSION_containers(0,5,11) -cartesianProductSet = S.cartesianProduct -#else -cartesianProductSet as bs = - getMergeSet $ foldMap (\a -> MergeSet $ S.mapMonotonic ((,) a) bs) as - -newtype MergeSet a = MergeSet { getMergeSet :: Set a } - -instance Semigroup (MergeSet a) where - MergeSet xs <> MergeSet ys = MergeSet (S.merge xs ys) - -instance Monoid (MergeSet a) where - mempty = MergeSet S.empty - mappend = (<>) -#endif -{-# INLINE cartesianProductSet #-} - - + Tip -> S.singleton x + Bin _ y l r -> balanceR y l (insertMaxSet x r) +{-# INLINEABLE insertMaxSet #-} -- ------------------------------------------ + -- | Unexported code from "Data.Set.Internal" -- ------------------------------------------ - balanceR :: a -> Set a -> Set a -> Set a balanceR x l r = case l of - Tip -> case r of - Tip -> Bin 1 x Tip Tip - Bin _ _ Tip Tip -> Bin 2 x Tip r - Bin _ rx Tip rr@Bin{} -> Bin 3 rx (Bin 1 x Tip Tip) rr - Bin _ rx (Bin _ rlx _ _) Tip -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip) - Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _) - | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr - | otherwise -> Bin (1+rs) rlx (Bin (1+S.size rll) x Tip rll) (Bin (1+rrs+S.size rlr) rx rlr rr) - Bin ls _ _ _ -> case r of - Tip -> Bin (1+ls) x l Tip - Bin rs rx rl rr - | rs > delta*ls -> case (rl, rr) of - (Bin rls rlx rll rlr, Bin rrs _ _ _) - | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr - | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+S.size rll) x l rll) (Bin (1+rrs+S.size rlr) rx rlr rr) - (_, _) -> error "Failure in Data.Map.balanceR" - | otherwise -> Bin (1+ls+rs) x l r + Tip -> case r of + Tip -> Bin 1 x Tip Tip + Bin _ _ Tip Tip -> Bin 2 x Tip r + Bin _ rx Tip rr@Bin{} -> Bin 3 rx (Bin 1 x Tip Tip) rr + Bin _ rx (Bin _ rlx _ _) Tip -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip) + Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _) + | rls < ratio * rrs -> Bin (1 + rs) rx (Bin (1 + rls) x Tip rl) rr + | otherwise -> + Bin (1 + rs) rlx (Bin (1 + S.size rll) x Tip rll) (Bin (1 + rrs + S.size rlr) rx rlr rr) + Bin ls _ _ _ -> case r of + Tip -> Bin (1 + ls) x l Tip + Bin rs rx rl rr + | rs > delta * ls -> case (rl, rr) of + (Bin rls rlx rll rlr, Bin rrs _ _ _) + | rls < ratio * rrs -> Bin (1 + ls + rs) rx (Bin (1 + ls + rls) x l rl) rr + | otherwise -> + Bin (1 + ls + rs) rlx (Bin (1 + ls + S.size rll) x l rll) (Bin (1 + rrs + S.size rlr) rx rlr rr) + (_, _) -> error "Failure in Data.Map.balanceR" + | otherwise -> Bin (1 + ls + rs) x l r {-# NOINLINE balanceR #-} balanceL :: a -> Set a -> Set a -> Set a balanceL x l r = case r of - Tip -> case l of - Tip -> Bin 1 x Tip Tip - Bin _ _ Tip Tip -> Bin 2 x l Tip - Bin _ lx Tip (Bin _ lrx _ _) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip) - Bin _ lx ll@Bin{} Tip -> Bin 3 lx ll (Bin 1 x Tip Tip) - Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr) - | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip) - | otherwise -> Bin (1+ls) lrx (Bin (1+lls+S.size lrl) lx ll lrl) (Bin (1+S.size lrr) x lrr Tip) - Bin rs _ _ _ -> case l of - Tip -> Bin (1+rs) x Tip r - Bin ls lx ll lr - | ls > delta*rs -> case (ll, lr) of - (Bin lls _ _ _, Bin lrs lrx lrl lrr) - | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r) - | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+S.size lrl) lx ll lrl) (Bin (1+rs+S.size lrr) x lrr r) - (_, _) -> error "Failure in Data.Set.NonEmpty.Internal.balanceL" - | otherwise -> Bin (1+ls+rs) x l r + Tip -> case l of + Tip -> Bin 1 x Tip Tip + Bin _ _ Tip Tip -> Bin 2 x l Tip + Bin _ lx Tip (Bin _ lrx _ _) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip) + Bin _ lx ll@Bin{} Tip -> Bin 3 lx ll (Bin 1 x Tip Tip) + Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr) + | lrs < ratio * lls -> Bin (1 + ls) lx ll (Bin (1 + lrs) x lr Tip) + | otherwise -> + Bin (1 + ls) lrx (Bin (1 + lls + S.size lrl) lx ll lrl) (Bin (1 + S.size lrr) x lrr Tip) + Bin rs _ _ _ -> case l of + Tip -> Bin (1 + rs) x Tip r + Bin ls lx ll lr + | ls > delta * rs -> case (ll, lr) of + (Bin lls _ _ _, Bin lrs lrx lrl lrr) + | lrs < ratio * lls -> Bin (1 + ls + rs) lx ll (Bin (1 + rs + lrs) x lr r) + | otherwise -> + Bin (1 + ls + rs) lrx (Bin (1 + lls + S.size lrl) lx ll lrl) (Bin (1 + rs + S.size lrr) x lrr r) + (_, _) -> error "Failure in Data.Set.NonEmpty.Internal.balanceL" + | otherwise -> Bin (1 + ls + rs) x l r {-# NOINLINE balanceL #-} -delta,ratio :: Int +delta, ratio :: Int delta = 3 ratio = 2 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,25 +1,27 @@ - -- import Test.Tasty.Hedgehog -- import Test.Tasty.Ingredients.ConsoleReporter -import Test.Tasty -import Tests.IntMap -import Tests.IntSet -import Tests.Map -import Tests.Sequence -import Tests.Set +import Test.Tasty +import Tests.IntMap +import Tests.IntSet +import Tests.Map +import Tests.Sequence +import Tests.Set setOpts :: TestTree -> TestTree setOpts = id + -- setOpts = localOption (HedgehogTestLimit (Just 500)) -- . localOption (HedgehogDiscardLimit (Just 500)) -- . localOption (HideSuccesses True ) main :: IO () -main = defaultMain . setOpts $ - testGroup "Tests" [ mapTests - , setTests - , intMapTests - , intSetTests - , sequenceTests - ] - +main = + defaultMain . setOpts $ + testGroup + "Tests" + [ mapTests + , setTests + , intMapTests + , intSetTests + , sequenceTests + ] diff --git a/test/Tests/IntMap.hs b/test/Tests/IntMap.hs --- a/test/Tests/IntMap.hs +++ b/test/Tests/IntMap.hs @@ -1,37 +1,34 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Tests.IntMap (intMapTests) where -import Control.Applicative -import Control.Comonad -import Data.Coerce -import Data.Foldable -import Data.Functor.Alt -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup.Foldable -import Data.Text (Text) -import Hedgehog -import Test.Tasty -import Tests.Util -import qualified Data.IntMap as M -import qualified Data.IntMap.NonEmpty as NEM -import qualified Data.IntMap.NonEmpty.Internal as NEM -import qualified Data.List.NonEmpty as NE -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Control.Applicative +import Control.Comonad +import Data.Coerce +import Data.Foldable +import Data.Functor.Alt +import Data.Functor.Identity +import qualified Data.IntMap as M +import qualified Data.IntMap.NonEmpty as NEM +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Text (Text) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Tests.Util intMapTests :: TestTree -intMapTests = groupTree $$(discover) - - - - +intMapTests = groupTree $$discover prop_valid :: Property -prop_valid = property $ +prop_valid = + property $ assert . NEM.valid =<< forAll neIntMapGen -- | We cannot implement these because there is no 'valid' for IntSet @@ -59,33 +56,37 @@ prop_valid_insertMapMin :: Property prop_valid_insertMapMin = property $ do - n <- forAll $ do - m <- intMapGen - let k = maybe 0 (subtract 1 . fst) $ NEM.lookupMinMap m - v <- valGen - pure $ NEM.insertMapMin k v m - assert $ NEM.valid n + n <- forAll $ do + m <- intMapGen + let k = maybe 0 (subtract 1 . fst) $ M.lookupMin m + v <- valGen + pure $ NEM.insertMapMin k v m + assert $ NEM.valid n prop_valid_insertMapMax :: Property prop_valid_insertMapMax = property $ do - n <- forAll $ do - m <- intMapGen - let k = maybe 0 ((+ 1) . fst) $ NEM.lookupMaxMap m - v <- valGen - pure $ NEM.insertMapMax k v m - assert $ NEM.valid n + n <- forAll $ do + m <- intMapGen + let k = maybe 0 ((+ 1) . fst) $ M.lookupMax m + v <- valGen + pure $ NEM.insertMapMax k v m + assert $ NEM.valid n prop_toMapIso1 :: Property prop_toMapIso1 = property $ do - m0 <- forAll intMapGen - tripping m0 (NEM.nonEmptyMap) - (Identity . maybe M.empty NEM.toMap) + m0 <- forAll intMapGen + tripping + m0 + NEM.nonEmptyMap + (Identity . maybe M.empty NEM.toMap) prop_toMapIso2 :: Property prop_toMapIso2 = property $ do - m0 <- forAll $ Gen.maybe neIntMapGen - tripping m0 (maybe M.empty NEM.toMap) - (Identity . NEM.nonEmptyMap) + m0 <- forAll $ Gen.maybe neIntMapGen + tripping + m0 + (maybe M.empty NEM.toMap) + (Identity . NEM.nonEmptyMap) prop_read_show :: Property prop_read_show = readShow neIntMapGen @@ -98,159 +99,198 @@ prop_splitRoot :: Property prop_splitRoot = property $ do - n <- forAll neIntMapGen - let rs = NEM.splitRoot n - allItems = foldMap1 NEM.keys rs - n' = NEM.unions rs - assert $ ascending allItems - mapM_ (assert . (`NEM.isSubmapOf` n)) rs - length allItems === length n' - n === n' + n <- forAll neIntMapGen + let rs = NEM.splitRoot n + allItems = foldMap1 NEM.keys rs + n' = NEM.unions rs + assert $ ascending allItems + mapM_ (assert . (`NEM.isSubmapOf` n)) rs + length allItems === length n' + n === n' where ascending (x :| xs) = case NE.nonEmpty xs of - Nothing -> True + Nothing -> True Just ys@(y :| _) -> x < y && ascending ys prop_extract_duplicate :: Property prop_extract_duplicate = property $ do - n <- forAll neIntMapGen - tripping n duplicate - (Identity . extract) + n <- forAll neIntMapGen + tripping + n + duplicate + (Identity . extract) prop_fmap_extract_duplicate :: Property prop_fmap_extract_duplicate = property $ do - n <- forAll neIntMapGen - tripping n duplicate - (Identity . fmap extract) + n <- forAll neIntMapGen + tripping + n + duplicate + (Identity . fmap extract) prop_duplicate_duplicate :: Property prop_duplicate_duplicate = property $ do - n <- forAll neIntMapGen - let dd1 = duplicate . duplicate $ n - dd2 = fmap duplicate . duplicate $ n - assert $ NEM.valid dd1 - assert $ NEM.valid dd2 - dd1 === dd2 - - - - - + n <- forAll neIntMapGen + let dd1 = duplicate . duplicate $ n + dd2 = fmap duplicate . duplicate $ n + assert $ NEM.valid dd1 + assert $ NEM.valid dd2 + dd1 === dd2 prop_insertMapWithKey :: Property -prop_insertMapWithKey = ttProp (gf3 valGen :?> GTIntKey :-> GTVal :-> GTIntMap :-> TTNEIntMap) +prop_insertMapWithKey = + ttProp + (gf3 valGen :?> GTIntKey :-> GTVal :-> GTIntMap :-> TTNEIntMap) M.insertWithKey NEM.insertMapWithKey prop_singleton :: Property -prop_singleton = ttProp (GTIntKey :-> GTVal :-> TTNEIntMap) +prop_singleton = + ttProp + (GTIntKey :-> GTVal :-> TTNEIntMap) M.singleton NEM.singleton prop_fromSet :: Property -prop_fromSet = ttProp (gf1 valGen :?> GTNEIntSet :-> TTNEIntMap) +prop_fromSet = + ttProp + (gf1 valGen :?> GTNEIntSet :-> TTNEIntMap) M.fromSet NEM.fromSet prop_fromAscList :: Property -prop_fromAscList = ttProp (GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) +prop_fromAscList = + ttProp + (GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) M.fromAscList NEM.fromAscList prop_fromAscListWithKey :: Property -prop_fromAscListWithKey = ttProp (gf3 valGen :?> GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) +prop_fromAscListWithKey = + ttProp + (gf3 valGen :?> GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) M.fromAscListWithKey NEM.fromAscListWithKey prop_fromDistinctAscList :: Property -prop_fromDistinctAscList = ttProp (GTSorted STDistinctAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) +prop_fromDistinctAscList = + ttProp + (GTSorted STDistinctAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) M.fromDistinctAscList NEM.fromDistinctAscList prop_fromListWithKey :: Property -prop_fromListWithKey = ttProp (gf3 valGen :?> GTNEList Nothing (GTIntKey :&: GTVal) :-> TTNEIntMap) +prop_fromListWithKey = + ttProp + (gf3 valGen :?> GTNEList Nothing (GTIntKey :&: GTVal) :-> TTNEIntMap) M.fromListWithKey NEM.fromListWithKey prop_insert :: Property -prop_insert = ttProp (GTIntKey :-> GTVal :-> GTNEIntMap :-> TTNEIntMap) +prop_insert = + ttProp + (GTIntKey :-> GTVal :-> GTNEIntMap :-> TTNEIntMap) M.insert NEM.insert prop_insertWithKey :: Property -prop_insertWithKey = ttProp (gf3 valGen :?> GTIntKey :-> GTVal :-> GTNEIntMap :-> TTNEIntMap) +prop_insertWithKey = + ttProp + (gf3 valGen :?> GTIntKey :-> GTVal :-> GTNEIntMap :-> TTNEIntMap) M.insertWithKey NEM.insertWithKey prop_delete :: Property -prop_delete = ttProp (GTIntKey :-> GTNEIntMap :-> TTOther) +prop_delete = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTOther) M.delete NEM.delete prop_adjustWithKey :: Property -prop_adjustWithKey = ttProp (gf2 valGen :?> GTIntKey :-> GTNEIntMap :-> TTNEIntMap) +prop_adjustWithKey = + ttProp + (gf2 valGen :?> GTIntKey :-> GTNEIntMap :-> TTNEIntMap) M.adjustWithKey NEM.adjustWithKey prop_updateWithKey :: Property -prop_updateWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTOther) +prop_updateWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTOther) M.updateWithKey NEM.updateWithKey prop_updateLookupWithKey :: Property -prop_updateLookupWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTMaybe TTVal :*: TTOther) +prop_updateLookupWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTMaybe TTVal :*: TTOther) M.updateLookupWithKey NEM.updateLookupWithKey prop_alter :: Property -prop_alter = ttProp (gf1 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTOther) +prop_alter = + ttProp + (gf1 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTOther) M.alter NEM.alter prop_alter' :: Property -prop_alter' = ttProp (gf1 valGen :?> GTIntKey :-> GTNEIntMap :-> TTNEIntMap) +prop_alter' = + ttProp + (gf1 valGen :?> GTIntKey :-> GTNEIntMap :-> TTNEIntMap) (M.alter . fmap Just) NEM.alter' prop_alterF :: Property -prop_alterF = ttProp ( gf1 (Gen.maybe valGen) - :?> GTIntKey - :-> GTNEIntMap - :-> TTCtx (GTMaybe GTVal :-> TTOther) (TTMaybe TTVal) - ) - (M.alterF . Context) +prop_alterF = + ttProp + ( gf1 (Gen.maybe valGen) + :?> GTIntKey + :-> GTNEIntMap + :-> TTCtx (GTMaybe GTVal :-> TTOther) (TTMaybe TTVal) + ) + (M.alterF . Context) (NEM.alterF . Context) prop_alterF_rules_Const :: Property -prop_alterF_rules_Const = ttProp ( gf1 (Const <$> valGen) - :?> GTIntKey - :-> GTNEIntMap - :-> TTOther - ) - (\f k m -> getConst (M.alterF f k m)) +prop_alterF_rules_Const = + ttProp + ( gf1 (Const <$> valGen) + :?> GTIntKey + :-> GTNEIntMap + :-> TTOther + ) + (\f k m -> getConst (M.alterF f k m)) (\f k m -> getConst (NEM.alterF f k m)) prop_alterF_rules_Identity :: Property -prop_alterF_rules_Identity = ttProp ( gf1 (Identity <$> Gen.maybe valGen) - :?> GTIntKey - :-> GTNEIntMap - :-> TTOther - ) - (\f k m -> runIdentity (M.alterF f k m)) +prop_alterF_rules_Identity = + ttProp + ( gf1 (Identity <$> Gen.maybe valGen) + :?> GTIntKey + :-> GTNEIntMap + :-> TTOther + ) + (\f k m -> runIdentity (M.alterF f k m)) (\f k m -> runIdentity (NEM.alterF f k m)) prop_alterF' :: Property -prop_alterF' = ttProp (gf1 valGen :?> GTIntKey :-> GTNEIntMap :-> TTCtx (GTVal :-> TTNEIntMap) (TTMaybe TTVal)) - (M.alterF . Context . fmap Just) +prop_alterF' = + ttProp + (gf1 valGen :?> GTIntKey :-> GTNEIntMap :-> TTCtx (GTVal :-> TTNEIntMap) (TTMaybe TTVal)) + (M.alterF . Context . fmap Just) (NEM.alterF' . Context) prop_alterF'_rules_Const :: Property -prop_alterF'_rules_Const = ttProp ( gf1 (Const <$> valGen) - :?> GTIntKey - :-> GTNEIntMap - :-> TTOther - ) - (\f k m -> let f' = fmap Just . f in getConst (M.alterF f' k m)) +prop_alterF'_rules_Const = + ttProp + ( gf1 (Const <$> valGen) + :?> GTIntKey + :-> GTNEIntMap + :-> TTOther + ) + (\f k m -> let f' = fmap Just . f in getConst (M.alterF f' k m)) (\f k m -> getConst (NEM.alterF' f k m)) -- -- | This fails, but isn't possible to fix without copying-and-pasting more @@ -265,472 +305,636 @@ -- (\f k m -> runIdentity (NEM.alterF' f k m)) prop_lookup :: Property -prop_lookup = ttProp (GTIntKey :-> GTNEIntMap :-> TTMaybe TTVal) +prop_lookup = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTMaybe TTVal) M.lookup NEM.lookup prop_findWithDefault :: Property -prop_findWithDefault = ttProp (GTVal :-> GTIntKey :-> GTNEIntMap :-> TTVal) +prop_findWithDefault = + ttProp + (GTVal :-> GTIntKey :-> GTNEIntMap :-> TTVal) M.findWithDefault NEM.findWithDefault prop_member :: Property -prop_member = ttProp (GTIntKey :-> GTNEIntMap :-> TTOther) +prop_member = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTOther) M.member NEM.member prop_notMember :: Property -prop_notMember = ttProp (GTIntKey :-> GTNEIntMap :-> TTOther) +prop_notMember = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTOther) M.notMember NEM.notMember prop_lookupLT :: Property -prop_lookupLT = ttProp (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) +prop_lookupLT = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) M.lookupLT NEM.lookupLT prop_lookupGT :: Property -prop_lookupGT = ttProp (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) +prop_lookupGT = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) M.lookupGT NEM.lookupGT prop_lookupLE :: Property -prop_lookupLE = ttProp (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) +prop_lookupLE = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) M.lookupLE NEM.lookupLE prop_lookupGE :: Property -prop_lookupGE = ttProp (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) +prop_lookupGE = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) M.lookupGE NEM.lookupGE prop_size :: Property -prop_size = ttProp (GTNEIntMap :-> TTOther) +prop_size = + ttProp + (GTNEIntMap :-> TTOther) M.size NEM.size prop_union :: Property -prop_union = ttProp (GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) +prop_union = + ttProp + (GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) M.union NEM.union prop_unionWith :: Property -prop_unionWith = ttProp (gf2 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) +prop_unionWith = + ttProp + (gf2 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) M.unionWith NEM.unionWith prop_unionWithKey :: Property -prop_unionWithKey = ttProp (gf3 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) +prop_unionWithKey = + ttProp + (gf3 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) M.unionWithKey NEM.unionWithKey prop_unions :: Property -prop_unions = ttProp (GTNEList (Just (Range.linear 2 5)) GTNEIntMap :-> TTNEIntMap) +prop_unions = + ttProp + (GTNEList (Just (Range.linear 2 5)) GTNEIntMap :-> TTNEIntMap) M.unions NEM.unions prop_unionsWith :: Property -prop_unionsWith = ttProp (gf2 valGen :?> GTNEList (Just (Range.linear 2 5)) GTNEIntMap :-> TTNEIntMap) +prop_unionsWith = + ttProp + (gf2 valGen :?> GTNEList (Just (Range.linear 2 5)) GTNEIntMap :-> TTNEIntMap) M.unionsWith NEM.unionsWith prop_difference :: Property -prop_difference = ttProp (GTNEIntMap :-> GTNEIntMap :-> TTOther) +prop_difference = + ttProp + (GTNEIntMap :-> GTNEIntMap :-> TTOther) M.difference NEM.difference prop_differenceWithKey :: Property -prop_differenceWithKey = ttProp (gf3 (Gen.maybe valGen) :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) +prop_differenceWithKey = + ttProp + (gf3 (Gen.maybe valGen) :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) M.differenceWithKey NEM.differenceWithKey prop_intersection :: Property -prop_intersection = ttProp (GTNEIntMap :-> GTNEIntMap :-> TTOther) +prop_intersection = + ttProp + (GTNEIntMap :-> GTNEIntMap :-> TTOther) M.intersection NEM.intersection prop_intersectionWithKey :: Property -prop_intersectionWithKey = ttProp (gf3 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) +prop_intersectionWithKey = + ttProp + (gf3 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) M.intersectionWithKey NEM.intersectionWithKey prop_map :: Property -prop_map = ttProp (gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) +prop_map = + ttProp + (gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) M.map NEM.map prop_map_rules_map :: Property -prop_map_rules_map = ttProp (gf1 valGen :?> gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) - (\f g xs -> M.map f (M.map g xs)) +prop_map_rules_map = + ttProp + (gf1 valGen :?> gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) + (\f g xs -> M.map f (M.map g xs)) (\f g xs -> NEM.map f (NEM.map g xs)) prop_map_rules_coerce :: Property -prop_map_rules_coerce = ttProp (GTNEIntMap :-> TTNEIntMap) - (M.map @Text @Text coerce) +prop_map_rules_coerce = + ttProp + (GTNEIntMap :-> TTNEIntMap) + (M.map @Text @Text coerce) (NEM.map @Text @Text coerce) prop_map_rules_mapWithKey :: Property -prop_map_rules_mapWithKey = ttProp (gf1 valGen :?> gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) - (\f g xs -> M.map f (M.mapWithKey g xs)) +prop_map_rules_mapWithKey = + ttProp + (gf1 valGen :?> gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) + (\f g xs -> M.map f (M.mapWithKey g xs)) (\f g xs -> NEM.map f (NEM.mapWithKey g xs)) prop_mapWithKey :: Property -prop_mapWithKey = ttProp (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) +prop_mapWithKey = + ttProp + (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) M.mapWithKey NEM.mapWithKey prop_mapWithKey_rules_mapWithKey :: Property -prop_mapWithKey_rules_mapWithKey = ttProp (gf2 valGen :?> gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) - (\f g xs -> M.mapWithKey f (M.mapWithKey g xs)) +prop_mapWithKey_rules_mapWithKey = + ttProp + (gf2 valGen :?> gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) + (\f g xs -> M.mapWithKey f (M.mapWithKey g xs)) (\f g xs -> NEM.mapWithKey f (NEM.mapWithKey g xs)) prop_mapWithKey_rules_map :: Property -prop_mapWithKey_rules_map = ttProp (gf2 valGen :?> gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) - (\f g xs -> M.mapWithKey f (M.map g xs)) +prop_mapWithKey_rules_map = + ttProp + (gf2 valGen :?> gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) + (\f g xs -> M.mapWithKey f (M.map g xs)) (\f g xs -> NEM.mapWithKey f (NEM.map g xs)) --- | These intentionally do not match, because Foldable for IntMap is --- inconsistent --- prop_traverseWithKey1 :: Property --- prop_traverseWithKey1 = ttProp (gf1 valGen :?> GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) --- (\f -> M.traverseWithKey (\k -> (`More` Done (f . (k,))))) --- (\f -> NEM.traverseWithKey1 (\k -> (`More` Done (f . (k,))))) +prop_traverseWithKey1 :: Property +prop_traverseWithKey1 = + ttProp + (gf1 valGen :?> GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) + (\f -> M.traverseWithKey (\k -> (`More` Done (f . (k,))))) + (\f -> NEM.traverseWithKey1 (\k -> (`More` Done (f . (k,))))) --- prop_traverseWithKey :: Property --- prop_traverseWithKey = ttProp (gf1 valGen :?> GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) --- (\f -> M.traverseWithKey (\k -> (`More` Done (f . (k,))))) --- (\f -> NEM.traverseWithKey (\k -> (`More` Done (f . (k,))))) +prop_traverseWithKey :: Property +prop_traverseWithKey = + ttProp + (gf1 valGen :?> GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) + (\f -> M.traverseWithKey (\k -> (`More` Done (f . (k,))))) + (\f -> NEM.traverseWithKey (\k -> (`More` Done (f . (k,))))) --- prop_sequence1 :: Property --- prop_sequence1 = ttProp (GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) --- (sequenceA . fmap (`More` Done id)) --- (sequence1 . fmap (`More` Done id)) +prop_sequence1 :: Property +prop_sequence1 = + ttProp + (GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) + (traverse (`More` Done id)) + (traverse1 (`More` Done id)) --- prop_sequenceA :: Property --- prop_sequenceA = ttProp (GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) --- (sequenceA . fmap (`More` Done id)) --- (sequenceA . fmap (`More` Done id)) +prop_sequenceA :: Property +prop_sequenceA = + ttProp + (GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) + (traverse (`More` Done id)) + (traverse (`More` Done id)) --- prop_mapAccumWithKey :: Property --- prop_mapAccumWithKey = ttProp ( gf3 ((,) <$> valGen <*> valGen) --- :?> GTOther valGen --- :-> GTNEIntMap --- :-> TTOther :*: TTNEIntMap --- ) --- M.mapAccumWithKey --- NEM.mapAccumWithKey +prop_mapAccumWithKey :: Property +prop_mapAccumWithKey = + ttProp + ( gf3 ((,) <$> valGen <*> valGen) + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + :*: TTNEIntMap + ) + M.mapAccumWithKey + NEM.mapAccumWithKey --- prop_mapAccumRWithKey :: Property --- prop_mapAccumRWithKey = ttProp ( gf3 ((,) <$> valGen <*> valGen) --- :?> GTOther valGen --- :-> GTNEIntMap --- :-> TTOther :*: TTNEIntMap --- ) --- M.mapAccumRWithKey --- NEM.mapAccumRWithKey +prop_mapAccumRWithKey :: Property +prop_mapAccumRWithKey = + ttProp + ( gf3 ((,) <$> valGen <*> valGen) + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + :*: TTNEIntMap + ) + M.mapAccumRWithKey + NEM.mapAccumRWithKey prop_mapKeys :: Property -prop_mapKeys = ttProp (gf1 intKeyGen :?> GTNEIntMap :-> TTNEIntMap) +prop_mapKeys = + ttProp + (gf1 intKeyGen :?> GTNEIntMap :-> TTNEIntMap) M.mapKeys NEM.mapKeys prop_mapKeysWith :: Property -prop_mapKeysWith = ttProp ( gf2 valGen - :?> gf1 intKeyGen - :?> GTNEIntMap - :-> TTNEIntMap - ) +prop_mapKeysWith = + ttProp + ( gf2 valGen + :?> gf1 intKeyGen + :?> GTNEIntMap + :-> TTNEIntMap + ) M.mapKeysWith NEM.mapKeysWith prop_mapKeysMonotonic :: Property -prop_mapKeysMonotonic = ttProp (GTNEIntMap :-> TTNEIntMap) - (M.mapKeysMonotonic (*2)) - (NEM.mapKeysMonotonic (*2)) +prop_mapKeysMonotonic = + ttProp + (GTNEIntMap :-> TTNEIntMap) + (M.mapKeysMonotonic (* 2)) + (NEM.mapKeysMonotonic (* 2)) prop_foldr :: Property -prop_foldr = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldr = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldr NEM.foldr prop_foldl :: Property -prop_foldl = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldl = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldl NEM.foldl prop_foldr1 :: Property -prop_foldr1 = ttProp ( gf2 valGen - :?> GTNEIntMap - :-> TTOther - ) +prop_foldr1 = + ttProp + ( gf2 valGen + :?> GTNEIntMap + :-> TTOther + ) foldr1 NEM.foldr1 prop_foldl1 :: Property -prop_foldl1 = ttProp ( gf2 valGen - :?> GTNEIntMap - :-> TTOther - ) +prop_foldl1 = + ttProp + ( gf2 valGen + :?> GTNEIntMap + :-> TTOther + ) foldl1 NEM.foldl1 prop_foldrWithKey :: Property -prop_foldrWithKey = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldrWithKey = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldrWithKey NEM.foldrWithKey prop_foldlWithKey :: Property -prop_foldlWithKey = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldlWithKey = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldlWithKey NEM.foldlWithKey prop_foldMapWithKey :: Property -prop_foldMapWithKey = ttProp (gf2 valGen :?> GTNEIntMap :-> TTOther) +prop_foldMapWithKey = + ttProp + (gf2 valGen :?> GTNEIntMap :-> TTOther) (\f -> foldMap (uncurry f) . M.toList) NEM.foldMapWithKey prop_foldr' :: Property -prop_foldr' = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldr' = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldr' NEM.foldr' prop_foldl' :: Property -prop_foldl' = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldl' = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldl' NEM.foldl' prop_foldr1' :: Property -prop_foldr1' = ttProp ( gf2 valGen - :?> GTNEIntMap - :-> TTOther - ) +prop_foldr1' = + ttProp + ( gf2 valGen + :?> GTNEIntMap + :-> TTOther + ) foldr1 NEM.foldr1' prop_foldl1' :: Property -prop_foldl1' = ttProp ( gf2 valGen - :?> GTNEIntMap - :-> TTOther - ) +prop_foldl1' = + ttProp + ( gf2 valGen + :?> GTNEIntMap + :-> TTOther + ) foldl1 NEM.foldl1' prop_foldrWithKey' :: Property -prop_foldrWithKey' = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldrWithKey' = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldrWithKey' NEM.foldrWithKey' prop_foldlWithKey' :: Property -prop_foldlWithKey' = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEIntMap - :-> TTOther - ) +prop_foldlWithKey' = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEIntMap + :-> TTOther + ) M.foldlWithKey' NEM.foldlWithKey' prop_elems :: Property -prop_elems = ttProp (GTNEIntMap :-> TTNEList TTVal) +prop_elems = + ttProp + (GTNEIntMap :-> TTNEList TTVal) M.elems NEM.elems prop_keys :: Property -prop_keys = ttProp (GTNEIntMap :-> TTNEList TTOther) +prop_keys = + ttProp + (GTNEIntMap :-> TTNEList TTOther) M.keys NEM.keys prop_assocs :: Property -prop_assocs = ttProp (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) +prop_assocs = + ttProp + (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) M.assocs NEM.assocs prop_keysSet :: Property -prop_keysSet = ttProp (GTNEIntMap :-> TTNEIntSet) +prop_keysSet = + ttProp + (GTNEIntMap :-> TTNEIntSet) M.keysSet NEM.keysSet prop_toList :: Property -prop_toList = ttProp (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) +prop_toList = + ttProp + (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) M.toList NEM.toList prop_toDescList :: Property -prop_toDescList = ttProp (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) +prop_toDescList = + ttProp + (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) M.toDescList NEM.toDescList prop_filter :: Property -prop_filter = ttProp (gf1 Gen.bool :?> GTNEIntMap :-> TTOther) +prop_filter = + ttProp + (gf1 Gen.bool :?> GTNEIntMap :-> TTOther) M.filter NEM.filter prop_filterWithKey :: Property -prop_filterWithKey = ttProp (gf2 Gen.bool :?> GTNEIntMap :-> TTOther) +prop_filterWithKey = + ttProp + (gf2 Gen.bool :?> GTNEIntMap :-> TTOther) M.filterWithKey NEM.filterWithKey prop_restrictKeys :: Property -prop_restrictKeys = ttProp (GTNEIntMap :-> GTIntSet :-> TTOther) +prop_restrictKeys = + ttProp + (GTNEIntMap :-> GTIntSet :-> TTOther) M.restrictKeys NEM.restrictKeys prop_withoutKeys :: Property -prop_withoutKeys = ttProp (GTNEIntMap :-> GTIntSet :-> TTOther) +prop_withoutKeys = + ttProp + (GTNEIntMap :-> GTIntSet :-> TTOther) M.withoutKeys NEM.withoutKeys prop_partitionWithKey :: Property -prop_partitionWithKey = ttProp (gf2 Gen.bool :?> GTNEIntMap :-> TTThese TTNEIntMap TTNEIntMap) +prop_partitionWithKey = + ttProp + (gf2 Gen.bool :?> GTNEIntMap :-> TTThese TTNEIntMap TTNEIntMap) M.partitionWithKey NEM.partitionWithKey prop_mapMaybeWithKey :: Property -prop_mapMaybeWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) +prop_mapMaybeWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) M.mapMaybeWithKey NEM.mapMaybeWithKey prop_mapEitherWithKey :: Property -prop_mapEitherWithKey = ttProp ( gf2 (Gen.choice [Left <$> valGen, Right <$> valGen]) - :?> GTNEIntMap - :-> TTThese TTNEIntMap TTNEIntMap - ) +prop_mapEitherWithKey = + ttProp + ( gf2 (Gen.choice [Left <$> valGen, Right <$> valGen]) + :?> GTNEIntMap + :-> TTThese TTNEIntMap TTNEIntMap + ) M.mapEitherWithKey NEM.mapEitherWithKey prop_split :: Property -prop_split = ttProp (GTIntKey :-> GTNEIntMap :-> TTMThese TTNEIntMap TTNEIntMap) +prop_split = + ttProp + (GTIntKey :-> GTNEIntMap :-> TTMThese TTNEIntMap TTNEIntMap) M.split NEM.split prop_splitLookup :: Property -prop_splitLookup = ttProp (GTIntKey :-> GTNEIntMap :-> TTTThese TTVal 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 -prop_isSubmapOfBy = ttProp (gf2 Gen.bool :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) +prop_isSubmapOfBy = + ttProp + (gf2 Gen.bool :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) M.isSubmapOfBy NEM.isSubmapOfBy prop_isProperSubmapOfBy :: Property -prop_isProperSubmapOfBy = ttProp (gf2 Gen.bool :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) +prop_isProperSubmapOfBy = + ttProp + (gf2 Gen.bool :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) M.isProperSubmapOfBy NEM.isProperSubmapOfBy prop_findMin :: Property -prop_findMin = ttProp (GTNEIntMap :-> TTOther :*: TTVal) +prop_findMin = + ttProp + (GTNEIntMap :-> TTOther :*: TTVal) M.findMin NEM.findMin prop_findMax :: Property -prop_findMax = ttProp (GTNEIntMap :-> TTOther :*: TTVal) +prop_findMax = + ttProp + (GTNEIntMap :-> TTOther :*: TTVal) M.findMax NEM.findMax prop_deleteMin :: Property -prop_deleteMin = ttProp (GTNEIntMap :-> TTOther) +prop_deleteMin = + ttProp + (GTNEIntMap :-> TTOther) M.deleteMin NEM.deleteMin prop_deleteMax :: Property -prop_deleteMax = ttProp (GTNEIntMap :-> TTOther) +prop_deleteMax = + ttProp + (GTNEIntMap :-> TTOther) M.deleteMax NEM.deleteMax prop_deleteFindMin :: Property -prop_deleteFindMin = ttProp (GTNEIntMap :-> (TTOther :*: TTVal) :*: TTOther) +prop_deleteFindMin = + ttProp + (GTNEIntMap :-> (TTOther :*: TTVal) :*: TTOther) M.deleteFindMin NEM.deleteFindMin prop_deleteFindMax :: Property -prop_deleteFindMax = ttProp (GTNEIntMap :-> (TTOther :*: TTVal) :*: TTOther) +prop_deleteFindMax = + ttProp + (GTNEIntMap :-> (TTOther :*: TTVal) :*: TTOther) M.deleteFindMax NEM.deleteFindMax prop_updateMinWithKey :: Property -prop_updateMinWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) +prop_updateMinWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) M.updateMinWithKey NEM.updateMinWithKey prop_updateMaxWithKey :: Property -prop_updateMaxWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) +prop_updateMaxWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) M.updateMaxWithKey NEM.updateMaxWithKey prop_adjustMinWithKey :: Property -prop_adjustMinWithKey = ttProp (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) - (M.updateMinWithKey . (fmap . fmap) Just) +prop_adjustMinWithKey = + ttProp + (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) + (M.updateMinWithKey . (fmap . fmap) Just) NEM.adjustMinWithKey prop_adjustMaxWithKey :: Property -prop_adjustMaxWithKey = ttProp (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) - (M.updateMaxWithKey . (fmap . fmap) Just) +prop_adjustMaxWithKey = + ttProp + (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) + (M.updateMaxWithKey . (fmap . fmap) Just) NEM.adjustMaxWithKey prop_minView :: Property -prop_minView = ttProp (GTNEIntMap :-> TTMaybe (TTVal :*: TTOther)) +prop_minView = + ttProp + (GTNEIntMap :-> TTMaybe (TTVal :*: TTOther)) M.minView (Just . NEM.minView) prop_maxView :: Property -prop_maxView = ttProp (GTNEIntMap :-> TTMaybe (TTVal :*: TTOther)) +prop_maxView = + ttProp + (GTNEIntMap :-> TTMaybe (TTVal :*: TTOther)) M.maxView (Just . NEM.maxView) prop_elem :: Property -prop_elem = ttProp (GTVal :-> GTNEIntMap :-> TTOther) +prop_elem = + ttProp + (GTVal :-> GTNEIntMap :-> TTOther) elem elem prop_fold1 :: Property -prop_fold1 = ttProp (GTNEIntMap :-> TTVal) - (fold . toList) +prop_fold1 = + ttProp + (GTNEIntMap :-> TTVal) + fold fold1 prop_fold :: Property -prop_fold = ttProp (GTNEIntMap :-> TTVal) - (fold . toList) +prop_fold = + ttProp + (GTNEIntMap :-> TTVal) fold + fold prop_foldMap1 :: Property -prop_foldMap1 = ttProp (gf1 valGen :?> GTNEIntMap :-> TTOther) - (\f -> foldMap ((:[]) . f) . toList) - (\f -> foldMap1 ((:[]) . f)) +prop_foldMap1 = + ttProp + (gf1 valGen :?> GTNEIntMap :-> TTOther) + (\f -> foldMap ((: []) . f)) + (\f -> foldMap1 ((: []) . f)) prop_foldMap :: Property -prop_foldMap = ttProp (gf1 valGen :?> GTNEIntMap :-> TTOther) - (\f -> foldMap ((:[]) . f) . toList) - (\f -> foldMap ((:[]) . f)) +prop_foldMap = + ttProp + (gf1 valGen :?> GTNEIntMap :-> TTOther) + (\f -> foldMap ((: []) . f)) + (\f -> foldMap ((: []) . f)) prop_alt :: Property -prop_alt = ttProp (GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) +prop_alt = + ttProp + (GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) () () diff --git a/test/Tests/IntSet.hs b/test/Tests/IntSet.hs --- a/test/Tests/IntSet.hs +++ b/test/Tests/IntSet.hs @@ -1,32 +1,27 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Tests.IntSet (intSetTests) where -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup.Foldable -import Hedgehog -import Test.Tasty -import Tests.Util -import qualified Data.IntSet as S -import qualified Data.IntSet.NonEmpty as NES -import qualified Data.IntSet.NonEmpty.Internal as NES -import qualified Data.List.NonEmpty as NE -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Data.Functor.Identity +import qualified Data.IntSet as S +import qualified Data.IntSet.NonEmpty as NES +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Semigroup.Foldable +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Tests.Util intSetTests :: TestTree -intSetTests = groupTree $$(discover) - - - - +intSetTests = groupTree $$discover prop_valid :: Property -prop_valid = property $ +prop_valid = + property $ assert . NES.valid =<< forAll neIntSetGen - -- | We cannot implement these because there is no 'valid' for IntSet -- prop_valid_toSet :: Property -- prop_valid_toSet = property $ do @@ -50,294 +45,372 @@ prop_valid_insertSetMin :: Property prop_valid_insertSetMin = property $ do - n <- forAll $ do - m <- intSetGen - let k = maybe 0 (subtract 1 . fst) $ S.minView m - pure $ NES.insertSetMin k m - assert $ NES.valid n + n <- forAll $ do + m <- intSetGen + let k = maybe 0 (subtract 1 . fst) $ S.minView m + pure $ NES.insertSetMin k m + assert $ NES.valid n prop_valid_insertSetMax :: Property prop_valid_insertSetMax = property $ do - n <- forAll $ do - m <- intSetGen - let k = maybe 0 ((+ 1) . fst) $ S.maxView m - pure $ NES.insertSetMax k m - assert $ NES.valid n + n <- forAll $ do + m <- intSetGen + let k = maybe 0 ((+ 1) . fst) $ S.maxView m + pure $ NES.insertSetMax k m + assert $ NES.valid n prop_toSetIso1 :: Property prop_toSetIso1 = property $ do - m0 <- forAll intSetGen - tripping m0 NES.nonEmptySet - (Identity . maybe S.empty NES.toSet) + m0 <- forAll intSetGen + tripping + m0 + NES.nonEmptySet + (Identity . maybe S.empty NES.toSet) prop_toSetIso2 :: Property prop_toSetIso2 = property $ do - m0 <- forAll $ Gen.maybe neIntSetGen - tripping m0 (maybe S.empty NES.toSet) - (Identity . NES.nonEmptySet) + m0 <- forAll $ Gen.maybe neIntSetGen + tripping + m0 + (maybe S.empty NES.toSet) + (Identity . NES.nonEmptySet) prop_read_show :: Property prop_read_show = readShow neIntSetGen prop_splitRoot :: Property prop_splitRoot = property $ do - n <- forAll neIntSetGen - let rs = NES.splitRoot n - allItems = foldMap1 NES.toList rs - n' = NES.unions rs - assert $ ascending allItems - mapM_ (assert . (`NES.isSubsetOf` n)) rs - length allItems === NES.size n' - n === n' + n <- forAll neIntSetGen + let rs = NES.splitRoot n + allItems = foldMap1 NES.toList rs + n' = NES.unions rs + assert $ ascending allItems + mapM_ (assert . (`NES.isSubsetOf` n)) rs + length allItems === NES.size n' + n === n' where ascending (x :| xs) = case NE.nonEmpty xs of - Nothing -> True + Nothing -> True Just ys@(y :| _) -> x < y && ascending ys - - - - - - - - - prop_insertSet :: Property -prop_insertSet = ttProp (GTIntKey :-> GTIntSet :-> TTNEIntSet) +prop_insertSet = + ttProp + (GTIntKey :-> GTIntSet :-> TTNEIntSet) S.insert NES.insertSet prop_singleton :: Property -prop_singleton = ttProp (GTIntKey :-> TTNEIntSet) +prop_singleton = + ttProp + (GTIntKey :-> TTNEIntSet) S.singleton NES.singleton prop_fromAscList :: Property -prop_fromAscList = ttProp (GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntSet) - (S.fromAscList . fmap fst) +prop_fromAscList = + ttProp + (GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntSet) + (S.fromAscList . fmap fst) (NES.fromAscList . fmap fst) prop_fromDistinctAscList :: Property -prop_fromDistinctAscList = ttProp (GTSorted STAsc (GTNEList Nothing GTIntKey) :-> TTNEIntSet) +prop_fromDistinctAscList = + ttProp + (GTSorted STAsc (GTNEList Nothing GTIntKey) :-> TTNEIntSet) S.fromDistinctAscList NES.fromDistinctAscList prop_fromList :: Property -prop_fromList = ttProp (GTNEList Nothing GTIntKey :-> TTNEIntSet) +prop_fromList = + ttProp + (GTNEList Nothing GTIntKey :-> TTNEIntSet) S.fromList NES.fromList prop_insert :: Property -prop_insert = ttProp (GTIntKey :-> GTNEIntSet :-> TTNEIntSet) +prop_insert = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTNEIntSet) S.insert NES.insert prop_delete :: Property -prop_delete = ttProp (GTIntKey :-> GTNEIntSet :-> TTOther) +prop_delete = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTOther) S.delete NES.delete prop_member :: Property -prop_member = ttProp (GTIntKey :-> GTNEIntSet :-> TTOther) +prop_member = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTOther) S.member NES.member prop_notMember :: Property -prop_notMember = ttProp (GTIntKey :-> GTNEIntSet :-> TTOther) +prop_notMember = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTOther) S.notMember NES.notMember prop_lookupLT :: Property -prop_lookupLT = ttProp (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) +prop_lookupLT = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) S.lookupLT NES.lookupLT prop_lookupGT :: Property -prop_lookupGT = ttProp (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) +prop_lookupGT = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) S.lookupGT NES.lookupGT prop_lookupLE :: Property -prop_lookupLE = ttProp (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) +prop_lookupLE = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) S.lookupLE NES.lookupLE prop_lookupGE :: Property -prop_lookupGE = ttProp (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) +prop_lookupGE = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) S.lookupGE NES.lookupGE prop_size :: Property -prop_size = ttProp (GTNEIntSet :-> TTOther) +prop_size = + ttProp + (GTNEIntSet :-> TTOther) S.size NES.size prop_isSubsetOf :: Property -prop_isSubsetOf = ttProp (GTNEIntSet :-> GTNEIntSet :-> TTOther) +prop_isSubsetOf = + ttProp + (GTNEIntSet :-> GTNEIntSet :-> TTOther) S.isSubsetOf NES.isSubsetOf prop_isProperSubsetOf :: Property -prop_isProperSubsetOf = ttProp (GTNEIntSet :-> GTNEIntSet :-> TTOther) +prop_isProperSubsetOf = + ttProp + (GTNEIntSet :-> GTNEIntSet :-> TTOther) S.isProperSubsetOf NES.isProperSubsetOf prop_disjoint :: Property -prop_disjoint = ttProp (GTNEIntSet :-> GTNEIntSet :-> TTOther) - NES.disjointSet +prop_disjoint = + ttProp + (GTNEIntSet :-> GTNEIntSet :-> TTOther) + S.disjoint NES.disjoint prop_union :: Property -prop_union = ttProp (GTNEIntSet :-> GTNEIntSet :-> TTNEIntSet) +prop_union = + ttProp + (GTNEIntSet :-> GTNEIntSet :-> TTNEIntSet) S.union NES.union prop_unions :: Property -prop_unions = ttProp (GTNEList (Just (Range.linear 2 5)) GTNEIntSet :-> TTNEIntSet) +prop_unions = + ttProp + (GTNEList (Just (Range.linear 2 5)) GTNEIntSet :-> TTNEIntSet) S.unions NES.unions prop_difference :: Property -prop_difference = ttProp (GTNEIntSet :-> GTNEIntSet :-> TTOther) +prop_difference = + ttProp + (GTNEIntSet :-> GTNEIntSet :-> TTOther) S.difference NES.difference prop_intersection :: Property -prop_intersection = ttProp (GTNEIntSet :-> GTNEIntSet :-> TTOther) +prop_intersection = + ttProp + (GTNEIntSet :-> GTNEIntSet :-> TTOther) S.intersection NES.intersection prop_filter :: Property -prop_filter = ttProp (gf1 Gen.bool :?> GTNEIntSet :-> TTOther) +prop_filter = + ttProp + (gf1 Gen.bool :?> GTNEIntSet :-> TTOther) S.filter NES.filter prop_partition :: Property -prop_partition = ttProp (gf1 Gen.bool :?> GTNEIntSet :-> TTThese TTNEIntSet TTNEIntSet) +prop_partition = + ttProp + (gf1 Gen.bool :?> GTNEIntSet :-> TTThese TTNEIntSet TTNEIntSet) S.partition NES.partition prop_split :: Property -prop_split = ttProp (GTIntKey :-> GTNEIntSet :-> TTMThese TTNEIntSet TTNEIntSet) +prop_split = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTMThese TTNEIntSet TTNEIntSet) S.split NES.split prop_splitMember :: Property -prop_splitMember = ttProp (GTIntKey :-> GTNEIntSet :-> TTOther :*: TTMThese TTNEIntSet TTNEIntSet) - (\k -> (\(x,y,z) -> (y,(x,z))) . S.splitMember k) +prop_splitMember = + ttProp + (GTIntKey :-> GTNEIntSet :-> TTOther :*: TTMThese TTNEIntSet TTNEIntSet) + (\k -> (\(x, y, z) -> (y, (x, z))) . S.splitMember k) NES.splitMember prop_map :: Property -prop_map = ttProp (gf1 intKeyGen :?> GTNEIntSet :-> TTNEIntSet) +prop_map = + ttProp + (gf1 intKeyGen :?> GTNEIntSet :-> TTNEIntSet) S.map NES.map prop_foldr :: Property -prop_foldr = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEIntSet - :-> TTOther - ) +prop_foldr = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEIntSet + :-> TTOther + ) S.foldr NES.foldr prop_foldl :: Property -prop_foldl = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEIntSet - :-> TTOther - ) +prop_foldl = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEIntSet + :-> TTOther + ) S.foldl NES.foldl prop_foldr1 :: Property -prop_foldr1 = ttProp ( gf2 intKeyGen - :?> GTNEIntSet - :-> TTOther - ) +prop_foldr1 = + ttProp + ( gf2 intKeyGen + :?> GTNEIntSet + :-> TTOther + ) (\f -> foldr1 f . S.toList) NES.foldr1 prop_foldl1 :: Property -prop_foldl1 = ttProp ( gf2 intKeyGen - :?> GTNEIntSet - :-> TTOther - ) +prop_foldl1 = + ttProp + ( gf2 intKeyGen + :?> GTNEIntSet + :-> TTOther + ) (\f -> foldl1 f . S.toList) NES.foldl1 prop_foldr' :: Property -prop_foldr' = ttProp ( gf2 intKeyGen - :?> GTOther intKeyGen - :-> GTNEIntSet - :-> TTOther - ) +prop_foldr' = + ttProp + ( gf2 intKeyGen + :?> GTOther intKeyGen + :-> GTNEIntSet + :-> TTOther + ) S.foldr' NES.foldr' prop_foldl' :: Property -prop_foldl' = ttProp ( gf2 intKeyGen - :?> GTOther intKeyGen - :-> GTNEIntSet - :-> TTOther - ) +prop_foldl' = + ttProp + ( gf2 intKeyGen + :?> GTOther intKeyGen + :-> GTNEIntSet + :-> TTOther + ) S.foldl' NES.foldl' prop_foldr1' :: Property -prop_foldr1' = ttProp ( gf2 intKeyGen - :?> GTNEIntSet - :-> TTOther - ) +prop_foldr1' = + ttProp + ( gf2 intKeyGen + :?> GTNEIntSet + :-> TTOther + ) (\f -> foldr1 f . S.toList) NES.foldr1' prop_foldl1' :: Property -prop_foldl1' = ttProp ( gf2 intKeyGen - :?> GTNEIntSet - :-> TTOther - ) +prop_foldl1' = + ttProp + ( gf2 intKeyGen + :?> GTNEIntSet + :-> TTOther + ) (\f -> foldl1 f . S.toList) NES.foldl1' prop_findMin :: Property -prop_findMin = ttProp (GTNEIntSet :-> TTOther) +prop_findMin = + ttProp + (GTNEIntSet :-> TTOther) S.findMin NES.findMin prop_findMax :: Property -prop_findMax = ttProp (GTNEIntSet :-> TTOther) +prop_findMax = + ttProp + (GTNEIntSet :-> TTOther) S.findMax NES.findMax prop_deleteMin :: Property -prop_deleteMin = ttProp (GTNEIntSet :-> TTOther) +prop_deleteMin = + ttProp + (GTNEIntSet :-> TTOther) S.deleteMin NES.deleteMin prop_deleteMax :: Property -prop_deleteMax = ttProp (GTNEIntSet :-> TTOther) +prop_deleteMax = + ttProp + (GTNEIntSet :-> TTOther) S.deleteMax NES.deleteMax prop_deleteFindMin :: Property -prop_deleteFindMin = ttProp (GTNEIntSet :-> TTOther :*: TTOther) +prop_deleteFindMin = + ttProp + (GTNEIntSet :-> TTOther :*: TTOther) S.deleteFindMin NES.deleteFindMin prop_deleteFindMax :: Property -prop_deleteFindMax = ttProp (GTNEIntSet :-> TTOther :*: TTOther) +prop_deleteFindMax = + ttProp + (GTNEIntSet :-> TTOther :*: TTOther) S.deleteFindMax NES.deleteFindMax prop_toList :: Property -prop_toList = ttProp (GTNEIntSet :-> TTNEList TTOther) +prop_toList = + ttProp + (GTNEIntSet :-> TTNEList TTOther) S.toList NES.toList prop_toDescList :: Property -prop_toDescList = ttProp (GTNEIntSet :-> TTNEList TTOther) +prop_toDescList = + ttProp + (GTNEIntSet :-> TTNEList TTOther) S.toDescList NES.toDescList - diff --git a/test/Tests/Map.hs b/test/Tests/Map.hs --- a/test/Tests/Map.hs +++ b/test/Tests/Map.hs @@ -1,90 +1,92 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Tests.Map (mapTests) where -import Control.Applicative -import Control.Comonad -import Data.Coerce -import Data.Foldable -import Data.Functor.Alt -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Data.Text (Text) -import Hedgehog -import Test.Tasty -import Tests.Util -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Map.NonEmpty as NEM +import Control.Applicative +import Control.Comonad +import Data.Coerce +import Data.Foldable +import Data.Functor.Alt +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import qualified Data.Map.NonEmpty as NEM import qualified Data.Map.NonEmpty.Internal as NEM -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Text (Text) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Tests.Util mapTests :: TestTree -mapTests = groupTree $$(discover) - - - - +mapTests = groupTree $$discover prop_valid :: Property -prop_valid = property $ +prop_valid = + property $ assert . NEM.valid =<< forAll neMapGen prop_valid_toMap :: Property -prop_valid_toMap = property $ +prop_valid_toMap = + property $ assert . M.valid . NEM.toMap =<< forAll neMapGen prop_valid_insertMinMap :: Property prop_valid_insertMinMap = property $ do - n <- forAll $ do - m <- mapGen - let k = maybe dummyKey (subtract 1 . fst) $ M.lookupMin m - v <- valGen - pure $ NEM.insertMinMap k v m - assert $ M.valid n + n <- forAll $ do + m <- mapGen + let k = maybe dummyKey (subtract 1 . fst) $ M.lookupMin m + v <- valGen + pure $ NEM.insertMinMap k v m + assert $ M.valid n prop_valid_insertMaxMap :: Property prop_valid_insertMaxMap = property $ do - n <- forAll $ do - m <- mapGen - let k = maybe dummyKey ((+ 1) . fst) $ M.lookupMax m - v <- valGen - pure $ NEM.insertMaxMap k v m - assert $ M.valid n + n <- forAll $ do + m <- mapGen + let k = maybe dummyKey ((+ 1) . fst) $ M.lookupMax m + v <- valGen + pure $ NEM.insertMaxMap k v m + assert $ M.valid n prop_valid_insertMapMin :: Property prop_valid_insertMapMin = property $ do - n <- forAll $ do - m <- mapGen - let k = maybe dummyKey (subtract 1 . fst) $ M.lookupMin m - v <- valGen - pure $ NEM.insertMapMin k v m - assert $ NEM.valid n + n <- forAll $ do + m <- mapGen + let k = maybe dummyKey (subtract 1 . fst) $ M.lookupMin m + v <- valGen + pure $ NEM.insertMapMin k v m + assert $ NEM.valid n prop_valid_insertMapMax :: Property prop_valid_insertMapMax = property $ do - n <- forAll $ do - m <- mapGen - let k = maybe dummyKey ((+ 1) . fst) $ M.lookupMax m - v <- valGen - pure $ NEM.insertMapMax k v m - assert $ NEM.valid n + n <- forAll $ do + m <- mapGen + let k = maybe dummyKey ((+ 1) . fst) $ M.lookupMax m + v <- valGen + pure $ NEM.insertMapMax k v m + assert $ NEM.valid n prop_toMapIso1 :: Property prop_toMapIso1 = property $ do - m0 <- forAll mapGen - tripping m0 NEM.nonEmptyMap - (Identity . maybe M.empty NEM.toMap) + m0 <- forAll mapGen + tripping + m0 + NEM.nonEmptyMap + (Identity . maybe M.empty NEM.toMap) prop_toMapIso2 :: Property prop_toMapIso2 = property $ do - m0 <- forAll $ Gen.maybe neMapGen - tripping m0 (maybe M.empty NEM.toMap) - (Identity . NEM.nonEmptyMap) + m0 <- forAll $ Gen.maybe neMapGen + tripping + m0 + (maybe M.empty NEM.toMap) + (Identity . NEM.nonEmptyMap) prop_read_show :: Property prop_read_show = readShow neMapGen @@ -100,176 +102,219 @@ prop_splitRoot :: Property prop_splitRoot = property $ do - n <- forAll neMapGen - let rs = NEM.splitRoot n - allItems = foldMap1 NEM.keys rs - n' = NEM.unions rs - assert $ ascending allItems - mapM_ (assert . (`NEM.isSubmapOf` n)) rs - length allItems === length n' - n === n' + n <- forAll neMapGen + let rs = NEM.splitRoot n + allItems = foldMap1 NEM.keys rs + n' = NEM.unions rs + assert $ ascending allItems + mapM_ (assert . (`NEM.isSubmapOf` n)) rs + length allItems === length n' + n === n' where ascending (x :| xs) = case NE.nonEmpty xs of - Nothing -> True + Nothing -> True Just ys@(y :| _) -> x < y && ascending ys prop_extract_duplicate :: Property prop_extract_duplicate = property $ do - n <- forAll neMapGen - tripping n duplicate - (Identity . extract) + n <- forAll neMapGen + tripping + n + duplicate + (Identity . extract) prop_fmap_extract_duplicate :: Property prop_fmap_extract_duplicate = property $ do - n <- forAll neMapGen - tripping n duplicate - (Identity . fmap extract) + n <- forAll neMapGen + tripping + n + duplicate + (Identity . fmap extract) prop_duplicate_duplicate :: Property prop_duplicate_duplicate = property $ do - n <- forAll neMapGen - let dd1 = duplicate . duplicate $ n - dd2 = fmap duplicate . duplicate $ n - assert $ NEM.valid dd1 - assert $ NEM.valid dd2 - dd1 === dd2 - - - - - - - + n <- forAll neMapGen + let dd1 = duplicate . duplicate $ n + dd2 = fmap duplicate . duplicate $ n + assert $ NEM.valid dd1 + assert $ NEM.valid dd2 + dd1 === dd2 prop_insertMapWithKey :: Property -prop_insertMapWithKey = ttProp (gf3 valGen :?> GTKey :-> GTVal :-> GTMap :-> TTNEMap) +prop_insertMapWithKey = + ttProp + (gf3 valGen :?> GTKey :-> GTVal :-> GTMap :-> TTNEMap) M.insertWithKey NEM.insertMapWithKey prop_singleton :: Property -prop_singleton = ttProp (GTKey :-> GTVal :-> TTNEMap) +prop_singleton = + ttProp + (GTKey :-> GTVal :-> TTNEMap) M.singleton NEM.singleton prop_fromSet :: Property -prop_fromSet = ttProp (gf1 valGen :?> GTNESet :-> TTNEMap) +prop_fromSet = + ttProp + (gf1 valGen :?> GTNESet :-> TTNEMap) M.fromSet NEM.fromSet prop_fromAscList :: Property -prop_fromAscList = ttProp (GTSorted STAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) +prop_fromAscList = + ttProp + (GTSorted STAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) M.fromAscList NEM.fromAscList prop_fromDescList :: Property -prop_fromDescList = ttProp (GTSorted STDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) +prop_fromDescList = + ttProp + (GTSorted STDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) M.fromDescList NEM.fromDescList prop_fromAscListWithKey :: Property -prop_fromAscListWithKey = ttProp (gf3 valGen :?> GTSorted STAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) +prop_fromAscListWithKey = + ttProp + (gf3 valGen :?> GTSorted STAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) M.fromAscListWithKey NEM.fromAscListWithKey prop_fromDescListWithKey :: Property -prop_fromDescListWithKey = ttProp (gf3 valGen :?> GTSorted STDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) +prop_fromDescListWithKey = + ttProp + (gf3 valGen :?> GTSorted STDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) M.fromDescListWithKey NEM.fromDescListWithKey prop_fromDistinctAscList :: Property -prop_fromDistinctAscList = ttProp (GTSorted STDistinctAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) +prop_fromDistinctAscList = + ttProp + (GTSorted STDistinctAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) M.fromDistinctAscList NEM.fromDistinctAscList prop_fromDistinctDescList :: Property -prop_fromDistinctDescList = ttProp (GTSorted STDistinctDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) +prop_fromDistinctDescList = + ttProp + (GTSorted STDistinctDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNEMap) M.fromDistinctDescList NEM.fromDistinctDescList prop_fromListWithKey :: Property -prop_fromListWithKey = ttProp (gf3 valGen :?> GTNEList Nothing (GTKey :&: GTVal) :-> TTNEMap) +prop_fromListWithKey = + ttProp + (gf3 valGen :?> GTNEList Nothing (GTKey :&: GTVal) :-> TTNEMap) M.fromListWithKey NEM.fromListWithKey prop_insert :: Property -prop_insert = ttProp (GTKey :-> GTVal :-> GTNEMap :-> TTNEMap) +prop_insert = + ttProp + (GTKey :-> GTVal :-> GTNEMap :-> TTNEMap) M.insert NEM.insert prop_insertWithKey :: Property -prop_insertWithKey = ttProp (gf3 valGen :?> GTKey :-> GTVal :-> GTNEMap :-> TTNEMap) +prop_insertWithKey = + ttProp + (gf3 valGen :?> GTKey :-> GTVal :-> GTNEMap :-> TTNEMap) M.insertWithKey NEM.insertWithKey prop_delete :: Property -prop_delete = ttProp (GTKey :-> GTNEMap :-> TTMap) +prop_delete = + ttProp + (GTKey :-> GTNEMap :-> TTMap) M.delete NEM.delete prop_adjustWithKey :: Property -prop_adjustWithKey = ttProp (gf2 valGen :?> GTKey :-> GTNEMap :-> TTNEMap) +prop_adjustWithKey = + ttProp + (gf2 valGen :?> GTKey :-> GTNEMap :-> TTNEMap) M.adjustWithKey NEM.adjustWithKey prop_updateWithKey :: Property -prop_updateWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTKey :-> GTNEMap :-> TTMap) +prop_updateWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTKey :-> GTNEMap :-> TTMap) M.updateWithKey NEM.updateWithKey prop_updateLookupWithKey :: Property -prop_updateLookupWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTKey :-> GTNEMap :-> TTMaybe TTVal :*: TTMap) +prop_updateLookupWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTKey :-> GTNEMap :-> TTMaybe TTVal :*: TTMap) M.updateLookupWithKey NEM.updateLookupWithKey prop_alter :: Property -prop_alter = ttProp (gf1 (Gen.maybe valGen) :?> GTKey :-> GTNEMap :-> TTMap) +prop_alter = + ttProp + (gf1 (Gen.maybe valGen) :?> GTKey :-> GTNEMap :-> TTMap) M.alter NEM.alter prop_alter' :: Property -prop_alter' = ttProp (gf1 valGen :?> GTKey :-> GTNEMap :-> TTNEMap) +prop_alter' = + ttProp + (gf1 valGen :?> GTKey :-> GTNEMap :-> TTNEMap) (M.alter . fmap Just) NEM.alter' prop_alterF :: Property -prop_alterF = ttProp ( gf1 (Gen.maybe valGen) - :?> GTKey - :-> GTNEMap - :-> TTCtx (GTMaybe GTVal :-> TTMap) (TTMaybe TTVal) - ) - (M.alterF . Context) +prop_alterF = + ttProp + ( gf1 (Gen.maybe valGen) + :?> GTKey + :-> GTNEMap + :-> TTCtx (GTMaybe GTVal :-> TTMap) (TTMaybe TTVal) + ) + (M.alterF . Context) (NEM.alterF . Context) prop_alterF_rules_Const :: Property -prop_alterF_rules_Const = ttProp ( gf1 (Const <$> valGen) - :?> GTKey - :-> GTNEMap - :-> TTOther - ) - (\f k m -> getConst (M.alterF f k m)) +prop_alterF_rules_Const = + ttProp + ( gf1 (Const <$> valGen) + :?> GTKey + :-> GTNEMap + :-> TTOther + ) + (\f k m -> getConst (M.alterF f k m)) (\f k m -> getConst (NEM.alterF f k m)) prop_alterF_rules_Identity :: Property -prop_alterF_rules_Identity = ttProp ( gf1 (Identity <$> Gen.maybe valGen) - :?> GTKey - :-> GTNEMap - :-> TTMap - ) - (\f k m -> runIdentity (M.alterF f k m)) +prop_alterF_rules_Identity = + ttProp + ( gf1 (Identity <$> Gen.maybe valGen) + :?> GTKey + :-> GTNEMap + :-> TTMap + ) + (\f k m -> runIdentity (M.alterF f k m)) (\f k m -> runIdentity (NEM.alterF f k m)) prop_alterF' :: Property -prop_alterF' = ttProp (gf1 valGen :?> GTKey :-> GTNEMap :-> TTCtx (GTVal :-> TTNEMap) (TTMaybe TTVal)) - (M.alterF . Context . fmap Just) +prop_alterF' = + ttProp + (gf1 valGen :?> GTKey :-> GTNEMap :-> TTCtx (GTVal :-> TTNEMap) (TTMaybe TTVal)) + (M.alterF . Context . fmap Just) (NEM.alterF' . Context) prop_alterF'_rules_Const :: Property -prop_alterF'_rules_Const = ttProp ( gf1 (Const <$> valGen) - :?> GTKey - :-> GTNEMap - :-> TTOther - ) - (\f k m -> let f' = fmap Just . f in getConst (M.alterF f' k m)) +prop_alterF'_rules_Const = + ttProp + ( gf1 (Const <$> valGen) + :?> GTKey + :-> GTNEMap + :-> TTOther + ) + (\f k m -> let f' = fmap Just . f in getConst (M.alterF f' k m)) (\f k m -> getConst (NEM.alterF' f k m)) -- -- | This fails, but isn't possible to fix without copying-and-pasting more @@ -284,537 +329,731 @@ -- (\f k m -> runIdentity (NEM.alterF' f k m)) prop_lookup :: Property -prop_lookup = ttProp (GTKey :-> GTNEMap :-> TTMaybe TTVal) +prop_lookup = + ttProp + (GTKey :-> GTNEMap :-> TTMaybe TTVal) M.lookup NEM.lookup prop_findWithDefault :: Property -prop_findWithDefault = ttProp (GTVal :-> GTKey :-> GTNEMap :-> TTVal) +prop_findWithDefault = + ttProp + (GTVal :-> GTKey :-> GTNEMap :-> TTVal) M.findWithDefault NEM.findWithDefault prop_member :: Property -prop_member = ttProp (GTKey :-> GTNEMap :-> TTOther) +prop_member = + ttProp + (GTKey :-> GTNEMap :-> TTOther) M.member NEM.member prop_notMember :: Property -prop_notMember = ttProp (GTKey :-> GTNEMap :-> TTOther) +prop_notMember = + ttProp + (GTKey :-> GTNEMap :-> TTOther) M.notMember NEM.notMember prop_lookupLT :: Property -prop_lookupLT = ttProp (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) +prop_lookupLT = + ttProp + (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) M.lookupLT NEM.lookupLT prop_lookupGT :: Property -prop_lookupGT = ttProp (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) +prop_lookupGT = + ttProp + (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) M.lookupGT NEM.lookupGT prop_lookupLE :: Property -prop_lookupLE = ttProp (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) +prop_lookupLE = + ttProp + (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) M.lookupLE NEM.lookupLE prop_lookupGE :: Property -prop_lookupGE = ttProp (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) +prop_lookupGE = + ttProp + (GTKey :-> GTNEMap :-> TTMaybe (TTKey :*: TTVal)) M.lookupGE NEM.lookupGE prop_size :: Property -prop_size = ttProp (GTNEMap :-> TTOther) +prop_size = + ttProp + (GTNEMap :-> TTOther) M.size NEM.size prop_union :: Property -prop_union = ttProp (GTNEMap :-> GTNEMap :-> TTNEMap) +prop_union = + ttProp + (GTNEMap :-> GTNEMap :-> TTNEMap) M.union NEM.union prop_unionWith :: Property -prop_unionWith = ttProp (gf2 valGen :?> GTNEMap :-> GTNEMap :-> TTNEMap) +prop_unionWith = + ttProp + (gf2 valGen :?> GTNEMap :-> GTNEMap :-> TTNEMap) M.unionWith NEM.unionWith prop_unionWithKey :: Property -prop_unionWithKey = ttProp (gf3 valGen :?> GTNEMap :-> GTNEMap :-> TTNEMap) +prop_unionWithKey = + ttProp + (gf3 valGen :?> GTNEMap :-> GTNEMap :-> TTNEMap) M.unionWithKey NEM.unionWithKey prop_unions :: Property -prop_unions = ttProp (GTNEList (Just (Range.linear 2 5)) GTNEMap :-> TTNEMap) +prop_unions = + ttProp + (GTNEList (Just (Range.linear 2 5)) GTNEMap :-> TTNEMap) M.unions NEM.unions prop_unionsWith :: Property -prop_unionsWith = ttProp (gf2 valGen :?> GTNEList (Just (Range.linear 2 5)) GTNEMap :-> TTNEMap) +prop_unionsWith = + ttProp + (gf2 valGen :?> GTNEList (Just (Range.linear 2 5)) GTNEMap :-> TTNEMap) M.unionsWith NEM.unionsWith prop_difference :: Property -prop_difference = ttProp (GTNEMap :-> GTNEMap :-> TTMap) +prop_difference = + ttProp + (GTNEMap :-> GTNEMap :-> TTMap) M.difference NEM.difference prop_differenceWithKey :: Property -prop_differenceWithKey = ttProp (gf3 (Gen.maybe valGen) :?> GTNEMap :-> GTNEMap :-> TTMap) +prop_differenceWithKey = + ttProp + (gf3 (Gen.maybe valGen) :?> GTNEMap :-> GTNEMap :-> TTMap) M.differenceWithKey NEM.differenceWithKey prop_intersection :: Property -prop_intersection = ttProp (GTNEMap :-> GTNEMap :-> TTMap) +prop_intersection = + ttProp + (GTNEMap :-> GTNEMap :-> TTMap) M.intersection NEM.intersection prop_intersectionWithKey :: Property -prop_intersectionWithKey = ttProp (gf3 valGen :?> GTNEMap :-> GTNEMap :-> TTMap) +prop_intersectionWithKey = + ttProp + (gf3 valGen :?> GTNEMap :-> GTNEMap :-> TTMap) M.intersectionWithKey NEM.intersectionWithKey prop_map :: Property -prop_map = ttProp (gf1 valGen :?> GTNEMap :-> TTNEMap) +prop_map = + ttProp + (gf1 valGen :?> GTNEMap :-> TTNEMap) M.map NEM.map prop_map_rules_map :: Property -prop_map_rules_map = ttProp (gf1 valGen :?> gf1 valGen :?> GTNEMap :-> TTNEMap) - (\f g xs -> M.map f (M.map g xs)) +prop_map_rules_map = + ttProp + (gf1 valGen :?> gf1 valGen :?> GTNEMap :-> TTNEMap) + (\f g xs -> M.map f (M.map g xs)) (\f g xs -> NEM.map f (NEM.map g xs)) prop_map_rules_coerce :: Property -prop_map_rules_coerce = ttProp (GTNEMap :-> TTNEMap) - (M.map @Text @Text coerce) +prop_map_rules_coerce = + ttProp + (GTNEMap :-> TTNEMap) + (M.map @Text @Text coerce) (NEM.map @Text @Text coerce) prop_map_rules_mapWithKey :: Property -prop_map_rules_mapWithKey = ttProp (gf1 valGen :?> gf2 valGen :?> GTNEMap :-> TTNEMap) - (\f g xs -> M.map f (M.mapWithKey g xs)) +prop_map_rules_mapWithKey = + ttProp + (gf1 valGen :?> gf2 valGen :?> GTNEMap :-> TTNEMap) + (\f g xs -> M.map f (M.mapWithKey g xs)) (\f g xs -> NEM.map f (NEM.mapWithKey g xs)) prop_mapWithKey :: Property -prop_mapWithKey = ttProp (gf2 valGen :?> GTNEMap :-> TTNEMap) +prop_mapWithKey = + ttProp + (gf2 valGen :?> GTNEMap :-> TTNEMap) M.mapWithKey NEM.mapWithKey prop_mapWithKey_rules_mapWithKey :: Property -prop_mapWithKey_rules_mapWithKey = ttProp (gf2 valGen :?> gf2 valGen :?> GTNEMap :-> TTNEMap) - (\f g xs -> M.mapWithKey f (M.mapWithKey g xs)) +prop_mapWithKey_rules_mapWithKey = + ttProp + (gf2 valGen :?> gf2 valGen :?> GTNEMap :-> TTNEMap) + (\f g xs -> M.mapWithKey f (M.mapWithKey g xs)) (\f g xs -> NEM.mapWithKey f (NEM.mapWithKey g xs)) prop_mapWithKey_rules_map :: Property -prop_mapWithKey_rules_map = ttProp (gf2 valGen :?> gf1 valGen :?> GTNEMap :-> TTNEMap) - (\f g xs -> M.mapWithKey f (M.map g xs)) +prop_mapWithKey_rules_map = + ttProp + (gf2 valGen :?> gf1 valGen :?> GTNEMap :-> TTNEMap) + (\f g xs -> M.mapWithKey f (M.map g xs)) (\f g xs -> NEM.mapWithKey f (NEM.map g xs)) prop_traverseWithKey1 :: Property -prop_traverseWithKey1 = ttProp (gf2 valGen :?> GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) - (\f -> M.traverseWithKey (\k -> (`More` Done (f k)))) +prop_traverseWithKey1 = + ttProp + (gf2 valGen :?> GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) + (\f -> M.traverseWithKey (\k -> (`More` Done (f k)))) (\f -> NEM.traverseWithKey1 (\k -> (`More` Done (f k)))) prop_traverseWithKey :: Property -prop_traverseWithKey = ttProp (gf2 valGen :?> GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) - (\f -> M.traverseWithKey (\k -> (`More` Done (f k)))) +prop_traverseWithKey = + ttProp + (gf2 valGen :?> GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) + (\f -> M.traverseWithKey (\k -> (`More` Done (f k)))) (\f -> NEM.traverseWithKey (\k -> (`More` Done (f k)))) prop_traverseMaybeWithKey1 :: Property -prop_traverseMaybeWithKey1 = ttProp (gf2 valGen :?> GTNEMap :-> TTBazaar (GTMaybe GTVal) TTMap TTVal) - (\f -> M.traverseMaybeWithKey (\k -> (`More` Done (fmap (f k))))) +prop_traverseMaybeWithKey1 = + ttProp + (gf2 valGen :?> GTNEMap :-> TTBazaar (GTMaybe GTVal) TTMap TTVal) + (\f -> M.traverseMaybeWithKey (\k -> (`More` Done (fmap (f k))))) (\f -> NEM.traverseMaybeWithKey1 (\k -> (`More` Done (fmap (f k))))) prop_traverseMaybeWithKey :: Property -prop_traverseMaybeWithKey = ttProp (gf2 valGen :?> GTNEMap :-> TTBazaar (GTMaybe GTVal) TTMap TTVal) - (\f -> M.traverseMaybeWithKey (\k -> (`More` Done (fmap (f k))))) +prop_traverseMaybeWithKey = + ttProp + (gf2 valGen :?> GTNEMap :-> TTBazaar (GTMaybe GTVal) TTMap TTVal) + (\f -> M.traverseMaybeWithKey (\k -> (`More` Done (fmap (f k))))) (\f -> NEM.traverseMaybeWithKey (\k -> (`More` Done (fmap (f k))))) prop_sequence1 :: Property -prop_sequence1 = ttProp (GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) +prop_sequence1 = + ttProp + (GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) (sequenceA . fmap (`More` Done id)) (sequence1 . fmap (`More` Done id)) +{-# ANN prop_sequence1 "HLint: ignore Use traverse" #-} prop_sequenceA :: Property -prop_sequenceA = ttProp (GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) +prop_sequenceA = + ttProp + (GTNEMap :-> TTBazaar GTVal TTNEMap TTVal) (sequenceA . fmap (`More` Done id)) (sequenceA . fmap (`More` Done id)) +{-# ANN prop_sequenceA "HLint: ignore Use traverse" #-} prop_mapAccumWithKey :: Property -prop_mapAccumWithKey = ttProp ( gf3 ((,) <$> valGen <*> valGen) - :?> GTOther valGen - :-> GTNEMap - :-> TTOther :*: TTNEMap - ) +prop_mapAccumWithKey = + ttProp + ( gf3 ((,) <$> valGen <*> valGen) + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + :*: TTNEMap + ) M.mapAccumWithKey NEM.mapAccumWithKey prop_mapAccumRWithKey :: Property -prop_mapAccumRWithKey = ttProp ( gf3 ((,) <$> valGen <*> valGen) - :?> GTOther valGen - :-> GTNEMap - :-> TTOther :*: TTNEMap - ) +prop_mapAccumRWithKey = + ttProp + ( gf3 ((,) <$> valGen <*> valGen) + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + :*: TTNEMap + ) M.mapAccumRWithKey NEM.mapAccumRWithKey prop_mapKeys :: Property -prop_mapKeys = ttProp (gf1 keyGen :?> GTNEMap :-> TTNEMap) +prop_mapKeys = + ttProp + (gf1 keyGen :?> GTNEMap :-> TTNEMap) M.mapKeys NEM.mapKeys - + prop_mapKeysWith :: Property -prop_mapKeysWith = ttProp ( gf2 valGen - :?> gf1 keyGen - :?> GTNEMap - :-> TTNEMap - ) +prop_mapKeysWith = + ttProp + ( gf2 valGen + :?> gf1 keyGen + :?> GTNEMap + :-> TTNEMap + ) M.mapKeysWith NEM.mapKeysWith prop_mapKeysMonotonic :: Property -prop_mapKeysMonotonic = ttProp (GF valGen go :?> GTNEMap :-> TTNEMap) +prop_mapKeysMonotonic = + ttProp + (GF valGen go :?> GTNEMap :-> TTNEMap) M.mapKeysMonotonic NEM.mapKeysMonotonic where go f (K i t) = K (i * 2) (f t) prop_foldr :: Property -prop_foldr = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldr = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldr NEM.foldr - + prop_foldl :: Property -prop_foldl = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldl = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldl NEM.foldl prop_foldr1 :: Property -prop_foldr1 = ttProp ( gf2 valGen - :?> GTNEMap - :-> TTOther - ) +prop_foldr1 = + ttProp + ( gf2 valGen + :?> GTNEMap + :-> TTOther + ) foldr1 NEM.foldr1 - + prop_foldl1 :: Property -prop_foldl1 = ttProp ( gf2 valGen - :?> GTNEMap - :-> TTOther - ) +prop_foldl1 = + ttProp + ( gf2 valGen + :?> GTNEMap + :-> TTOther + ) foldl1 NEM.foldl1 - + prop_foldrWithKey :: Property -prop_foldrWithKey = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldrWithKey = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldrWithKey NEM.foldrWithKey - + prop_foldlWithKey :: Property -prop_foldlWithKey = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldlWithKey = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldlWithKey NEM.foldlWithKey - + prop_foldMapWithKey :: Property -prop_foldMapWithKey = ttProp (gf2 valGen :?> GTNEMap :-> TTOther) +prop_foldMapWithKey = + ttProp + (gf2 valGen :?> GTNEMap :-> TTOther) M.foldMapWithKey NEM.foldMapWithKey - + prop_foldr' :: Property -prop_foldr' = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldr' = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldr' NEM.foldr' - + prop_foldl' :: Property -prop_foldl' = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldl' = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldl' NEM.foldl' prop_foldr1' :: Property -prop_foldr1' = ttProp ( gf2 valGen - :?> GTNEMap - :-> TTOther - ) +prop_foldr1' = + ttProp + ( gf2 valGen + :?> GTNEMap + :-> TTOther + ) foldr1 NEM.foldr1' - + prop_foldl1' :: Property -prop_foldl1' = ttProp ( gf2 valGen - :?> GTNEMap - :-> TTOther - ) +prop_foldl1' = + ttProp + ( gf2 valGen + :?> GTNEMap + :-> TTOther + ) foldl1 NEM.foldl1' - + prop_foldrWithKey' :: Property -prop_foldrWithKey' = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldrWithKey' = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldrWithKey' NEM.foldrWithKey' - + prop_foldlWithKey' :: Property -prop_foldlWithKey' = ttProp ( gf3 valGen - :?> GTOther valGen - :-> GTNEMap - :-> TTOther - ) +prop_foldlWithKey' = + ttProp + ( gf3 valGen + :?> GTOther valGen + :-> GTNEMap + :-> TTOther + ) M.foldlWithKey' NEM.foldlWithKey' prop_elems :: Property -prop_elems = ttProp (GTNEMap :-> TTNEList TTVal) +prop_elems = + ttProp + (GTNEMap :-> TTNEList TTVal) M.elems NEM.elems prop_keys :: Property -prop_keys = ttProp (GTNEMap :-> TTNEList TTKey) +prop_keys = + ttProp + (GTNEMap :-> TTNEList TTKey) M.keys NEM.keys prop_assocs :: Property -prop_assocs = ttProp (GTNEMap :-> TTNEList (TTKey :*: TTVal)) +prop_assocs = + ttProp + (GTNEMap :-> TTNEList (TTKey :*: TTVal)) M.assocs NEM.assocs prop_keysSet :: Property -prop_keysSet = ttProp (GTNEMap :-> TTNESet) +prop_keysSet = + ttProp + (GTNEMap :-> TTNESet) M.keysSet NEM.keysSet prop_toList :: Property -prop_toList = ttProp (GTNEMap :-> TTNEList (TTKey :*: TTVal)) +prop_toList = + ttProp + (GTNEMap :-> TTNEList (TTKey :*: TTVal)) M.toList NEM.toList prop_toDescList :: Property -prop_toDescList = ttProp (GTNEMap :-> TTNEList (TTKey :*: TTVal)) +prop_toDescList = + ttProp + (GTNEMap :-> TTNEList (TTKey :*: TTVal)) M.toDescList NEM.toDescList prop_filter :: Property -prop_filter = ttProp (gf1 Gen.bool :?> GTNEMap :-> TTMap) +prop_filter = + ttProp + (gf1 Gen.bool :?> GTNEMap :-> TTMap) M.filter NEM.filter prop_filterWithKey :: Property -prop_filterWithKey = ttProp (gf2 Gen.bool :?> GTNEMap :-> TTMap) +prop_filterWithKey = + ttProp + (gf2 Gen.bool :?> GTNEMap :-> TTMap) M.filterWithKey NEM.filterWithKey prop_restrictKeys :: Property -prop_restrictKeys = ttProp (GTNEMap :-> GTSet :-> TTMap) +prop_restrictKeys = + ttProp + (GTNEMap :-> GTSet :-> TTMap) M.restrictKeys NEM.restrictKeys prop_withoutKeys :: Property -prop_withoutKeys = ttProp (GTNEMap :-> GTSet :-> TTMap) +prop_withoutKeys = + ttProp + (GTNEMap :-> GTSet :-> TTMap) M.withoutKeys NEM.withoutKeys prop_partitionWithKey :: Property -prop_partitionWithKey = ttProp (gf2 Gen.bool :?> GTNEMap :-> TTThese TTNEMap TTNEMap) +prop_partitionWithKey = + ttProp + (gf2 Gen.bool :?> GTNEMap :-> TTThese TTNEMap TTNEMap) M.partitionWithKey NEM.partitionWithKey - + prop_takeWhileAntitone :: Property -prop_takeWhileAntitone = ttProp (GTNEMap :-> TTMap) - (M.takeWhileAntitone ((< 0) . getKX)) +prop_takeWhileAntitone = + ttProp + (GTNEMap :-> TTMap) + (M.takeWhileAntitone ((< 0) . getKX)) (NEM.takeWhileAntitone ((< 0) . getKX)) prop_dropWhileAntitone :: Property -prop_dropWhileAntitone = ttProp (GTNEMap :-> TTMap) - (M.dropWhileAntitone ((< 0) . getKX)) +prop_dropWhileAntitone = + ttProp + (GTNEMap :-> TTMap) + (M.dropWhileAntitone ((< 0) . getKX)) (NEM.dropWhileAntitone ((< 0) . getKX)) prop_spanAntitone :: Property -prop_spanAntitone = ttProp (GTNEMap :-> TTThese TTNEMap TTNEMap) - (M.spanAntitone ((< 0) . getKX)) +prop_spanAntitone = + ttProp + (GTNEMap :-> TTThese TTNEMap TTNEMap) + (M.spanAntitone ((< 0) . getKX)) (NEM.spanAntitone ((< 0) . getKX)) prop_mapMaybeWithKey :: Property -prop_mapMaybeWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTNEMap :-> TTMap) +prop_mapMaybeWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTNEMap :-> TTMap) M.mapMaybeWithKey NEM.mapMaybeWithKey prop_mapEitherWithKey :: Property -prop_mapEitherWithKey = ttProp ( gf2 (Gen.choice [Left <$> valGen, Right <$> valGen]) - :?> GTNEMap - :-> TTThese TTNEMap TTNEMap - ) +prop_mapEitherWithKey = + ttProp + ( gf2 (Gen.choice [Left <$> valGen, Right <$> valGen]) + :?> GTNEMap + :-> TTThese TTNEMap TTNEMap + ) M.mapEitherWithKey NEM.mapEitherWithKey prop_split :: Property -prop_split = ttProp (GTKey :-> GTNEMap :-> TTMThese TTNEMap TTNEMap) +prop_split = + ttProp + (GTKey :-> GTNEMap :-> TTMThese TTNEMap TTNEMap) M.split NEM.split prop_splitLookup :: Property -prop_splitLookup = ttProp (GTKey :-> GTNEMap :-> TTTThese TTVal 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 -prop_isSubmapOfBy = ttProp (gf2 Gen.bool :?> GTNEMap :-> GTNEMap :-> TTOther) +prop_isSubmapOfBy = + ttProp + (gf2 Gen.bool :?> GTNEMap :-> GTNEMap :-> TTOther) M.isSubmapOfBy NEM.isSubmapOfBy prop_isProperSubmapOfBy :: Property -prop_isProperSubmapOfBy = ttProp (gf2 Gen.bool :?> GTNEMap :-> GTNEMap :-> TTOther) +prop_isProperSubmapOfBy = + ttProp + (gf2 Gen.bool :?> GTNEMap :-> GTNEMap :-> TTOther) M.isProperSubmapOfBy NEM.isProperSubmapOfBy prop_lookupIndex :: Property -prop_lookupIndex = ttProp (GTKey :-> GTNEMap :-> TTMaybe TTOther) +prop_lookupIndex = + ttProp + (GTKey :-> GTNEMap :-> TTMaybe TTOther) M.lookupIndex NEM.lookupIndex prop_elemAt :: Property -prop_elemAt = ttProp (GTSize :-> GTNEMap :-> TTKey :*: TTVal) - (\i m -> M.elemAt (i `mod` M.size m) m) +prop_elemAt = + ttProp + (GTSize :-> GTNEMap :-> TTKey :*: TTVal) + (\i m -> M.elemAt (i `mod` M.size m) m) (\i m -> NEM.elemAt (i `mod` NEM.size m) m) prop_adjustAt :: Property -prop_adjustAt = ttProp (gf2 valGen :?> GTSize :-> GTNEMap :-> TTNEMap) - (\f i m -> M.updateAt (\k -> Just . f k) (i `mod` M.size m) m) - (\f i m -> NEM.adjustAt f (i `mod` NEM.size m) m) +prop_adjustAt = + ttProp + (gf2 valGen :?> GTSize :-> GTNEMap :-> TTNEMap) + (\f i m -> M.updateAt (\k -> Just . f k) (i `mod` M.size m) m) + (\f i m -> NEM.adjustAt f (i `mod` NEM.size m) m) prop_updateAt :: Property -prop_updateAt = ttProp (gf2 (Gen.maybe valGen) :?> GTSize :-> GTNEMap :-> TTMap) - (\f i m -> M.updateAt f (i `mod` M.size m) m) +prop_updateAt = + ttProp + (gf2 (Gen.maybe valGen) :?> GTSize :-> GTNEMap :-> TTMap) + (\f i m -> M.updateAt f (i `mod` M.size m) m) (\f i m -> NEM.updateAt f (i `mod` NEM.size m) m) prop_deleteAt :: Property -prop_deleteAt = ttProp (GTSize :-> GTNEMap :-> TTMap) - (\i m -> M.deleteAt (i `mod` M.size m) m) +prop_deleteAt = + ttProp + (GTSize :-> GTNEMap :-> TTMap) + (\i m -> M.deleteAt (i `mod` M.size m) m) (\i m -> NEM.deleteAt (i `mod` NEM.size m) m) prop_take :: Property -prop_take = ttProp (GTSize :-> GTNEMap :-> TTMap) +prop_take = + ttProp + (GTSize :-> GTNEMap :-> TTMap) M.take NEM.take prop_drop :: Property -prop_drop = ttProp (GTSize :-> GTNEMap :-> TTMap) +prop_drop = + ttProp + (GTSize :-> GTNEMap :-> TTMap) M.drop NEM.drop prop_splitAt :: Property -prop_splitAt = ttProp (GTSize :-> GTNEMap :-> TTThese TTNEMap TTNEMap) +prop_splitAt = + ttProp + (GTSize :-> GTNEMap :-> TTThese TTNEMap TTNEMap) M.splitAt NEM.splitAt prop_findMin :: Property -prop_findMin = ttProp (GTNEMap :-> TTKey :*: TTVal) +prop_findMin = + ttProp + (GTNEMap :-> TTKey :*: TTVal) M.findMin NEM.findMin prop_findMax :: Property -prop_findMax = ttProp (GTNEMap :-> TTKey :*: TTVal) +prop_findMax = + ttProp + (GTNEMap :-> TTKey :*: TTVal) M.findMax NEM.findMax prop_deleteMin :: Property -prop_deleteMin = ttProp (GTNEMap :-> TTMap) +prop_deleteMin = + ttProp + (GTNEMap :-> TTMap) M.deleteMin NEM.deleteMin prop_deleteMax :: Property -prop_deleteMax = ttProp (GTNEMap :-> TTMap) +prop_deleteMax = + ttProp + (GTNEMap :-> TTMap) M.deleteMax NEM.deleteMax prop_deleteFindMin :: Property -prop_deleteFindMin = ttProp (GTNEMap :-> (TTKey :*: TTVal) :*: TTMap) +prop_deleteFindMin = + ttProp + (GTNEMap :-> (TTKey :*: TTVal) :*: TTMap) M.deleteFindMin NEM.deleteFindMin prop_deleteFindMax :: Property -prop_deleteFindMax = ttProp (GTNEMap :-> (TTKey :*: TTVal) :*: TTMap) +prop_deleteFindMax = + ttProp + (GTNEMap :-> (TTKey :*: TTVal) :*: TTMap) M.deleteFindMax NEM.deleteFindMax prop_updateMinWithKey :: Property -prop_updateMinWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTNEMap :-> TTMap) +prop_updateMinWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTNEMap :-> TTMap) M.updateMinWithKey NEM.updateMinWithKey prop_updateMaxWithKey :: Property -prop_updateMaxWithKey = ttProp (gf2 (Gen.maybe valGen) :?> GTNEMap :-> TTMap) +prop_updateMaxWithKey = + ttProp + (gf2 (Gen.maybe valGen) :?> GTNEMap :-> TTMap) M.updateMaxWithKey NEM.updateMaxWithKey prop_adjustMinWithKey :: Property -prop_adjustMinWithKey = ttProp (gf2 valGen :?> GTNEMap :-> TTNEMap) - (M.updateMinWithKey . (fmap . fmap) Just) +prop_adjustMinWithKey = + ttProp + (gf2 valGen :?> GTNEMap :-> TTNEMap) + (M.updateMinWithKey . (fmap . fmap) Just) NEM.adjustMinWithKey prop_adjustMaxWithKey :: Property -prop_adjustMaxWithKey = ttProp (gf2 valGen :?> GTNEMap :-> TTNEMap) - (M.updateMaxWithKey . (fmap . fmap) Just) +prop_adjustMaxWithKey = + ttProp + (gf2 valGen :?> GTNEMap :-> TTNEMap) + (M.updateMaxWithKey . (fmap . fmap) Just) NEM.adjustMaxWithKey prop_minView :: Property -prop_minView = ttProp (GTNEMap :-> TTMaybe (TTVal :*: TTMap)) +prop_minView = + ttProp + (GTNEMap :-> TTMaybe (TTVal :*: TTMap)) M.minView (Just . NEM.minView) prop_maxView :: Property -prop_maxView = ttProp (GTNEMap :-> TTMaybe (TTVal :*: TTMap)) +prop_maxView = + ttProp + (GTNEMap :-> TTMaybe (TTVal :*: TTMap)) M.maxView (Just . NEM.maxView) prop_elem :: Property -prop_elem = ttProp (GTVal :-> GTNEMap :-> TTOther) +prop_elem = + ttProp + (GTVal :-> GTNEMap :-> TTOther) elem elem prop_fold1 :: Property -prop_fold1 = ttProp (GTNEMap :-> TTVal) +prop_fold1 = + ttProp + (GTNEMap :-> TTVal) fold fold1 prop_fold :: Property -prop_fold = ttProp (GTNEMap :-> TTVal) +prop_fold = + ttProp + (GTNEMap :-> TTVal) fold fold prop_foldMap1 :: Property -prop_foldMap1 = ttProp (gf1 valGen :?> GTNEMap :-> TTOther) - (\f -> foldMap ((:[]) . f)) - (\f -> foldMap1 ((:[]) . f)) +prop_foldMap1 = + ttProp + (gf1 valGen :?> GTNEMap :-> TTOther) + (\f -> foldMap ((: []) . f)) + (\f -> foldMap1 ((: []) . f)) prop_foldMap :: Property -prop_foldMap = ttProp (gf1 valGen :?> GTNEMap :-> TTOther) - (\f -> foldMap ((:[]) . f)) - (\f -> foldMap ((:[]) . f)) +prop_foldMap = + ttProp + (gf1 valGen :?> GTNEMap :-> TTOther) + (\f -> foldMap ((: []) . f)) + (\f -> foldMap ((: []) . f)) prop_alt :: Property -prop_alt = ttProp (GTNEMap :-> GTNEMap :-> TTNEMap) +prop_alt = + ttProp + (GTNEMap :-> GTNEMap :-> TTNEMap) () () diff --git a/test/Tests/Sequence.hs b/test/Tests/Sequence.hs --- a/test/Tests/Sequence.hs +++ b/test/Tests/Sequence.hs @@ -1,44 +1,47 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Tests.Sequence (sequenceTests) where -import Control.Applicative -import Control.Comonad -import Control.Monad -import Data.Bifunctor -import Data.Functor.Identity -import Data.Ord -import Data.Sequence (Seq(..)) -import Data.Sequence.NonEmpty (NESeq(..)) -import Data.Tuple -import Hedgehog -import Test.Tasty -import Tests.Util -import qualified Data.Foldable as F -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup.Foldable as F1 -import qualified Data.Semigroup.Traversable as T1 -import qualified Data.Sequence as Seq -import qualified Data.Sequence.NonEmpty as NESeq -import qualified Data.Sequence.NonEmpty.Internal as NESeq -import qualified Hedgehog.Gen as Gen +import Control.Applicative +import Control.Comonad +import Control.Monad +import Data.Bifunctor +import qualified Data.Foldable as F +import Data.Functor.Identity +import qualified Data.List.NonEmpty as NE +import Data.Ord +import qualified Data.Semigroup.Foldable as F1 +import qualified Data.Semigroup.Traversable as T1 +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Sequence.NonEmpty (NESeq (..)) +import qualified Data.Sequence.NonEmpty as NESeq +import Data.Tuple +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Test.Tasty +import Tests.Util sequenceTests :: TestTree -sequenceTests = groupTree $$(discover) +sequenceTests = groupTree $$discover prop_toSeqIso1 :: Property prop_toSeqIso1 = property $ do - m0 <- forAll seqGen - tripping m0 NESeq.nonEmptySeq - (Identity . maybe Seq.empty NESeq.toSeq) + m0 <- forAll seqGen + tripping + m0 + NESeq.nonEmptySeq + (Identity . maybe Seq.empty NESeq.toSeq) prop_toSeqIso2 :: Property prop_toSeqIso2 = property $ do - m0 <- forAll $ Gen.maybe neSeqGen - tripping m0 (maybe Seq.empty NESeq.toSeq) - (Identity . NESeq.nonEmptySeq) + m0 <- forAll $ Gen.maybe neSeqGen + tripping + m0 + (maybe Seq.empty NESeq.toSeq) + (Identity . NESeq.nonEmptySeq) prop_read_show :: Property prop_read_show = readShow neSeqGen @@ -49,507 +52,698 @@ prop_show_show1 :: Property prop_show_show1 = showShow1 neSeqGen - - - - prop_cons :: Property -prop_cons = ttProp (GTVal :-> GTSeq :-> TTNESeq) +prop_cons = + ttProp + (GTVal :-> GTSeq :-> TTNESeq) (:<|) (:<||) prop_snoc :: Property -prop_snoc = ttProp (GTSeq :-> GTVal :-> TTNESeq) +prop_snoc = + ttProp + (GTSeq :-> GTVal :-> TTNESeq) (:|>) (:||>) prop_insertSeqAt :: Property -prop_insertSeqAt = ttProp (GTIntKey :-> GTVal :-> GTSeq :-> TTNESeq) +prop_insertSeqAt = + ttProp + (GTIntKey :-> GTVal :-> GTSeq :-> TTNESeq) Seq.insertAt NESeq.insertSeqAt prop_singleton :: Property -prop_singleton = ttProp (GTVal :-> TTNESeq) +prop_singleton = + ttProp + (GTVal :-> TTNESeq) Seq.singleton NESeq.singleton prop_consNE :: Property -prop_consNE = ttProp (GTVal :-> GTNESeq :-> TTNESeq) +prop_consNE = + ttProp + (GTVal :-> GTNESeq :-> TTNESeq) (Seq.<|) (NESeq.<|) prop_snocNE :: Property -prop_snocNE = ttProp (GTNESeq :-> GTVal :-> TTNESeq) +prop_snocNE = + ttProp + (GTNESeq :-> GTVal :-> TTNESeq) (Seq.|>) (NESeq.|>) prop_append :: Property -prop_append = ttProp (GTNESeq :-> GTNESeq :-> TTNESeq) +prop_append = + ttProp + (GTNESeq :-> GTNESeq :-> TTNESeq) (Seq.><) (NESeq.><) prop_appendL :: Property -prop_appendL = ttProp (GTNESeq :-> GTSeq :-> TTNESeq) +prop_appendL = + ttProp + (GTNESeq :-> GTSeq :-> TTNESeq) (Seq.><) (NESeq.|><) prop_appendR :: Property -prop_appendR = ttProp (GTSeq :-> GTNESeq :-> TTNESeq) +prop_appendR = + ttProp + (GTSeq :-> GTNESeq :-> TTNESeq) (Seq.><) (NESeq.><|) prop_fromList :: Property -prop_fromList = ttProp (GTNEList Nothing GTVal :-> TTNESeq) +prop_fromList = + ttProp + (GTNEList Nothing GTVal :-> TTNESeq) Seq.fromList NESeq.fromList prop_fromFunction :: Property -prop_fromFunction = ttProp (GTSize :-> gf1 valGen :?> TTNESeq) - (Seq.fromFunction . (+ 1)) +prop_fromFunction = + ttProp + (GTSize :-> gf1 valGen :?> TTNESeq) + (Seq.fromFunction . (+ 1)) (NESeq.fromFunction . (+ 1)) prop_replicate :: Property -prop_replicate = ttProp (GTSize :-> GTVal :-> TTNESeq) - (Seq.replicate . (+ 1)) +prop_replicate = + ttProp + (GTSize :-> GTVal :-> TTNESeq) + (Seq.replicate . (+ 1)) (NESeq.replicate . (+ 1)) prop_replicateA :: Property -prop_replicateA = ttProp (GTSize :-> GTVal :-> TTBazaar GTVal TTNESeq TTVal) - (\i x -> Seq.replicateA (i + 1) (x `More` Done id)) +prop_replicateA = + ttProp + (GTSize :-> GTVal :-> TTBazaar GTVal TTNESeq TTVal) + (\i x -> Seq.replicateA (i + 1) (x `More` Done id)) (\i x -> NESeq.replicateA (i + 1) (x `More` Done id)) prop_replicateA1 :: Property -prop_replicateA1 = ttProp (GTSize :-> GTVal :-> TTBazaar GTVal TTNESeq TTVal) - (\i x -> Seq.replicateA (i + 1) (x `More` Done id)) +prop_replicateA1 = + ttProp + (GTSize :-> GTVal :-> TTBazaar GTVal TTNESeq TTVal) + (\i x -> Seq.replicateA (i + 1) (x `More` Done id)) (\i x -> NESeq.replicateA1 (i + 1) (x `More` Done id)) prop_cycleTaking :: Property -prop_cycleTaking = ttProp (GTSize :-> GTNESeq :-> TTNESeq) - (Seq.cycleTaking . (* 5) . (+ 1)) +prop_cycleTaking = + ttProp + (GTSize :-> GTNESeq :-> TTNESeq) + (Seq.cycleTaking . (* 5) . (+ 1)) (NESeq.cycleTaking . (* 5) . (+ 1)) prop_iterateN :: Property -prop_iterateN = ttProp (GTSize :-> gf1 valGen :?> GTVal :-> TTNESeq) - (Seq.iterateN . (+ 1)) +prop_iterateN = + ttProp + (GTSize :-> gf1 valGen :?> GTVal :-> TTNESeq) + (Seq.iterateN . (+ 1)) (NESeq.iterateN . (+ 1)) prop_unfoldr :: Property -prop_unfoldr = ttProp ( GTSize - :-> gf1 ((,) <$> valGen <*> Gen.maybe intKeyGen) - :?> GTIntKey - :-> TTNESeqList - ) - (\i f -> NE.unfoldr (limiter f) . (i,)) +prop_unfoldr = + ttProp + ( GTSize + :-> gf1 ((,) <$> valGen <*> Gen.maybe intKeyGen) + :?> GTIntKey + :-> TTNESeqList + ) + (\i f -> NE.unfoldr (limiter f) . (i,)) (\i f -> NESeq.unfoldr (limiter f) . (i,)) prop_unfoldl :: Property -prop_unfoldl = ttProp ( GTSize - :-> gf1 ((,) <$> valGen <*> Gen.maybe intKeyGen) - :?> GTIntKey - :-> TTNESeqList - ) - (\i f -> NE.reverse . NE.unfoldr ( limiter f) . (i,)) - (\i f -> NESeq.unfoldl (swap . limiter f) . (i,)) +prop_unfoldl = + ttProp + ( GTSize + :-> gf1 ((,) <$> valGen <*> Gen.maybe intKeyGen) + :?> GTIntKey + :-> TTNESeqList + ) + (\i f -> NE.reverse . NE.unfoldr (limiter f) . (i,)) + (\i f -> NESeq.unfoldl (swap . limiter f) . (i,)) -limiter - :: (a -> (b, Maybe a)) - -> (Int, a) - -> (b, Maybe (Int, a)) +limiter :: + (a -> (b, Maybe a)) -> + (Int, a) -> + (b, Maybe (Int, a)) limiter f (n, x) = second (go =<<) $ f x where go y - | n <= 0 = Nothing + | n <= 0 = Nothing | otherwise = Just (n - 1, y) prop_head :: Property -prop_head = ttProp (GTNESeq :-> TTMaybe TTVal) +prop_head = + ttProp + (GTNESeq :-> TTMaybe TTVal) (\case x :<| _ -> Just x; Empty -> Nothing) (Just . NESeq.head) prop_tail :: Property -prop_tail = ttProp (GTNESeq :-> TTMaybe TTOther) +prop_tail = + ttProp + (GTNESeq :-> TTMaybe TTOther) (\case _ :<| xs -> Just xs; Empty -> Nothing) (Just . NESeq.tail) prop_last :: Property -prop_last = ttProp (GTNESeq :-> TTMaybe TTVal) +prop_last = + ttProp + (GTNESeq :-> TTMaybe TTVal) (\case _ :|> x -> Just x; Empty -> Nothing) (Just . NESeq.last) prop_init :: Property -prop_init = ttProp (GTNESeq :-> TTMaybe TTOther) +prop_init = + ttProp + (GTNESeq :-> TTMaybe TTOther) (\case xs :|> _ -> Just xs; Empty -> Nothing) (Just . NESeq.init) prop_length :: Property -prop_length = ttProp (GTNESeq :-> TTOther) +prop_length = + ttProp + (GTNESeq :-> TTOther) Seq.length NESeq.length prop_scanl :: Property -prop_scanl = ttProp (gf2 valGen :?> GTVal :-> GTNESeq :-> TTNESeq) +prop_scanl = + ttProp + (gf2 valGen :?> GTVal :-> GTNESeq :-> TTNESeq) Seq.scanl NESeq.scanl prop_scanl1 :: Property -prop_scanl1 = ttProp (gf2 valGen :?> GTNESeq :-> TTNESeq) +prop_scanl1 = + ttProp + (gf2 valGen :?> GTNESeq :-> TTNESeq) Seq.scanl1 NESeq.scanl1 prop_scanr :: Property -prop_scanr = ttProp (gf2 valGen :?> GTVal :-> GTNESeq :-> TTNESeq) +prop_scanr = + ttProp + (gf2 valGen :?> GTVal :-> GTNESeq :-> TTNESeq) Seq.scanr NESeq.scanr prop_scanr1 :: Property -prop_scanr1 = ttProp (gf2 valGen :?> GTNESeq :-> TTNESeq) +prop_scanr1 = + ttProp + (gf2 valGen :?> GTNESeq :-> TTNESeq) Seq.scanl1 NESeq.scanl1 prop_tails :: Property -prop_tails = ttProp (GTNESeq :-> TTNESeq) +prop_tails = + ttProp + (GTNESeq :-> TTNESeq) (Seq.filter (not . null) . Seq.tails) (fmap NESeq.toSeq . NESeq.tails) prop_inits :: Property -prop_inits = ttProp (GTNESeq :-> TTNESeq) +prop_inits = + ttProp + (GTNESeq :-> TTNESeq) (Seq.filter (not . null) . Seq.inits) (fmap NESeq.toSeq . NESeq.inits) prop_chunksOf :: Property -prop_chunksOf = ttProp (GTSize :-> GTNESeq :-> TTNESeq) - (\i -> Seq.filter (not . null) . Seq.chunksOf (i + 1)) - (\i -> fmap NESeq.toSeq . NESeq.chunksOf (i + 1)) +prop_chunksOf = + ttProp + (GTSize :-> GTNESeq :-> TTNESeq) + (\i -> Seq.filter (not . null) . Seq.chunksOf (i + 1)) + (\i -> fmap NESeq.toSeq . NESeq.chunksOf (i + 1)) prop_takeWhileL :: Property -prop_takeWhileL = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_takeWhileL = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.takeWhileL NESeq.takeWhileL prop_takeWhileR :: Property -prop_takeWhileR = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_takeWhileR = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.takeWhileR NESeq.takeWhileR prop_dropWhileL :: Property -prop_dropWhileL = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_dropWhileL = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.dropWhileL NESeq.dropWhileL prop_dropWhileR :: Property -prop_dropWhileR = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_dropWhileR = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.dropWhileR NESeq.dropWhileR prop_spanl :: Property -prop_spanl = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) +prop_spanl = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) Seq.spanl NESeq.spanl prop_spanr :: Property -prop_spanr = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) +prop_spanr = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) Seq.spanr NESeq.spanr prop_breakl :: Property -prop_breakl = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) +prop_breakl = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) Seq.breakl NESeq.breakl prop_breakr :: Property -prop_breakr = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) +prop_breakr = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) Seq.breakr NESeq.breakr prop_partition :: Property -prop_partition = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) +prop_partition = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) Seq.partition NESeq.partition prop_filter :: Property -prop_filter = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_filter = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.filter NESeq.filter prop_sort :: Property -prop_sort = ttProp (GTNESeq :-> TTNESeq) +prop_sort = + ttProp + (GTNESeq :-> TTNESeq) Seq.sort NESeq.sort prop_sortBy :: Property -prop_sortBy = ttProp (gf1 valGen :?> GTNESeq :-> TTNESeq) - (Seq.sortBy . comparing) +prop_sortBy = + ttProp + (gf1 valGen :?> GTNESeq :-> TTNESeq) + (Seq.sortBy . comparing) (NESeq.sortBy . comparing) prop_sortOn :: Property -prop_sortOn = ttProp (gf1 valGen :?> GTNESeq :-> TTNESeq) - NESeq.sortOnSeq +prop_sortOn = + ttProp + (gf1 valGen :?> GTNESeq :-> TTNESeq) + Seq.sortOn NESeq.sortOn prop_unstableSort :: Property -prop_unstableSort = ttProp (GTNESeq :-> TTNESeq) +prop_unstableSort = + ttProp + (GTNESeq :-> TTNESeq) Seq.unstableSort NESeq.unstableSort prop_unstableSortBy :: Property -prop_unstableSortBy = ttProp (gf1 valGen :?> GTNESeq :-> TTNESeq) - (Seq.unstableSortBy . comparing) +prop_unstableSortBy = + ttProp + (gf1 valGen :?> GTNESeq :-> TTNESeq) + (Seq.unstableSortBy . comparing) (NESeq.unstableSortBy . comparing) prop_unstableSortOn :: Property -prop_unstableSortOn = ttProp (gf1 valGen :?> GTNESeq :-> TTNESeq) - NESeq.unstableSortOnSeq +prop_unstableSortOn = + ttProp + (gf1 valGen :?> GTNESeq :-> TTNESeq) + Seq.unstableSortOn NESeq.unstableSortOn prop_lookup :: Property -prop_lookup = ttProp (GTIntKey :-> GTNESeq :-> TTMaybe TTVal) +prop_lookup = + ttProp + (GTIntKey :-> GTNESeq :-> TTMaybe TTVal) Seq.lookup NESeq.lookup prop_index :: Property -prop_index = ttProp (GTNESeq :-> GTIntKey :-> TTVal) - (\xs i -> xs `Seq.index` (i `mod` Seq.length xs )) +prop_index = + ttProp + (GTNESeq :-> GTIntKey :-> TTVal) + (\xs i -> xs `Seq.index` (i `mod` Seq.length xs)) (\xs i -> xs `NESeq.index` (i `mod` NESeq.length xs)) prop_adjust :: Property -prop_adjust = ttProp (gf1 valGen :?> GTIntKey :-> GTNESeq :-> TTNESeq) +prop_adjust = + ttProp + (gf1 valGen :?> GTIntKey :-> GTNESeq :-> TTNESeq) Seq.adjust NESeq.adjust prop_adjust' :: Property -prop_adjust' = ttProp (gf1 valGen :?> GTIntKey :-> GTNESeq :-> TTNESeq) +prop_adjust' = + ttProp + (gf1 valGen :?> GTIntKey :-> GTNESeq :-> TTNESeq) Seq.adjust' NESeq.adjust' prop_update :: Property -prop_update = ttProp (GTIntKey :-> GTVal :-> GTNESeq :-> TTNESeq) +prop_update = + ttProp + (GTIntKey :-> GTVal :-> GTNESeq :-> TTNESeq) Seq.update NESeq.update prop_take :: Property -prop_take = ttProp (GTIntKey :-> GTNESeq :-> TTOther) +prop_take = + ttProp + (GTIntKey :-> GTNESeq :-> TTOther) Seq.take NESeq.take prop_drop :: Property -prop_drop = ttProp (GTIntKey :-> GTNESeq :-> TTOther) +prop_drop = + ttProp + (GTIntKey :-> GTNESeq :-> TTOther) Seq.drop NESeq.drop prop_insertAt :: Property -prop_insertAt = ttProp (GTIntKey :-> GTVal :-> GTNESeq :-> TTNESeq) +prop_insertAt = + ttProp + (GTIntKey :-> GTVal :-> GTNESeq :-> TTNESeq) Seq.insertAt NESeq.insertAt prop_deleteAt :: Property -prop_deleteAt = ttProp (GTIntKey :-> GTNESeq :-> TTOther) +prop_deleteAt = + ttProp + (GTIntKey :-> GTNESeq :-> TTOther) Seq.deleteAt NESeq.deleteAt prop_splitAt :: Property -prop_splitAt = ttProp (GTIntKey :-> GTNESeq :-> TTThese TTNESeq TTNESeq) +prop_splitAt = + ttProp + (GTIntKey :-> GTNESeq :-> TTThese TTNESeq TTNESeq) Seq.splitAt NESeq.splitAt prop_elemIndexL :: Property -prop_elemIndexL = ttProp (GTVal :-> GTNESeq :-> TTOther) +prop_elemIndexL = + ttProp + (GTVal :-> GTNESeq :-> TTOther) Seq.elemIndexL NESeq.elemIndexL prop_elemIndicesL :: Property -prop_elemIndicesL = ttProp (GTVal :-> GTNESeq :-> TTOther) +prop_elemIndicesL = + ttProp + (GTVal :-> GTNESeq :-> TTOther) Seq.elemIndicesL NESeq.elemIndicesL prop_elemIndexR :: Property -prop_elemIndexR = ttProp (GTVal :-> GTNESeq :-> TTOther) +prop_elemIndexR = + ttProp + (GTVal :-> GTNESeq :-> TTOther) Seq.elemIndexR NESeq.elemIndexR prop_elemIndicesR :: Property -prop_elemIndicesR = ttProp (GTVal :-> GTNESeq :-> TTOther) +prop_elemIndicesR = + ttProp + (GTVal :-> GTNESeq :-> TTOther) Seq.elemIndicesR NESeq.elemIndicesR prop_findIndexL :: Property -prop_findIndexL = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_findIndexL = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.findIndexL NESeq.findIndexL prop_findIndicesL :: Property -prop_findIndicesL = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_findIndicesL = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.findIndicesL NESeq.findIndicesL prop_findIndexR :: Property -prop_findIndexR = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_findIndexR = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.findIndexR NESeq.findIndexR prop_findIndicesR :: Property -prop_findIndicesR = ttProp (gf1 Gen.bool :?> GTNESeq :-> TTOther) +prop_findIndicesR = + ttProp + (gf1 Gen.bool :?> GTNESeq :-> TTOther) Seq.findIndicesR NESeq.findIndicesR prop_foldMapWithIndex :: Property -prop_foldMapWithIndex = ttProp (gf2 valGen :?> GTNESeq :-> TTOther) - (\f -> Seq.foldMapWithIndex (\i -> (:[]) . f i)) - (\f -> NESeq.foldMapWithIndex (\i -> (:[]) . f i)) +prop_foldMapWithIndex = + ttProp + (gf2 valGen :?> GTNESeq :-> TTOther) + (\f -> Seq.foldMapWithIndex (\i -> (: []) . f i)) + (\f -> NESeq.foldMapWithIndex (\i -> (: []) . f i)) prop_foldlWithIndex :: Property -prop_foldlWithIndex = ttProp (gf3 valGen :?> GTVal :-> GTNESeq :-> TTVal) +prop_foldlWithIndex = + ttProp + (gf3 valGen :?> GTVal :-> GTNESeq :-> TTVal) Seq.foldlWithIndex NESeq.foldlWithIndex prop_foldrWithIndex :: Property -prop_foldrWithIndex = ttProp (gf3 valGen :?> GTVal :-> GTNESeq :-> TTVal) +prop_foldrWithIndex = + ttProp + (gf3 valGen :?> GTVal :-> GTNESeq :-> TTVal) Seq.foldrWithIndex NESeq.foldrWithIndex prop_mapWithIndex :: Property -prop_mapWithIndex = ttProp (gf2 valGen :?> GTNESeq :-> TTNESeq) +prop_mapWithIndex = + ttProp + (gf2 valGen :?> GTNESeq :-> TTNESeq) Seq.mapWithIndex NESeq.mapWithIndex prop_traverseWithIndex :: Property -prop_traverseWithIndex = ttProp (gf2 valGen :?> GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) - (\f -> Seq.traverseWithIndex (\k -> (`More` Done (f k)))) +prop_traverseWithIndex = + ttProp + (gf2 valGen :?> GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) + (\f -> Seq.traverseWithIndex (\k -> (`More` Done (f k)))) (\f -> NESeq.traverseWithIndex (\k -> (`More` Done (f k)))) prop_traverseWithIndex1 :: Property -prop_traverseWithIndex1 = ttProp (gf2 valGen :?> GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) - (\f -> Seq.traverseWithIndex (\k -> (`More` Done (f k)))) +prop_traverseWithIndex1 = + ttProp + (gf2 valGen :?> GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) + (\f -> Seq.traverseWithIndex (\k -> (`More` Done (f k)))) (\f -> NESeq.traverseWithIndex1 (\k -> (`More` Done (f k)))) prop_reverse :: Property -prop_reverse = ttProp (GTNESeq :-> TTNESeq) +prop_reverse = + ttProp + (GTNESeq :-> TTNESeq) Seq.reverse NESeq.reverse prop_intersperse :: Property -prop_intersperse = ttProp (GTVal :-> GTNESeq :-> TTNESeq) +prop_intersperse = + ttProp + (GTVal :-> GTNESeq :-> TTNESeq) Seq.intersperse NESeq.intersperse prop_zip :: Property -prop_zip = ttProp (GTNESeq :-> GTNESeq :-> TTNESeq) +prop_zip = + ttProp + (GTNESeq :-> GTNESeq :-> TTNESeq) Seq.zip NESeq.zip prop_zipWith :: Property -prop_zipWith = ttProp (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) +prop_zipWith = + ttProp + (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) Seq.zipWith NESeq.zipWith prop_zip3 :: Property -prop_zip3 = ttProp (GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) +prop_zip3 = + ttProp + (GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) Seq.zip3 NESeq.zip3 prop_zipWith3 :: Property -prop_zipWith3 = ttProp (gf3 valGen :?> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) +prop_zipWith3 = + ttProp + (gf3 valGen :?> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) Seq.zipWith3 NESeq.zipWith3 prop_zip4 :: Property -prop_zip4 = ttProp (GTNESeq :-> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) +prop_zip4 = + ttProp + (GTNESeq :-> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) Seq.zip4 NESeq.zip4 prop_zipWith4 :: Property -prop_zipWith4 = ttProp (gf4 valGen :?> GTNESeq :-> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) +prop_zipWith4 = + ttProp + (gf4 valGen :?> GTNESeq :-> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) Seq.zipWith4 NESeq.zipWith4 prop_unzip :: Property -prop_unzip = ttProp (GTNESeq :-> GTNESeq :-> TTNESeq :*: TTNESeq) - (\xs -> NESeq.unzipSeq . Seq.zip xs) - (\xs -> NESeq.unzip . NESeq.zip xs) +prop_unzip = + ttProp + (GTNESeq :-> GTNESeq :-> TTNESeq :*: TTNESeq) + (\xs -> Seq.unzip . Seq.zip xs) + (\xs -> NESeq.unzip . NESeq.zip xs) prop_unzipWith :: Property -prop_unzipWith = ttProp ( gf1 ((,) <$> valGen <*> valGen) - :?> GTNESeq - :-> TTNESeq :*: TTNESeq - ) - NESeq.unzipWithSeq +prop_unzipWith = + ttProp + ( gf1 ((,) <$> valGen <*> valGen) + :?> GTNESeq + :-> TTNESeq + :*: TTNESeq + ) + Seq.unzipWith NESeq.unzipWith prop_liftA2 :: Property -prop_liftA2 = ttProp (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) +prop_liftA2 = + ttProp + (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) liftA2 liftA2 prop_liftM2 :: Property -prop_liftM2 = ttProp (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) +prop_liftM2 = + ttProp + (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) liftM2 liftM2 prop_duplicate :: Property -prop_duplicate = ttProp (GTNESeqList :-> TTNESeqList) +prop_duplicate = + ttProp + (GTNESeqList :-> TTNESeqList) duplicate (fmap F1.toNonEmpty . duplicate) prop_foldMap :: Property -prop_foldMap = ttProp (gf1 valGen :?> GTNESeq :-> TTOther) - (foldMap . fmap (:[])) - (foldMap . fmap (:[])) +prop_foldMap = + ttProp + (gf1 valGen :?> GTNESeq :-> TTOther) + (foldMap . fmap (: [])) + (foldMap . fmap (: [])) prop_foldl :: Property -prop_foldl = ttProp (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) +prop_foldl = + ttProp + (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) foldl foldl prop_foldr :: Property -prop_foldr = ttProp (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) +prop_foldr = + ttProp + (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) foldr foldr prop_foldl' :: Property -prop_foldl' = ttProp (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) +prop_foldl' = + ttProp + (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) F.foldl' F.foldl' prop_foldr' :: Property -prop_foldr' = ttProp (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) +prop_foldr' = + ttProp + (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) F.foldr' F.foldr' prop_foldl1 :: Property -prop_foldl1 = ttProp (gf2 valGen :?> GTNESeq :-> TTVal) +prop_foldl1 = + ttProp + (gf2 valGen :?> GTNESeq :-> TTVal) foldl1 foldl1 prop_foldr1 :: Property -prop_foldr1 = ttProp (gf2 valGen :?> GTNESeq :-> TTVal) +prop_foldr1 = + ttProp + (gf2 valGen :?> GTNESeq :-> TTVal) foldr1 foldr1 prop_fold :: Property -prop_fold = ttProp (GTNESeq :-> TTVal) +prop_fold = + ttProp + (GTNESeq :-> TTVal) F.fold F.fold prop_fold1 :: Property -prop_fold1 = ttProp (GTNESeq :-> TTVal) +prop_fold1 = + ttProp + (GTNESeq :-> TTVal) F.fold F1.fold1 prop_toList :: Property -prop_toList = ttProp (GTNESeq :-> TTOther) +prop_toList = + ttProp + (GTNESeq :-> TTOther) F.toList F.toList prop_toNonEmpty :: Property -prop_toNonEmpty = ttProp (GTNESeq :-> TTNEList TTVal) +prop_toNonEmpty = + ttProp + (GTNESeq :-> TTNEList TTVal) F.toList F1.toNonEmpty prop_sequenceA :: Property -prop_sequenceA = ttProp (GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) +prop_sequenceA = + ttProp + (GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) (sequenceA . fmap (`More` Done id)) (sequenceA . fmap (`More` Done id)) +{-# ANN prop_sequenceA "HLint: ignore Use traverse" #-} prop_sequence1 :: Property -prop_sequence1 = ttProp (GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) +prop_sequence1 = + ttProp + (GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) (sequenceA . fmap (`More` Done id)) (T1.sequence1 . fmap (`More` Done id)) +{-# ANN prop_sequence1 "HLint: ignore Use traverse" #-} diff --git a/test/Tests/Set.hs b/test/Tests/Set.hs --- a/test/Tests/Set.hs +++ b/test/Tests/Set.hs @@ -1,77 +1,78 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Tests.Set (setTests) where -import Data.Foldable -import Data.Functor.Identity -import Data.Semigroup.Foldable -import Hedgehog -import Test.Tasty -import Tests.Util -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES +import Data.Foldable +import Data.Functor.Identity +import Data.Semigroup.Foldable +import qualified Data.Set as S +import qualified Data.Set.NonEmpty as NES import qualified Data.Set.NonEmpty.Internal as NES -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Tests.Util setTests :: TestTree -setTests = groupTree $$(discover) - - - - +setTests = groupTree $$discover prop_valid :: Property -prop_valid = property $ +prop_valid = + property $ assert . NES.valid =<< forAll neSetGen prop_valid_toSet :: Property prop_valid_toSet = property $ do - assert . S.valid . NES.toSet =<< forAll neSetGen + assert . S.valid . NES.toSet =<< forAll neSetGen prop_valid_insertMinSet :: Property prop_valid_insertMinSet = property $ do - n <- forAll $ do - m <- setGen - let k = maybe dummyKey (subtract 1) $ S.lookupMin m - pure $ NES.insertMinSet k m - assert $ S.valid n + n <- forAll $ do + m <- setGen + let k = maybe dummyKey (subtract 1) $ S.lookupMin m + pure $ NES.insertMinSet k m + assert $ S.valid n prop_valid_insertMaxSet :: Property prop_valid_insertMaxSet = property $ do - n <- forAll $ do - m <- setGen - let k = maybe dummyKey (+ 1) $ S.lookupMax m - pure $ NES.insertMaxSet k m - assert $ S.valid n + n <- forAll $ do + m <- setGen + let k = maybe dummyKey (+ 1) $ S.lookupMax m + pure $ NES.insertMaxSet k m + assert $ S.valid n prop_valid_insertSetMin :: Property prop_valid_insertSetMin = property $ do - n <- forAll $ do - m <- setGen - let k = maybe dummyKey (subtract 1) $ S.lookupMin m - pure $ NES.insertSetMin k m - assert $ NES.valid n + n <- forAll $ do + m <- setGen + let k = maybe dummyKey (subtract 1) $ S.lookupMin m + pure $ NES.insertSetMin k m + assert $ NES.valid n prop_valid_insertSetMax :: Property prop_valid_insertSetMax = property $ do - n <- forAll $ do - m <- setGen - let k = maybe dummyKey (+ 1) $ S.lookupMax m - pure $ NES.insertSetMax k m - assert $ NES.valid n + n <- forAll $ do + m <- setGen + let k = maybe dummyKey (+ 1) $ S.lookupMax m + pure $ NES.insertSetMax k m + assert $ NES.valid n prop_toSetIso1 :: Property prop_toSetIso1 = property $ do - m0 <- forAll setGen - tripping m0 NES.nonEmptySet - (Identity . maybe S.empty NES.toSet) + m0 <- forAll setGen + tripping + m0 + NES.nonEmptySet + (Identity . maybe S.empty NES.toSet) prop_toSetIso2 :: Property prop_toSetIso2 = property $ do - m0 <- forAll $ Gen.maybe neSetGen - tripping m0 (maybe S.empty NES.toSet) - (Identity . NES.nonEmptySet) + m0 <- forAll $ Gen.maybe neSetGen + tripping + m0 + (maybe S.empty NES.toSet) + (Identity . NES.nonEmptySet) prop_read_show :: Property prop_read_show = readShow neSetGen @@ -81,352 +82,473 @@ prop_splitRoot :: Property prop_splitRoot = property $ do - n <- forAll neSetGen - let rs = NES.splitRoot n - n' = foldl1 NES.merge rs - assert $ NES.valid n' - mapM_ (assert . (`NES.isSubsetOf` n)) rs - n === n' - - - + n <- forAll neSetGen + let rs = NES.splitRoot n + n' = foldl1 NES.merge rs + assert $ NES.valid n' + mapM_ (assert . (`NES.isSubsetOf` n)) rs + n === n' prop_insertSet :: Property -prop_insertSet = ttProp (GTKey :-> GTSet :-> TTNESet) +prop_insertSet = + ttProp + (GTKey :-> GTSet :-> TTNESet) S.insert NES.insertSet prop_singleton :: Property -prop_singleton = ttProp (GTKey :-> TTNESet) +prop_singleton = + ttProp + (GTKey :-> TTNESet) S.singleton NES.singleton prop_fromAscList :: Property -prop_fromAscList = ttProp (GTSorted STAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNESet) - (S.fromAscList . fmap fst) +prop_fromAscList = + ttProp + (GTSorted STAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNESet) + (S.fromAscList . fmap fst) (NES.fromAscList . fmap fst) prop_fromDescList :: Property -prop_fromDescList = ttProp (GTSorted STDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNESet) - (S.fromDescList . fmap fst) +prop_fromDescList = + ttProp + (GTSorted STDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNESet) + (S.fromDescList . fmap fst) (NES.fromDescList . fmap fst) prop_fromDistinctAscList :: Property -prop_fromDistinctAscList = ttProp (GTSorted STAsc (GTNEList Nothing GTKey) :-> TTNESet) +prop_fromDistinctAscList = + ttProp + (GTSorted STAsc (GTNEList Nothing GTKey) :-> TTNESet) S.fromDistinctAscList NES.fromDistinctAscList prop_fromDistinctDescList :: Property -prop_fromDistinctDescList = ttProp (GTSorted STDesc (GTNEList Nothing GTKey) :-> TTNESet) +prop_fromDistinctDescList = + ttProp + (GTSorted STDesc (GTNEList Nothing GTKey) :-> TTNESet) S.fromDistinctDescList NES.fromDistinctDescList prop_fromList :: Property -prop_fromList = ttProp (GTNEList Nothing GTKey :-> TTNESet) +prop_fromList = + ttProp + (GTNEList Nothing GTKey :-> TTNESet) S.fromList NES.fromList prop_powerSet :: Property -prop_powerSet = ttProp (GTNESet :-> TTNEList TTNESet) - (S.toList . S.drop 1 . NES.powerSetSet) - (NES.toList . NES.powerSet ) +prop_powerSet = + ttProp + (GTNESet :-> TTNEList TTNESet) + (S.toList . S.drop 1 . S.powerSet) + (NES.toList . NES.powerSet) prop_insert :: Property -prop_insert = ttProp (GTKey :-> GTNESet :-> TTNESet) +prop_insert = + ttProp + (GTKey :-> GTNESet :-> TTNESet) S.insert NES.insert prop_delete :: Property -prop_delete = ttProp (GTKey :-> GTNESet :-> TTSet) +prop_delete = + ttProp + (GTKey :-> GTNESet :-> TTSet) S.delete NES.delete prop_member :: Property -prop_member = ttProp (GTKey :-> GTNESet :-> TTOther) +prop_member = + ttProp + (GTKey :-> GTNESet :-> TTOther) S.member NES.member prop_notMember :: Property -prop_notMember = ttProp (GTKey :-> GTNESet :-> TTOther) +prop_notMember = + ttProp + (GTKey :-> GTNESet :-> TTOther) S.notMember NES.notMember prop_lookupLT :: Property -prop_lookupLT = ttProp (GTKey :-> GTNESet :-> TTMaybe TTKey) +prop_lookupLT = + ttProp + (GTKey :-> GTNESet :-> TTMaybe TTKey) S.lookupLT NES.lookupLT prop_lookupGT :: Property -prop_lookupGT = ttProp (GTKey :-> GTNESet :-> TTMaybe TTKey) +prop_lookupGT = + ttProp + (GTKey :-> GTNESet :-> TTMaybe TTKey) S.lookupGT NES.lookupGT prop_lookupLE :: Property -prop_lookupLE = ttProp (GTKey :-> GTNESet :-> TTMaybe TTKey) +prop_lookupLE = + ttProp + (GTKey :-> GTNESet :-> TTMaybe TTKey) S.lookupLE NES.lookupLE prop_lookupGE :: Property -prop_lookupGE = ttProp (GTKey :-> GTNESet :-> TTMaybe TTKey) +prop_lookupGE = + ttProp + (GTKey :-> GTNESet :-> TTMaybe TTKey) S.lookupGE NES.lookupGE prop_size :: Property -prop_size = ttProp (GTNESet :-> TTOther) +prop_size = + ttProp + (GTNESet :-> TTOther) S.size NES.size prop_isSubsetOf :: Property -prop_isSubsetOf = ttProp (GTNESet :-> GTNESet :-> TTOther) +prop_isSubsetOf = + ttProp + (GTNESet :-> GTNESet :-> TTOther) S.isSubsetOf NES.isSubsetOf prop_isProperSubsetOf :: Property -prop_isProperSubsetOf = ttProp (GTNESet :-> GTNESet :-> TTOther) +prop_isProperSubsetOf = + ttProp + (GTNESet :-> GTNESet :-> TTOther) S.isProperSubsetOf NES.isProperSubsetOf prop_disjoint :: Property -prop_disjoint = ttProp (GTNESet :-> GTNESet :-> TTOther) - NES.disjointSet +prop_disjoint = + ttProp + (GTNESet :-> GTNESet :-> TTOther) + S.disjoint NES.disjoint prop_union :: Property -prop_union = ttProp (GTNESet :-> GTNESet :-> TTNESet) +prop_union = + ttProp + (GTNESet :-> GTNESet :-> TTNESet) S.union NES.union prop_unions :: Property -prop_unions = ttProp (GTNEList (Just (Range.linear 2 5)) GTNESet :-> TTNESet) +prop_unions = + ttProp + (GTNEList (Just (Range.linear 2 5)) GTNESet :-> TTNESet) S.unions NES.unions prop_difference :: Property -prop_difference = ttProp (GTNESet :-> GTNESet :-> TTSet) +prop_difference = + ttProp + (GTNESet :-> GTNESet :-> TTSet) S.difference NES.difference prop_intersection :: Property -prop_intersection = ttProp (GTNESet :-> GTNESet :-> TTSet) +prop_intersection = + ttProp + (GTNESet :-> GTNESet :-> TTSet) S.intersection NES.intersection prop_cartesianProduct :: Property -prop_cartesianProduct = ttProp (GTNESet :-> GTNESet :-> TTNEList (TTKey :*: TTKey)) - (\xs -> S.toList . NES.cartesianProductSet xs) - (\xs -> NES.toList . NES.cartesianProduct xs) +prop_cartesianProduct = + ttProp + (GTNESet :-> GTNESet :-> TTNEList (TTKey :*: TTKey)) + (\xs -> S.toList . S.cartesianProduct xs) + (\xs -> NES.toList . NES.cartesianProduct xs) prop_disjointUnion :: Property -prop_disjointUnion = ttProp (GTNESet :-> GTNESet :-> TTNEList (TTEither TTKey TTKey)) - (\xs -> S.toList . NES.disjointUnionSet xs) - (\xs -> NES.toList . NES.disjointUnion xs) +prop_disjointUnion = + ttProp + (GTNESet :-> GTNESet :-> TTNEList (TTEither TTKey TTKey)) + (\xs -> S.toList . S.disjointUnion xs) + (\xs -> NES.toList . NES.disjointUnion xs) prop_filter :: Property -prop_filter = ttProp (gf1 Gen.bool :?> GTNESet :-> TTSet) +prop_filter = + ttProp + (gf1 Gen.bool :?> GTNESet :-> TTSet) S.filter NES.filter prop_takeWhileAntitone :: Property -prop_takeWhileAntitone = ttProp (GTNESet :-> TTSet) - (S.takeWhileAntitone ((< 0) . getKX)) +prop_takeWhileAntitone = + ttProp + (GTNESet :-> TTSet) + (S.takeWhileAntitone ((< 0) . getKX)) (NES.takeWhileAntitone ((< 0) . getKX)) prop_dropWhileAntitone :: Property -prop_dropWhileAntitone = ttProp (GTNESet :-> TTSet) - (S.dropWhileAntitone ((< 0) . getKX)) +prop_dropWhileAntitone = + ttProp + (GTNESet :-> TTSet) + (S.dropWhileAntitone ((< 0) . getKX)) (NES.dropWhileAntitone ((< 0) . getKX)) prop_spanAntitone :: Property -prop_spanAntitone = ttProp (GTNESet :-> TTThese TTNESet TTNESet) - (S.spanAntitone ((< 0) . getKX)) +prop_spanAntitone = + ttProp + (GTNESet :-> TTThese TTNESet TTNESet) + (S.spanAntitone ((< 0) . getKX)) (NES.spanAntitone ((< 0) . getKX)) prop_partition :: Property -prop_partition = ttProp (gf1 Gen.bool :?> GTNESet :-> TTThese TTNESet TTNESet) +prop_partition = + ttProp + (gf1 Gen.bool :?> GTNESet :-> TTThese TTNESet TTNESet) S.partition NES.partition prop_split :: Property -prop_split = ttProp (GTKey :-> GTNESet :-> TTMThese TTNESet TTNESet) +prop_split = + ttProp + (GTKey :-> GTNESet :-> TTMThese TTNESet TTNESet) S.split NES.split prop_splitMember :: Property -prop_splitMember = ttProp (GTKey :-> GTNESet :-> TTOther :*: TTMThese TTNESet TTNESet) - (\k -> (\(x,y,z) -> (y,(x,z))) . S.splitMember k) +prop_splitMember = + ttProp + (GTKey :-> GTNESet :-> TTOther :*: TTMThese TTNESet TTNESet) + (\k -> (\(x, y, z) -> (y, (x, z))) . S.splitMember k) NES.splitMember prop_lookupIndex :: Property -prop_lookupIndex = ttProp (GTKey :-> GTNESet :-> TTMaybe TTOther) +prop_lookupIndex = + ttProp + (GTKey :-> GTNESet :-> TTMaybe TTOther) S.lookupIndex NES.lookupIndex prop_elemAt :: Property -prop_elemAt = ttProp (GTSize :-> GTNESet :-> TTKey) - (\i m -> S.elemAt (i `mod` S.size m) m) +prop_elemAt = + ttProp + (GTSize :-> GTNESet :-> TTKey) + (\i m -> S.elemAt (i `mod` S.size m) m) (\i m -> NES.elemAt (i `mod` NES.size m) m) prop_deleteAt :: Property -prop_deleteAt = ttProp (GTSize :-> GTNESet :-> TTSet) - (\i m -> S.deleteAt (i `mod` S.size m) m) +prop_deleteAt = + ttProp + (GTSize :-> GTNESet :-> TTSet) + (\i m -> S.deleteAt (i `mod` S.size m) m) (\i m -> NES.deleteAt (i `mod` NES.size m) m) prop_take :: Property -prop_take = ttProp (GTSize :-> GTNESet :-> TTSet) +prop_take = + ttProp + (GTSize :-> GTNESet :-> TTSet) S.take NES.take prop_drop :: Property -prop_drop = ttProp (GTSize :-> GTNESet :-> TTSet) +prop_drop = + ttProp + (GTSize :-> GTNESet :-> TTSet) S.drop NES.drop prop_splitAt :: Property -prop_splitAt = ttProp (GTSize :-> GTNESet :-> TTThese TTNESet TTNESet) +prop_splitAt = + ttProp + (GTSize :-> GTNESet :-> TTThese TTNESet TTNESet) S.splitAt NES.splitAt prop_map :: Property -prop_map = ttProp (gf1 keyGen :?> GTNESet :-> TTNESet) +prop_map = + ttProp + (gf1 keyGen :?> GTNESet :-> TTNESet) S.map NES.map prop_mapMonotonic :: Property -prop_mapMonotonic = ttProp (GF valGen go :?> GTNESet :-> TTNESet) +prop_mapMonotonic = + ttProp + (GF valGen go :?> GTNESet :-> TTNESet) S.mapMonotonic NES.mapMonotonic where go f (K i t) = K (i * 2) (f t) prop_foldr :: Property -prop_foldr = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNESet - :-> TTOther - ) +prop_foldr = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNESet + :-> TTOther + ) S.foldr NES.foldr prop_foldl :: Property -prop_foldl = ttProp ( gf2 valGen - :?> GTOther valGen - :-> GTNESet - :-> TTOther - ) +prop_foldl = + ttProp + ( gf2 valGen + :?> GTOther valGen + :-> GTNESet + :-> TTOther + ) S.foldl NES.foldl prop_foldr1 :: Property -prop_foldr1 = ttProp ( gf2 keyGen - :?> GTNESet - :-> TTOther - ) +prop_foldr1 = + ttProp + ( gf2 keyGen + :?> GTNESet + :-> TTOther + ) foldr1 NES.foldr1 prop_foldl1 :: Property -prop_foldl1 = ttProp ( gf2 keyGen - :?> GTNESet - :-> TTOther - ) +prop_foldl1 = + ttProp + ( gf2 keyGen + :?> GTNESet + :-> TTOther + ) foldl1 NES.foldl1 prop_foldr' :: Property -prop_foldr' = ttProp ( gf2 keyGen - :?> GTOther keyGen - :-> GTNESet - :-> TTOther - ) +prop_foldr' = + ttProp + ( gf2 keyGen + :?> GTOther keyGen + :-> GTNESet + :-> TTOther + ) S.foldr' NES.foldr' prop_foldl' :: Property -prop_foldl' = ttProp ( gf2 keyGen - :?> GTOther keyGen - :-> GTNESet - :-> TTOther - ) +prop_foldl' = + ttProp + ( gf2 keyGen + :?> GTOther keyGen + :-> GTNESet + :-> TTOther + ) S.foldl' NES.foldl' prop_foldr1' :: Property -prop_foldr1' = ttProp ( gf2 keyGen - :?> GTNESet - :-> TTOther - ) +prop_foldr1' = + ttProp + ( gf2 keyGen + :?> GTNESet + :-> TTOther + ) foldr1 NES.foldr1' prop_foldl1' :: Property -prop_foldl1' = ttProp ( gf2 keyGen - :?> GTNESet - :-> TTOther - ) +prop_foldl1' = + ttProp + ( gf2 keyGen + :?> GTNESet + :-> TTOther + ) foldl1 NES.foldl1' prop_findMin :: Property -prop_findMin = ttProp (GTNESet :-> TTKey) +prop_findMin = + ttProp + (GTNESet :-> TTKey) S.findMin NES.findMin prop_findMax :: Property -prop_findMax = ttProp (GTNESet :-> TTKey) +prop_findMax = + ttProp + (GTNESet :-> TTKey) S.findMax NES.findMax prop_deleteMin :: Property -prop_deleteMin = ttProp (GTNESet :-> TTSet) +prop_deleteMin = + ttProp + (GTNESet :-> TTSet) S.deleteMin NES.deleteMin prop_deleteMax :: Property -prop_deleteMax = ttProp (GTNESet :-> TTSet) +prop_deleteMax = + ttProp + (GTNESet :-> TTSet) S.deleteMax NES.deleteMax prop_deleteFindMin :: Property -prop_deleteFindMin = ttProp (GTNESet :-> TTKey :*: TTSet) +prop_deleteFindMin = + ttProp + (GTNESet :-> TTKey :*: TTSet) S.deleteFindMin NES.deleteFindMin prop_deleteFindMax :: Property -prop_deleteFindMax = ttProp (GTNESet :-> TTKey :*: TTSet) +prop_deleteFindMax = + ttProp + (GTNESet :-> TTKey :*: TTSet) S.deleteFindMax NES.deleteFindMax prop_toList :: Property -prop_toList = ttProp (GTNESet :-> TTNEList TTKey) +prop_toList = + ttProp + (GTNESet :-> TTNEList TTKey) S.toList NES.toList prop_toDescList :: Property -prop_toDescList = ttProp (GTNESet :-> TTNEList TTKey) +prop_toDescList = + ttProp + (GTNESet :-> TTNEList TTKey) S.toDescList NES.toDescList prop_elem :: Property -prop_elem = ttProp (GTKey :-> GTNESet :-> TTOther) +prop_elem = + ttProp + (GTKey :-> GTNESet :-> TTOther) elem elem prop_fold1 :: Property -prop_fold1 = ttProp (GTNESet :-> TTKey) +prop_fold1 = + ttProp + (GTNESet :-> TTKey) fold fold1 prop_fold :: Property -prop_fold = ttProp (GTNESet :-> TTKey) +prop_fold = + ttProp + (GTNESet :-> TTKey) fold fold prop_foldMap1 :: Property -prop_foldMap1 = ttProp (gf1 keyGen :?> GTNESet :-> TTOther) - (\f -> foldMap ((:[]) . f)) - (\f -> foldMap1 ((:[]) . f)) +prop_foldMap1 = + ttProp + (gf1 keyGen :?> GTNESet :-> TTOther) + (\f -> foldMap ((: []) . f)) + (\f -> foldMap1 ((: []) . f)) prop_foldMap :: Property -prop_foldMap = ttProp (gf1 keyGen :?> GTNESet :-> TTOther) - (\f -> foldMap ((:[]) . f)) - (\f -> foldMap ((:[]) . f)) +prop_foldMap = + ttProp + (gf1 keyGen :?> GTNESet :-> TTOther) + (\f -> foldMap ((: []) . f)) + (\f -> foldMap ((: []) . f)) diff --git a/test/Tests/Util.hs b/test/Tests/Util.hs --- a/test/Tests/Util.hs +++ b/test/Tests/Util.hs @@ -1,96 +1,120 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Tests.Util ( - K(..), KeyType, overKX, dummyKey - , SortType(..) - , GenFunc(..), gf1, gf2, gf3, gf4 - , GenType(..) - , TestType(..) - , ttProp - , groupTree - , readShow, readShow1, showShow1, showShow2 - , Context(..) - , Bazaar(..) - , keyGen, valGen, mapSize, mapGen, neMapGen, setGen, neSetGen - , intKeyGen, intMapGen, neIntMapGen, intSetGen, neIntSetGen - , seqGen, neSeqGen - ) where + K (..), + KeyType, + overKX, + dummyKey, + SortType (..), + GenFunc (..), + gf1, + gf2, + gf3, + gf4, + GenType (..), + TestType (..), + ttProp, + groupTree, + readShow, + readShow1, + showShow1, + showShow2, + Context (..), + Bazaar (..), + keyGen, + valGen, + mapSize, + mapGen, + neMapGen, + setGen, + neSetGen, + intKeyGen, + intMapGen, + neIntMapGen, + intSetGen, + neIntSetGen, + seqGen, + neSeqGen, +) where -import Control.Applicative -import Control.Monad -import Data.Bifunctor -import Data.Char -import Data.Foldable -import Data.Function -import Data.Functor.Apply -import Data.Functor.Classes -import Data.Functor.Identity -import Data.IntMap (IntMap) -import Data.IntMap.NonEmpty (NEIntMap) -import Data.IntSet (IntSet, Key) -import Data.IntSet.NonEmpty (NEIntSet) -import Data.Kind -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map (Map) -import Data.Map.NonEmpty (NEMap) -import Data.Maybe -import Data.Semigroup.Foldable -import Data.Sequence (Seq(..)) -import Data.Sequence.NonEmpty (NESeq(..)) -import Data.Set (Set) -import Data.Set.NonEmpty (NESet) -import Data.Text (Text) -import Data.These -import Hedgehog -import Hedgehog.Function hiding ((:*:)) -import Hedgehog.Internal.Property -import Test.Tasty -import Test.Tasty.Hedgehog -import Text.Read -import qualified Data.IntMap as IM -import qualified Data.IntMap.NonEmpty as NEIM -import qualified Data.IntSet as IS -import qualified Data.IntSet.NonEmpty as NEIS -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Map.NonEmpty as NEM -import qualified Data.Sequence.NonEmpty as NESeq -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES -import qualified Data.Text as T -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Control.Applicative +import Control.Monad +import Data.Bifunctor +import Data.Char +import Data.Foldable +import Data.Function +import Data.Functor.Apply +import Data.Functor.Classes +import Data.Functor.Identity +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.IntMap.NonEmpty (NEIntMap) +import qualified Data.IntMap.NonEmpty as NEIM +import Data.IntSet (IntSet, Key) +import qualified Data.IntSet as IS +import Data.IntSet.NonEmpty (NEIntSet) +import qualified Data.IntSet.NonEmpty as NEIS +import Data.Kind +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as M +import Data.Map.NonEmpty (NEMap) +import qualified Data.Map.NonEmpty as NEM +import Data.Maybe +import Data.Semigroup.Foldable +import Data.Sequence (Seq (..)) +import Data.Sequence.NonEmpty (NESeq (..)) +import qualified Data.Sequence.NonEmpty as NESeq +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NES +import Data.Text (Text) +import qualified Data.Text as T +import Data.These +import Hedgehog +import Hedgehog.Function hiding ((:*:)) +import qualified Hedgehog.Gen as Gen +import Hedgehog.Internal.Property +import qualified Hedgehog.Range as Range +import Test.Tasty +import Test.Tasty.Hedgehog +import Text.Read #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup(..)) #endif +{-# ANN module ("HLint: ignore Avoid NonEmpty.unzip" :: String) #-} + groupTree :: Group -> TestTree -groupTree Group{..} = testGroup (unGroupName groupName) - (map (uncurry go) groupProperties) +groupTree Group{..} = + testGroup + (unGroupName groupName) + (map (uncurry go) groupProperties) where go :: PropertyName -> Property -> TestTree go n = testProperty (mkName (unPropertyName n)) mkName = map deUnderscore . drop (length @[] @Char "prop_") deUnderscore '_' = ' ' - deUnderscore c = c + deUnderscore c = c -- | test for stability -data K a b = K { getKX :: !a, getKY :: !b } - deriving (Show, Read, Generic) +data K a b = K {getKX :: !a, getKY :: !b} + deriving (Show, Read, Generic) withK :: (a -> b -> c) -> K a b -> c withK f (K x y) = f x y @@ -99,10 +123,10 @@ overKX f (K x y) = K (f x) y instance Eq a => Eq (K a b) where - (==) = (==) `on` getKX + (==) = (==) `on` getKX instance Ord a => Ord (K a b) where - compare = compare `on` getKX + compare = compare `on` getKX instance (Vary a, Vary b) => Vary (K a b) instance (Arg a, Arg b) => Arg (K a b) @@ -110,21 +134,26 @@ type KeyType = K Int Text instance Semigroup KeyType where - K x1 y1 <> K x2 y2 = K (x1 + x2) (y1 <> y2) + K x1 y1 <> K x2 y2 = K (x1 + x2) (y1 <> y2) instance Monoid KeyType where - mempty = K 0 "" - mappend = (<>) + mempty = K 0 "" + mappend = (<>) dummyKey :: KeyType dummyKey = K 0 "hello" - #if MIN_VERSION_base(4,11,0) instance (Num a, Monoid b) => Num (K a b) where + K x1 y1 + K x2 y2 = K (x1 + x2) (y1 <> y2) + K x1 y1 - K x2 y2 = K (x1 - x2) (y1 <> y2) + K x1 y1 * K x2 y2 = K (x1 * x2) (y1 <> y2) + negate (K x y) = K (negate x) y + abs (K x y) = K (abs x) y + signum (K x y) = K (signum x) y + fromInteger n = K (fromInteger n) mempty #else instance (Num a, Semigroup b, Monoid b) => Num (K a b) where -#endif K x1 y1 + K x2 y2 = K (x1 + x2) (y1 <> y2) K x1 y1 - K x2 y2 = K (x1 - x2) (y1 <> y2) K x1 y1 * K x2 y2 = K (x1 * x2) (y1 <> y2) @@ -132,300 +161,331 @@ abs (K x y) = K (abs x) y signum (K x y) = K (signum x) y fromInteger n = K (fromInteger n) mempty +#endif data Context a b t = Context (b -> t) a - deriving Functor + deriving (Functor) -data Bazaar a b t = Done t - | More a (Bazaar a b (b -> t)) - deriving Functor +data Bazaar a b t + = Done t + | More a (Bazaar a b (b -> t)) + deriving (Functor) -instance Apply (Bazaar a b) where #if MIN_VERSION_semigroupoids(5,2,2) +instance Apply (Bazaar a b) where liftF2 f = \case Done x -> fmap (f x) More x b -> More x . liftA2 (\g r y -> f (g y) r) b #else +instance Apply (Bazaar a b) where (<.>) = \case Done x -> fmap x More x b -> More x . liftA2 (\g r y -> g y r) b #endif instance Applicative (Bazaar a b) where - pure = Done - liftA2 = liftF2 + pure = Done + liftA2 = liftF2 data SortType :: Type -> Type where - STAsc :: Ord a => SortType a - STDesc :: Ord a => SortType a - STDistinctAsc :: Ord a => SortType (a, b) - STDistinctDesc :: Ord a => SortType (a, b) + STAsc :: Ord a => SortType a + STDesc :: Ord a => SortType a + STDistinctAsc :: Ord a => SortType (a, b) + STDistinctDesc :: Ord a => SortType (a, b) data GenType :: Type -> Type -> Type where - GTNEMap :: GenType (Map KeyType Text) (NEMap KeyType Text) - GTMap :: GenType (Map KeyType Text) (Map KeyType Text ) - GTNESet :: GenType (Set KeyType ) (NESet KeyType ) - GTNEIntMap :: GenType (IntMap Text ) (NEIntMap Text ) - GTNEIntSet :: GenType IntSet NEIntSet - GTIntMap :: GenType (IntMap Text ) (IntMap Text ) - GTNESeq :: GenType (Seq Text ) (NESeq Text ) - GTNESeqList :: GenType (NonEmpty Text ) (NESeq Text ) - GTSeq :: GenType (Seq Text ) (Seq Text ) - GTKey :: GenType KeyType KeyType - GTIntKey :: GenType Int Int - GTVal :: GenType Text Text - GTSize :: GenType Int Int - GTOther :: Gen a - -> GenType a a - GTMaybe :: GenType a b - -> GenType (Maybe a) (Maybe b) - (:&:) :: GenType a b - -> GenType c d - -> GenType (a, c) (b, d) - GTNEList :: Maybe (Range Int) - -> GenType a b - -> GenType [a] (NonEmpty b) - GTSet :: GenType (Set KeyType) (Set KeyType) - GTIntSet :: GenType IntSet IntSet - GTSorted :: SortType a - -> GenType [a] (NonEmpty a) - -> GenType [a] (NonEmpty a) + GTNEMap :: GenType (Map KeyType Text) (NEMap KeyType Text) + GTMap :: GenType (Map KeyType Text) (Map KeyType Text) + GTNESet :: GenType (Set KeyType) (NESet KeyType) + GTNEIntMap :: GenType (IntMap Text) (NEIntMap Text) + GTNEIntSet :: GenType IntSet NEIntSet + GTIntMap :: GenType (IntMap Text) (IntMap Text) + GTNESeq :: GenType (Seq Text) (NESeq Text) + GTNESeqList :: GenType (NonEmpty Text) (NESeq Text) + GTSeq :: GenType (Seq Text) (Seq Text) + GTKey :: GenType KeyType KeyType + GTIntKey :: GenType Int Int + GTVal :: GenType Text Text + GTSize :: GenType Int Int + GTOther :: + Gen a -> + GenType a a + GTMaybe :: + GenType a b -> + GenType (Maybe a) (Maybe b) + (:&:) :: + GenType a b -> + GenType c d -> + GenType (a, c) (b, d) + GTNEList :: + Maybe (Range Int) -> + GenType a b -> + GenType [a] (NonEmpty b) + GTSet :: GenType (Set KeyType) (Set KeyType) + GTIntSet :: GenType IntSet IntSet + GTSorted :: + SortType a -> + GenType [a] (NonEmpty a) -> + GenType [a] (NonEmpty a) data GenFunc :: Type -> Type -> Type -> Type where - GF :: (Show a, Arg a, Vary a, Show b) - => Gen b - -> ((a -> b) -> f) - -> GenFunc f c d + GF :: + (Show a, Arg a, Vary a, Show b) => + Gen b -> + ((a -> b) -> f) -> + GenFunc f c d -gf1 :: (Show a, Arg a, Vary a, Show b) - => Gen b - -> GenFunc (a -> b) c d +gf1 :: + (Show a, Arg a, Vary a, Show b) => + Gen b -> + GenFunc (a -> b) c d gf1 = (`GF` id) -gf2 :: (Show a, Show b, Arg a, Vary a, Arg b, Vary b, Show c) - => Gen c - -> GenFunc (a -> b -> c) d e +gf2 :: + (Show a, Show b, Arg a, Vary a, Arg b, Vary b, Show c) => + Gen c -> + GenFunc (a -> b -> c) d e gf2 = (`GF` curry) -gf3 :: (Show a, Show b, Show c, Arg a, Vary a, Arg b, Vary b, Arg c, Vary c, Show d) - => Gen d - -> GenFunc (a -> b -> c -> d) e f +gf3 :: + (Show a, Show b, Show c, Arg a, Vary a, Arg b, Vary b, Arg c, Vary c, Show d) => + Gen d -> + GenFunc (a -> b -> c -> d) e f gf3 = (`GF` (curry . curry)) -gf4 :: (Show a, Show b, Show c, Arg a, Vary a, Arg b, Vary b, Arg c, Vary c, Show d, Show e, Arg d, Vary d) - => Gen e - -> GenFunc (a -> b -> c -> d -> e) f g +gf4 :: + (Show a, Show b, Show c, Arg a, Vary a, Arg b, Vary b, Arg c, Vary c, Show d, Show e, Arg d, Vary d) => + Gen e -> + GenFunc (a -> b -> c -> d -> e) f g gf4 = (`GF` (curry . curry . curry)) - - - data TestType :: Type -> Type -> Type where - TTNEMap :: (Eq a, Show a) - => TestType (Map KeyType a) (NEMap KeyType a ) - TTNEIntMap :: (Eq a, Show a) - => TestType (IntMap a ) (NEIntMap a ) - TTNESet :: TestType (Set KeyType ) (NESet KeyType ) - TTNEIntSet :: TestType IntSet NEIntSet - TTMap :: (Eq a, Show a) - => TestType (Map KeyType a) (Map KeyType a ) - TTSet :: TestType (Set KeyType ) (Set KeyType ) - TTNESeq :: (Eq a, Show a) - => TestType (Seq a ) (NESeq a ) - TTNESeqList :: (Eq a, Show a) - => TestType (NonEmpty a ) (NESeq a ) - TTKey :: TestType KeyType KeyType - TTVal :: TestType Text Text - TTOther :: (Eq a, Show a) - => TestType a a - TTThese :: (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c) - => TestType a b - -> TestType c d - -> TestType (a, c) (These b d) - TTMThese :: (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c) - => 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 - -> TestType c d - -> TestType (Either a c) (Either b d) - TTNEList :: TestType a b - -> TestType [a] (NonEmpty b) - TTCtx :: TestType (c -> t) (d -> u) - -> TestType a b - -> TestType (Context a c t) (Context b d u) - TTBazaar :: (Show a, Show b, Show c, Show d) - => GenType c d - -> TestType t u - -> TestType a b - -> TestType (Bazaar a c t) (Bazaar b d u) - (:*:) :: (Eq a, Eq b, Eq c, Eq d, Show a, Show b, Show c, Show d) - => TestType a b - -> TestType c d - -> TestType (a, c) (b, d) - (:?>) :: GenFunc f c d - -> TestType c d - -> TestType (f -> c) (f -> d) - (:->) :: (Show a, Show b) - => GenType a b - -> TestType c d - -> TestType (a -> c) (b -> d) + TTNEMap :: + (Eq a, Show a) => + TestType (Map KeyType a) (NEMap KeyType a) + TTNEIntMap :: + (Eq a, Show a) => + TestType (IntMap a) (NEIntMap a) + TTNESet :: TestType (Set KeyType) (NESet KeyType) + TTNEIntSet :: TestType IntSet NEIntSet + TTMap :: + (Eq a, Show a) => + TestType (Map KeyType a) (Map KeyType a) + TTSet :: TestType (Set KeyType) (Set KeyType) + TTNESeq :: + (Eq a, Show a) => + TestType (Seq a) (NESeq a) + TTNESeqList :: + (Eq a, Show a) => + TestType (NonEmpty a) (NESeq a) + TTKey :: TestType KeyType KeyType + TTVal :: TestType Text Text + TTOther :: + (Eq a, Show a) => + TestType a a + TTThese :: + (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c) => + TestType a b -> + TestType c d -> + TestType (a, c) (These b d) + TTMThese :: + (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c) => + 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 -> + TestType c d -> + TestType (Either a c) (Either b d) + TTNEList :: + TestType a b -> + TestType [a] (NonEmpty b) + TTCtx :: + TestType (c -> t) (d -> u) -> + TestType a b -> + TestType (Context a c t) (Context b d u) + TTBazaar :: + (Show a, Show b, Show c, Show d) => + GenType c d -> + TestType t u -> + TestType a b -> + TestType (Bazaar a c t) (Bazaar b d u) + (:*:) :: + (Eq a, Eq b, Eq c, Eq d, Show a, Show b, Show c, Show d) => + TestType a b -> + TestType c d -> + TestType (a, c) (b, d) + (:?>) :: + GenFunc f c d -> + TestType c d -> + TestType (f -> c) (f -> d) + (:->) :: + (Show a, Show b) => + GenType a b -> + TestType c d -> + TestType (a -> c) (b -> d) infixr 2 :&: infixr 1 :-> infixr 1 :?> infixr 2 :*: -runSorter - :: SortType a - -> [a] - -> [a] +runSorter :: + SortType a -> + [a] -> + [a] runSorter = \case - STAsc -> S.toAscList . S.fromList - STDesc -> S.toDescList . S.fromList - STDistinctAsc -> M.toAscList . M.fromList - STDistinctDesc -> M.toDescList . M.fromList + STAsc -> S.toAscList . S.fromList + STDesc -> S.toDescList . S.fromList + STDistinctAsc -> M.toAscList . M.fromList + STDistinctDesc -> M.toDescList . M.fromList runGT :: GenType a b -> Gen (a, b) runGT = \case - GTNEMap -> (\n -> (NEM.IsNonEmpty n, n)) <$> neMapGen - GTMap -> join (,) <$> mapGen - GTNESet -> (\n -> (NES.IsNonEmpty n, n)) <$> neSetGen - GTNEIntMap -> (\n -> (NEIM.IsNonEmpty n, n)) <$> neIntMapGen - GTNEIntSet -> (\n -> (NEIS.IsNonEmpty n, n)) <$> neIntSetGen - GTIntMap -> join (,) <$> intMapGen - GTSet -> join (,) <$> setGen - GTIntSet -> join (,) <$> intSetGen - GTNESeq -> (\n -> (NESeq.IsNonEmpty n, n)) <$> neSeqGen - GTNESeqList -> (\n -> (toNonEmpty n, n)) <$> neSeqGen - GTSeq -> join (,) <$> seqGen - GTKey -> join (,) <$> keyGen - GTIntKey -> join (,) <$> intKeyGen - GTVal -> join (,) <$> valGen - GTSize -> join (,) <$> Gen.int mapSize - GTOther g -> join (,) <$> g - GTMaybe g -> maybe (Nothing, Nothing) (bimap Just Just) <$> - Gen.maybe (runGT g) - g1 :&: g2 -> do - (x1, y1) <- runGT g1 - (x2, y2) <- runGT g2 - pure ((x1,x2), (y1,y2)) - GTNEList r g -> first toList . NE.unzip <$> - Gen.nonEmpty (fromMaybe mapSize r) (runGT g) - GTSorted s g -> bimap (runSorter s) (fromJust . NE.nonEmpty . runSorter s . toList) <$> - runGT g + GTNEMap -> (\n -> (NEM.IsNonEmpty n, n)) <$> neMapGen + GTMap -> join (,) <$> mapGen + GTNESet -> (\n -> (NES.IsNonEmpty n, n)) <$> neSetGen + GTNEIntMap -> (\n -> (NEIM.IsNonEmpty n, n)) <$> neIntMapGen + GTNEIntSet -> (\n -> (NEIS.IsNonEmpty n, n)) <$> neIntSetGen + GTIntMap -> join (,) <$> intMapGen + GTSet -> join (,) <$> setGen + GTIntSet -> join (,) <$> intSetGen + GTNESeq -> (\n -> (NESeq.IsNonEmpty n, n)) <$> neSeqGen + GTNESeqList -> (\n -> (toNonEmpty n, n)) <$> neSeqGen + GTSeq -> join (,) <$> seqGen + GTKey -> join (,) <$> keyGen + GTIntKey -> join (,) <$> intKeyGen + GTVal -> join (,) <$> valGen + GTSize -> join (,) <$> Gen.int mapSize + GTOther g -> join (,) <$> g + GTMaybe g -> + maybe (Nothing, Nothing) (bimap Just Just) + <$> Gen.maybe (runGT g) + g1 :&: g2 -> do + (x1, y1) <- runGT g1 + (x2, y2) <- runGT g2 + pure ((x1, x2), (y1, y2)) + GTNEList r g -> + first toList . NE.unzip + <$> Gen.nonEmpty (fromMaybe mapSize r) (runGT g) + GTSorted s g -> + bimap (runSorter s) (fromJust . NE.nonEmpty . runSorter s . toList) + <$> runGT g runTT :: Monad m => TestType a b -> a -> b -> PropertyT m () runTT = \case - TTNEMap -> \x y -> do - assert $ NEM.valid y - unKMap x === unKMap (NEM.IsNonEmpty y) - TTNEIntMap -> \x y -> do - assert $ NEIM.valid y - x === NEIM.IsNonEmpty y - TTNESet -> \x y -> do - assert $ NES.valid y - unKSet x === unKSet (NES.IsNonEmpty y) - TTNEIntSet -> \x y -> do - assert $ NEIS.valid y - x === NEIS.IsNonEmpty y - TTMap -> \x y -> - unKMap x === unKMap y - TTSet -> \x y -> - unKSet x === unKSet y - TTNESeq -> \x y -> - x === NESeq.IsNonEmpty y - TTNESeqList -> \x y -> - x === toNonEmpty y - TTKey -> \(K x1 y1) (K x2 y2) -> do - x1 === x2 - y1 === y2 - TTVal -> (===) - TTOther -> (===) - TTThese t1 t2 -> \(x1, x2) -> \case - This y1 -> do - runTT t1 x1 y1 - x2 === mempty - That y2 -> do - x1 === mempty - runTT t2 x2 y2 - These y1 y2 -> do - runTT t1 x1 y1 - runTT t2 x2 y2 - TTMThese t1 t2 -> \(x1, x2) -> \case - Nothing -> do - x1 === mempty - x2 === mempty - Just (This y1) -> do - runTT t1 x1 y1 - x2 === mempty - Just (That y2) -> do - x1 === mempty - runTT t2 x2 y2 - 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 - TTEither tl tr -> \case - Left x -> \case - Left y -> runTT tl x y - Right _ -> annotate "Left -> Right" *> failure - Right x -> \case - Left _ -> annotate "Right -> Left" *> failure - Right y -> runTT tr x y - TTNEList tt -> \xs ys -> do - length xs === length ys - zipWithM_ (runTT tt) xs (toList ys) - TTCtx tSet tView -> \(Context xS xV) (Context yS yV) -> do - runTT tSet xS yS - runTT tView xV yV - TTBazaar gNew tRes tView -> testBazaar gNew tRes tView - t1 :*: t2 -> \(x1, x2) (y1, y2) -> do + TTNEMap -> \x y -> do + assert $ NEM.valid y + unKMap x === unKMap (NEM.IsNonEmpty y) + TTNEIntMap -> \x y -> do + assert $ NEIM.valid y + x === NEIM.IsNonEmpty y + TTNESet -> \x y -> do + assert $ NES.valid y + unKSet x === unKSet (NES.IsNonEmpty y) + TTNEIntSet -> \x y -> do + assert $ NEIS.valid y + x === NEIS.IsNonEmpty y + TTMap -> \x y -> + unKMap x === unKMap y + TTSet -> \x y -> + unKSet x === unKSet y + TTNESeq -> \x y -> + x === NESeq.IsNonEmpty y + TTNESeqList -> \x y -> + x === toNonEmpty y + TTKey -> \(K x1 y1) (K x2 y2) -> do + x1 === x2 + y1 === y2 + TTVal -> (===) + TTOther -> (===) + TTThese t1 t2 -> \(x1, x2) -> \case + This y1 -> do runTT t1 x1 y1 + x2 === mempty + That y2 -> do + x1 === mempty runTT t2 x2 y2 - GF gt c :?> tt -> \gx gy -> do - f <- c <$> forAllFn (fn gt) - runTT tt (gx f) (gy f) - gt :-> tt -> \f g -> do - (x, y) <- forAll $ runGT gt - runTT tt (f x) (g y) + These y1 y2 -> do + runTT t1 x1 y1 + runTT t2 x2 y2 + TTMThese t1 t2 -> \(x1, x2) -> \case + Nothing -> do + x1 === mempty + x2 === mempty + Just (This y1) -> do + runTT t1 x1 y1 + x2 === mempty + Just (That y2) -> do + x1 === mempty + runTT t2 x2 y2 + 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 + TTEither tl tr -> \case + Left x -> \case + Left y -> runTT tl x y + Right _ -> annotate "Left -> Right" *> failure + Right x -> \case + Left _ -> annotate "Right -> Left" *> failure + Right y -> runTT tr x y + TTNEList tt -> \xs ys -> do + length xs === length ys + zipWithM_ (runTT tt) xs (toList ys) + TTCtx tSet tView -> \(Context xS xV) (Context yS yV) -> do + runTT tSet xS yS + runTT tView xV yV + TTBazaar gNew tRes tView -> testBazaar gNew tRes tView + t1 :*: t2 -> \(x1, x2) (y1, y2) -> do + runTT t1 x1 y1 + runTT t2 x2 y2 + GF gt c :?> tt -> \gx gy -> do + f <- c <$> forAllFn (fn gt) + runTT tt (gx f) (gy f) + gt :-> tt -> \f g -> do + (x, y) <- forAll $ runGT gt + runTT tt (f x) (g y) where unKMap :: (Ord k, Ord j) => Map (K k j) c -> Map (k, j) c unKMap = M.mapKeys (withK (,)) unKSet :: (Ord k, Ord j) => Set (K k j) -> Set (k, j) unKSet = S.map (withK (,)) -testBazaar - :: forall a b c d t u m. (Show a, Show b, Show c, Show d, Monad m) - => GenType c d - -> TestType t u - -> TestType a b - -> Bazaar a c t - -> Bazaar b d u - -> PropertyT m () +testBazaar :: + forall a b c d t u m. + (Show a, Show b, Show c, Show d, Monad m) => + GenType c d -> + TestType t u -> + TestType a b -> + Bazaar a c t -> + Bazaar b d u -> + PropertyT m () testBazaar gNew tRes0 tView = go [] [] tRes0 where - go :: [a] -> [b] -> TestType t' u' -> Bazaar a c t' -> Bazaar b d u' -> PropertyT m () + go :: [a] -> [b] -> TestType t' u' -> Bazaar a c t' -> Bazaar b d u' -> PropertyT m () go xs ys tRes = \case Done xRes -> \case Done yRes -> do @@ -448,8 +508,7 @@ annotate "Each individual piece matches pair-wise" runTT tView xView yView annotate "The remainders also match" - go (xView:xs) (yView:ys) (gNew :-> tRes) xNext yNext - + go (xView : xs) (yView : ys) (gNew :-> tRes) xNext yNext -- --------------------- -- Properties @@ -458,41 +517,41 @@ ttProp :: TestType a b -> a -> b -> Property ttProp tt x = property . runTT tt x -readShow - :: (Show a, Read a, Eq a) - => Gen a - -> Property +readShow :: + (Show a, Read a, Eq a) => + Gen a -> + Property readShow g = property $ do - m0 <- forAll g - tripping m0 show readMaybe + m0 <- forAll g + tripping m0 show readMaybe -readShow1 - :: (Eq (f a), Show1 f, Show a, Show (f a), Read1 f, Read a) - => Gen (f a) - -> Property +readShow1 :: + (Eq (f a), Show1 f, Show a, Show (f a), Read1 f, Read a) => + Gen (f a) -> + Property readShow1 g = property $ do - m0 <- forAll g - tripping m0 (($ "") . showsPrec1 0) (fmap fst . listToMaybe . readsPrec1 0) + m0 <- forAll g + tripping m0 (flip (showsPrec1 0) "") (fmap fst . listToMaybe . readsPrec1 0) -showShow1 - :: (Show1 f, Show a, Show (f a)) - => Gen (f a) - -> Property +showShow1 :: + (Show1 f, Show a, Show (f a)) => + Gen (f a) -> + Property showShow1 g = property $ do - m0 <- forAll g - let s0 = show m0 - s1 = showsPrec1 0 m0 "" - s0 === s1 + m0 <- forAll g + let s0 = show m0 + s1 = showsPrec1 0 m0 "" + s0 === s1 -showShow2 - :: (Show2 f, Show a, Show b, Show (f a b)) - => Gen (f a b) - -> Property +showShow2 :: + (Show2 f, Show a, Show b, Show (f a b)) => + Gen (f a b) -> + Property showShow2 g = property $ do - m0 <- forAll g - let s0 = show m0 - s2 = showsPrec2 0 m0 "" - s0 === s2 + m0 <- forAll g + let s0 = show m0 + s2 = showsPrec2 0 m0 "" + s0 === s2 -- readShow2 -- :: (Eq (f a b), Show2 f, Show a, Show b, Show (f a b), Read2 f, Read a, Read b) @@ -507,8 +566,10 @@ -- --------------------- keyGen :: MonadGen m => m KeyType -keyGen = K <$> intKeyGen - <*> Gen.text (Range.linear 0 5) Gen.alphaNum +keyGen = + K + <$> intKeyGen + <*> Gen.text (Range.linear 0 5) Gen.alphaNum valGen :: MonadGen m => m Text valGen = Gen.text (Range.linear 0 5) Gen.alphaNum @@ -549,23 +610,18 @@ neSeqGen :: (MonadGen m, GenBase m ~ Identity) => m (NESeq Text) neSeqGen = Gen.just $ NESeq.nonEmptySeq <$> seqGen - - - - -- --------------------- -- Orphans -- --------------------- instance Arg Char where - build = via ord chr + build = via ord chr instance Arg Text where - build = via T.unpack T.pack + build = via T.unpack T.pack instance Vary Char where - vary = contramap ord vary + vary = contramap ord vary instance Vary Text where - vary = contramap T.unpack vary - + vary = contramap T.unpack vary