pomaps (empty) → 0.0.0.1
raw patch · 19 files changed
+4275/−0 lines, 19 filesdep +ChasingBottomsdep +Globdep +basesetup-changed
Dependencies added: ChasingBottoms, Glob, base, containers, criterion, deepseq, doctest, ghc-prim, lattices, pomaps, random, tasty, tasty-hspec, tasty-quickcheck, vector
Files
- CHANGELOG.md +7/−0
- LICENSE.md +23/−0
- README.md +16/−0
- Setup.hs +7/−0
- bench/Main.hs +77/−0
- lattices/Algebra/PartialOrd.hs +154/−0
- pomaps.cabal +117/−0
- src/Data/POMap/Internal.hs +1264/−0
- src/Data/POMap/Lazy.hs +651/−0
- src/Data/POMap/Strict.hs +664/−0
- src/Data/POSet.hs +117/−0
- src/Data/POSet/Internal.hs +356/−0
- stack.yaml +71/−0
- tests/Data/POMap/Arbitrary.hs +10/−0
- tests/Data/POMap/Divisibility.hs +21/−0
- tests/Data/POMap/Properties.hs +529/−0
- tests/Data/POMap/Strictness.hs +173/−0
- tests/Main.hs +13/−0
- tests/doctest-driver.hs +5/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Change log++pomaps uses [Semantic Versioning][].+The change log is available through the [releases on GitHub][].++[Semantic Versioning]: http://semver.org/spec/v2.0.0.html+[releases on GitHub]: https://github.com/sgraf812/pomaps/releases
+ LICENSE.md view
@@ -0,0 +1,23 @@+[The MIT License (MIT)][]++Copyright (c) 2017 Author name here++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.++[The MIT License (MIT)]: https://opensource.org/licenses/MIT
+ README.md view
@@ -0,0 +1,16 @@+# [pomaps][] [](https://travis-ci.org/sgraf812/pomaps)++Reasonably fast maps (and possibly sets) based on keys satisfying [`PartialOrd`](https://hackage.haskell.org/package/lattices-1.6.0/docs/Algebra-PartialOrd.html#t:PartialOrd).++This package tries to load off as much work as possible to the excellent [`containers`](https://hackage.haskell.org/package/containers) library, in order to achieve acceptable performance.+The interface is kept as similar to [`Data.Map.{Strict/Lazy}`](https://hackage.haskell.org/package/containers-0.5.10.2/docs/Data-Map-Strict.html) as possible, which is an excuse for somewhat lacking documentation.++`POMap`s basically store a decomposition of totally ordered chains (e.g. something `Map`s can handle). +Functionality and strictness properties should be pretty much covered by the testsuite. +But it's not battle-tested yet, so if you encounter space leaks in the implementation, let me know.++A rather naive implementation leads to `O(w*n*log n)` lookups, where `w` is the width of the decomposition (which should be the size of the biggest anti-chain).+This is enough for me at the moment to get things going, but there is room for improvement ([Sorting and Selection in Posets](https://arxiv.org/abs/0707.1532)).+Let me know if things are too slow and I'll see what I can do!++[pomaps]: https://github.com/sgraf812/pomaps
+ Setup.hs view
@@ -0,0 +1,7 @@+-- This script is used to build and install your package. Typically you don't+-- need to change it. The Cabal documentation has more information about this+-- file: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain
+ bench/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++import Algebra.PartialOrd+import Control.Arrow (first)+import Control.DeepSeq+import Criterion.Main+import qualified Data.POMap.Lazy as L+import qualified Data.POMap.Strict as S+import qualified Data.Vector as V+import System.Random++newtype Divisibility+ = Div { _unDiv :: Int }+ deriving (Eq, Num, Show, Read, NFData)++instance PartialOrd Divisibility where+ leq (Div a) (Div b) = b `mod` a == 0++instance Bounded Divisibility where+ minBound = Div 1+ maxBound = Div maxBound++instance Random Divisibility where+ randomR (Div l, Div h) = first Div . randomR (l, h)+ random = randomR (minBound, maxBound)++genElems :: Int -> [(Divisibility, Int)]+genElems n = zip (randoms (mkStdGen 0) :: [Divisibility]) [1 :: Int .. n]++main :: IO ()+main = defaultMain+ [ bgroup "insert"+ [ bgroup s+ [ env+ (pure (genElems n))+ (bench (show n) . whnf (foldr (uncurry insert) L.empty))+ | n <- [100, 1000, 2000]+ ]+ | (s, insert) <- [("Lazy", L.insert), ("Strict", S.insert)]+ ]+ , bgroup "lookup(present)"+ [ env+ (let elems = genElems n+ m = L.fromList elems+ k = fst (elems !! (length elems `div` 2))+ in pure (m, k))+ (\ ~(m, k) -> bench (show n) (whnf (L.lookup k) m))+ | n <- [100, 1000, 2000]+ ]+ , bgroup "lookup(absent)"+ [ env+ (let elems = genElems n+ m = L.fromList elems+ k = fst (random (mkStdGen (-1)))+ in pure (m, k))+ (\ ~(m, k) -> bench (show n) (whnf (L.lookup k) m))+ | n <- [100, 1000, 2000]+ ]+ , bgroup "Vector.lookup(present)"+ [ env+ (let elems = genElems n+ v = V.fromListN n elems+ k = fst (elems !! (length elems `div` 2))+ in pure (v, k))+ (\ ~(v, k) -> bench (show n) (whnf (V.find ((== k) . fst)) v))+ | n <- [100, 1000, 2000]+ ]+ , bgroup "Vector.lookup(absent)"+ [ env+ (let elems = genElems n+ v = V.fromListN n elems+ k = fst (random (mkStdGen (-1)))+ in pure (v, k))+ (\ ~(v, k) -> bench (show n) (whnf (V.find ((== k) . fst)) v))+ | n <- [100, 1000, 2000]+ ]+ ]
+ lattices/Algebra/PartialOrd.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE Safe #-}+----------------------------------------------------------------------------+-- |+-- Module : Algebra.PartialOrd+-- Copyright : (C) 2010-2015 Maximilian Bolingbroke+-- License : BSD-3-Clause (see the file LICENSE)+--+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+----------------------------------------------------------------------------+module Algebra.PartialOrd (+ -- * Partial orderings+ PartialOrd(..),+ partialOrdEq,++ -- * Fixed points of chains in partial orders+ lfpFrom, unsafeLfpFrom,+ gfpFrom, unsafeGfpFrom+ ) where++import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Void (Void)++-- | A partial ordering on sets+-- (<http://en.wikipedia.org/wiki/Partially_ordered_set>) is a set equipped+-- with a binary relation, `leq`, that obeys the following laws+--+-- @+-- Reflexive: a ``leq`` a+-- Antisymmetric: a ``leq`` b && b ``leq`` a ==> a == b+-- Transitive: a ``leq`` b && b ``leq`` c ==> a ``leq`` c+-- @+--+-- Two elements of the set are said to be `comparable` when they are are+-- ordered with respect to the `leq` relation. So+--+-- @+-- `comparable` a b ==> a ``leq`` b || b ``leq`` a+-- @+--+-- If `comparable` always returns true then the relation `leq` defines a+-- total ordering (and an `Ord` instance may be defined). Any `Ord` instance is+-- trivially an instance of `PartialOrd`. 'Algebra.Lattice.Ordered' provides a+-- convenient wrapper to satisfy 'PartialOrd' given 'Ord'.+--+-- As an example consider the partial ordering on sets induced by set+-- inclusion. Then for sets `a` and `b`,+--+-- @+-- a ``leq`` b+-- @+--+-- is true when `a` is a subset of `b`. Two sets are `comparable` if one is a+-- subset of the other. Concretely+--+-- @+-- a = {1, 2, 3}+-- b = {1, 3, 4}+-- c = {1, 2}+--+-- a ``leq`` a = `True`+-- a ``leq`` b = `False`+-- a ``leq`` c = `False`+-- b ``leq`` a = `False`+-- b ``leq`` b = `True`+-- b ``leq`` c = `False`+-- c ``leq`` a = `True`+-- c ``leq`` b = `False`+-- c ``leq`` c = `True`+--+-- `comparable` a b = `False`+-- `comparable` a c = `True`+-- `comparable` b c = `False`+-- @+class Eq a => PartialOrd a where+ -- | The relation that induces the partial ordering+ leq :: a -> a -> Bool++ -- | Whether two elements are ordered with respect to the relation. A+ -- default implementation is given by+ --+ -- > comparable x y = leq x y || leq y x+ comparable :: a -> a -> Bool+ comparable x y = leq x y || leq y x++-- | The equality relation induced by the partial-order structure. It must obey+-- the laws+-- @+-- Reflexive: a == a+-- Transitive: a == b && b == c ==> a == c+-- @+partialOrdEq :: PartialOrd a => a -> a -> Bool+partialOrdEq x y = leq x y && leq y x++instance PartialOrd () where+ leq _ _ = True++instance PartialOrd Void where+ leq _ _ = True++instance Ord a => PartialOrd (S.Set a) where+ leq = S.isSubsetOf++instance PartialOrd IS.IntSet where+ leq = IS.isSubsetOf++instance (Ord k, PartialOrd v) => PartialOrd (M.Map k v) where+ leq = M.isSubmapOfBy leq++instance PartialOrd v => PartialOrd (IM.IntMap v) where+ leq = IM.isSubmapOfBy leq++instance (PartialOrd a, PartialOrd b) => PartialOrd (a, b) where+ -- NB: *not* a lexical ordering. This is because for some component partial orders, lexical+ -- ordering is incompatible with the transitivity axiom we require for the derived partial order+ (x1, y1) `leq` (x2, y2) = x1 `leq` x2 && y1 `leq` y2++-- | Least point of a partially ordered monotone function. Checks that the function is monotone.+lfpFrom :: PartialOrd a => a -> (a -> a) -> a+lfpFrom = lfpFrom' leq++-- | Least point of a partially ordered monotone function. Does not checks that the function is monotone.+unsafeLfpFrom :: Eq a => a -> (a -> a) -> a+unsafeLfpFrom = lfpFrom' (\_ _ -> True)++{-# INLINE lfpFrom' #-}+lfpFrom' :: Eq a => (a -> a -> Bool) -> a -> (a -> a) -> a+lfpFrom' check init_x f = go init_x+ where go x | x' == x = x+ | x `check` x' = go x'+ | otherwise = error "lfpFrom: non-monotone function"+ where x' = f x+++-- | Greatest fixed point of a partially ordered antinone function. Checks that the function is antinone.+{-# INLINE gfpFrom #-}+gfpFrom :: PartialOrd a => a -> (a -> a) -> a+gfpFrom = gfpFrom' leq++-- | Greatest fixed point of a partially ordered antinone function. Does not check that the function is antinone.+{-# INLINE unsafeGfpFrom #-}+unsafeGfpFrom :: Eq a => a -> (a -> a) -> a+unsafeGfpFrom = gfpFrom' (\_ _ -> True)++{-# INLINE gfpFrom' #-}+gfpFrom' :: Eq a => (a -> a -> Bool) -> a -> (a -> a) -> a+gfpFrom' check init_x f = go init_x+ where go x | x' == x = x+ | x' `check` x = go x'+ | otherwise = error "gfpFrom: non-antinone function"+ where x' = f x
+ pomaps.cabal view
@@ -0,0 +1,117 @@+name: pomaps+version: 0.0.0.1+synopsis: Maps and sets of partial orders+category: Data Structures+homepage: https://github.com/sgraf812/pomaps#readme+bug-reports: https://github.com/sgraf812/pomaps/issues+maintainer: Sebastian Graf+license: MIT+license-file: LICENSE.md+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ CHANGELOG.md+ LICENSE.md+ README.md+ stack.yaml++description:+ Maps (and sets) indexed by keys satisfying <https://hackage.haskell.org/package/lattices/docs/Algebra-PartialOrd.html#t:PartialOrd PartialOrd>.+ .+ The goal is to provide asymptotically better data structures than simple association lists or lookup tables.+ Asymptotics depend on the partial order used as keys, its /width/ \(w\) specifically (the size of the biggest anti-chain).+ .+ For partial orders with great width, this package won't provide any benefit over using association lists, so benchmark for your use-case!++source-repository head+ type: git+ location: https://github.com/sgraf812/pomaps++flag use-lattices+ description: Depend on the lattices package for the PartialOrd class.+ default: True++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >= 4.6.0.0 && < 4.11+ -- oneShot+ , ghc-prim >= 0.4 && < 0.6+ , deepseq >= 1.1 && < 1.5+ -- We depend on the internal modules of containers, + -- so we have to track development real close.+ -- Data.Map.Internal is only available since 0.5.9,+ -- of which 0.5.9.2 is the first safe version+ , containers >= 0.5.9.2 && <= 0.5.10.2+ if flag(use-lattices)+ build-depends: + -- We need PartialOrd instances for ()+ lattices >= 1.7 && < 2+ exposed-modules:+ Data.POMap.Internal+ Data.POMap.Lazy+ Data.POMap.Strict+ Data.POSet+ Data.POSet.Internal+ if !flag(use-lattices)+ hs-source-dirs:+ lattices+ exposed-modules:+ Algebra.PartialOrd+ default-language: Haskell2010++test-suite unittests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ tests+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+ build-depends:+ base+ , containers >= 0.5.9.2+ , pomaps+ , tasty+ , tasty-hspec+ , tasty-quickcheck+ , ChasingBottoms+ if flag(use-lattices)+ build-depends: + lattices < 2+ other-modules:+ Data.POMap.Arbitrary+ Data.POMap.Divisibility+ Data.POMap.Properties+ Data.POMap.Strictness+ default-language: Haskell2010++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctest-driver.hs+ hs-source-dirs: + tests+ ghc-options: -threaded+ build-depends: + base >4 && <5+ , doctest+ , Glob+ default-language: Haskell2010++benchmark pomaps-benchmarks+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ bench+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+ build-depends:+ base+ , pomaps+ , criterion+ , deepseq+ , random+ , vector+ default-language: Haskell2010++
+ src/Data/POMap/Internal.hs view
@@ -0,0 +1,1264 @@+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module doesn't respect the PVP! +-- Breaking changes may happen at any minor version (>= *.*.m.*) + +module Data.POMap.Internal where + +import Algebra.PartialOrd +import Control.Arrow (first, second, (***)) +import Control.DeepSeq (NFData (rnf)) +import qualified Data.List as List +import Data.Map.Internal (AreWeStrict (..), Map (..)) +import qualified Data.Map.Internal as Map +import qualified Data.Map.Lazy as Map.Lazy +import qualified Data.Map.Strict as Map.Strict +import Data.Maybe (fromMaybe) +import qualified Data.Maybe as Maybe +import Data.Monoid (Alt (..), Any (..)) +import GHC.Exts (Proxy#, inline, proxy#) +import qualified GHC.Exts +import GHC.Magic (oneShot) +import Prelude hiding (filter, lookup, map) +import Text.Read (Lexeme (Ident), Read (..), lexP, parens, + prec, readListPrecDefault) + +-- $setup +-- This is some setup code for @doctest@. +-- >>> :set -XGeneralizedNewtypeDeriving +-- >>> import Algebra.PartialOrd +-- >>> import Data.POMap.Lazy +-- >>> import Data.POMap.Internal +-- >>> :{ +-- newtype Divisibility +-- = Div Int +-- deriving (Eq, Num) +-- instance Show Divisibility where +-- show (Div a) = show a +-- instance PartialOrd Divisibility where +-- Div a `leq` Div b = b `mod` a == 0 +-- type DivMap a = POMap Divisibility a +-- default (Divisibility, DivMap String) +-- :} + +-- | Allows us to abstract over value-strictness in a zero-cost manner. +-- GHC should always be able to specialise the two instances of this and +-- consequently inline 'areWeStrict'. +-- +-- It's a little sad we can't just use regular singletons, for reasons +-- outlined [here](https://stackoverflow.com/questions/45734362/specialization-of-singleton-parameters). +class SingIAreWeStrict (s :: AreWeStrict) where + areWeStrict :: Proxy# s -> AreWeStrict + +instance SingIAreWeStrict 'Strict where + areWeStrict _ = Strict + +instance SingIAreWeStrict 'Lazy where + areWeStrict _ = Lazy + +-- | Should be inlined and specialised at all call sites. +seq' :: SingIAreWeStrict s => Proxy# s -> a -> b -> b +seq' p a b + | Lazy <- areWeStrict p = b + | otherwise = seq a b +{-# INLINE seq' #-} + +seqList :: [a] -> [a] +seqList xs = foldr seq xs xs + +-- | A map from partially-ordered keys @k@ to values @v@. +data POMap k v = POMap !Int ![Map k v] + +type role POMap nominal representational + +-- | Internal smart constructor so that we can be sure that we are always +-- spine-strict, discard empty maps and have appropriate size information. +mkPOMap :: [Map k v] -> POMap k v +mkPOMap decomp = POMap (foldr ((+) . Map.size) 0 decomp') decomp' + where + decomp' = seqList (List.filter (not . Map.null) decomp) +{-# INLINE mkPOMap #-} + +chainDecomposition :: POMap k v -> [Map k v] +chainDecomposition (POMap _ cd) = cd +{-# INLINE chainDecomposition #-} + +-- +-- * Instances +-- + +instance (Show k, Show v) => Show (POMap k v) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + +instance (PartialOrd k, Read k, Read e) => Read (POMap k e) where + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromListImpl (proxy# :: Proxy# 'Lazy) xs) + + readListPrec = readListPrecDefault + +-- | \(\mathcal{O}(wn\log n)\), where \(w=\max(w_1,w_2)), n=\max(n_1,n_2)\). +instance (PartialOrd k, Eq v) => Eq (POMap k v) where + a == b + | size a /= size b = False + | otherwise = isSubmapOf a b && isSubmapOf b a + +-- | \(\mathcal{O}(wn\log n)\), where \(w=\max(w_1,w_2)), n=\max(n_1,n_2)\). +instance (PartialOrd k, PartialOrd v) => PartialOrd (POMap k v) where + a `leq` b = isSubmapOfBy leq a b + +instance (NFData k, NFData v) => NFData (POMap k v) where + rnf (POMap _ d) = rnf d + +instance PartialOrd k => GHC.Exts.IsList (POMap k v) where + type Item (POMap k v) = (k, v) + fromList = fromListImpl (proxy# :: Proxy# 'Lazy) + toList = toList + +instance Functor (POMap k) where + fmap = map (proxy# :: Proxy# 'Lazy) + a <$ (POMap _ d) = mkPOMap (fmap (a <$) d) + +instance Foldable (POMap k) where + foldr f acc = List.foldr (flip (Map.foldr f)) acc . chainDecomposition + {-# INLINE foldr #-} + foldl f acc = List.foldl (Map.foldl f) acc . chainDecomposition + {-# INLINE foldl #-} + foldMap f (POMap _ d) = foldMap (foldMap f) d + {-# INLINE foldMap #-} + null m = size m == 0 + {-# INLINE null #-} + length = size + {-# INLINE length #-} + +instance Traversable (POMap k) where + traverse f = traverseWithKey (proxy# :: Proxy# 'Lazy) (const f) + {-# INLINE traverse #-} + +-- +-- * Query +-- + +-- | \(\mathcal{O}(1)\). The number of elements in this map. +size :: POMap k v -> Int +size (POMap s _) = s +{-# INLINE size #-} + +-- | \(\mathcal{O}(w)\). +-- The width \(w\) of the chain decomposition in the internal +-- data structure. +-- This is always at least as big as the size of the biggest possible +-- anti-chain. +width :: POMap k v -> Int +width = length . chainDecomposition +{-# INLINE width #-} + +foldEntry :: (Monoid m, PartialOrd k) => k -> (v -> m) -> POMap k v -> m +foldEntry !k !f = foldMap find . chainDecomposition + where + find Tip = mempty + find (Bin _ k' v l r) = + case (k `leq` k', k' `leq` k) of + (True, True) -> f v + (True, False) -> find l + (False, True) -> find r + (False, False) -> mempty +{-# INLINE foldEntry #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Is the key a member of the map? +lookup :: PartialOrd k => k -> POMap k v -> Maybe v +lookup !k = getAlt . foldEntry k pure +{-# INLINABLE lookup #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Is the key a member of the map? See also 'notMember'. +-- +-- >>> member 5 (fromList [(5,'a'), (3,'b')]) == True +-- True +-- >>> member 1 (fromList [(5,'a'), (3,'b')]) == False +-- True +member :: PartialOrd k => k -> POMap k v -> Bool +member !k = getAny . foldEntry k (const (Any True)) +{-# INLINABLE member #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Is the key not a member of the map? See also 'member'. +-- +-- >>> notMember 5 (fromList [(5,'a'), (3,'b')]) == False +-- True +-- >>> notMember 1 (fromList [(5,'a'), (3,'b')]) == True +-- True +notMember :: PartialOrd k => k -> POMap k v -> Bool +notMember k = not . member k +{-# INLINABLE notMember #-} + +-- | \(\mathcal{O}(w\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' +-- True +-- >>> findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' +-- True +findWithDefault :: PartialOrd k => v -> k -> POMap k v -> v +findWithDefault def k = fromMaybe def . lookup k +{-# INLINABLE findWithDefault #-} + +data RelationalOperator + = LessThan + | LessEqual + | Equal + | GreaterEqual + | GreaterThan + deriving (Eq, Ord, Show) + +flipRelationalOperator :: RelationalOperator -> RelationalOperator +flipRelationalOperator op = + case op of + LessThan -> GreaterThan + GreaterThan -> LessThan + LessEqual -> GreaterEqual + GreaterEqual -> LessEqual + _ -> op + +containsOrdering :: Ordering -> RelationalOperator -> Bool +containsOrdering LT LessThan = True +containsOrdering LT LessEqual = True +containsOrdering LT _ = False +containsOrdering GT GreaterThan = True +containsOrdering GT GreaterEqual = True +containsOrdering GT _ = False +containsOrdering EQ LessThan = False +containsOrdering EQ GreaterThan = False +containsOrdering EQ _ = True + +comparePartial :: PartialOrd k => k -> k -> Maybe Ordering +comparePartial a b = + case (a `leq` b, b `leq` a) of + (True, True) -> Just EQ + (True, False) -> Just LT + (False, True) -> Just GT + (False, False) -> Nothing +{-# INLINE comparePartial #-} + +addToAntichain :: PartialOrd k => RelationalOperator -> (k, v) -> [(k, v)] -> [(k, v)] +addToAntichain !op entry@(k, _) chain = maybe chain (entry:) (foldr weedOut (Just []) chain) + where + weedOut e'@(k', _) mayChain' = + case comparePartial k k' of + Just LT + | containsOrdering LT op -> mayChain' -- don't need e' + | containsOrdering GT op -> Nothing + Just GT + | containsOrdering LT op -> Nothing + | containsOrdering GT op -> mayChain' -- don't need e' + Just EQ -> Nothing -- should never happen + _ -> (e' :) <$> mayChain' -- still need e' +{-# INLINE addToAntichain #-} + +dedupAntichain :: PartialOrd k => RelationalOperator -> [(k, v)] -> [(k, v)] +dedupAntichain !op = foldr (addToAntichain op) [] + +-- If inlined, this optimizes to the equivalent hand-written variants. +lookupX :: PartialOrd k => RelationalOperator -> k -> POMap k v -> [(k, v)] +lookupX !op !k + -- we bias comparable elements in the opposite direction + = dedupAntichain (flipRelationalOperator op) + . Maybe.mapMaybe findNothing + . chainDecomposition + where + findNothing Tip = Nothing + findNothing (Bin _ k' v' l r) = + case comparePartial k k' of + Just EQ + | containsOrdering EQ op -> Just (k', v') + | containsOrdering GT op -> findNothing r + | containsOrdering LT op -> findNothing l + | otherwise -> error "lookupX.findNothing: inexhaustive match" + Just LT + | containsOrdering GT op -> findJust l k' v' + | otherwise -> findNothing l + Just GT + | containsOrdering LT op -> findJust r k' v' + | otherwise -> findNothing r + Nothing -- Incomparable, only the min or max element might not be + | containsOrdering LT op -> findNothing l + | containsOrdering GT op -> findNothing r + | otherwise -> Nothing + findJust Tip k'' v'' = Just (k'', v'') + findJust (Bin _ k' v' l r) k'' v'' = + case comparePartial k k' of + Just EQ + | containsOrdering EQ op -> Just (k', v') + | containsOrdering GT op -> findJust r k'' v'' + | containsOrdering LT op -> findJust l k'' v'' + | otherwise -> error "lookupX.findJust: inexhaustive match" + Just LT + | containsOrdering GT op -> findJust l k' v' + | containsOrdering GT op -> findJust l k' v' + | otherwise -> findJust l k'' v'' + Just GT + | containsOrdering LT op -> findJust r k' v' + | otherwise -> findJust r k'' v'' + Nothing -> Just (k'', v'') +{-# INLINE lookupX #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Find the largest set of keys smaller than the given one and +-- return the corresponding list of (key, value) pairs. +-- +-- Note that the following examples assume the @Divisibility@ +-- partial order defined at the top. +-- +-- >>> lookupLT 3 (fromList [(3,'a'), (5,'b')]) +-- [] +-- >>> lookupLT 9 (fromList [(3,'a'), (5,'b')]) +-- [(3,'a')] +lookupLT :: PartialOrd k => k -> POMap k v -> [(k, v)] +lookupLT = inline lookupX LessThan +{-# INLINABLE lookupLT #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Find the largest key smaller or equal to the given one and return +-- the corresponding list of (key, value) pairs. +-- +-- Note that the following examples assume the @Divisibility@ +-- partial order defined at the top. +-- +-- >>> lookupLE 2 (fromList [(3,'a'), (5,'b')]) +-- [] +-- >>> lookupLE 3 (fromList [(3,'a'), (5,'b')]) +-- [(3,'a')] +-- >>> lookupLE 10 (fromList [(3,'a'), (5,'b')]) +-- [(5,'b')] +lookupLE :: PartialOrd k => k -> POMap k v -> [(k, v)] +lookupLE = inline lookupX LessEqual +{-# INLINABLE lookupLE #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Find the smallest key greater or equal to the given one and return +-- the corresponding list of (key, value) pairs. +-- +-- Note that the following examples assume the @Divisibility@ +-- partial order defined at the top. +-- +-- >>> lookupGE 3 (fromList [(3,'a'), (5,'b')]) +-- [(3,'a')] +-- >>> lookupGE 5 (fromList [(3,'a'), (10,'b')]) +-- [(10,'b')] +-- >>> lookupGE 6 (fromList [(3,'a'), (5,'b')]) +-- [] +lookupGE :: PartialOrd k => k -> POMap k v -> [(k, v)] +lookupGE = inline lookupX GreaterEqual +{-# INLINABLE lookupGE #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Find the smallest key greater than the given one and return the +-- corresponding list of (key, value) pairs. +-- +-- Note that the following examples assume the @Divisibility@ +-- partial order defined at the top. +-- +-- >>> lookupGT 5 (fromList [(3,'a'), (10,'b')]) +-- [(10,'b')] +-- >>> lookupGT 5 (fromList [(3,'a'), (5,'b')]) +-- [] +lookupGT :: PartialOrd k => k -> POMap k v -> [(k, v)] +lookupGT = inline lookupX GreaterThan +{-# INLINABLE lookupGT #-} + + +-- +-- * Construction +-- + +-- | \(\mathcal{O}(1)\). The empty map. +-- +-- >>> empty +-- fromList [] +-- >>> size empty +-- 0 +empty :: POMap k v +empty = POMap 0 [] +{-# INLINE empty #-} + +singleton :: SingIAreWeStrict s => Proxy# s -> k -> v -> POMap k v +singleton s k v = seq' s v $ POMap 1 [Map.singleton k v] +{-# INLINE singleton #-} +-- INLINE means we don't need to SPECIALIZE + +-- +-- * Insertion +-- + +insert :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> k -> v -> POMap k v -> POMap k v +insert s = inline insertWith s const +{-# INLINABLE insert #-} +{-# SPECIALIZE insert :: PartialOrd k => Proxy# 'Strict -> k -> v -> POMap k v -> POMap k v #-} +{-# SPECIALIZE insert :: PartialOrd k => Proxy# 'Lazy -> k -> v -> POMap k v -> POMap k v #-} + +insertWith + :: (PartialOrd k, SingIAreWeStrict s) + => Proxy# s + -> (v -> v -> v) + -> k + -> v + -> POMap k v + -> POMap k v +insertWith s f = inline insertWithKey s (const f) +{-# INLINABLE insertWith #-} +{-# SPECIALIZE insertWith :: PartialOrd k => Proxy# 'Strict -> (v -> v -> v) -> k -> v -> POMap k v -> POMap k v #-} +{-# SPECIALIZE insertWith :: PartialOrd k => Proxy# 'Lazy -> (v -> v -> v) -> k -> v -> POMap k v -> POMap k v #-} + +insertWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> v -> v -> v) -> k -> v -> POMap k v -> POMap k v +insertWithKey s f k v = inline alterWithKey s (keyedInsertAsAlter f v) k +{-# INLINABLE insertWithKey #-} +{-# SPECIALIZE insertWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> v -> v -> v) -> k -> v -> POMap k v -> POMap k v #-} +{-# SPECIALIZE insertWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> v -> v -> v) -> k -> v -> POMap k v -> POMap k v #-} + +insertLookupWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> v -> v -> v) -> k -> v -> POMap k v -> (Maybe v, POMap k v) +insertLookupWithKey s f k v = inline alterLookupWithKey s (keyedInsertAsAlter f v) k +{-# INLINABLE insertLookupWithKey #-} +{-# SPECIALIZE insertLookupWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> v -> v -> v) -> k -> v -> POMap k v -> (Maybe v, POMap k v) #-} +{-# SPECIALIZE insertLookupWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> v -> v -> v) -> k -> v -> POMap k v -> (Maybe v, POMap k v) #-} + +keyedInsertAsAlter :: (k -> v -> v -> v) -> v -> k -> Maybe v -> Maybe v +keyedInsertAsAlter _ v _ Nothing = Just v +keyedInsertAsAlter f v k (Just v') = Just (f k v v') +{-# INLINE keyedInsertAsAlter #-} + +-- +-- * Deletion +-- + +data LookupResult a + = Incomparable + | NotFound a + | Found a + deriving (Eq, Show, Functor) + +instance Ord a => Ord (LookupResult a) where + compare a b = + case (a, b) of + (Incomparable, Incomparable) -> EQ + (Incomparable, _) -> GT + (NotFound n, NotFound m) -> compare n m + (NotFound{}, Found{}) -> GT + (Found n, Found m) -> compare n m + _ -> LT + +overChains + :: (Map k v -> LookupResult a) + -> (Map k v -> b -> b) + -> (a -> [Map k v] -> b) + -> ([Map k v] -> b) + -> POMap k v + -> b +overChains handleChain oldWon newWon incomparable pomap + = unwrapResult + . fmap snd + . foldr improve Incomparable + . zip (List.tails decomp) + . fmap handleChain + $ decomp + where + decomp = chainDecomposition pomap + improve ([], _) _ = error "List.tails was empty" + improve (chain:chains, candidate) winner = + -- We want to minimize the score: Prefer Found over NotFound and + -- Incomparability (which means we have to add a new chain to the + -- composition) + case compare (Map.size chain <$ candidate) (fst <$> winner) of + GT -> second (oldWon chain) <$> winner + _ -> (\chain' -> (Map.size chain, newWon chain' chains)) <$> candidate + unwrapResult res = + case res of + Incomparable -> incomparable decomp + NotFound chains -> chains + Found chains -> chains +{-# INLINE overChains #-} + +-- | \(\mathcal{O}(w\log n)\). +-- Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +-- +-- >>> delete 5 (fromList [(5,"a"), (3,"b")]) +-- fromList [(3,"b")] +-- >>> delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> delete 5 empty +-- fromList [] +delete :: PartialOrd k => k -> POMap k v -> POMap k v +delete = inline update (proxy# :: Proxy# 'Lazy) (const Nothing) +{-# INLINABLE delete #-} + +-- | \(\mathcal{O}(w\log n)\). Simultaneous 'delete' and 'lookup'. +deleteLookup :: PartialOrd k => k -> POMap k v -> (Maybe v, POMap k v) +deleteLookup = inline updateLookupWithKey (proxy# :: Proxy# 'Lazy) (\_ _ -> Nothing) +{-# INLINABLE deleteLookup #-} + +adjust :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (v -> v) -> k -> POMap k v -> POMap k v +adjust s f = inline update s (Just . f) +{-# INLINABLE adjust #-} +{-# SPECIALIZE adjust :: PartialOrd k => Proxy# 'Strict -> (v -> v) -> k -> POMap k v -> POMap k v #-} +{-# SPECIALIZE adjust :: PartialOrd k => Proxy# 'Lazy -> (v -> v) -> k -> POMap k v -> POMap k v #-} + + +adjustWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> v -> v) -> k -> POMap k v -> POMap k v +adjustWithKey s f = inline updateWithKey s (\k v -> Just (f k v)) +{-# INLINABLE adjustWithKey #-} +{-# SPECIALIZE adjustWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> v -> v) -> k -> POMap k v -> POMap k v #-} +{-# SPECIALIZE adjustWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> v -> v) -> k -> POMap k v -> POMap k v #-} + +adjustLookupWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> v -> v) -> k -> POMap k v -> (Maybe v, POMap k v) +adjustLookupWithKey s f = inline updateLookupWithKey s (\k v -> Just (f k v)) +{-# INLINABLE adjustLookupWithKey #-} +{-# SPECIALIZE adjustLookupWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> v -> v) -> k -> POMap k v -> (Maybe v, POMap k v) #-} +{-# SPECIALIZE adjustLookupWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> v -> v) -> k -> POMap k v -> (Maybe v, POMap k v) #-} + +update :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (v -> Maybe v) -> k -> POMap k v -> POMap k v +update s f = inline alter s (>>= f) +{-# INLINABLE update #-} +{-# SPECIALIZE update :: PartialOrd k => Proxy# 'Strict -> (v -> Maybe v) -> k -> POMap k v -> POMap k v #-} +{-# SPECIALIZE update :: PartialOrd k => Proxy# 'Lazy -> (v -> Maybe v) -> k -> POMap k v -> POMap k v #-} + +updateWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> v -> Maybe v) -> k -> POMap k v -> POMap k v +updateWithKey s f = inline alterWithKey s (\k mv -> mv >>= f k) +{-# INLINABLE updateWithKey #-} +{-# SPECIALIZE updateWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> v -> Maybe v) -> k -> POMap k v -> POMap k v #-} +{-# SPECIALIZE updateWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> v -> Maybe v) -> k -> POMap k v -> POMap k v #-} + +updateLookupWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) +updateLookupWithKey s f = inline alterLookupWithKey s (\k mv -> mv >>= f k) +{-# INLINABLE updateLookupWithKey #-} +{-# SPECIALIZE updateLookupWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) #-} +{-# SPECIALIZE updateLookupWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) #-} + +alter :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v +alter s f = inline alterWithKey s (const f) +{-# INLINABLE alter #-} +{-# SPECIALIZE alter :: PartialOrd k => Proxy# 'Strict -> (Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v #-} +{-# SPECIALIZE alter :: PartialOrd k => Proxy# 'Lazy -> (Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v #-} + +alterWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v +alterWithKey s f !k = mkPOMap . overChains handleChain oldWon newWon incomparable + where + handleChain = alterChain s f k + oldWon chain chains' = chain : chains' + newWon chain' chains = chain' : chains + incomparable decomp = + case f k Nothing of + Nothing -> decomp + Just v -> seq' s v (Map.singleton k v : decomp) +{-# INLINABLE alterWithKey #-} +{-# SPECIALIZE alterWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v #-} +{-# SPECIALIZE alterWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v #-} + +alterChain :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> Maybe v -> Maybe v) -> k -> Map k v -> LookupResult (Map k v) +alterChain s f k = go + where + go Tip = NotFound $ case f k Nothing of + Just v -> seq' s v (Map.singleton k v) + Nothing -> Tip + go (Bin n k' v' l r) = + case (k `leq` k', k' `leq` k) of + (True, True) -> Found $ case f k (Just v') of + Just v -> seq' s v (Bin n k' v l r) + Nothing -> Tip + (True, False) -> oneShot (\l' -> Map.balanceL k' v' l' r) <$> go l + (False, True) -> oneShot (\r' -> Map.balanceR k' v' l r') <$> go r + (False, False) -> Incomparable +{-# INLINE alterChain #-} + +alterLookupWithKey + :: (PartialOrd k, SingIAreWeStrict s) + => Proxy# s + -> (k -> Maybe v -> Maybe v) + -> k + -> POMap k v + -> (Maybe v, POMap k v) +alterLookupWithKey s f !k + = second mkPOMap + . overChains handleChain oldWon newWon incomparable + where + handleChain = alterLookupChain s f k + oldWon chain (v, chains') = (v, chain : chains') + newWon (v', chain') chains = (v', chain' : chains) + incomparable decomp = + (Nothing, case f k Nothing of + Nothing -> decomp + Just v -> seq' s v (Map.singleton k v : decomp)) +{-# INLINABLE alterLookupWithKey #-} +{-# SPECIALIZE alterLookupWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> Maybe v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) #-} +{-# SPECIALIZE alterLookupWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> Maybe v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) #-} + +alterLookupChain :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> Maybe v -> Maybe v) -> k -> Map k v -> LookupResult (Maybe v, Map k v) +alterLookupChain s f k = go + where + go Tip = NotFound (Nothing, case f k Nothing of + Just v -> seq' s v (Map.singleton k v) + Nothing -> Tip) + go (Bin n k' v' l r) = + case (k `leq` k', k' `leq` k) of + (True, True) -> Found (Just v', case f k (Just v') of + Just v -> seq' s v (Bin n k' v l r) + Nothing -> Tip) + (True, False) -> second (oneShot (\l' -> Map.balanceL k' v' l' r)) <$> go l + (False, True) -> second (oneShot (\r' -> Map.balanceR k' v' l r')) <$> go r + (False, False) -> Incomparable +{-# INLINE alterLookupChain #-} + +alterF + :: (Functor f, PartialOrd k, SingIAreWeStrict s) + => Proxy# s + -> (Maybe v -> f (Maybe v)) + -> k + -> POMap k v + -> f (POMap k v) +alterF s f !k = fmap mkPOMap . overChains handleChain oldWon newWon incomparable + where + handleChain = alterFChain s k + -- prepends the unaltered chain to the altered tail + oldWon chain altered = fmap (chain:) altered + -- prepends the altered chain to the unaltered tail + newWon alt chains = fmap (:chains) (alt f) + (<#>) = flip (<$>) + -- prepends a new chain in the incomparable case if + -- the alteration function produces a value + incomparable decomp = f Nothing <#> \case + Nothing -> decomp + Just v -> seq' s v (Map.singleton k v : decomp) +{-# INLINABLE alterF #-} +{-# SPECIALIZE alterF :: (Functor f, PartialOrd k) => Proxy# 'Strict -> (Maybe v -> f (Maybe v)) -> k -> POMap k v -> f (POMap k v) #-} +{-# SPECIALIZE alterF :: (Functor f, PartialOrd k) => Proxy# 'Lazy -> (Maybe v -> f (Maybe v)) -> k -> POMap k v -> f (POMap k v) #-} + +alterFChain + -- `f` should potentially be pulled into the result type, but not willing + -- to complicate this right now + :: (Functor f, PartialOrd k, SingIAreWeStrict s) + => Proxy# s + -> k + -> Map k v + -> LookupResult ((Maybe v -> f (Maybe v)) -> f (Map k v)) +alterFChain s k = go + where + -- This is going to be reaaally crazy. Maybe we could use some ContT for + -- this, I don't know... + -- So, we always lift the outer functor LookupResult. + -- That functor contains the logic for actually doing the adjustment, + -- which takes the function that does the actual adjustment as an argument + -- and maps into an arbitrary functor `f` which we have to map through. + ret res val cont = res (oneShot (\f -> cont <$> f val)) + lift sub cont = oneShot (\a f -> cont <$> a f) <$> sub + go Tip = + ret NotFound Nothing . oneShot $ \case + Just v -> seq' s v (Map.singleton k v) + Nothing -> Tip + go (Bin n k' v l r) = + case (k `leq` k', k' `leq` k) of + (True, True) -> + ret Found (Just v) . oneShot $ \case + Just v' -> seq' s v' (Bin n k v' l r) + Nothing -> Tip + (True, False) -> lift (go l) . oneShot $ \l' -> Map.balanceL k' v l' r + (False, True) -> lift (go r) . oneShot $ \r' -> Map.balanceL k' v l r' + (False, False) -> Incomparable + +-- +-- * Combine +-- + +-- ** Union + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered, +-- i.e. (@'union' == 'unionWith' 'const'@). +-- +-- >>> union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")] +-- True +union :: PartialOrd k => POMap k v -> POMap k v -> POMap k v +union = inline unionWith const +{-# INLINABLE union #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- Union with a combining function. +-- +-- >>> unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] +-- True +unionWith :: PartialOrd k => (v -> v -> v) -> POMap k v -> POMap k v -> POMap k v +unionWith f = inline unionWithKey (const f) +{-# INLINABLE unionWith #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- Union with a combining function. +-- +-- >>> 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")] +-- True +unionWithKey :: PartialOrd k => (k -> v -> v -> v) -> POMap k v -> POMap k v -> POMap k v +unionWithKey f l r = List.foldl' (\m (k, v) -> inline insertWithKey (proxy# :: Proxy# 'Lazy) f k v m) r (toList l) +{-# INLINABLE unionWithKey #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max_i n_i\) and \(w=\max_i w_i\). +-- The union of a list of maps: +-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). +-- +-- >>> :{ +-- unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- == fromList [(3, "b"), (5, "a"), (7, "C")] +-- :} +-- True +-- +-- >>> :{ +-- unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] +-- == fromList [(3, "B3"), (5, "A3"), (7, "C")] +-- :} +-- True +unions :: PartialOrd k => [POMap k v] -> POMap k v +unions = inline unionsWith const +{-# INLINABLE unions #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max_i n_i\) and \(w=\max_i w_i\). +-- The union of a list of maps, with a combining operation: +-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). +-- +-- >>> :{ +-- unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] +-- :} +-- True +unionsWith :: PartialOrd k => (v -> v -> v) -> [POMap k v] -> POMap k v +unionsWith f = List.foldl' (unionWith f) empty +{-# INLINABLE unionsWith #-} + +-- * Difference + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- Difference of two maps. +-- Return elements of the first map not existing in the second map. +-- +-- >>> difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) +-- fromList [(3,"b")] +difference :: PartialOrd k => POMap k a -> POMap k b -> POMap k a +difference = inline differenceWith (\_ _ -> Nothing) +{-# INLINABLE difference #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- 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@. +-- +-- >>> 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")]) +-- fromList [(3,"b:B")] +differenceWith :: PartialOrd k => (a -> b -> Maybe a) -> POMap k a -> POMap k b -> POMap k a +differenceWith f = inline differenceWithKey (const f) +{-# INLINABLE differenceWith #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- 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@. +-- +-- >>> 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")]) +-- fromList [(3,"3:b|B")] +differenceWithKey :: PartialOrd k => (k -> a -> b -> Maybe a) -> POMap k a -> POMap k b -> POMap k a +differenceWithKey f l + = List.foldl' (\m (k, v) -> inline alterWithKey (proxy# :: Proxy# 'Lazy) (f' v) k m) l + . toList + where + f' _ _ Nothing = Nothing + f' v k (Just v') = f k v' v +{-# INLINABLE differenceWithKey #-} + +-- ** Intersection + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- Intersection of two maps. +-- Return data in the first map for the keys existing in both maps. +-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). +-- +-- >>> intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) +-- fromList [(5,"a")] +intersection :: PartialOrd k => POMap k a -> POMap k b -> POMap k a +intersection = inline intersectionWith const +{-# INLINABLE intersection #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- Intersection with a combining function. +-- +-- >>> intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) +-- fromList [(5,"aA")] +intersectionWith :: PartialOrd k => (a -> b -> c) -> POMap k a -> POMap k b -> POMap k c +intersectionWith f = inline intersectionWithKey (const f) +{-# INLINABLE intersectionWith #-} + +-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\). +-- Intersection with a combining function. +-- +-- >>> let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar +-- >>> intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) +-- fromList [(5,"5:a|A")] +intersectionWithKey :: PartialOrd k => (k -> a -> b -> c) -> POMap k a -> POMap k b -> POMap k c +intersectionWithKey f l r + = fromListImpl (proxy# :: Proxy# 'Lazy) + . Maybe.mapMaybe (\(k,a) -> [(k, f k a b) | b <- lookup k r]) + . toList + $ l +{-# INLINABLE intersectionWithKey #-} + + +-- * Traversals + +map :: SingIAreWeStrict s => Proxy# s -> (a -> b) -> POMap k a -> POMap k b +map s f (POMap _ chains) + | Strict <- areWeStrict s = mkPOMap (fmap (Map.Strict.map f) chains) + | otherwise = mkPOMap (fmap (Map.Lazy.map f) chains) +{-# NOINLINE [1] map #-} +{-# RULES +"map/map" forall s f g xs . map s f (map s g xs) = map s (f . g) xs + #-} +{-# SPECIALIZE map :: Proxy# 'Strict -> (a -> b) -> POMap k a -> POMap k b #-} +{-# SPECIALIZE map :: Proxy# 'Lazy -> (a -> b) -> POMap k a -> POMap k b #-} + +mapWithKey :: SingIAreWeStrict s => Proxy# s -> (k -> a -> b) -> POMap k a -> POMap k b +mapWithKey s f (POMap _ d) + | Strict <- areWeStrict s = mkPOMap (fmap (Map.Strict.mapWithKey f) d) + | otherwise = mkPOMap (fmap (Map.Lazy.mapWithKey f) d) +{-# NOINLINE [1] mapWithKey #-} +{-# RULES +"mapWithKey/mapWithKey" forall s f g xs . mapWithKey s f (mapWithKey s g xs) = + mapWithKey s (\k a -> f k (g k a)) xs +"mapWithKey/map" forall s f g xs . mapWithKey s f (map s g xs) = + mapWithKey s (\k a -> f k (g a)) xs +"map/mapWithKey" forall s f g xs . map s f (mapWithKey s g xs) = + mapWithKey s (\k a -> f (g k a)) xs + #-} +{-# SPECIALIZE mapWithKey :: Proxy# 'Strict -> (k -> a -> b) -> POMap k a -> POMap k b #-} +{-# SPECIALIZE mapWithKey :: Proxy# 'Lazy -> (k -> a -> b) -> POMap k a -> POMap k b #-} + +traverseWithKey :: (Applicative t, SingIAreWeStrict s) => Proxy# s -> (k -> a -> t b) -> POMap k a -> t (POMap k b) +traverseWithKey s f (POMap _ d) + | Strict <- areWeStrict s = mkPOMap <$> traverse (Map.Strict.traverseWithKey f) d + | otherwise = mkPOMap <$> traverse (Map.Lazy.traverseWithKey f) d +{-# INLINABLE traverseWithKey #-} +{-# SPECIALIZE traverseWithKey :: Applicative t => Proxy# 'Strict -> (k -> a -> t b) -> POMap k a -> t (POMap k b) #-} +{-# SPECIALIZE traverseWithKey :: Applicative t => Proxy# 'Lazy -> (k -> a -> t b) -> POMap k a -> t (POMap k b) #-} + +mapAccum :: SingIAreWeStrict s => Proxy# s -> (a -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) +mapAccum s f = inline mapAccumWithKey s (\a _ b -> f a b) +{-# INLINABLE mapAccum #-} +{-# SPECIALIZE mapAccum :: Proxy# 'Strict -> (a -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) #-} +{-# SPECIALIZE mapAccum :: Proxy# 'Lazy -> (a -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) #-} + +mapAccumWithKey :: SingIAreWeStrict s => Proxy# s -> (a -> k -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) +mapAccumWithKey s f acc (POMap _ chains) = (acc', mkPOMap chains') + where + (acc', chains') + | Strict <- areWeStrict s = List.mapAccumL (Map.Strict.mapAccumWithKey f) acc chains + | otherwise = List.mapAccumL (Map.Lazy.mapAccumWithKey f) acc chains +{-# INLINABLE mapAccumWithKey #-} +{-# SPECIALIZE mapAccumWithKey :: Proxy# 'Strict -> (a -> k -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) #-} +{-# SPECIALIZE mapAccumWithKey :: Proxy# 'Lazy -> (a -> k -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) #-} + +-- | \(\mathcal{O}(wn\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. +-- +-- >>> mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] +-- True +-- >>> mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) +-- fromList [(1,"c")] +-- >>> mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) +-- fromList [(3,"c")] +mapKeys :: PartialOrd k2 => (k1 -> k2) -> POMap k1 v -> POMap k2 v +mapKeys f = fromListImpl (proxy# :: Proxy# 'Lazy) . fmap (first f) . toList + +mapKeysWith :: (PartialOrd k2, SingIAreWeStrict s) => Proxy# s -> (v -> v -> v) -> (k1 -> k2) -> POMap k1 v -> POMap k2 v +mapKeysWith s c f = fromListWith s c . fmap (first f) . toList +{-# INLINABLE mapKeysWith #-} +{-# SPECIALIZE mapKeysWith :: PartialOrd k2 => Proxy# 'Strict -> (v -> v -> v) -> (k1 -> k2) -> POMap k1 v -> POMap k2 v #-} +{-# SPECIALIZE mapKeysWith :: PartialOrd k2 => Proxy# 'Lazy -> (v -> v -> v) -> (k1 -> k2) -> POMap k1 v -> POMap k2 v #-} + +-- | \(\mathcal{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, for every chain @ls@ in @s@ we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s +-- +-- This means that @f@ maps distinct original keys to distinct resulting keys. +-- This function has better performance than 'mapKeys'. +-- +-- >>> mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] +-- True +mapKeysMonotonic :: (k1 -> k2) -> POMap k1 v -> POMap k2 v +mapKeysMonotonic f (POMap _ d) = mkPOMap (fmap (Map.mapKeysMonotonic f) d) + +-- +-- * Folds +-- + +-- | \(\mathcal{O}(n)\). +-- A strict version of 'foldr'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr' :: (a -> b -> b) -> b -> POMap k a -> b +foldr' f acc = List.foldr (flip (Map.foldr' f)) acc . chainDecomposition +{-# INLINE foldr' #-} + +-- | \(\mathcal{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, +-- +-- >>> keys map = foldrWithKey (\k x ks -> k:ks) [] map +-- +-- >>> let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- >>> foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" +-- True +foldrWithKey :: (k -> a -> b -> b) -> b -> POMap k a -> b +foldrWithKey f acc = List.foldr (flip (Map.foldrWithKey f)) acc . chainDecomposition +{-# INLINE foldrWithKey #-} + +-- | \(\mathcal{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 -> POMap k a -> b +foldrWithKey' f acc = List.foldr (flip (Map.foldrWithKey' f)) acc . chainDecomposition +{-# INLINE foldrWithKey' #-} + +-- | \(\mathcal{O}(n)\). +-- A strict version of 'foldl'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl' :: (b -> a -> b) -> b -> POMap k a -> b +foldl' f acc = List.foldl' (Map.foldl' f) acc . chainDecomposition +{-# INLINE foldl' #-} + +-- | \(\mathcal{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'@. +-- +-- >>> keys = reverse . foldlWithKey (\ks k x -> k:ks) [] +-- +-- >>> let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- >>> foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" +-- True +foldlWithKey :: (b -> k -> a -> b) -> b -> POMap k a -> b +foldlWithKey f acc = List.foldl (Map.foldlWithKey f) acc . chainDecomposition +{-# INLINE foldlWithKey #-} + +-- | \(\mathcal{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' :: (b -> k -> a -> b) -> b -> POMap k a -> b +foldlWithKey' f acc = List.foldl' (Map.foldlWithKey' f) acc . chainDecomposition +{-# INLINE foldlWithKey' #-} + +-- | \(\mathcal{O}(n)\). +-- Fold the keys and values in the map using the given monoid, such that +-- +-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@ +foldMapWithKey :: Monoid m => (k -> a -> m) -> POMap k a -> m +foldMapWithKey f = foldMap (Map.foldMapWithKey f ) . chainDecomposition +{-# INLINE foldMapWithKey #-} + +-- * Conversion + +-- | \(\mathcal{O}(n)\). +-- Return all elements of the map in unspecified order. +-- +-- >>> elems (fromList [(5,"a"), (3,"b")]) +-- ["b","a"] +-- >>> elems empty +-- [] +elems :: POMap k v -> [v] +elems = concatMap Map.elems . chainDecomposition + +-- | \(\mathcal{O}(n)\). +-- Return all keys of the map in unspecified order. +-- +-- >>> keys (fromList [(5,"a"), (3,"b")]) +-- [3,5] +-- >>> keys empty +-- [] +keys :: POMap k v -> [k] +keys = concatMap Map.keys . chainDecomposition + +-- | \(\mathcal{O}(n)\). +-- Return all key\/value pairs in the map +-- in unspecified order. +-- +-- >>> assocs (fromList [(5,"a"), (3,"b")]) +-- [(3,"b"),(5,"a")] +-- >>> assocs empty +-- [] +assocs :: POMap k v -> [(k, v)] +assocs = concatMap Map.toList . chainDecomposition + +-- | \(\mathcal{O}(n)\). +-- Return all key\/value pairs in the map +-- in unspecified order. +-- +-- Currently, @toList = 'assocs'@. +toList :: POMap k v -> [(k, v)] +toList = assocs + +-- TODO: keysSet, fromSet + +-- | Intentionally named this way, to disambiguate it from 'fromList'. +-- This is so that we can doctest this module. +fromListImpl :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> [(k, v)] -> POMap k v +fromListImpl s = List.foldl' (\m (k,v) -> insert s k v m) empty +{-# INLINABLE fromListImpl #-} +{-# SPECIALIZE fromListImpl :: PartialOrd k => Proxy# 'Strict -> [(k, v)] -> POMap k v #-} +{-# SPECIALIZE fromListImpl :: PartialOrd k => Proxy# 'Lazy -> [(k, v)] -> POMap k v #-} + +fromListWith :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (v -> v -> v) -> [(k, v)] -> POMap k v +fromListWith s f = List.foldl' (\m (k,v) -> insertWith s f k v m) empty +{-# INLINABLE fromListWith #-} +{-# SPECIALIZE fromListWith :: PartialOrd k => Proxy# 'Strict -> (v -> v -> v) -> [(k, v)] -> POMap k v #-} +{-# SPECIALIZE fromListWith :: PartialOrd k => Proxy# 'Lazy -> (v -> v -> v) -> [(k, v)] -> POMap k v #-} + +fromListWithKey :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> (k -> v -> v -> v) -> [(k, v)] -> POMap k v +fromListWithKey s f = List.foldl' (\m (k,v) -> insertWithKey s f k v m) empty +{-# INLINABLE fromListWithKey #-} +{-# SPECIALIZE fromListWithKey :: PartialOrd k => Proxy# 'Strict -> (k -> v -> v -> v) -> [(k, v)] -> POMap k v #-} +{-# SPECIALIZE fromListWithKey :: PartialOrd k => Proxy# 'Lazy -> (k -> v -> v -> v) -> [(k, v)] -> POMap k v #-} + +-- +-- * Filter +-- + +-- | \(\mathcal{O}(n)\). +-- Filter all values that satisfy the predicate. +-- +-- >>> filter (> "a") (fromList [(5,"a"), (3,"b")]) +-- fromList [(3,"b")] +-- >>> filter (> "x") (fromList [(5,"a"), (3,"b")]) +-- fromList [] +-- >>> filter (< "a") (fromList [(5,"a"), (3,"b")]) +-- fromList [] +filter :: (v -> Bool) -> POMap k v -> POMap k v +filter p = filterWithKey (const p) + +-- | \(\mathcal{O}(n)\). +-- Filter all keys\/values that satisfy the predicate. +-- +-- >>> filterWithKey (\(Div k) _ -> k > 4) (fromList [(5,"a"), (3,"b")]) +-- fromList [(5,"a")] +filterWithKey :: (k -> v -> Bool) -> POMap k v -> POMap k v +filterWithKey p (POMap _ d) = mkPOMap (Map.filterWithKey p <$> d) + +-- TODO: restrictKeys, withoutKeys + +-- | \(\mathcal{O}(n)\). +-- Partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +-- +-- >>> partition (> "a") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b")], fromList [(5, "a")]) +-- True +-- >>> partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) +-- True +-- >>> partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) +-- True +partition :: (v -> Bool) -> POMap k v -> (POMap k v, POMap k v) +partition p = partitionWithKey (const p) + +-- | \(\mathcal{O}(n)\). +-- Partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +-- +-- >>> partitionWithKey (\ (Div k) _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (fromList [(5, "a")], fromList [(3, "b")]) +-- True +-- >>> partitionWithKey (\ (Div k) _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) +-- True +-- >>> partitionWithKey (\ (Div k) _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) +-- True +partitionWithKey :: (k -> v -> Bool) -> POMap k v -> (POMap k v, POMap k v) +partitionWithKey p (POMap _ d) + = (mkPOMap *** mkPOMap) + . unzip + . fmap (Map.partitionWithKey p) + $ d + +mapMaybe :: SingIAreWeStrict s => Proxy# s -> (a -> Maybe b) -> POMap k a -> POMap k b +mapMaybe s f = mapMaybeWithKey s (const f) +{-# INLINABLE mapMaybe #-} +{-# SPECIALIZE mapMaybe :: Proxy# 'Strict -> (a -> Maybe b) -> POMap k a -> POMap k b #-} +{-# SPECIALIZE mapMaybe :: Proxy# 'Lazy -> (a -> Maybe b) -> POMap k a -> POMap k b #-} + +mapMaybeWithKey :: SingIAreWeStrict s => Proxy# s -> (k -> a -> Maybe b) -> POMap k a -> POMap k b +mapMaybeWithKey s f (POMap _ d) + | Strict <- areWeStrict s = mkPOMap (Map.Strict.mapMaybeWithKey f <$> d) + | otherwise = mkPOMap (Map.Lazy.mapMaybeWithKey f <$> d) +{-# INLINABLE mapMaybeWithKey #-} +{-# SPECIALIZE mapMaybeWithKey :: Proxy# 'Strict -> (k -> a -> Maybe b) -> POMap k a -> POMap k b #-} +{-# SPECIALIZE mapMaybeWithKey :: Proxy# 'Lazy -> (k -> a -> Maybe b) -> POMap k a -> POMap k b #-} + +traverseMaybeWithKey :: (Applicative f, SingIAreWeStrict s) => Proxy# s -> (k -> a -> f (Maybe b)) -> POMap k a -> f (POMap k b) +traverseMaybeWithKey s f (POMap _ d) + | Strict <- areWeStrict s = mkPOMap <$> traverse (Map.Strict.traverseMaybeWithKey f) d + | otherwise = mkPOMap <$> traverse (Map.Lazy.traverseMaybeWithKey f) d +{-# INLINABLE traverseMaybeWithKey #-} +{-# SPECIALIZE traverseMaybeWithKey :: Applicative f => Proxy# 'Strict -> (k -> a -> f (Maybe b)) -> POMap k a -> f (POMap k b) #-} +{-# SPECIALIZE traverseMaybeWithKey :: Applicative f => Proxy# 'Lazy -> (k -> a -> f (Maybe b)) -> POMap k a -> f (POMap k b) #-} + +mapEither :: SingIAreWeStrict s => Proxy# s -> (a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) +mapEither s p = mapEitherWithKey s (const p) +{-# INLINABLE mapEither #-} +{-# SPECIALIZE mapEither :: Proxy# 'Strict -> (a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) #-} +{-# SPECIALIZE mapEither :: Proxy# 'Lazy -> (a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) #-} + +mapEitherWithKey :: SingIAreWeStrict s => Proxy# s -> (k -> a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) +mapEitherWithKey s p (POMap _ d) + = (mkPOMap *** mkPOMap) + . unzip + . fmap (mewk p) + $ d + where + mewk + | Strict <- areWeStrict s = Map.Strict.mapEitherWithKey + | otherwise = Map.Lazy.mapEitherWithKey +{-# INLINABLE mapEitherWithKey #-} +{-# SPECIALIZE mapEitherWithKey :: Proxy# 'Strict -> (k -> a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) #-} +{-# SPECIALIZE mapEitherWithKey :: Proxy# 'Lazy -> (k -> a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) #-} + +-- TODO: Maybe `split*` variants, returning a triple, but that would +-- be rather inefficient anyway. + +-- +-- * Submap +-- + +-- | \(\mathcal{O}(n_2 w_1 n_1 \log n_1)\). +-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). +isSubmapOf :: (PartialOrd k, Eq v) => POMap k v -> POMap k v -> Bool +isSubmapOf = isSubmapOfBy (==) +{-# INLINABLE isSubmapOf #-} + +{- | \(\mathcal{O}(n_2 w_1 n_1 \log n_1)\). + 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 (==) (fromList [(1,'a')]) (fromList [(1,'a'),(2,'b')]) + True + >>> isSubmapOfBy (<=) (fromList [(1,'a')]) (fromList [(1,'b'),(2,'c')]) + True + >>> isSubmapOfBy (==) (fromList [(1,'a'),(2,'b')]) (fromList [(1,'a'),(2,'b')]) + True + + But the following are all 'False': + + >>> isSubmapOfBy (==) (fromList [(2,'a')]) (fromList [(1,'a'),(2,'b')]) + False + >>> isSubmapOfBy (<) (fromList [(1,'a')]) (fromList [(1,'a'),(2,'b')]) + False + >>> isSubmapOfBy (==) (fromList [(1,'a'),(2,'b')]) (fromList [(1,'a')]) + False +-} +isSubmapOfBy :: (PartialOrd k) => (a -> b -> Bool) -> POMap k a -> POMap k b -> Bool +isSubmapOfBy f s m + = all (\(k, v) -> fmap (f v) (lookup k m) == Just True) + . toList + $ s +{-# INLINABLE isSubmapOfBy #-} + +-- | \(\mathcal{O}(n_2 w_1 n_1 \log n_1)\). +-- Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). +isProperSubmapOf :: (PartialOrd k, Eq v) => POMap k v -> POMap k v -> Bool +isProperSubmapOf = isProperSubmapOfBy (==) +{-# INLINABLE isProperSubmapOf #-} + +{- | \(\mathcal{O}(n_2 w_1 n_1 \log n_1)\). + 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 (==) (fromList [(1,'a')]) (fromList [(1,'a'),(2,'b')]) + True + >>> isProperSubmapOfBy (<=) (fromList [(1,'a')]) (fromList [(1,'a'),(2,'b')]) + True + + But the following are all 'False': + + >>> isProperSubmapOfBy (==) (fromList [(1,'a'),(2,'b')]) (fromList [(1,'a'),(2,'b')]) + False + >>> isProperSubmapOfBy (==) (fromList [(1,'a'),(2,'b')]) (fromList [(1,'a')]) + False + >>> isProperSubmapOfBy (<) (fromList [(1,'a')]) (fromList [(1,'a'),(2,'b')]) + False +-} +isProperSubmapOfBy :: (PartialOrd k) => (a -> b -> Bool) -> POMap k a -> POMap k b -> Bool +isProperSubmapOfBy f s m = size s < size m && isSubmapOfBy f s m +{-# INLINABLE isProperSubmapOfBy #-} + +-- +-- * Min/Max +-- + +-- | \(\mathcal{O}(w\log n)\). +-- The minimal keys of the map. +-- +-- Note that the following examples assume the @Divisibility@ +-- partial order defined at the top. +-- +-- >>> lookupMin (fromList [(6,"a"), (3,"b")]) +-- [(3,"b")] +-- >>> lookupMin empty +-- [] +lookupMin :: PartialOrd k => POMap k v -> [(k, v)] +lookupMin = dedupAntichain LessThan . Maybe.mapMaybe Map.lookupMin . chainDecomposition +{-# INLINABLE lookupMin #-} + +-- | \(\mathcal{O}(w\log n)\). +-- The maximal keys of the map. +-- +-- Note that the following examples assume the @Divisibility@ +-- partial order defined at the top. +-- +-- >>> lookupMax (fromList [(6,"a"), (3,"b")]) +-- [(6,"a")] +-- >>> lookupMax empty +-- [] +lookupMax :: PartialOrd k => POMap k v -> [(k, v)] +lookupMax = dedupAntichain GreaterThan . Maybe.mapMaybe Map.lookupMax . chainDecomposition +{-# INLINABLE lookupMax #-}
+ src/Data/POMap/Lazy.hs view
@@ -0,0 +1,651 @@+{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} + +-- | +-- Module : Data.POMap.Lazy +-- Copyright : (c) Sebastian Graf 2017 +-- License : MIT +-- Maintainer : sgraf1337@gmail.com +-- Portability : portable +-- +-- A reasonably efficient implementation of partially ordered maps from keys to values +-- (dictionaries). +-- +-- The API of this module is lazy in both the keys and the values. +-- If you need value-strict maps, use "Data.POMap.Strict" instead. +-- The 'POMap' type is shared between the lazy and strict modules, +-- meaning that the same 'POMap' value can be passed to functions in +-- both modules (although that is rarely needed). +-- +-- These modules are intended to be imported qualified, to avoid name +-- clashes with Prelude functions, e.g. +-- +-- > import qualified Data.POMap.Lazy as POMap +-- +-- The implementation of 'POMap' is based on a decomposition of +-- chains (totally ordered submaps), inspired by +-- [\"Sorting and Selection in Posets\"](https://arxiv.org/abs/0707.1532). +-- +-- Operation comments contain the operation time complexity in +-- [Big-O notation](http://en.wikipedia.org/wiki/Big_O_notation) and +-- commonly refer to two characteristics of the poset from which keys are drawn: +-- The number of elements in the map \(n\) and the /width/ \(w\) of the poset, +-- referring to the size of the biggest anti-chain (set of incomparable elements). +-- +-- Generally speaking, lookup and mutation operations incur an additional +-- factor of \(\mathcal{O}(w)\) compared to their counter-parts in "Data.Map.Lazy". +-- +-- Note that for practical applications, the width of the poset should be +-- in the order of \(w\in \mathcal{O}(\frac{n}{\log n})\), otherwise a simple lookup list +-- is asymptotically superior. +-- Even if that holds, the constants might be too big to be useful for any \(n\) that can +-- can happen in practice. +-- +-- The following examples assume the following definitions for a map on the divisibility +-- relation on `Int`egers: +-- +-- @ +-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-} +-- +-- import Algebra.PartialOrd +-- import Data.POMap.Lazy (POMap) +-- import qualified Data.POMap.Lazy as POMap +-- +-- newtype Divisibility +-- = Div Int +-- deriving (Eq, Read, Show, Num) +-- +-- default (Divisibility) +-- +-- instance 'PartialOrd' Divisibility where +-- Div a \`leq\` Div b = b \`mod\` a == 0 +-- +-- type DivMap a = POMap Divisibility a +-- +-- -- We want integer literals to be interpreted as 'Divisibility's +-- -- and default 'empty's to DivMap String. +-- default (Divisibility, DivMap String) +-- @ +-- +-- 'Divisility' is actually an example for a 'PartialOrd' that should not be used as keys of 'POMap'. +-- Its width is \(w=\frac{n}{2}\in\Omega(n)\)! + +module Data.POMap.Lazy ( + -- * Map type + Impl.POMap + + -- * Query + , null + , Impl.size + , Impl.width + , Impl.member + , Impl.notMember + , Impl.lookup + , Impl.findWithDefault + , Impl.lookupLT + , Impl.lookupGT + , Impl.lookupLE + , Impl.lookupGE + + -- * Construction + , Impl.empty + , singleton + + -- ** Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- ** Delete\/Update + , Impl.delete + , Impl.deleteLookup + , adjust + , adjustWithKey + , adjustLookupWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + , alterWithKey + , alterLookupWithKey + , alterF + + -- * Combine + + -- ** Union + , Impl.union + , Impl.unionWith + , Impl.unionWithKey + , Impl.unions + , Impl.unionsWith + + -- ** Difference + , Impl.difference + , Impl.differenceWith + , Impl.differenceWithKey + + -- ** Intersection + , Impl.intersection + , Impl.intersectionWith + , Impl.intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , traverseWithKey + , traverseMaybeWithKey + , mapAccum + , mapAccumWithKey + , Impl.mapKeys + , mapKeysWith + , Impl.mapKeysMonotonic + + -- * Folds + , Impl.foldrWithKey + , Impl.foldlWithKey + , Impl.foldMapWithKey + + -- ** Strict folds + , Impl.foldr' + , Impl.foldl' + , Impl.foldrWithKey' + , Impl.foldlWithKey' + + -- * Conversion + , Impl.elems + , Impl.keys + , Impl.assocs + + -- ** Lists + , Impl.toList + , fromList + , fromListWith + , fromListWithKey + + -- * Filter + , Impl.filter + , Impl.filterWithKey + + , Impl.partition + , Impl.partitionWithKey + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + -- * Submap + , Impl.isSubmapOf, Impl.isSubmapOfBy + , Impl.isProperSubmapOf, Impl.isProperSubmapOfBy + + -- * Min\/Max + , Impl.lookupMin + , Impl.lookupMax + ) where + +import Algebra.PartialOrd +import Data.Map.Internal (AreWeStrict (..)) +import Data.POMap.Internal (POMap (..)) +import qualified Data.POMap.Internal as Impl +import GHC.Exts (Proxy#, proxy#) +import Prelude hiding (map) + +-- $setup +-- This is some setup code for @doctest@. +-- >>> :set -XGeneralizedNewtypeDeriving +-- >>> import Algebra.PartialOrd +-- >>> import Data.POMap.Lazy +-- >>> :{ +-- newtype Divisibility +-- = Div Int +-- deriving (Eq, Num) +-- instance Show Divisibility where +-- show (Div a) = show a +-- instance PartialOrd Divisibility where +-- Div a `leq` Div b = b `mod` a == 0 +-- type DivMap a = POMap Divisibility a +-- default (Divisibility, DivMap String) +-- :} + +-- | \(\mathcal{O}(1)\). A map with a single element. +-- +-- >>> singleton 1 'a' +-- fromList [(1,'a')] +-- >>> size (singleton 1 'a') +-- 1 +singleton :: k -> v -> POMap k v +singleton = Impl.singleton (proxy# :: Proxy# 'Lazy) +{-# INLINE singleton #-} + +-- | \(\mathcal{O}(w\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'@. +-- +-- >>> insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3,'b'), (5,'x')] +-- True +-- >>> insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3,'b'), (5,'a'), (7,'x')] +-- True +-- >>> insert 5 'x' empty == singleton 5 'x' +-- True +insert :: PartialOrd k => k -> v -> POMap k v -> POMap k v +insert = Impl.insert (proxy# :: Proxy# 'Lazy) +{-# INLINE insert #-} + +-- | \(\mathcal{O}(w\log n)\). Insert with a function, combining new value and old value. +-- @'insertWith' 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 new_value old_value)@. +-- +-- >>> insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] +-- True +-- >>> insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- True +-- >>> insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +-- True +insertWith :: PartialOrd k => (v -> v -> v) -> k -> v -> POMap k v -> POMap k v +insertWith = Impl.insertWith (proxy# :: Proxy# 'Lazy) +{-# INLINE insertWith #-} + +-- | \(\mathcal{O}(w\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'. +-- +-- >>> 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")] +-- True +-- >>> insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- True +-- >>> insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +-- True +insertWithKey :: PartialOrd k => (k -> v -> v -> v) -> k -> v -> POMap k v -> POMap k v +insertWithKey = Impl.insertWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE insertWithKey #-} + +-- | \(\mathcal{O}(w\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")]) +-- True +-- >>> insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) +-- True +-- >>> insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") +-- True +-- +-- 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")]) +-- True +-- >>> insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +-- True +insertLookupWithKey + :: PartialOrd k + => (k -> v -> v -> v) + -> k + -> v + -> POMap k v + -> (Maybe v, POMap k v) +insertLookupWithKey = Impl.insertLookupWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE insertLookupWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Adjust 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")] +-- True +-- >>> adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> adjust ("new " ++) 7 empty == empty +-- True +adjust :: PartialOrd k => (v -> v) -> k -> POMap k v -> POMap k v +adjust = Impl.adjust (proxy# :: Proxy# 'Lazy) +{-# INLINE adjust #-} + +-- | \(\mathcal{O}(w\log n)\). Adjust 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. +-- +-- >>> let f key x = (show key) ++ ":new " ++ x +-- >>> adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- True +-- >>> adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> adjustWithKey f 7 empty == empty +-- True +adjustWithKey :: PartialOrd k => (k -> v -> v) -> k -> POMap k v -> POMap k v +adjustWithKey = Impl.adjustWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE adjustWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Adjust a value at a specific key with the +-- result of the provided function and simultaneously look up the old value +-- at that key. +-- When the key is not a member of the map, the original map is returned. +-- +-- >>> let f key old_value = show key ++ ":" ++ show 42 ++ "|" ++ old_value +-- >>> adjustLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:42|a")]) +-- True +-- >>> adjustLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- True +-- >>> adjustLookupWithKey f 5 empty == (Nothing, empty) +-- True +adjustLookupWithKey :: PartialOrd k => (k -> v -> v) -> k -> POMap k v -> (Maybe v, POMap k v) +adjustLookupWithKey = Impl.adjustLookupWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE adjustLookupWithKey #-} + +-- | \(\mathcal{O}(w\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@. +-- +-- >>> let f x = if x == "a" then Just "new a" else Nothing +-- >>> update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- True +-- >>> update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +-- True +update :: PartialOrd k => (v -> Maybe v) -> k -> POMap k v -> POMap k v +update = Impl.update (proxy# :: Proxy# 'Lazy) +{-# INLINE update #-} + +-- | \(\mathcal{O}(w\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@. +-- +-- >>> let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- >>> updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- True +-- >>> updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +-- True +updateWithKey :: PartialOrd k => (k -> v -> Maybe v) -> k -> POMap k v -> POMap k v +updateWithKey = Impl.updateWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE updateWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Lookup and update. See also 'updateWithKey'. +-- __Warning__: Contrary to "Data.Map.Lazy", the lookup does /not/ return +-- the updated value, but the old value. This is consistent with 'insertLookupWithKey' +-- and also @Data.IntMap.Lazy.'Data.IntMap.Lazy.updateLookupWithKey'@. +-- +-- Re-apply the updating function to the looked-up value once more to get the +-- value in the map, like in the last example: +-- +-- >>> let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- >>> updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) +-- True +-- >>> updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- True +-- >>> updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") +-- True +-- >>> fst (updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")])) >>= f 5 +-- Just "5:new a" +updateLookupWithKey :: PartialOrd k => (k -> v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) +updateLookupWithKey = Impl.updateLookupWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE updateLookupWithKey #-} + +-- | \(\mathcal{O}(w\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 : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +-- +-- >>> let f _ = Nothing +-- >>> alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +-- True +-- >>> let f _ = Just "c" +-- >>> alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] +-- True +-- >>> alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] +-- True +alter :: PartialOrd k => (Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v +alter = Impl.alter (proxy# :: Proxy# 'Lazy) +{-# INLINE alter #-} + +-- | \(\mathcal{O}(w\log n)\). The expression (@'alterWithKey' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alterWithKey' can be used to insert, delete, or update a value in a 'Map'. +-- In short : @'lookup' k ('alter' f k m) = f k ('lookup' k m)@. +-- +-- >>> let f _ _ = Nothing +-- >>> alterWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> alterWithKey f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +-- True +-- >>> let f k _ = Just (show k ++ ":c") +-- >>> alterWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "7:c")] +-- True +-- >>> alterWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:c")] +-- True +alterWithKey :: PartialOrd k => (k -> Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v +alterWithKey = Impl.alterWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE alterWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Lookup and alteration. See also 'alterWithKey'. +-- +-- >>> let f k x = if x == Nothing then Just ((show k) ++ ":new a") else Nothing +-- >>> alterLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b")]) +-- True +-- >>> alterLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "7:new a")]) +-- True +-- >>> alterLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") +-- True +alterLookupWithKey :: PartialOrd k => (k -> Maybe v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) +alterLookupWithKey = Impl.alterLookupWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE alterLookupWithKey #-} + +-- | \(\mathcal{O}(w\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: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Divibility -> DivMap String -> IO (DivMap 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) +-- @ +-- +-- 'alterF' is the most general operation for working with an individual +-- key that may or may not be in a given map. When used with trivial +-- functors like 'Identity' and 'Const', it is often slightly slower than +-- more specialized combinators like 'lookup' and 'insert'. However, when +-- the functor is non-trivial and key comparison is not particularly cheap, +-- it is the fastest way. +alterF + :: (Functor f, PartialOrd k) + => (Maybe v -> f (Maybe v)) + -> k + -> POMap k v + -> f (POMap k v) +alterF = Impl.alterF (proxy# :: Proxy# 'Lazy) +{-# INLINE alterF #-} + +-- | \(\mathcal{O}(wn\log n)\). +-- Build a map from a list of key\/value pairs. +-- If the list contains more than one value for the same key, the last value +-- for the key is retained. +-- +-- >>> fromList [] == (empty :: DivMap String) +-- True +-- >>> fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] +-- True +-- >>> fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] +-- True +fromList :: PartialOrd k => [(k, v)] -> POMap k v +fromList = Impl.fromListImpl (proxy# :: Proxy# 'Lazy) +{-# INLINE fromList #-} + +-- | \(\mathcal{O}(wn\log n)\). +-- Build a map from a list of key\/value pairs with a combining function. +-- +-- >>> fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] +-- True +-- >>> fromListWith (++) [] == (empty :: DivMap String) +-- True +fromListWith :: PartialOrd k => (v -> v -> v) -> [(k, v)] -> POMap k v +fromListWith = Impl.fromListWith (proxy# :: Proxy# 'Lazy) +{-# INLINE fromListWith #-} + +-- | \(\mathcal{O}(wn\log n)\). +-- Build a map from a list of key\/value pairs with a combining function. +-- +-- >>> 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")] +-- True +-- >>> fromListWithKey f [] == (empty :: DivMap String) +-- True +fromListWithKey :: PartialOrd k => (k -> v -> v -> v) -> [(k, v)] -> POMap k v +fromListWithKey = Impl.fromListWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE fromListWithKey #-} + +-- | \(\mathcal{O}(n)\). Map a function over all values in the map. +-- +-- >>> map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] +-- True +map :: (a -> b) -> POMap k a -> POMap k b +map = Impl.map (proxy# :: Proxy# 'Lazy) +{-# INLINE map #-} + +-- | \(\mathcal{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")] +-- True +mapWithKey :: (k -> a -> b) -> POMap k a -> POMap k b +mapWithKey = Impl.mapWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE mapWithKey #-} + +-- | \(\mathcal{O}(n)\). +-- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' `seq` (k,v')) <$> f k v) ('toList' m)@ +-- That is, it behaves much like a regular 'traverse' except that the traversing +-- function also has access to the key associated with a value and the values are +-- forced before they are installed in the result map. +-- +-- >>> traverseWithKey (\(Div k) v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- True +-- >>> traverseWithKey (\(Div k) v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +-- True +traverseWithKey :: Applicative t => (k -> a -> t b) -> POMap k a -> t (POMap k b) +traverseWithKey = Impl.traverseWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE traverseWithKey #-} + +-- | \(\mathcal{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")]) +-- True +mapAccum :: (a -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) +mapAccum = Impl.mapAccum (proxy# :: Proxy# 'Lazy) +{-# INLINE mapAccum #-} + +-- | \(\mathcal{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")]) +-- True +mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) +mapAccumWithKey = Impl.mapAccumWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE mapAccumWithKey #-} + +-- | \(\mathcal{O}(wn\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@. +-- +-- >>> mapKeysWith (+) (\ _ -> 1) (fromList [(1,1), (2,2), (3,3), (4,4)]) == singleton 1 10 +-- True +-- >>> mapKeysWith (+) (\ _ -> 3) (fromList [(1,1), (2,1), (3,1), (4,1)]) == singleton 3 4 +-- True +mapKeysWith :: PartialOrd k2 => (v -> v -> v) -> (k1 -> k2) -> POMap k1 v -> POMap k2 v +mapKeysWith = Impl.mapKeysWith (proxy# :: Proxy# 'Lazy) +{-# INLINE mapKeysWith #-} + +-- | \(\mathcal{O}(n)\). +-- Traverse keys\/values and collect the 'Just' results. +traverseMaybeWithKey :: Applicative t => (k -> a -> t (Maybe b)) -> POMap k a -> t (POMap k b) +traverseMaybeWithKey = Impl.traverseMaybeWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE traverseMaybeWithKey #-} + +-- | \(\mathcal{O}(n)\). +-- Map values and collect the 'Just' results. +-- +-- >>> let f x = if x == "a" then Just "new a" else Nothing +-- >>> mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" +-- True +mapMaybe :: (a -> Maybe b) -> POMap k a -> POMap k b +mapMaybe = Impl.mapMaybe (proxy# :: Proxy# 'Lazy) +{-# INLINE mapMaybe #-} + +-- | \(\mathcal{O}(n)\). +-- Map keys\/values and collect the 'Just' results. +-- +-- >>> let f k _ = if k == 3 then Just ("key : " ++ (show k)) else Nothing +-- >>> mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" +-- True +mapMaybeWithKey :: (k -> a -> Maybe b) -> POMap k a -> POMap k b +mapMaybeWithKey = Impl.mapMaybeWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE mapMaybeWithKey #-} + +-- | \(\mathcal{O}(n)\). +-- Map values and separate the 'Left' and 'Right' results. +-- +-- >>> let f a = if a < "c" then Left a else Right a +-- +-- >>> :{ +-- mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) +-- :} +-- True +-- +-- >>> :{ +-- mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- :} +-- True +mapEither :: (a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) +mapEither = Impl.mapEither (proxy# :: Proxy# 'Lazy) +{-# INLINE mapEither #-} + +-- | \(\mathcal{O}(n)\). +-- Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- >>> let f (Div k) a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- +-- >>> :{ +-- mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) +-- :} +-- True +-- +-- >>> :{ +-- mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) +-- :} +-- True +mapEitherWithKey :: (k -> a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) +mapEitherWithKey = Impl.mapEitherWithKey (proxy# :: Proxy# 'Lazy) +{-# INLINE mapEitherWithKey #-}
+ src/Data/POMap/Strict.hs view
@@ -0,0 +1,664 @@+{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} + +-- | +-- Module : Data.POMap.Strict +-- Copyright : (c) Sebastian Graf 2017 +-- License : MIT +-- Maintainer : sgraf1337@gmail.com +-- Portability : portable +-- +-- A reasonably efficient implementation of partially ordered maps from keys to values +-- (dictionaries). +-- +-- The API of this module is strict in both the keys and the values. +-- If you need value-lazy maps, use "Data.POMap.Lazy" instead. +-- The 'POMap' type is shared between the lazy and strict modules, +-- meaning that the same 'POMap' value can be passed to functions in +-- both modules (although that is rarely needed). +-- +-- A consequence of this is that the 'Functor', 'Traversable' and 'Data' instances +-- are the same as for the "Data.POMap.Lazy" module, so if they are used +-- on strict maps, the resulting maps will be lazy. +-- +-- These modules are intended to be imported qualified, to avoid name +-- clashes with Prelude functions, e.g. +-- +-- > import qualified Data.POMap.Strict as POMap +-- +-- The implementation of 'POMap' is based on a decomposition of +-- chains (totally ordered submaps), inspired by +-- [\"Sorting and Selection in Posets\"](https://arxiv.org/abs/0707.1532). +-- +-- Operation comments contain the operation time complexity in +-- [Big-O notation](http://en.wikipedia.org/wiki/Big_O_notation) and +-- commonly refer to two characteristics of the poset from which keys are drawn: +-- The number of elements in the map \(n\) and the /width/ \(w\) of the poset, +-- referring to the size of the biggest anti-chain (set of incomparable elements). +-- +-- Generally speaking, lookup and mutation operations incur an additional +-- factor of \(\mathcal{O}(w)\) compared to their counter-parts in "Data.Map.Strict". +-- +-- Note that for practical applications, the width of the poset should be +-- in the order of \(w\in \mathcal{O}(\frac{n}{\log n})\), otherwise a simple lookup list +-- is asymptotically superior. +-- Even if that holds, the constants might be too big to be useful for any \(n\) that can +-- can happen in practice. +-- +-- The following examples assume the following definitions for a map on the divisibility +-- relation on `Int`egers: +-- +-- @ +-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-} +-- +-- import Algebra.PartialOrd +-- import Data.POMap.Strict (POMap) +-- import qualified Data.POMap.Strict as POMap +-- +-- newtype Divisibility +-- = Div Int +-- deriving (Eq, Read, Show, Num) +-- +-- default (Divisibility) +-- +-- instance 'PartialOrd' Divisibility where +-- Div a \`leq\` Div b = b \`mod\` a == 0 +-- +-- type DivMap a = POMap Divisibility a +-- +-- -- We want integer literals to be interpreted as 'Divisibility's +-- -- and default 'empty's to DivMap String. +-- default (Divisibility, DivMap String) +-- @ +-- +-- 'Divisility' is actually an example for a 'PartialOrd' that should not be used as keys of 'POMap'. +-- Its width is \(w=\frac{n}{2}\in\Omega(n)\)! + +module Data.POMap.Strict ( + -- * Map type + Impl.POMap + + -- * Query + , null + , Impl.size + , Impl.width + , Impl.member + , Impl.notMember + , Impl.lookup + , Impl.findWithDefault + , Impl.lookupLT + , Impl.lookupGT + , Impl.lookupLE + , Impl.lookupGE + + -- * Construction + , Impl.empty + , singleton + + -- ** Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- ** Delete\/Update + , Impl.delete + , Impl.deleteLookup + , adjust + , adjustWithKey + , adjustLookupWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + , alterWithKey + , alterLookupWithKey + , alterF + + -- * Combine + + -- ** Union + , Impl.union + , Impl.unionWith + , Impl.unionWithKey + , Impl.unions + , Impl.unionsWith + + -- ** Difference + , Impl.difference + , Impl.differenceWith + , Impl.differenceWithKey + + -- ** Intersection + , Impl.intersection + , Impl.intersectionWith + , Impl.intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , traverseWithKey + , traverseMaybeWithKey + , mapAccum + , mapAccumWithKey + , Impl.mapKeys + , mapKeysWith + , Impl.mapKeysMonotonic + + -- * Folds + , Impl.foldrWithKey + , Impl.foldlWithKey + , Impl.foldMapWithKey + + -- ** Strict folds + , Impl.foldr' + , Impl.foldl' + , Impl.foldrWithKey' + , Impl.foldlWithKey' + + -- * Conversion + , Impl.elems + , Impl.keys + , Impl.assocs + + -- ** Lists + , Impl.toList + , fromList + , fromListWith + , fromListWithKey + + -- * Filter + , Impl.filter + , Impl.filterWithKey + + , Impl.partition + , Impl.partitionWithKey + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + -- * Submap + , Impl.isSubmapOf, Impl.isSubmapOfBy + , Impl.isProperSubmapOf, Impl.isProperSubmapOfBy + + -- * Min\/Max + , Impl.lookupMin + , Impl.lookupMax + ) where + +import Algebra.PartialOrd +import Data.Map.Internal (AreWeStrict (..)) +import Data.POMap.Internal (POMap (..)) +import qualified Data.POMap.Internal as Impl +import GHC.Exts (Proxy#, proxy#) +import Prelude hiding (map) + +-- $setup +-- This is some setup code for @doctest@. +-- >>> :set -XGeneralizedNewtypeDeriving +-- >>> import Algebra.PartialOrd +-- >>> import Data.POMap.Strict +-- >>> :{ +-- newtype Divisibility +-- = Div Int +-- deriving (Eq, Num) +-- instance Show Divisibility where +-- show (Div a) = show a +-- instance PartialOrd Divisibility where +-- Div a `leq` Div b = b `mod` a == 0 +-- type DivMap a = POMap Divisibility a +-- default (Divisibility, DivMap String) +-- :} + +-- | \(\mathcal{O}(1)\). A map with a single element. +-- +-- >>> singleton 1 'a' +-- fromList [(1,'a')] +-- >>> size (singleton 1 'a') +-- 1 +singleton :: k -> v -> POMap k v +singleton = Impl.singleton (proxy# :: Proxy# 'Strict) +{-# INLINE singleton #-} + +-- | \(\mathcal{O}(w\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'@. +-- +-- >>> insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3,'b'), (5,'x')] +-- True +-- >>> insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3,'b'), (5,'a'), (7,'x')] +-- True +-- >>> insert 5 'x' empty == singleton 5 'x' +-- True +insert :: PartialOrd k => k -> v -> POMap k v -> POMap k v +insert = Impl.insert (proxy# :: Proxy# 'Strict) +{-# INLINE insert #-} + +-- | \(\mathcal{O}(w\log n)\). Insert with a function, combining new value and old value. +-- @'insertWith' 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 new_value old_value)@. +-- +-- >>> insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] +-- True +-- >>> insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- True +-- >>> insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +-- True +insertWith :: PartialOrd k => (v -> v -> v) -> k -> v -> POMap k v -> POMap k v +insertWith = Impl.insertWith (proxy# :: Proxy# 'Strict) +{-# INLINE insertWith #-} + +-- | \(\mathcal{O}(w\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'. +-- +-- >>> 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")] +-- True +-- >>> insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- True +-- >>> insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +-- True +insertWithKey :: PartialOrd k => (k -> v -> v -> v) -> k -> v -> POMap k v -> POMap k v +insertWithKey = Impl.insertWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE insertWithKey #-} + +-- | \(\mathcal{O}(w\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")]) +-- True +-- >>> insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) +-- True +-- >>> insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") +-- True +-- +-- 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")]) +-- True +-- >>> insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +-- True +insertLookupWithKey + :: PartialOrd k + => (k -> v -> v -> v) + -> k + -> v + -> POMap k v + -> (Maybe v, POMap k v) +insertLookupWithKey = Impl.insertLookupWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE insertLookupWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Adjust 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")] +-- True +-- >>> adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> adjust ("new " ++) 7 empty == empty +-- True +adjust :: PartialOrd k => (v -> v) -> k -> POMap k v -> POMap k v +adjust = Impl.adjust (proxy# :: Proxy# 'Strict) +{-# INLINE adjust #-} + +-- | \(\mathcal{O}(w\log n)\). Adjust 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. +-- +-- >>> let f key x = (show key) ++ ":new " ++ x +-- >>> adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- True +-- >>> adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> adjustWithKey f 7 empty == empty +-- True +adjustWithKey :: PartialOrd k => (k -> v -> v) -> k -> POMap k v -> POMap k v +adjustWithKey = Impl.adjustWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE adjustWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Adjust a value at a specific key with the +-- result of the provided function and simultaneously look up the old value +-- at that key. +-- When the key is not a member of the map, the original map is returned. +-- +-- >>> let f key old_value = show key ++ ":" ++ show 42 ++ "|" ++ old_value +-- >>> adjustLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:42|a")]) +-- True +-- >>> adjustLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- True +-- >>> adjustLookupWithKey f 5 empty == (Nothing, empty) +-- True +adjustLookupWithKey :: PartialOrd k => (k -> v -> v) -> k -> POMap k v -> (Maybe v, POMap k v) +adjustLookupWithKey = Impl.adjustLookupWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE adjustLookupWithKey #-} + +-- | \(\mathcal{O}(w\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@. +-- +-- >>> let f x = if x == "a" then Just "new a" else Nothing +-- >>> update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- True +-- >>> update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +-- True +update :: PartialOrd k => (v -> Maybe v) -> k -> POMap k v -> POMap k v +update = Impl.update (proxy# :: Proxy# 'Strict) +{-# INLINE update #-} + +-- | \(\mathcal{O}(w\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@. +-- +-- >>> let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- >>> updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- True +-- >>> updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +-- True +updateWithKey :: PartialOrd k => (k -> v -> Maybe v) -> k -> POMap k v -> POMap k v +updateWithKey = Impl.updateWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE updateWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Lookup and update. See also 'updateWithKey'. +-- __Warning__: Contrary to "Data.Map.Strict", the lookup does /not/ return +-- the updated value, but the old value. This is consistent with 'insertLookupWithKey' +-- and also @Data.IntMap.Strict.'Data.IntMap.Strict.updateLookupWithKey'@. +-- +-- Re-apply the updating function to the looked-up value once more to get the +-- value in the map, like in the last example: +-- +-- >>> let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- >>> updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) +-- True +-- >>> updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- True +-- >>> updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") +-- True +-- >>> fst (updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")])) >>= f 5 +-- Just "5:new a" +updateLookupWithKey :: PartialOrd k => (k -> v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) +updateLookupWithKey = Impl.updateLookupWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE updateLookupWithKey #-} + +-- | \(\mathcal{O}(w\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 : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +-- +-- >>> let f _ = Nothing +-- >>> alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +-- True +-- >>> let f _ = Just "c" +-- >>> alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] +-- True +-- >>> alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] +-- True +alter :: PartialOrd k => (Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v +alter = Impl.alter (proxy# :: Proxy# 'Strict) +{-# INLINE alter #-} + +-- | \(\mathcal{O}(w\log n)\). The expression (@'alterWithKey' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alterWithKey' can be used to insert, delete, or update a value in a 'Map'. +-- In short : @'lookup' k ('alter' f k m) = f k ('lookup' k m)@. +-- +-- >>> let f _ _ = Nothing +-- >>> alterWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- True +-- >>> alterWithKey f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +-- True +-- >>> let f k _ = Just (show k ++ ":c") +-- >>> alterWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "7:c")] +-- True +-- >>> alterWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:c")] +-- True +alterWithKey :: PartialOrd k => (k -> Maybe v -> Maybe v) -> k -> POMap k v -> POMap k v +alterWithKey = Impl.alterWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE alterWithKey #-} + +-- | \(\mathcal{O}(w\log n)\). Lookup and alteration. See also 'alterWithKey'. +-- +-- >>> let f k x = if x == Nothing then Just ((show k) ++ ":new a") else Nothing +-- >>> alterLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b")]) +-- True +-- >>> alterLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "7:new a")]) +-- True +-- >>> alterLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") +-- True +alterLookupWithKey :: PartialOrd k => (k -> Maybe v -> Maybe v) -> k -> POMap k v -> (Maybe v, POMap k v) +alterLookupWithKey = Impl.alterLookupWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE alterLookupWithKey #-} + +-- | \(\mathcal{O}(w\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: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Divibility -> DivMap String -> IO (DivMap 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) +-- @ +-- +-- 'alterF' is the most general operation for working with an individual +-- key that may or may not be in a given map. When used with trivial +-- functors like 'Identity' and 'Const', it is often slightly slower than +-- more specialized combinators like 'lookup' and 'insert'. However, when +-- the functor is non-trivial and key comparison is not particularly cheap, +-- it is the fastest way. +alterF + :: (Functor f, PartialOrd k) + => (Maybe v -> f (Maybe v)) + -> k + -> POMap k v + -> f (POMap k v) +alterF = Impl.alterF (proxy# :: Proxy# 'Strict) +{-# INLINE alterF #-} + +-- | \(\mathcal{O}(wn\log n)\). +-- Build a map from a list of key\/value pairs. +-- If the list contains more than one value for the same key, the last value +-- for the key is retained. +-- +-- This version is strict in its values, as opposed to the 'IsList' instance +-- for 'POMap'. +-- +-- >>> fromList [] == (empty :: DivMap String) +-- True +-- >>> fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] +-- True +-- >>> fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] +-- True +fromList :: PartialOrd k => [(k, v)] -> POMap k v +fromList = Impl.fromListImpl (proxy# :: Proxy# 'Strict) +{-# INLINE fromList #-} + +-- | \(\mathcal{O}(wn\log n)\). +-- Build a map from a list of key\/value pairs with a combining function. +-- +-- This version is strict in its values, as opposed to the 'IsList' instance +-- for 'POMap'. +-- +-- >>> fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] +-- True +-- >>> fromListWith (++) [] == (empty :: DivMap String) +-- True +fromListWith :: PartialOrd k => (v -> v -> v) -> [(k, v)] -> POMap k v +fromListWith = Impl.fromListWith (proxy# :: Proxy# 'Strict) +{-# INLINE fromListWith #-} + +-- | \(\mathcal{O}(wn\log n)\). +-- Build a map from a list of key\/value pairs with a combining function. +-- +-- >>> 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")] +-- True +-- >>> fromListWithKey f [] == (empty :: DivMap String) +-- True +fromListWithKey :: PartialOrd k => (k -> v -> v -> v) -> [(k, v)] -> POMap k v +fromListWithKey = Impl.fromListWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE fromListWithKey #-} + +-- | \(\mathcal{O}(n)\). Map a function over all values in the map. +-- +-- >>> map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] +-- True +map :: (a -> b) -> POMap k a -> POMap k b +map = Impl.map (proxy# :: Proxy# 'Strict) +{-# INLINE map #-} + +-- | \(\mathcal{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")] +-- True +mapWithKey :: (k -> a -> b) -> POMap k a -> POMap k b +mapWithKey = Impl.mapWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE mapWithKey #-} + +-- | \(\mathcal{O}(n)\). +-- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' `seq` (k,v')) <$> f k v) ('toList' m)@ +-- That is, it behaves much like a regular 'traverse' except that the traversing +-- function also has access to the key associated with a value and the values are +-- forced before they are installed in the result map. +-- +-- >>> traverseWithKey (\(Div k) v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- True +-- >>> traverseWithKey (\(Div k) v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +-- True +traverseWithKey :: Applicative t => (k -> a -> t b) -> POMap k a -> t (POMap k b) +traverseWithKey = Impl.traverseWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE traverseWithKey #-} + +-- | \(\mathcal{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")]) +-- True +mapAccum :: (a -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) +mapAccum = Impl.mapAccum (proxy# :: Proxy# 'Strict) +{-# INLINE mapAccum #-} + +-- | \(\mathcal{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")]) +-- True +mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> POMap k b -> (a, POMap k c) +mapAccumWithKey = Impl.mapAccumWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE mapAccumWithKey #-} + +-- | \(\mathcal{O}(wn\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@. +-- +-- >>> mapKeysWith (+) (\ _ -> 1) (fromList [(1,1), (2,2), (3,3), (4,4)]) == singleton 1 10 +-- True +-- >>> mapKeysWith (+) (\ _ -> 3) (fromList [(1,1), (2,1), (3,1), (4,1)]) == singleton 3 4 +-- True +mapKeysWith :: PartialOrd k2 => (v -> v -> v) -> (k1 -> k2) -> POMap k1 v -> POMap k2 v +mapKeysWith = Impl.mapKeysWith (proxy# :: Proxy# 'Strict) +{-# INLINE mapKeysWith #-} + +-- | \(\mathcal{O}(n)\). +-- Traverse keys\/values and collect the 'Just' results. +-- +-- Contrary to 'traverse', this is value-strict. +traverseMaybeWithKey :: Applicative t => (k -> a -> t (Maybe b)) -> POMap k a -> t (POMap k b) +traverseMaybeWithKey = Impl.traverseMaybeWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE traverseMaybeWithKey #-} + +-- | \(\mathcal{O}(n)\). +-- Map values and collect the 'Just' results. +-- +-- >>> let f x = if x == "a" then Just "new a" else Nothing +-- >>> mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" +-- True +mapMaybe :: (a -> Maybe b) -> POMap k a -> POMap k b +mapMaybe = Impl.mapMaybe (proxy# :: Proxy# 'Strict) +{-# INLINE mapMaybe #-} + +-- | \(\mathcal{O}(n)\). +-- Map keys\/values and collect the 'Just' results. +-- +-- >>> let f k _ = if k == 3 then Just ("key : " ++ (show k)) else Nothing +-- >>> mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" +-- True +mapMaybeWithKey :: (k -> a -> Maybe b) -> POMap k a -> POMap k b +mapMaybeWithKey = Impl.mapMaybeWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE mapMaybeWithKey #-} + +-- | \(\mathcal{O}(n)\). +-- Map values and separate the 'Left' and 'Right' results. +-- +-- >>> let f a = if a < "c" then Left a else Right a +-- +-- >>> :{ +-- mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) +-- :} +-- True +-- +-- >>> :{ +-- mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- :} +-- True +mapEither :: (a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) +mapEither = Impl.mapEither (proxy# :: Proxy# 'Strict) +{-# INLINE mapEither #-} + +-- | \(\mathcal{O}(n)\). +-- Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- >>> let f (Div k) a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- +-- >>> :{ +-- mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) +-- :} +-- True +-- +-- >>> :{ +-- mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) +-- :} +-- True +mapEitherWithKey :: (k -> a -> Either b c) -> POMap k a -> (POMap k b, POMap k c) +mapEitherWithKey = Impl.mapEitherWithKey (proxy# :: Proxy# 'Strict) +{-# INLINE mapEitherWithKey #-}
+ src/Data/POSet.hs view
@@ -0,0 +1,117 @@+-- |+-- Module : Data.POSet+-- Copyright : (c) Sebastian Graf 2017+-- License : MIT+-- Maintainer : sgraf1337@gmail.com+-- Portability : portable+--+-- A reasonably efficient implementation of partially ordered sets.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- > import qualified Data.POSet as POSet+--+-- The implementation of 'POSet' is based on a decomposition of+-- chains (totally ordered submaps), inspired by+-- [\"Sorting and Selection in Posets\"](https://arxiv.org/abs/0707.1532).+--+-- Operation comments contain the operation time complexity in+-- [Big-O notation](http://en.wikipedia.org/wiki/Big_O_notation) and+-- commonly refer to two characteristics of the poset from which keys are drawn:+-- The number of elements in the set \(n\) and the /width/ \(w\) of the poset,+-- referring to the size of the biggest anti-chain (set of incomparable elements).+--+-- Generally speaking, lookup and mutation operations incur an additional+-- factor of \(\mathcal{O}(w)\) compared to their counter-parts in "Data.Set".+--+-- Note that for practical applications, the width of the poset should be+-- in the order of \(w\in \mathcal{O}(\frac{n}{\log n})\), otherwise a simple lookup list+-- is asymptotically superior.+-- Even if that holds, the constants might be too big to be useful for any \(n\) that can+-- can happen in practice.+--+-- The following examples assume the following definitions for a set on the divisibility+-- relation on `Int`egers:+--+-- @+-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-}+--+-- import Algebra.PartialOrd+-- import Data.POSet (POSet)+-- import qualified Data.POSet as POSet+--+-- newtype Divisibility+-- = Div Int+-- deriving (Eq, Read, Show, Num)+--+-- default (Divisibility)+--+-- instance 'PartialOrd' Divisibility where+-- Div a \`leq\` Div b = b \`mod\` a == 0+--+-- type DivSet = POSet Divisibility+--+-- -- We want integer literals to be interpreted as 'Divisibility's+-- -- and default 'empty's to DivSet.+-- default (Divisibility, DivSet)+-- @+--+-- 'Divisility' is actually an example for a 'PartialOrd' that should not be used as keys of 'POSet'.+-- Its width is \(w=\frac{n}{2}\in\Omega(n)\)!++module Data.POSet+ (+ -- * Set type+ Impl.POSet+ -- * Query+ , Foldable.null+ , Impl.size+ , Impl.member+ , Impl.notMember+ , Impl.lookupLT+ , Impl.lookupGT+ , Impl.lookupLE+ , Impl.lookupGE+ , Impl.isSubsetOf+ , Impl.isProperSubsetOf++ -- * Construction+ , Impl.empty+ , Impl.singleton+ , Impl.insert+ , Impl.delete++ -- * Combine+ , Impl.union+ , Impl.unions+ , Impl.difference+ , Impl.intersection++ -- * Filter+ , Impl.filter+ , Impl.partition++ -- * Map+ , Impl.map+ , Impl.mapMonotonic++ -- * Folds+ , Foldable.foldr+ , Foldable.foldl+ -- ** Strict folds+ , Impl.foldr'+ , Impl.foldl'++ -- * Min\/Max+ , Impl.lookupMin+ , Impl.lookupMax++ -- * Conversion+ , Impl.elems+ , Impl.toList+ , Impl.fromList+ ) where++import qualified Data.Foldable as Foldable+import qualified Data.POSet.Internal as Impl
+ src/Data/POSet/Internal.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module doesn't respect the PVP!+-- Breaking changes may happen at any minor version (>= *.*.m.*)++module Data.POSet.Internal where++import Algebra.PartialOrd+import Control.DeepSeq (NFData (rnf))+import qualified Data.List as List+import Data.POMap.Lazy (POMap)+import qualified Data.POMap.Lazy as POMap+import GHC.Exts (coerce)+import qualified GHC.Exts+import Text.Read (Lexeme (Ident), Read (..), lexP, parens,+ prec, readListPrecDefault)++-- $setup+-- This is some setup code for @doctest@.+-- >>> :set -XGeneralizedNewtypeDeriving+-- >>> import Algebra.PartialOrd+-- >>> import Data.POSet+-- >>> :{+-- newtype Divisibility+-- = Div Int+-- deriving (Eq, Num)+-- instance Show Divisibility where+-- show (Div a) = show a+-- instance PartialOrd Divisibility where+-- Div a `leq` Div b = b `mod` a == 0+-- type DivSet = POSet Divisibility+-- default (Divisibility, DivSet)+-- :}++-- | A set of partially ordered values @k@.+newtype POSet k+ = POSet (POMap k ())++--+-- * Instances+--++instance PartialOrd k => Eq (POSet k) where+ POSet a == POSet b = a == b++instance PartialOrd k => PartialOrd (POSet k) where+ POSet a `leq` POSet b = a `leq` b++instance Show a => Show (POSet a) where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)++instance (Read a, PartialOrd a) => Read (POSet a) where+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault++instance NFData a => NFData (POSet a) where+ rnf (POSet m) = rnf m++instance Foldable POSet where+ foldr f = coerce (POMap.foldrWithKey @_ @() (\k _ acc -> f k acc))+ {-# INLINE foldr #-}+ foldl f = coerce (POMap.foldlWithKey @_ @_ @() (\k acc _ -> f k acc))+ {-# INLINE foldl #-}+ null m = size m == 0+ {-# INLINE null #-}+ length = size+ {-# INLINE length #-}++instance PartialOrd k => GHC.Exts.IsList (POSet k) where+ type Item (POSet k) = k+ fromList = fromList+ toList = toList++--+-- * Query+--++-- | \(\mathcal{O}(1)\). The number of elements in this set.+size :: POSet k -> Int+size = coerce (POMap.size @_ @())+{-# INLINE size #-}++-- | \(\mathcal{O}(w)\).+-- The width \(w\) of the chain decomposition in the internal+-- data structure.+-- This is always at least as big as the size of the biggest possible+-- anti-chain.+width :: POSet k -> Int+width = coerce (POMap.width @_ @())+{-# INLINE width #-}++-- | \(\mathcal{O}(w\log n)\).+-- Is the key a member of the map? See also 'notMember'.+member :: PartialOrd k => k -> POSet k -> Bool+member = coerce (POMap.member @_ @())+{-# INLINE member #-}++-- | \(\mathcal{O}(w\log n)\).+-- Is the key not a member of the map? See also 'member'.+notMember :: PartialOrd k => k -> POSet k -> Bool+notMember = coerce (POMap.notMember @_ @())+{-# INLINE notMember #-}++-- | \(\mathcal{O}(w\log n)\).+-- Find the largest set of keys smaller than the given one and+-- return the corresponding list of (key, value) pairs.+--+-- Note that the following examples assume the @Divisibility@+-- partial order defined at the top.+--+-- >>> lookupLT 3 (fromList [3, 5])+-- []+-- >>> lookupLT 6 (fromList [3, 5])+-- [3]+lookupLT :: PartialOrd k => k -> POSet k -> [k]+lookupLT k = List.map @(_,()) fst . coerce (POMap.lookupLT @_ @() k)+{-# INLINE lookupLT #-}++-- | \(\mathcal{O}(w\log n)\).+-- Find the largest key smaller or equal to the given one and return+-- the corresponding list of (key, value) pairs.+--+-- Note that the following examples assume the @Divisibility@+-- partial order defined at the top.+--+-- >>> lookupLE 2 (fromList [3, 5])+-- []+-- >>> lookupLE 3 (fromList [3, 5])+-- [3]+-- >>> lookupLE 10 (fromList [3, 5])+-- [5]+lookupLE :: PartialOrd k => k -> POSet k -> [k]+lookupLE k = List.map @(_,()) fst . coerce (POMap.lookupLE @_ @() k)+{-# INLINE lookupLE #-}++-- | \(\mathcal{O}(w\log n)\).+-- Find the smallest key greater or equal to the given one and return+-- the corresponding list of (key, value) pairs.+--+-- Note that the following examples assume the @Divisibility@+-- partial order defined at the top.+--+-- >>> lookupGE 3 (fromList [3, 5])+-- [3]+-- >>> lookupGE 5 (fromList [3, 10])+-- [10]+-- >>> lookupGE 6 (fromList [3, 5])+-- []+lookupGE :: PartialOrd k => k -> POSet k -> [k]+lookupGE k = List.map @(_,()) fst . coerce (POMap.lookupGE @_ @() k)+{-# INLINE lookupGE #-}++-- | \(\mathcal{O}(w\log n)\).+-- Find the smallest key greater than the given one and return the+-- corresponding list of (key, value) pairs.+--+-- Note that the following examples assume the @Divisibility@+-- partial order defined at the top.+--+-- >>> lookupGT 3 (fromList [6, 5])+-- [6]+-- >>> lookupGT 5 (fromList [3, 5])+-- []+lookupGT :: PartialOrd k => k -> POSet k -> [k]+lookupGT k = List.map @(_,()) fst . coerce (POMap.lookupGT @_ @() k)+{-# INLINE lookupGT #-}++-- | \(\mathcal{O}(n_2 w_1 n_1 \log n_1)\).+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.+isSubsetOf :: PartialOrd k => POSet k -> POSet k -> Bool+isSubsetOf = coerce (POMap.isSubmapOf @_ @())+{-# INLINE isSubsetOf #-}++-- | \(\mathcal{O}(n_2 w_1 n_1 \log n_1)\).+-- Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: PartialOrd k => POSet k -> POSet k -> Bool+isProperSubsetOf = coerce (POMap.isProperSubmapOf @_ @())+{-# INLINE isProperSubsetOf #-}++--+-- * Construction+--++-- | \(\mathcal{O}(1)\). The empty set.+empty :: POSet k+empty = POSet POMap.empty+{-# INLINE empty #-}++-- | \(\mathcal{O}(1)\). A set with a single element.+singleton :: k -> POSet k+singleton k = POSet (POMap.singleton k ())+{-# INLINE singleton #-}+-- INLINE means we don't need to SPECIALIZE++-- | \(\mathcal{O}(w\log n)\).+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: (PartialOrd k) => k -> POSet k -> POSet k+insert k = coerce (POMap.insert k ())+{-# INLINE insert #-}++-- | \(\mathcal{O}(w\log n)\).+-- Delete an element from a set.+delete :: (PartialOrd k) => k -> POSet k -> POSet k+delete = coerce (POMap.delete @_ @())+{-# INLINE delete #-}++--+-- * Combine+--++-- ** Union++-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\).+-- The union of two sets, preferring the first set when+-- equal elements are encountered.+union :: PartialOrd k => POSet k -> POSet k -> POSet k+union = coerce (POMap.union @_ @())+{-# INLINE union #-}++-- | \(\mathcal{O}(wn\log n)\), where \(n=\max_i n_i\) and \(w=\max_i w_i\).+-- The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).+unions :: PartialOrd k => [POSet k] -> POSet k+unions = coerce (POMap.unions @_ @())+{-# INLINE unions #-}++-- ** Difference++-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\).+-- Difference of two sets.+difference :: PartialOrd k => POSet k -> POSet k -> POSet k+difference = coerce (POMap.difference @_ @() @())+{-# INLINE difference #-}++-- ** Intersection++-- | \(\mathcal{O}(wn\log n)\), where \(n=\max(n_1,n_2)\) and \(w=\max(w_1,w_2)\).+-- The intersection of two sets.+-- Elements of the result come from the first set, so for example+--+-- >>> data AB = A | B deriving Show+-- >>> instance Eq AB where _ == _ = True+-- >>> instance PartialOrd AB where _ `leq` _ = True+-- >>> singleton A `intersection` singleton B+-- fromList [A]+-- >>> singleton B `intersection` singleton A+-- fromList [B]+intersection :: PartialOrd k => POSet k -> POSet k -> POSet k+intersection = coerce (POMap.intersection @_ @() @())+{-# INLINE intersection #-}++--+-- * Filter+--++-- | \(\mathcal{O}(n)\).+-- Filter all elements that satisfy the predicate.+filter :: (k -> Bool) -> POSet k -> POSet k+filter f = coerce (POMap.filterWithKey @_ @() (\k _ -> f k))+{-# INLINE filter #-}++-- | \(\mathcal{O}(n)\).+-- Partition the set into two sets, one with all elements that satisfy+-- the predicate and one with all elements that don't satisfy the predicate.+partition :: (k -> Bool) -> POSet k -> (POSet k, POSet k)+partition f = coerce (POMap.partitionWithKey @_ @() (\k _ -> f k))+{-# INLINE partition #-}++--+-- * Map+--++-- | \(\mathcal{O}(wn\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 :: PartialOrd k2 => (k1 -> k2) -> POSet k1 -> POSet k2+map = coerce (POMap.mapKeys @_ @_ @())+{-# INLINE map #-}++-- | \(\mathcal{O}(n)\).+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.+-- /The precondition is not checked./+-- Semi-formally, for every chain @ls@ in @s@ we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- > ==> mapMonotonic f s == map f s+mapMonotonic :: (k1 -> k2) -> POSet k1 -> POSet k2+mapMonotonic = coerce (POMap.mapKeysMonotonic @_ @_ @())+{-# INLINE mapMonotonic #-}++--+-- * Folds+--++-- | \(\mathcal{O}(n)\).+-- A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> POSet a -> b+foldr' f = coerce (POMap.foldrWithKey' @_ @() (\k _ acc -> f k acc))+{-# INLINE foldr' #-}++-- | \(\mathcal{O}(n)\).+-- A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (b -> a -> b) -> b -> POSet a -> b+foldl' f = coerce (POMap.foldlWithKey' @_ @_ @() (\k acc _ -> f k acc))+{-# INLINE foldl' #-}++--+-- * Min/Max+--++-- | \(\mathcal{O}(w\log n)\).+-- The minimal keys of the set.+lookupMin :: PartialOrd k => POSet k -> [k]+lookupMin = List.map @(_,()) fst . coerce (POMap.lookupMin @_ @())+{-# INLINE lookupMin #-}++-- | \(\mathcal{O}(w\log n)\).+-- The maximal keys of the set.+lookupMax :: PartialOrd k => POSet k -> [k]+lookupMax = List.map @(_,()) fst . coerce (POMap.lookupMax @_ @())+{-# INLINE lookupMax #-}++--+-- * Conversion+--++-- | \(\mathcal{O}(n)\).+-- The elements of a set in unspecified order.+elems :: POSet k -> [k]+elems = coerce (POMap.keys @_ @())+{-# INLINE elems #-}++-- | \(\mathcal{O}(n)\).+-- The elements of a set in unspecified order.+toList :: POSet k -> [k]+toList = coerce (POMap.keys @_ @())+{-# INLINE toList #-}++-- | \(\mathcal{O}(wn\log n)\).+-- Build a set from a list of keys.+fromList :: (PartialOrd k) => [k] -> POSet k+fromList = coerce (POMap.fromList @_ @()) . List.map (\k -> (k, ()))+{-# INLINE fromList #-}
+ stack.yaml view
@@ -0,0 +1,71 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# http://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+# resolver: ghcjs-0.1.0_ghc-7.10.2+# resolver:+# name: custom-snapshot+# location: "./custom-snapshot.yaml"+resolver: lts-9.13++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+# - location:+# git: https://github.com/commercialhaskell/stack.git+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# extra-dep: true+# subdirs:+# - auto-update+# - wai+#+# A package marked 'extra-dep: true' will only be built if demanded by a+# non-dependency (i.e. a user package), and its test suites and benchmarks+# will not be run. This is useful for tweaking upstream packages.+packages:+- '.'+# Dependency packages to be pulled from upstream that are not in the resolver+# (e.g., acme-missiles-0.3)+extra-deps:+- containers-0.5.10.2+- ChasingBottoms-1.3.1.3+- lattices-1.7++# Override default flag values for local packages and extra-deps+flags: + pomaps:+ use-lattices: false++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=1.4"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor
+ tests/Data/POMap/Arbitrary.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.POMap.Arbitrary where + +import Algebra.PartialOrd +import Data.POMap.Strict +import Test.Tasty.QuickCheck + +instance (PartialOrd k, Arbitrary k, Arbitrary v) => Arbitrary (POMap k v) where + arbitrary = fromList <$> arbitrary + shrink = fmap fromList . shrink . toList
+ tests/Data/POMap/Divisibility.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.POMap.Divisibility where + +import Algebra.PartialOrd +import Control.Arrow ((&&&)) +import Test.Tasty.QuickCheck + +newtype Divisibility + = Div { unDiv :: Integer } + deriving (Eq, Num, Show, Read) + +instance PartialOrd Divisibility where + leq (Div a) (Div b) = b `mod` a == 0 + +instance Arbitrary Divisibility where + arbitrary = Div . getPositive <$> arbitrary + shrink = fmap (Div . getPositive) . shrink . Positive . unDiv + +divisibility :: Int -> [(Divisibility, Integer)] +divisibility n = map ((Div &&& id) . fromIntegral) [1..n]
+ tests/Data/POMap/Properties.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.POMap.Properties where + +import Algebra.PartialOrd +import Control.Arrow (first, (&&&), (***)) +import Control.Monad (guard) +import Data.Bifunctor (bimap) +import Data.Coerce +import qualified Data.Either as Either +import Data.Foldable hiding (foldl', foldr', toList) +import Data.Function (on) +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Identity +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Monoid (Dual (..), Endo (..), Sum (..)) +import Data.Ord (comparing) +import Data.POMap.Arbitrary () +import Data.POMap.Divisibility +import Data.POMap.Lazy +import Data.Traversable +import Prelude hiding (filter, lookup, map, max, null) +import Test.Tasty.Hspec +import Test.Tasty.QuickCheck + +type DivMap v = POMap Divisibility v + +instance {-# OVERLAPPING #-} Eq v => Eq (DivMap v) where + (==) = (==) `on` List.sortBy (comparing (unDiv . fst)) . toList + +div' :: Int -> DivMap Integer +div' = fromList . divisibility + +div100 :: DivMap Integer +div100 = div' 100 + +div1000 :: DivMap Integer +div1000 = div' 1000 + +primes :: [Integer] +primes = 2 : [ p | p <- [3..], not . any (divides p) . takeWhile (\n -> n*n <= p) $ primes] + where + divides p n = p `mod` n == 0 + +primesUntil :: Integer -> [Integer] +primesUntil n = takeWhile (<= n) primes + +makeEntries :: [Integer] -> [(Divisibility, Integer)] +makeEntries = fmap (Div &&& id) + +shouldBeSameEntries :: (Eq v, Show v) => [(Divisibility, v)] -> [(Divisibility, v)] -> Expectation +shouldBeSameEntries = shouldBe `on` List.sortBy (comparing (unDiv . fst)) + +isAntichain :: PartialOrd k => [k] -> Bool +isAntichain [] = True +isAntichain (x:xs) = all (not . comparable x) xs && isAntichain xs + +spec :: Spec +spec = + describe "POMap" $ do + describe "empty" $ do + it "fromList []" $ fromList (divisibility 0) `shouldBe` empty + it "is null" $ null empty `shouldBe` True + it "has size 0" $ size empty `shouldBe` 0 + describe "singleton" $ do + let m = singleton 1 1 + it "fromList [(k, v)]" $ fromList (divisibility 1) `shouldBe` m + it "is not null" $ null m `shouldBe` False + it "has size 1" $ size m `shouldBe` 1 + describe "width" $ do + it "width empty == 0" $ width empty `shouldBe` 0 + it "width singleton == 1" $ width (singleton () ()) `shouldBe` 1 + it "width div100 == 50" $ width div100 `shouldBe` 50 + it "width div1000 == 500" $ width div1000 `shouldBe` 500 + + let prop100and1000 prop = do + it "100 divs" $ property (prop div100 (100 :: Integer)) + it "1000 divs" $ property (prop div1000 (1000 :: Integer)) + + describe "member" $ + prop100and1000 $ \m max (Positive n) -> + member (Div n) m == (n <= max) + describe "lookup" $ + prop100and1000 $ \m max (Positive n) -> + lookup (Div n) m == (guard (n <= max) >> Just n) + + let lookupXProps what lu p = + describe ("is " ++ what) $ + prop100and1000 $ \m _ (Positive n) -> + all (p (Div n) . fst) (lu (Div n) m) + + describe "lookupLT" $ do + it "nothing less than 1" $ + lookupLT 1 div100 `shouldBe` [] + it "1 is less than 2" $ + lookupLT 2 div100 `shouldBe` makeEntries [1] + it "64 is less than 128" $ + lookupLT 128 div100 `shouldBe` makeEntries [64] + it "[6, 10, 15] less than 30" $ + lookupLT 30 div100 `shouldBeSameEntries` makeEntries [6, 10, 15] + lookupXProps "less than" lookupLT $ \a b -> + not (a `leq` b) && b `leq` a + describe "lookupLE" $ do + it "50 leq 50" $ + lookupLE 50 div100 `shouldBe` makeEntries [50] + it "64 is less equal 128" $ + lookupLE 128 div100 `shouldBe` makeEntries [64] + it "[30, 42, 70] leq 210" $ + lookupLE 210 div100 `shouldBeSameEntries` makeEntries [30, 42, 70] + lookupXProps "less equal" lookupLE (flip leq) + describe "lookupGE" $ do + it "50 geq 50" $ + lookupGE 50 div100 `shouldBe` makeEntries [50] + it "Nothing is geq 101" $ + lookupGE 101 div100 `shouldBe` makeEntries [] + describe "lookupGT" $ do + it "primes are gt 1" $ + lookupGT 1 div100 `shouldBeSameEntries` makeEntries (primesUntil 100) + it "Nothing is gt 101" $ + lookupGT 101 div100 `shouldBe` makeEntries [] + it "[66, 99] gt 33" $ + lookupGT 33 div100 `shouldBeSameEntries` makeEntries [66, 99] + lookupXProps "greater than" lookupGT $ \a b -> + a `leq` b && not (b `leq` a) + + describe "insert" $ + it "overwrites an entry" $ + property $ \(m :: DivMap Int) k v -> + lookup k (insert k v m) `shouldBe` Just v + describe "insertWithKey" $ do + it "can access old value" $ + insertWithKey (\_ _ old -> old) 1 2 div100 `shouldBe` div100 + it "can access new value" $ + lookup 1 (insertWithKey (\_ new _ -> new) 1 2 div100) `shouldBe` Just 2 + it "can access key" $ + lookup 1 (insertWithKey (\k _ _ -> unDiv k + 2) 1 2 div100) `shouldBe` Just 3 + it "adds new values without consulting the function" $ + lookup 1 (insertWithKey (\_ _ _ -> 3) (Div 1) 2 empty) `shouldBe` Just (2 :: Integer) + describe "insertLookupWithKey" $ do + let f k new old = unDiv k + new + old + it "lookup &&& insertWithKey" $ + property $ \m k v -> + insertLookupWithKey f k v m `shouldBe` (lookup k m, insertWithKey f k v m) + + describe "delete" $ + it "deletes" $ property $ \(m :: DivMap Int) k -> + lookup k (delete k m) `shouldBe` Nothing + describe "deleteLookup" $ + it "lookup &&& delete" $ property $ \(m :: DivMap Int) k -> + deleteLookup k m `shouldBe` (lookup k m, delete k m) + + describe "adjust" $ do + let f old = old + 1 + it "adjusts" $ property $ \(m :: DivMap Int) k -> + lookup k (adjust f k m) `shouldBe` (+1) <$> lookup k m + describe "adjustWithKey" $ do + let f k old = unDiv k + old + 1 + it "passes the key" $ property $ \(m :: DivMap Integer) k -> + lookup k (adjustWithKey f k m) `shouldBe` (unDiv k + 1 +) <$> lookup k m + describe "adjustLookupWithKey" $ do + let f k old = unDiv k + old + 1 + it "lookup &&& adjustWithKey" $ property $ \(m :: DivMap Integer) k -> + adjustLookupWithKey f k m `shouldBe` (lookup k m, adjustWithKey f k m) + + describe "update" $ do + it "Nothing deletes" $ property $ \(m :: DivMap Int) k -> + lookup k (update (const Nothing) k m) `shouldBe` Nothing + let f old = old + 1 + it "Just adjusts" $ property $ \(m :: DivMap Int) k -> + lookup k (update (Just . f) k m) `shouldBe` lookup k (adjust f k m) + describe "updateWithKey" $ do + let f k old = Just (unDiv k + old + 1) + it "passes the key" $ property $ \(m :: DivMap Integer) k -> + lookup k (updateWithKey f k m) `shouldBe` (unDiv k + 1 +) <$> lookup k m + describe "updateLookupWithKey" $ do + let f k old = Just (unDiv k + old + 1) + it "lookup &&& updateWithKey" $ property $ \(m :: DivMap Integer) k -> + updateLookupWithKey f k m `shouldBe` (lookup k m, updateWithKey f k m) + + describe "alter" $ do + let fJust _ = Just 4 + it "const Just inserts" $ property $ \(m :: DivMap Int) k -> + lookup k (alter fJust k m) `shouldBe` lookup k (insert k 4 m) + let f old = Just (old + 1) + it "(>>=) updates" $ property $ \(m :: DivMap Int) k -> + lookup k (alter (>>= f) k m) `shouldBe` lookup k (update f k m) + describe "alterWithKey" $ do + let f old = (+1) <$> old + it "const f alters" $ property $ \(m :: DivMap Int) k -> + lookup k (alterWithKey (const f) k m) `shouldBe` lookup k (alter f k m) + let g k old = Just (unDiv k + old + 1) + let g' k old = old >>= g k + it "(>>=) updates" $ property $ \(m :: DivMap Integer) k -> + lookup k (alterWithKey g' k m) `shouldBe` lookup k (updateWithKey g k m) + describe "alterLookupWithKey" $ do + let f k Nothing = Just (unDiv k + 1) + f _ (Just _) = Nothing + it "lookup &&& alterWithKey" $ property $ \(m :: DivMap Integer) k -> + alterLookupWithKey f k m `shouldBe` (lookup k m, alterWithKey f k m) + describe "alterF" $ do + it "Const looks up" $ property $ \(m :: DivMap Integer) k -> + getConst (alterF Const k m) `shouldBe` lookup k m + let f _ = Identity (Just 4) + it "Identity inserts" $ property $ \(m :: DivMap Integer) k -> + lookup k (runIdentity (alterF f k m)) `shouldBe` lookup k (insert k 4 m) + + describe "union" $ do + it "domain" $ property $ \(m1 :: DivMap Integer) m2 k -> + (member k m1 || member k m2) === member k (union m1 m2) + it "left bias" $ property $ \(m1 :: DivMap Integer) m2 k -> + (member k m1 && member k m2) ==> lookup k (union m1 m2) === lookup k m1 + describe "unionWith" $ do + let left l _ = l + it "union == unionWith left" $ property $ \(m1 :: DivMap Integer) m2 k -> + lookup k (union m1 m2) === lookup k (unionWith left m1 m2) + let right _ r = r + it "can have right bias" $ property $ \(m1 :: DivMap Integer) m2 k -> + (member k m1 && member k m2) ==> lookup k (unionWith right m1 m2) === lookup k m2 + describe "unionWithKey" $ do + let left l _ = l + it "unionWith f == unionWithKey (const f)" $ property $ \(m1 :: DivMap Integer) m2 k -> + lookup k (unionWith left m1 m2) === lookup k (unionWithKey (const left) m1 m2) + let merge k l r = unDiv k + l + r + it "can access key" $ property $ \(m1 :: DivMap Integer) m2 k -> + (member k m1 && member k m2) ==> + lookup k (unionWithKey merge m1 m2) === (merge k <$> lookup k m1 <*> lookup k m2) + describe "unions" $ do + it "domain" $ + forAll (vectorOf 10 arbitrary) $ \(ms :: [DivMap Integer]) k -> + any (member k) ms === member k (unions ms) + it "left bias" $ + forAll (vectorOf 10 arbitrary) $ \(ms :: [DivMap Integer]) k -> + lookup k (unions ms) === (List.find (member k) ms >>= lookup k) + describe "unionsWith" $ do + let left l _ = l + it "unions = unionsWith left" $ + forAll (vectorOf 5 arbitrary) $ \(ms :: [DivMap Integer]) k -> + any (member k) ms === member k (unionsWith left ms) + let right _ r = r + it "can have right bias" $ + forAll (vectorOf 5 arbitrary) $ \(ms :: [DivMap Integer]) k -> + lookup k (unionsWith right ms) === (List.find (member k) (reverse ms) >>= lookup k) + + describe "difference" $ + it "domain" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k -> + (member k m1 && member k (difference m1 m2)) ==> not (member k m2) + describe "differenceWith" $ do + it "difference = differenceWith (\\_ _ -> Nothing)" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k -> + lookup k (difference m1 m2) === lookup k (differenceWith (\_ _ -> Nothing) m1 m2) + it "m = differenceWith (\\l _ -> Just l) m _" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k -> + lookup k m1 === lookup k (differenceWith (\l _ -> Just l) m1 m2) + describe "differenceWithKey" $ do + let f l r = Just (l + r) + it "differenceWith f = differenceWithKey (const f)" $ property $ \(m1 :: DivMap Int) (m2 :: DivMap Int) k -> + lookup k (differenceWith f m1 m2) === lookup k (differenceWithKey (const f) m1 m2) + + describe "intersection" $ + it "domain" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k -> + (member k m1 && member k m2) === member k (intersection m1 m2) + describe "intersectionWith" $ do + let left l _ = l + it "intersection = intersectionWith left" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k -> + lookup k (intersection m1 m2) === lookup k (intersectionWith left m1 m2) + describe "intersectionWithKey" $ do + let f = (+) + it "intersectionWith f = intersectionWithKey f" $ property $ \(m1 :: DivMap Int) (m2 :: DivMap Int) k -> + lookup k (intersectionWith f m1 m2) === lookup k (intersectionWithKey (const f) m1 m2) + let merge k l r = unDiv k + l + r + it "can access key" $ property $ \(m1 :: DivMap Integer) m2 k -> + (member k m1 && member k m2) ==> + lookup k (intersectionWithKey merge m1 m2) === (merge k <$> lookup k m1 <*> lookup k m2) + + describe "map" $ do + let f = (+1) + it "map = fmap" $ property $ \(m :: DivMap Int) -> + map f m `shouldBe` fmap f m + describe "mapWithKey" $ do + let f = (+1) + it "mapWithKey (const f) = map f" $ property $ \(m :: DivMap Int) -> + mapWithKey (const f) m `shouldBe` map f m + let g k v = unDiv k + v + it "can access keys" $ property $ \(m :: DivMap Integer) k -> + lookup k (mapWithKey g m) `shouldBe` (unDiv k +) <$> lookup k m + + describe "mapAccum" $ do + let f a b = a + b + let g b = b + 1 + it "mapAccum (\\a b -> (f a b, g b)) acc = foldr f acc &&& map g" $ property $ \(m :: DivMap Integer) -> + mapAccum (\a b -> (f a b, g b)) 0 m `shouldBe` (foldr f 0 &&& map g) m + describe "mapAccumWithKey" $ do + let f a b = (a + b, b + 1) + it "mapAccumWithKey (\\a _ b -> f a b) acc = mapAccum f acc" $ property $ \(m :: DivMap Integer) -> + mapAccumWithKey (\a _ b -> f a b) 0 m `shouldBe` mapAccum f 0 m + + describe "mapKeys" $ do + let f = Div . (+1) . unDiv + it "mapKeys f = fromList . fmap (first f) . toList" $ property $ \(m :: DivMap Integer) -> + mapKeys f m `shouldBe` fromList (fmap (first f) (toList m)) + describe "mapKeysWith" $ do + let f = Div . (\k -> (k `div` 2) + 1) . unDiv + let c = (+) + it "mapKeysWith c f = fromListWith c . fmap (first f) . toList" $ property $ \(m :: DivMap Integer) -> + mapKeysWith c f m `shouldBe` fromListWith c (fmap (first f) (toList m)) + describe "mapKeysMonotonic" $ do + let f = Div . (+1) . unDiv + it "mapKeysMonotonic = mapKeys" $ property $ \(m :: DivMap Integer) -> + mapKeysMonotonic f m `shouldBe` mapKeys f m + + describe "traverseWithKey" $ do + let f old = Identity (old + 1) + it "traverseWithKey (const f) = traverse f" $ property $ \(m :: DivMap Int) -> + runIdentity (traverseWithKey (const f) m) `shouldBe` runIdentity (traverse f m) + describe "traverseMaybeWithKey" $ do + let f k old = Identity (unDiv k + old + 1) + it "traverseMaybeWithKey (\\k v -> Just <$> f k v) = traverseWithKey f" $ property $ \(m :: DivMap Integer) -> + runIdentity (traverseMaybeWithKey (\k v -> Just <$> f k v) m) + `shouldBe` runIdentity (traverseWithKey f m) + + describe "foldrWithKey" $ do + it "foldrWithKey (const f) = foldr f" $ property $ \(m :: DivMap Int) -> + foldrWithKey (const (-)) 0 m `shouldBe` foldr (-) 0 m + let f k a b = unDiv k + a + b + it "foldrWithKey f z = foldr (uncurry f) z . mapWithKey (,)" $ property $ \(m :: DivMap Integer) -> + foldrWithKey f 0 m `shouldBe` foldr (uncurry f) 0 (mapWithKey (,) m) + describe "foldlWithKey" $ do + it "foldlWithKey (\a _ b -> f a b) = foldl f" $ property $ \(m :: DivMap Int) -> + foldlWithKey (\a _ b -> a - b) 0 m `shouldBe` foldl (-) 0 m + let f a k b = unDiv k + a + b + it "foldlWithKey f z = foldl (\a (k, b) -> f a k b) z . mapWithKey (,)" $ property $ \(m :: DivMap Integer) -> + foldlWithKey f 0 m `shouldBe` foldl (\a (k, b) -> f a k b) 0 (mapWithKey (,) m) + describe "foldMapWithKey" $ + it "foldMapWithKey (const f) = foldMap f" $ property $ \(m :: DivMap Int) -> + foldMapWithKey (const Sum) m `shouldBe` foldMap Sum m + + describe "foldr'" $ + it "foldr' = foldr" $ property $ \(m :: DivMap Int) -> + foldr' (-) 0 m `shouldBe` foldr (-) 0 m + describe "foldrWithKey'" $ do + let f k a b = unDiv k + a + b + it "foldrWithKey' = foldrWithKey" $ property $ \(m :: DivMap Integer) -> + foldrWithKey' f 0 m `shouldBe` foldrWithKey f 0 m + describe "foldl'" $ + it "foldl' = foldl" $ property $ \(m :: DivMap Int) -> + foldl' (-) 0 m `shouldBe` foldl (-) 0 m + describe "foldlWithKey'" $ do + let f a k b = unDiv k + a + b + it "foldlWithKey' = foldlWithKey" $ property $ \(m :: DivMap Integer) -> + foldlWithKey' f 0 m `shouldBe` foldlWithKey f 0 m + + describe "keys" $ do + it "length . keys = size" $ property $ \(m :: DivMap Int) -> + length (keys m) `shouldBe` size m + it "all (\\k -> member k m) (keys m)" $ property $ \(m :: DivMap Int) -> + all (`member` m) (keys m) `shouldBe` True + describe "elems" $ + it "foldMap Sum . elems = foldMap Sum" $ property $ \(m :: DivMap Int) -> + foldMap Sum (elems m) `shouldBe` foldMap Sum m + describe "assocs" $ do + it "length . assocs = size" $ property $ \(m :: DivMap Int) -> + length (assocs m) `shouldBe` size m + it "List.lookup k (assocs m) = lookup k m" $ property $ \(m :: DivMap Int) k -> + List.lookup k (assocs m) `shouldBe` lookup k m + + describe "toList" $ do + it "length . toList = size" $ property $ \(m :: DivMap Int) -> + length (toList m) `shouldBe` size m + it "List.lookup k (toList m) = lookup k m" $ property $ \(m :: DivMap Int) k -> + List.lookup k (toList m) `shouldBe` lookup k m + describe "fromList" $ + it "fromList = foldl (\\m (k,v) -> insert k v m) empty" $ property $ \(xs :: [(Divisibility, Int)]) -> + fromList xs `shouldBe` foldl (\m (k,v) -> insert k v m) empty xs + describe "fromListWith" $ do + it "fromListWith const = fromList" $ property $ \(xs :: [(Divisibility, Int)]) -> + fromListWith const xs `shouldBe` fromList xs + let f old new = old + new + it "fromListWith f = fromListWithKey (const f)" $ property $ \(xs :: [(Divisibility, Int)]) -> + fromListWith f xs `shouldBe` fromListWithKey (const f) xs + it "fromListWith f = foldl (\\m (k,v) -> insertWith f k v m) empty" $ property $ \(xs :: [(Divisibility, Int)]) -> + fromListWith f xs `shouldBe` foldl (\m (k,v) -> insertWith f k v m) empty xs + describe "fromListWithKey" $ do + let f k old new = unDiv k + old + new + it "fromListWithKey f = foldl (\\m (k,v) -> insertWithKey f k v m) empty" $ property $ \(xs :: [(Divisibility, Integer)]) -> + fromListWithKey f xs `shouldBe` foldl (\m (k,v) -> insertWithKey f k v m) empty xs + + describe "filter" $ + it "filter p = fromList . filter (p . snd) . toList" $ property $ \(m :: DivMap Int) -> + filter odd m `shouldBe` fromList (List.filter (odd . snd) (toList m)) + describe "filterWithKey" $ do + let p k v = odd (unDiv k + v) + it "filterWithKey p = fromList . filter (uncurry p) . toList" $ property $ \(m :: DivMap Integer) -> + filterWithKey p m `shouldBe` fromList (List.filter (uncurry p) (toList m)) + describe "partition" $ + it "partition p = filter p &&& filter even" $ property $ \(m :: DivMap Int) -> + partition odd m `shouldBe` (filter odd &&& filter even) m + describe "partitionWithKey" $ do + let p k v = odd (unDiv k + v) + it "partitionWithKey p = filterWithKey p &&& filterWithKey ((not .) . p)" $ property $ \(m :: DivMap Integer) -> + partitionWithKey p m `shouldBe` (filterWithKey p &&& filterWithKey ((not .) . p)) m + describe "mapMaybe" $ do + let f v = if odd v then Just (v + 1) else Nothing + it "mapMaybe f = fromList . Maybe.mapMaybe (traverse f) . toList" $ property $ \(m :: DivMap Int) -> + mapMaybe f m `shouldBe` fromList (Maybe.mapMaybe (traverse f) (toList m)) + describe "mapMaybeWithKey" $ do + let f k v = if odd (unDiv k + v) then Just (v + 1) else Nothing + it "mapMaybeWithKey f = fromList . Maybe.mapMaybe (sequenceA . (fst &&& uncurry f)) . toList" $ property $ \(m :: DivMap Integer) -> + mapMaybeWithKey f m `shouldBe` fromList (Maybe.mapMaybe (sequenceA . (fst &&& uncurry f)) (toList m)) + describe "mapEither" $ do + let f v + | odd v = Left (v + 1) + | otherwise = Right (v - 1) + it "mapEither f = (fromList &&& fromList) . Either.partitionEithers . fmap (... f ...) . toList" $ + property $ \(m :: DivMap Int) -> + mapEither f m `shouldBe` + ((fromList *** fromList) + . Either.partitionEithers + . fmap (\(k, v) -> bimap ((,) k) ((,) k) (f v)) + . toList) + m + describe "mapEitherWithKey" $ do + let f k v + | odd (unDiv k + v) = Left (v + 1) + | otherwise = Right (v - 1) + it "mapEitherWithKey f = (fromList &&& fromList) . Either.partitionEithers . fmap (... f ...) . toList" $ + property $ \(m :: DivMap Integer) -> + mapEitherWithKey f m `shouldBe` + ((fromList *** fromList) + . Either.partitionEithers + . fmap (\(k, v) -> bimap ((,) k) ((,) k) (f k v)) + . toList) + m + + describe "isSubmapOf" $ do + it "div100 is submap of div1000" $ + div100 `isSubmapOf` div1000 + it "div1000 is not submap of div100" $ + not (div1000 `isSubmapOf` div100) + describe "isSubmapOfBy" $ do + it "isSubmapOfBy (<) not refl" $ property $ \(m :: DivMap Int) -> + size m > 0 ==> not (isSubmapOfBy (<) m m) + it "isSubmapOfBy (<) m (map (+1) m)" $ property $ \(m :: DivMap Int) -> + isSubmapOfBy (<) m (map (+1) m) + describe "isProperSubmapOf" $ do + it "submap with less size" $ property $ \(m1 :: DivMap Int) m2 -> + (m1 `isProperSubmapOf` m2) `shouldBe` (size m1 < size m2 && m1 `isSubmapOf` m2) + it "div100 is proper submap of div1000" $ + div100 `isProperSubmapOf` div1000 + it "div1000 is not proper submap of div100" $ + not (div1000 `isSubmapOf` div100) + describe "isProperSubmapOfBy" $ + it "not (isProperSubmapOfBy (<) m (map (+1) m))" $ property $ \(m :: DivMap Int) -> + not (isProperSubmapOfBy (<) m (map (+1) m)) + + describe "lookupMin" $ do + it "antichain" $ property $ \(m :: DivMap Int) -> + isAntichain (fmap fst (lookupMin m)) + let less a b = a `leq` b && not (b `leq` a) + it "no element less" $ property $ \(m :: DivMap Int) -> + shouldSatisfy (fmap fst (lookupMin m)) $ \mins -> + all (\k -> not (any (`less` k) (keys m))) mins + describe "lookupMax" $ do + let greater a b = b `leq` a && not (a `leq` b) + it "antichain" $ property $ \(m :: DivMap Int) -> + isAntichain (fmap fst (lookupMax m)) + it "no element greater" $ property $ \(m :: DivMap Int) -> + shouldSatisfy (fmap fst (lookupMax m)) $ \mins -> + all (\k -> not (any (`greater` k) (keys m))) mins + + + describe "type class instances" $ do + describe "Functor" $ + describe "fmap" $ do + it "fmap id = id" $ property $ \(m :: DivMap Int) -> + fmap id m `shouldBe` m + let f = (+1) + let g = (*2) + it "fmap f . fmap g = fmap (f . g)" $ property $ \(m :: DivMap Int) -> + fmap f (fmap g m) `shouldBe` fmap (f . g) m + it "fmaps over all entries" $ property $ \(m :: DivMap Int) k -> + lookup k (fmap (+1) m) `shouldBe` (+1) <$> lookup k m + + describe "Foldable" $ do + describe "foldMap" $ do + it "getSum (foldMap (const (Sum 1))) = size" $ property $ \(m :: DivMap Int) -> + getSum (foldMap (const (Sum 1)) m) `shouldBe` size m + it "foldMap f = fold . fmap f" $ property $ \(m :: DivMap Int) -> + foldMap Sum m `shouldBe` fold (fmap Sum m) + describe "foldr" $ do + let f = (-) + let z = 9000 + it "foldr f z m = appEndo (foldMap (Endo . f) m ) z" $ property $ \(m :: DivMap Int) -> + foldr f z m `shouldBe` appEndo (foldMap (Endo . f) m ) z + describe "foldl" $ do + let f = (-) + let z = 9000 + it "foldl f z m = appEndo (getDual (foldMap (Dual . Endo . flip f) m)) z" $ property $ \(m :: DivMap Int) -> + foldl f z m `shouldBe` appEndo (getDual (foldMap (Dual . Endo . flip f) m)) z + describe "fold" $ + it "fold = foldMap id" $ property $ \(m :: DivMap Int) -> + let m' = coerce m :: DivMap (Sum Int) + in fold m' `shouldBe` foldMap id m' + + describe "Traversable" $ do + describe "traverse" $ do + it "traverse (const (Const (Sum 1))) = size" $ property $ \(m :: DivMap Int) -> + getSum (getConst (traverse (const (Const (Sum 1))) m)) `shouldBe` size m + let f n = replicate (min 2 n) n + let g n = if odd n then Just n else Nothing + let t = Maybe.listToMaybe + it "naturality" $ property $ \(m :: DivMap Int) -> + t (traverse f m) `shouldBe` traverse (t . f) m + it "identity" $ property $ \(m :: DivMap Int) -> + traverse Identity m `shouldBe` Identity m + it "composition" $ property $ \(m :: DivMap Int) -> + traverse (Compose . fmap g . f) m `shouldBe` (Compose . fmap (traverse g) . traverse f) m + describe "sequenceA" $ do + let t = Maybe.listToMaybe + it "naturality" $ property $ \(m :: DivMap [Int]) -> + t (sequenceA m) `shouldBe` sequenceA (fmap t m) + it "identity" $ property $ \(m :: DivMap Int) -> + sequenceA (fmap Identity m) `shouldBe` Identity m + it "composition" $ property $ \(m :: DivMap (Maybe (Maybe Int))) -> + sequenceA (fmap Compose m) `shouldBe` (Compose . fmap sequenceA . sequenceA) m + it "fmap = fmapDefault" $ property $ \(m :: DivMap Int) -> + fmap (+1) m `shouldBe` fmapDefault (+1) m + it "foldMap = foldMapDefault" $ property $ \(m :: DivMap Int) -> + foldMap Sum m `shouldBe` foldMapDefault Sum m
+ tests/Data/POMap/Strictness.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-} +module Data.POMap.Strictness where + +import Data.Function (on) +import Data.Functor.Identity +import qualified Data.List as List +import Data.Ord (comparing) +import Data.POMap.Arbitrary () +import Data.POMap.Divisibility +import qualified Data.POMap.Lazy as L +import qualified Data.POMap.Strict as S +import GHC.Exts (toList) +import Test.ChasingBottoms.IsBottom +import Test.Tasty.Hspec +import Test.Tasty.QuickCheck + +type DivMap v = L.POMap Divisibility v + +instance {-# OVERLAPPING #-} Eq v => Eq (DivMap v) where + (==) = (==) `on` List.sortBy (comparing (unDiv . fst)) . toList + +shouldBeBottom :: a -> Expectation +shouldBeBottom x = isBottom x `shouldBe` True + +shouldNotBeBottom :: a -> Expectation +shouldNotBeBottom x = isBottom x `shouldBe` False + +spec :: Spec +spec = + describe "POMap" $ do + describe "singleton" $ do + it "strict" $ shouldBeBottom (S.singleton (Div 1) bottom) + it "lazy" $ shouldNotBeBottom (L.singleton (Div 1) bottom) + + describe "member" $ + it "strict in the key" $ shouldBeBottom (L.member (Div bottom) L.empty) + describe "lookup" $ + it "strict in the key" $ shouldBeBottom (L.lookup (Div bottom) L.empty) + describe "lookupLT" $ + it "strict in the key" $ shouldBeBottom (L.lookupLT (Div bottom) L.empty) + describe "lookupLE" $ + it "strict in the key" $ shouldBeBottom (L.lookupLE (Div bottom) L.empty) + describe "lookupGT" $ + it "strict in the key" $ shouldBeBottom (L.lookupGT (Div bottom) L.empty) + describe "lookupGE" $ + it "strict in the key" $ shouldBeBottom (L.lookupGE (Div bottom) L.empty) + + let insertTemplate l s = do + it "strict in the key" $ property $ \(m :: DivMap Int) -> + shouldBeBottom (l (Div bottom) 0 m) + it "strict" $ property $ \(m :: DivMap Int) -> + shouldBeBottom (s (Div 1) bottom m) + it "lazy" $ property $ \(m :: DivMap Int) -> + shouldNotBeBottom (l (Div 1) bottom m) + + describe "insert" $ + insertTemplate L.insert S.insert + describe "insertWithKey" $ + insertTemplate (L.insertWithKey (\_ new _ -> new)) (S.insertWithKey (\_ new _ -> new)) + describe "insertLookupWithKey" $ do + let templ impl k v m = snd (impl (\_ new _ -> new) k v m) + insertTemplate (templ L.insertLookupWithKey) (templ S.insertLookupWithKey) + + describe "delete" $ + it "strict in the key" $ property $ \(m :: DivMap Int) -> + shouldBeBottom (L.delete (Div bottom) m) + describe "deleteLookup" $ + it "strict in the key" $ property $ \(m :: DivMap Int) -> + shouldBeBottom (L.deleteLookup (Div bottom) m) + + let adjustTemplate l s = do + it "strict in the key" $ property $ \(m :: DivMap Int) -> + shouldBeBottom (l (const 0) (Div bottom) m) + it "strict" $ + shouldBeBottom (s (const bottom) (Div 1) (L.singleton (Div 1) 1)) + it "lazy" $ property $ \(m :: DivMap Int) -> + shouldNotBeBottom (l (const bottom) (Div 1) m) + let ignoreKey impl f = impl (const f) + + describe "adjust" $ + adjustTemplate L.adjust S.adjust + describe "adjustWithKey" $ + adjustTemplate (ignoreKey L.adjustWithKey) (ignoreKey S.adjustWithKey) + describe "adjustLookupWithKey" $ do + let templ impl f k m = snd (ignoreKey impl f k m) + adjustTemplate (templ L.adjustLookupWithKey) (templ S.adjustLookupWithKey) + + let updateTemplate l s = adjustTemplate (\f -> l (Just . f)) (\f -> s (Just . f)) + + describe "update" $ + updateTemplate L.update S.update + describe "updateWithKey" $ + updateTemplate (ignoreKey L.updateWithKey) (ignoreKey S.updateWithKey) + describe "updateLookupWithKey" $ do + let templ impl f k m = snd (ignoreKey impl f k m) + updateTemplate (templ L.updateLookupWithKey) (templ S.updateLookupWithKey) + + describe "alter" $ + updateTemplate L.alter S.alter + describe "alterWithKey" $ + updateTemplate (ignoreKey L.alterWithKey) (ignoreKey S.alterWithKey) + describe "alterLookupWithKey" $ do + let templ impl f k m = snd (ignoreKey impl f k m) + updateTemplate (templ L.alterLookupWithKey) (templ S.alterLookupWithKey) + describe "alterF" $ do + let insertAt impl k v = impl (const (Identity (Just v))) k + insertTemplate (insertAt L.alterF) (insertAt S.alterF) + + let mapTemplate l s = do + it "strict" $ property $ \(m :: DivMap Int) -> + not (null m) ==> shouldBeBottom (s (const bottom) m) + it "lazy" $ property $ \(m :: DivMap Int) -> + shouldNotBeBottom (l (const bottom) m) + + describe "map" $ + mapTemplate L.map S.map + describe "mapWithKey" $ + mapTemplate (ignoreKey L.mapWithKey) (ignoreKey S.mapWithKey) + describe "mapAccum" $ do + let templ impl f m = snd (impl (const f) undefined m) + mapTemplate (templ L.mapAccum) (templ S.mapAccum) + describe "mapAccumWithKey" $ do + let templ impl f m = snd (impl (\_ _ -> f) undefined m) + mapTemplate (templ L.mapAccumWithKey) (templ S.mapAccumWithKey) + describe "mapKeysWith" $ do + it "strict" $ property $ \(m :: DivMap Int) -> + length m > 1 ==> shouldBeBottom (S.mapKeysWith (\_ _ -> bottom) (const (Div 1)) m) + it "lazy" $ property $ \(m :: DivMap Int) -> + shouldNotBeBottom (L.mapKeysWith (\_ _ -> bottom) (const (Div 1)) m) + describe "mapMaybe" $ do + let templ impl f = impl (Just . f) + mapTemplate (templ L.mapMaybe) (templ S.mapMaybe) + describe "mapMaybeWithKey" $ do + let templ impl f = impl (\_ v -> Just (f v)) + mapTemplate (templ L.mapMaybeWithKey) (templ S.mapMaybeWithKey) + describe "mapEither" $ do + let templ impl f = fst . impl (Left . f) + mapTemplate (templ L.mapEither) (templ S.mapEither) + + describe "traverseWithKey" $ do + let templ impl f = impl (\ _ v -> Identity (f v)) + mapTemplate (templ L.traverseWithKey) (templ S.traverseWithKey) + describe "traverseMaybeWithKey" $ do + let templ impl f = impl (\ _ v -> Identity (Just (f v))) + mapTemplate (templ L.traverseMaybeWithKey) (templ S.traverseMaybeWithKey) + + let fromListTemplate l s = do + it "strict" $ property $ \(xs :: [(Divisibility, Int)]) -> + not (null xs) ==> shouldBeBottom (s (fmap (\ (k, _) -> (k, bottom)) xs)) + it "lazy" $ property $ \(xs :: [(Divisibility, Int)]) -> + shouldNotBeBottom (l (fmap (\(k, _) -> (k, bottom)) xs)) + + describe "fromList" $ + fromListTemplate L.fromList S.fromList + describe "fromListWith" $ + fromListTemplate (L.fromListWith const) (S.fromListWith const) + describe "fromListWithKey" $ + fromListTemplate (L.fromListWithKey (\_ _ v -> v)) (S.fromListWithKey (\_ _ v -> v)) + + describe "type class instances" $ do + describe "Functor" $ do + describe "fmap" $ + it "always lazy" $ property $ \(m :: DivMap Int) -> + shouldNotBeBottom (const bottom <$> m) + describe "<$" $ + it "always lazy" $ property $ \(m :: DivMap Int) -> + shouldNotBeBottom (bottom <$ m) + describe "Traversable" $ + describe "traverse" $ + it "always lazy" $ property $ \(m :: DivMap Int) -> + shouldNotBeBottom (traverse (\_ -> Identity bottom) m)
+ tests/Main.hs view
@@ -0,0 +1,13 @@+import qualified Data.POMap.Properties+import qualified Data.POMap.Strictness+import qualified Test.Tasty+import Test.Tasty.Hspec++main :: IO ()+main = do+ props <- testSpec "properties" (parallel Data.POMap.Properties.spec)+ strict <- testSpec "strictness" (parallel Data.POMap.Strictness.spec)+ Test.Tasty.defaultMain $ Test.Tasty.testGroup "pomaps"+ [ props+ , strict+ ]
+ tests/doctest-driver.hs view
@@ -0,0 +1,5 @@+import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doctest