pomaps 0.0.1.0 → 0.0.2.0
raw patch · 13 files changed
+3845/−3777 lines, 13 files
Files
- CHANGELOG.md +7/−7
- bench/Main.hs +77/−77
- lattices/Algebra/PartialOrd.hs +154/−154
- pomaps.cabal +1/−1
- src/Data/POMap/Internal.hs +1343/−1304
- src/Data/POMap/Lazy.hs +665/−655
- src/Data/POMap/Strict.hs +678/−668
- src/Data/POSet.hs +117/−117
- stack.yaml +63/−63
- tests/Data/POMap/Properties.hs +550/−540
- tests/Data/POMap/Strictness.hs +172/−173
- tests/Main.hs +13/−13
- tests/doctest-driver.hs +5/−5
CHANGELOG.md view
@@ -1,7 +1,7 @@-# Change log--`pomaps` follows the [PVP][1].-The change log is available [on GitHub][2].--[1]: https://pvp.haskell.org/-[2]: https://github.com/sgraf812/pomaps/releases+# Change log + +`pomaps` follows the [PVP][1]. +The change log is available [on GitHub][2]. + +[1]: https://pvp.haskell.org/ +[2]: https://github.com/sgraf812/pomaps/releases
bench/Main.hs view
@@ -1,77 +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]- ]- ]+{-# 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
@@ -1,154 +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+{-# 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
@@ -1,5 +1,5 @@ name: pomaps-version: 0.0.1.0+version: 0.0.2.0 synopsis: Maps and sets of partial orders category: Data Structures homepage: https://github.com/sgraf812/pomaps#readme
src/Data/POMap/Internal.hs view
@@ -1,1304 +1,1343 @@-{-# 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 - fromListImpl (proxy# :: Proxy# 'Lazy) <$> readPrec - - 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 - --- | \(\mathcal{O}(log n)\). Take while a predicate on the keys holds. --- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, --- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. --- --- @ --- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k) --- @ --- --- @since 0.0.1.0 -takeWhileAntitone :: (k -> Bool) -> POMap k v -> POMap k v -takeWhileAntitone p = mkPOMap . fmap (Map.Strict.takeWhileAntitone p) . chainDecomposition - --- | \(\mathcal{O}(log n)\). Drop while a predicate on the keys holds. --- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, --- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. --- --- @ --- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k)) --- @ --- --- @since 0.0.1.0 -dropWhileAntitone :: (k -> Bool) -> POMap k v -> POMap k v -dropWhileAntitone p = mkPOMap . fmap (Map.Strict.dropWhileAntitone p) . chainDecomposition - --- | \(\mathcal{O}(log n)\). Divide a map at the point where a predicate on the keys stops holding. --- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, --- @j \< k ==\> p j \>= p k@. --- --- @ --- spanAntitone p xs = 'partitionWithKey' (\k _ -> p k) xs --- @ --- --- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map --- at some /unspecified/ point where the predicate switches from holding to not --- holding (where the predicate is seen to hold before the first key and to fail --- after the last key). --- --- @since 0.0.1.0 -spanAntitone :: (k -> Bool) -> POMap k v -> (POMap k v, POMap k v) -spanAntitone p = (mkPOMap *** mkPOMap) . unzip . fmap (Map.Strict.spanAntitone p) . chainDecomposition - -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 #-} +{-# 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.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+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+ fromListImpl (proxy# :: Proxy# 'Lazy) <$> readPrec++ 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++-- | \(\mathcal{O}(w^2n)\).+-- Return all key\/value pairs in the map such that+-- @map fst (toLinearisation m)@ is a /linearisation/ of the all keys present in+-- the map.+-- E.g., for any key @k1@ occuring before @k2@ in the linearisation, it+-- cannot happen that @k1@ is strictly greater than @k2@ (so they are either+-- incomparable or @k1 <= k2@).+toLinearisation :: PartialOrd k => POMap k v -> [(k, v)]+-- TODO: fusion? I'm not sure it's possible due to @dedupAntichain@+toLinearisation = concatLevels . fmap Map.toAscList . chainDecomposition+ where+ concatLevels [] = []+ concatLevels chains+ | (sinks, chains') <- findSinks chains+ = sinks ++ concatLevels chains'++ findSinks chains =+ let nonEmpties = Maybe.mapMaybe NonEmpty.nonEmpty chains+ heads = NonEmpty.head <$> nonEmpties+ sinks = dedupAntichain LessThan heads+ chains' = deleteHead sinks <$> nonEmpties+ in (sinks, chains')++ deleteHead sinks (cur@(k, _) :| chain)+ | Just _ <- List.lookup k sinks = chain+ | otherwise = cur:chain+{-# INLINABLE toLinearisation #-}++fromLinearisation :: (PartialOrd k, SingIAreWeStrict s) => Proxy# s -> [(k, v)] -> POMap k v+-- TODO: We could possibly take advantage by using fromAscList to construct the+-- chains in O(wn), but I don't know of a good way to split into anti-chains+-- before.+fromLinearisation = fromListImpl+{-# INLINABLE fromLinearisation #-}+{-# SPECIALIZE fromLinearisation :: PartialOrd k => Proxy# 'Strict -> [(k, v)] -> POMap k v #-}+{-# SPECIALIZE fromLinearisation :: PartialOrd k => Proxy# 'Lazy -> [(k, v)] -> POMap k v #-}++-- 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++-- | \(\mathcal{O}(\log n)\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k)+-- @+--+-- @since 0.0.1.0+takeWhileAntitone :: (k -> Bool) -> POMap k v -> POMap k v+takeWhileAntitone p = mkPOMap . fmap (Map.Strict.takeWhileAntitone p) . chainDecomposition++-- | \(\mathcal{O}(\log n)\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k))+-- @+--+-- @since 0.0.1.0+dropWhileAntitone :: (k -> Bool) -> POMap k v -> POMap k v+dropWhileAntitone p = mkPOMap . fmap (Map.Strict.dropWhileAntitone p) . chainDecomposition++-- | \(\mathcal{O}(log n)\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = 'partitionWithKey' (\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point where the predicate switches from holding to not+-- holding (where the predicate is seen to hold before the first key and to fail+-- after the last key).+--+-- @since 0.0.1.0+spanAntitone :: (k -> Bool) -> POMap k v -> (POMap k v, POMap k v)+spanAntitone p = (mkPOMap *** mkPOMap) . unzip . fmap (Map.Strict.spanAntitone p) . chainDecomposition++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
@@ -1,655 +1,665 @@-{-# 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 - - , Impl.takeWhileAntitone - , Impl.dropWhileAntitone - , Impl.spanAntitone - - , 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 #-} +{-# 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+ , Impl.toLinearisation+ , fromLinearisation++ -- * Filter+ , Impl.filter+ , Impl.filterWithKey++ , Impl.partition+ , Impl.partitionWithKey++ , Impl.takeWhileAntitone+ , Impl.dropWhileAntitone+ , Impl.spanAntitone++ , 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}(wn\log n)\).+-- Build a map from a linearisation of key\/value pairs.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromLinearisation :: PartialOrd k => [(k, v)] -> POMap k v+fromLinearisation = Impl.fromLinearisation (proxy# :: Proxy# 'Lazy)+{-# INLINE fromLinearisation #-}++-- | \(\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
@@ -1,668 +1,678 @@-{-# 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 - - , Impl.takeWhileAntitone - , Impl.dropWhileAntitone - , Impl.spanAntitone - - , 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 #-} +{-# 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+ , Impl.toLinearisation+ , fromLinearisation++ -- * Filter+ , Impl.filter+ , Impl.filterWithKey++ , Impl.partition+ , Impl.partitionWithKey++ , Impl.takeWhileAntitone+ , Impl.dropWhileAntitone+ , Impl.spanAntitone++ , 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}(wn\log n)\).+-- Build a map from a linearisation of key\/value pairs.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromLinearisation :: PartialOrd k => [(k, v)] -> POMap k v+fromLinearisation = Impl.fromLinearisation (proxy# :: Proxy# 'Strict)+{-# INLINE fromLinearisation #-}++-- | \(\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
@@ -1,117 +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+-- | +-- 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
stack.yaml view
@@ -1,63 +1,63 @@-# 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-11.1--# 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: []--# 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+# 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-12.7 + +# 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: [] + +# 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/Properties.hs view
@@ -1,540 +1,550 @@-{-# 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.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.sortOn (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.sortOn (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 "takeWhileAntitone" $ do - let p k = unDiv k < 50 - it "takeWhileAntitone p = filterWithKey (\\k _ -> p k)" $ property $ \(m :: DivMap Int) -> - takeWhileAntitone p m `shouldBe` filterWithKey (\k _ -> p k) m - describe "dropWhileAntitone" $ do - let p k = unDiv k < 50 - it "dropWhileAntitone p = filterWithKey (\\k _ -> not (p k))" $ property $ \(m :: DivMap Int) -> - dropWhileAntitone p m `shouldBe` filterWithKey (\k _ -> not (p k)) m - describe "spanAntitone" $ do - let p k = unDiv k < 50 - it "spanAntitone p = partitionWithKey (\\k _ -> p k)" $ property $ \(m :: DivMap Int) -> - spanAntitone p m `shouldBe` partitionWithKey (\k _ -> p k) 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 +{-# 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.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.sortOn (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.sortOn (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 "toLinearisation" $ do+ it "fromList . toLinearisation = id" $ property $ \(m :: DivMap Int) ->+ fromList (toLinearisation m) `shouldBe` m+ it "is a linearisation" $ property $ \(m :: DivMap Int) -> do+ let lin = toLinearisation m+ let greqs = zipWith (\(k1, _) (k2, _) -> (k2 `leq` k1) && k1 /= k2) lin (drop 1 lin)+ or greqs `shouldBe` False+ describe "fromLinearisation" $+ it "fromLinearisation . toLinearisation = id" $ property $ \(m :: DivMap Int) ->+ fromLinearisation (toLinearisation m) `shouldBe` m++ 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 "takeWhileAntitone" $ do+ let p k = unDiv k < 50+ it "takeWhileAntitone p = filterWithKey (\\k _ -> p k)" $ property $ \(m :: DivMap Int) ->+ takeWhileAntitone p m `shouldBe` filterWithKey (\k _ -> p k) m+ describe "dropWhileAntitone" $ do+ let p k = unDiv k < 50+ it "dropWhileAntitone p = filterWithKey (\\k _ -> not (p k))" $ property $ \(m :: DivMap Int) ->+ dropWhileAntitone p m `shouldBe` filterWithKey (\k _ -> not (p k)) m+ describe "spanAntitone" $ do+ let p k = unDiv k < 50+ it "spanAntitone p = partitionWithKey (\\k _ -> p k)" $ property $ \(m :: DivMap Int) ->+ spanAntitone p m `shouldBe` partitionWithKey (\k _ -> p k) 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
@@ -1,173 +1,172 @@-{-# 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.sortOn (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) +{-# 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.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.sortOn (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
@@ -1,13 +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- ]+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
@@ -1,5 +1,5 @@-import System.FilePath.Glob (glob)-import Test.DocTest (doctest)--main :: IO ()-main = glob "src/**/*.hs" >>= doctest+import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doctest