insert-ordered-containers (empty) → 0.1.0.0
raw patch · 6 files changed
+835/−0 lines, 6 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, base-compat, hashable, insert-ordered-containers, lens, semigroupoids, semigroups, tasty, tasty-quickcheck, text, transformers, unordered-containers
Files
- LICENSE +30/−0
- README.md +3/−0
- Setup.hs +2/−0
- insert-ordered-containers.cabal +68/−0
- src/Data/HashMap/Strict/InsOrd.hs +592/−0
- test/Tests.hs +140/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Oleg Grenrus nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+# insert-ordered-containers++Associative containers retating insertion order for traversals.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ insert-ordered-containers.cabal view
@@ -0,0 +1,68 @@+-- This file has been generated from package.yaml by hpack version 0.8.0.+--+-- see: https://github.com/sol/hpack++name: insert-ordered-containers+version: 0.1.0.0+synopsis: Associative containers retating insertion order for traversals.+description: Associative containers retating insertion order for traversals.+category: Web+homepage: https://github.com/phadej/insert-ordered-containers#readme+bug-reports: https://github.com/phadej/insert-ordered-containers/issues+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD3+license-file: LICENSE+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/phadej/insert-ordered-containers++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <4.9+ , aeson >=0.8.0.2 && <0.12+ , base-compat >=0.6.0 && <0.10+ , hashable >=1.2.3.3 && <1.4+ , lens >=4.7 && <4.14+ , semigroupoids >=4.3 && <5.1+ , semigroups >=0.16.2.2 && <0.19+ , text >=1.2.0.6 && <1.3+ , transformers >=0.3.0.0 && <0.6+ , unordered-containers >=0.2.7.0 && <0.3+ exposed-modules:+ Data.HashMap.Strict.InsOrd+ default-language: Haskell2010++test-suite ins-ord-containers-tests+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <4.9+ , aeson >=0.8.0.2 && <0.12+ , base-compat >=0.6.0 && <0.10+ , hashable >=1.2.3.3 && <1.4+ , lens >=4.7 && <4.14+ , semigroupoids >=4.3 && <5.1+ , semigroups >=0.16.2.2 && <0.19+ , text >=1.2.0.6 && <1.3+ , transformers >=0.3.0.0 && <0.6+ , unordered-containers >=0.2.7.0 && <0.3+ , base+ , insert-ordered-containers+ , tasty >= 0.10.1.2 && <0.12+ , tasty-quickcheck >= 0.8.3.2 && <0.9+ , QuickCheck >=2.7.6 && <2.9+ default-language: Haskell2010
+ src/Data/HashMap/Strict/InsOrd.hs view
@@ -0,0 +1,592 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+-- | 'InsOrdHashMap' is like 'HashMap', but it folds and traverses in insertion order.+--+-- This module interface mimics "Data.HashMap.Strict", with some additions.+module Data.HashMap.Strict.InsOrd (+ InsOrdHashMap,+ -- * Construction+ empty,+ singleton,+ -- * Basic interface+ null,+ size,+ member,+ lookup,+ lookupDefault,+ insert,+ insertWith,+ delete,+ adjust,+ update,+ alter,+ -- * Combine+ union,+ unionWith,+ unionWithKey,+ unions,+ -- * Transformations+ map,+ mapKeys,+ traverseKeys,+ mapWithKey,+ traverseWithKey,+ -- * Difference and intersection+ difference,+ intersection,+ intersectionWith,+ intersectionWithKey,+ -- * Folds+ foldl',+ foldlWithKey',+ foldr,+ foldrWithKey,+ -- * Filter+ filter,+ filterWithKey,+ mapMaybe,+ mapMaybeWithKey,+ -- * Conversions+ keys,+ elems,+ toList,+ toRevList,+ fromList,+ toHashMap,+ fromHashMap,+ -- * Aeson extras+ FromJSONKey(..),+ ToJSONKey(..),+ -- * Lenses+ hashMap,+ unorderedTraversal,+ -- * Debugging+ valid,+ ) where++#ifndef MIN_VERSION_aeson+#define MIN_VERSION_aeson(x,y,z) 0+#endif++import Prelude ()+import Prelude.Compat hiding (filter, foldr, lookup, map, null)++import Control.Arrow (first, second)+import Data.Aeson+import qualified Data.Aeson.Types as Aeson+import Data.Data (Data, Typeable)+import qualified Data.Foldable as F+import Data.Functor.Apply (Apply (..))+import Data.Functor.Bind (Bind (..))+import Data.Hashable (Hashable (..))+import Data.List (sortBy, nub)+import Data.Maybe (fromMaybe)+import Data.Ord (comparing)+import Data.Semigroup (Semigroup (..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified GHC.Exts as Exts+import Text.ParserCombinators.ReadPrec (prec)+import Text.Read (Lexeme (..), Read (..), lexP,+ parens, readListPrecDefault,+ readMaybe)++import Control.Lens (At (..), FoldableWithIndex,+ FunctorWithIndex, Index, Iso, IxValue,+ Ixed (..), TraversableWithIndex (..),+ Traversal, iso, (<&>), _1, _2)+import Control.Monad.Trans.State.Strict (State, runState, state)++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap++import Debug.Trace++-------------------------------------------------------------------------------+-- Strict Pair Int a+-------------------------------------------------------------------------------++data P a = P !Int !a+ deriving (Functor, Foldable, Traversable, Typeable, Data)++getPK :: P a -> Int+getPK (P i _) = i+{-# INLINABLE getPK #-}++getPV :: P a -> a+getPV (P _ a) = a+{-# INLINABLE getPV #-}++incPK :: Int -> P a -> P a+incPK i (P j x) = P (i + j) x+{-# INLINABLE incPK #-}++instance Eq a => Eq (P a) where+ P _ a == P _ b = a == b++instance Show a => Show (P a) where+ showsPrec d (P _ x) = showsPrec d x++instance Hashable a => Hashable (P a) where+ hashWithSalt salt (P _ x) = hashWithSalt salt x++-------------------------------------------------------------------------------+-- InsOrdHashMap+-------------------------------------------------------------------------------++-- | 'HashMap' which tries it's best to remember insertion order of elements.++data InsOrdHashMap k v = InsOrdHashMap+ { _getIndex :: !Int+ , getInsOrdHashMap :: !(HashMap k (P v))+ }+ deriving (Functor, Typeable, Data)++instance (Eq k, Eq v) => Eq (InsOrdHashMap k v) where+ InsOrdHashMap _ a == InsOrdHashMap _ b = a == b++instance (Show k, Show v) => Show (InsOrdHashMap k v) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . showsPrec 11 (toList m)++instance (Eq k, Hashable k, Read k, Read v) => Read (InsOrdHashMap k v) where+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault++instance (Eq k, Hashable k) => Semigroup (InsOrdHashMap k v) where+ (<>) = union++instance (Eq k, Hashable k) => Monoid (InsOrdHashMap k v) where+ mempty = empty+ mappend = union++-- We cannot derive this, as we want to ordered folding and traversing+instance Foldable (InsOrdHashMap k) where+ -- in newer base only+ -- length = length . getInsOrdHashMap+ foldMap f = foldMap (f . snd) . toList++#if MIN_VERSION_base(4,8,0)+ null = null+ toList = elems+ length = size+#endif++instance Traversable (InsOrdHashMap k) where+ traverse f (InsOrdHashMap i m) =+ InsOrdHashMap i <$> (traverse . traverse) f m++instance (Eq k, Hashable k) => Apply (InsOrdHashMap k) where+ (<.>) = intersectionWith id+ (<. ) = intersectionWith const+ ( .>) = intersectionWith (const id)++instance (Eq k, Hashable k) => Bind (InsOrdHashMap k) where+ m >>- f = mapMaybeWithKey (\k -> lookup k . f) m++-- | @hashWithSalt salt . toHashMap = hashWithSalt salt@.+instance (Hashable k, Hashable v) => Hashable (InsOrdHashMap k v) where+ hashWithSalt salt (InsOrdHashMap _ m) =+ hashWithSalt salt m++instance (Eq k, Hashable k) => Exts.IsList (InsOrdHashMap k v) where+ type Item (InsOrdHashMap k v) = (k, v)+ fromList = fromList+ toList = toList++-------------------------------------------------------------------------------+-- Aeson+-------------------------------------------------------------------------------++class ToJSONKey a where+ toJSONKey :: a -> Text+ + -- | Default implementations picks first element, if exists;+ -- otherwise evaluates to @""@.+ toJSONKeyList :: [a] -> Text+ toJSONKeyList [] = T.empty+ toJSONKeyList (x:_) = toJSONKey x++instance ToJSONKey Char where+ toJSONKey c = T.singleton c+ toJSONKeyList = T.pack++instance ToJSONKey Int where+ toJSONKey = T.pack . show++instance ToJSONKey a => ToJSONKey [a] where+ toJSONKey = toJSONKeyList++instance ToJSONKey Text where+ toJSONKey = id++instance (ToJSONKey k, ToJSON v, Show k, Show v) => ToJSON (InsOrdHashMap k v) where+ toJSON = object . fmap f . toList+ where+ f (k, v) = traceShow "foo" $ toJSONKey k .= v++#if MIN_VERSION_aeson(0,10,0)+ toEncoding = pairs . mconcat . fmap f . traceShowId . toList+ where+ f (k, v) = toJSONKey k .= v+#endif++-------------------------------------------------------------------------------++-- | See https://github.com/bos/aeson/pull/341+class FromJSONKey a where+ parseJSONKey :: Text -> Aeson.Parser a++ -- | Default implementation parses into singleton list. 'String' @:(@+ parseJSONKeyList :: Text -> Aeson.Parser [a]+ parseJSONKeyList t = (:[]) <$> parseJSONKey t++instance FromJSONKey Char where+ parseJSONKey t = case T.uncons t of+ Just (c, r) | T.null r -> pure c+ _ -> fail $ "Non-singleton json key for Char: " ++ T.unpack t+ parseJSONKeyList = pure . T.unpack++instance FromJSONKey Int where+ parseJSONKey t = maybe (fail "Cannot parse Int key") return $+ readMaybe $ T.unpack t++instance FromJSONKey a => FromJSONKey [a] where+ parseJSONKey = parseJSONKeyList++instance FromJSONKey Text where+ parseJSONKey = pure++instance (Eq k, Hashable k, FromJSONKey k, FromJSON v) => FromJSON (InsOrdHashMap k v) where+ parseJSON = withObject "OrdHasMap k v" $ \obj ->+ fmap fromList $ traverse f $ HashMap.toList obj+ where f (k, v) = (,) <$> parseJSONKey k <*> parseJSON v++-------------------------------------------------------------------------------+-- Lens+-------------------------------------------------------------------------------++type instance Index (InsOrdHashMap k v) = k+type instance IxValue (InsOrdHashMap k v) = v++instance (Eq k, Hashable k) => Ixed (InsOrdHashMap k v) where+ ix k f m = case lookup k m of+ Just v -> f v <&> \v' -> insert k v' m+ Nothing -> pure m+ {-# INLINABLE ix #-}++instance (Eq k, Hashable k) => At (InsOrdHashMap k a) where+ at k f m = f mv <&> \r -> case r of+ Nothing -> maybe m (const (delete k m)) mv+ Just v' -> insert k v' m+ where mv = lookup k m+ {-# INLINABLE at #-}++instance (Eq k, Hashable k) => FunctorWithIndex k (InsOrdHashMap k)+instance (Eq k, Hashable k) => FoldableWithIndex k (InsOrdHashMap k)+instance (Eq k, Hashable k) => TraversableWithIndex k (InsOrdHashMap k) where+ itraverse = traverseWithKey++-- | This is a slight lie, as roundtrip doesn't preserve ordering.+hashMap :: Iso (InsOrdHashMap k a) (InsOrdHashMap k b) (HashMap k a) (HashMap k b)+hashMap = iso toHashMap fromHashMap++unorderedTraversal :: Traversal (InsOrdHashMap k a) (InsOrdHashMap k b) a b+unorderedTraversal = hashMap . traverse++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++empty :: InsOrdHashMap k v+empty = InsOrdHashMap 0 HashMap.empty+{-# INLINABLE empty #-}++singleton :: Hashable k => k -> v -> InsOrdHashMap k v+singleton k v = InsOrdHashMap 1 (HashMap.singleton k (P 0 v))+{-# INLINABLE singleton #-}++-------------------------------------------------------------------------------+-- Basic interface+-------------------------------------------------------------------------------++null :: InsOrdHashMap k v -> Bool+null = HashMap.null . getInsOrdHashMap+{-# INLINABLE null #-}++size :: InsOrdHashMap k v -> Int+size = HashMap.size . getInsOrdHashMap+{-# INLINABLE size #-}++member :: (Eq k, Hashable k) => k -> InsOrdHashMap k a -> Bool+member k = HashMap.member k . getInsOrdHashMap+{-# INLINABLE member #-}++lookup :: (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v+lookup k = fmap getPV . HashMap.lookup k . getInsOrdHashMap+{-# INLINABLE lookup #-}++lookupDefault+ :: (Eq k, Hashable k)+ => v -- ^ Default value to return.+ -> k -> InsOrdHashMap k v -> v+lookupDefault def k m = fromMaybe def $ lookup k m+{-# INLINABLE lookupDefault #-}++delete :: (Eq k, Hashable k) => k -> InsOrdHashMap k v -> InsOrdHashMap k v+delete k (InsOrdHashMap i m) = InsOrdHashMap i $ HashMap.delete k m+{-# INLINABLE delete #-}++insert :: (Eq k, Hashable k) => k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v+insert = insertWith const+{-# INLINABLE insert #-}++insertWith+ :: (Eq k, Hashable k)+ => (v -> v -> v) -> k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v+insertWith f k v = alter (Just . maybe v (f v)) k+{-# INLINABLE insertWith #-}++adjust+ :: (Eq k, Hashable k)+ => (v -> v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v+adjust f = alter (fmap f)+{-# INLINABLE adjust #-}++update+ :: (Eq k, Hashable k)+ => (a -> Maybe a) -> k -> InsOrdHashMap k a -> InsOrdHashMap k a+update f = alter (>>= f)+{-# INLINABLE update #-}++alter+ :: (Eq k, Hashable k)+ => (Maybe v -> Maybe v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v+alter f k insm@(InsOrdHashMap j m) =+ case HashMap.lookup k m of+ Nothing -> case f Nothing of+ Nothing -> insm+ Just v -> InsOrdHashMap (j + 1) (HashMap.insert k (P j v) m)+ Just (P i v) -> case f (Just v) of+ Nothing -> InsOrdHashMap j (HashMap.delete k m)+ Just u -> InsOrdHashMap j (HashMap.insert k (P i u) m)+{-# INLINABLE alter #-}++-------------------------------------------------------------------------------+-- Combine+-------------------------------------------------------------------------------++-- | The union of two maps. If a key occurs in both maps,+-- the provided function (first argument) will be used to compute the result.+--+-- Ordered traversal will go thru keys in the first map first.+unionWith+ :: (Eq k, Hashable k)+ => (v -> v -> v)+ -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+unionWith f (InsOrdHashMap i a) (InsOrdHashMap j b) =+ InsOrdHashMap (i + j) $ HashMap.unionWith f' a b'+ where+ b' = fmap (incPK i) b+ f' (P ii x) (P _ y) = P ii (f x y)++unionWithKey+ :: (Eq k, Hashable k)+ => (k -> v -> v -> v)+ -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+unionWithKey f (InsOrdHashMap i a) (InsOrdHashMap j b) =+ InsOrdHashMap (i + j) $ HashMap.unionWithKey f' a b'+ where+ b' = fmap (incPK i) b+ f' k (P ii x) (P _ y) = P ii (f k x y)++union+ :: (Eq k, Hashable k)+ => InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+union = unionWith const++unions+ :: (Eq k, Hashable k, Foldable f)+ => f (InsOrdHashMap k v) -> InsOrdHashMap k v+unions = F.foldl' union empty++-------------------------------------------------------------------------------+-- Transformations+-------------------------------------------------------------------------------++-- | Order preserving mapping of keys.+mapKeys :: (Eq k', Hashable k') => (k -> k') -> InsOrdHashMap k v -> InsOrdHashMap k' v+mapKeys f (InsOrdHashMap i m) = InsOrdHashMap i $+ HashMap.fromList . fmap (first f) . HashMap.toList $ m++traverseKeys+ :: (Eq k', Hashable k', Applicative f)+ => (k -> f k') -> InsOrdHashMap k v -> f (InsOrdHashMap k' v)+traverseKeys f (InsOrdHashMap i m) = InsOrdHashMap i . HashMap.fromList <$>+ (traverse . _1) f (HashMap.toList m)++map :: (v1 -> v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2+map = fmap++mapWithKey :: (k -> v1 -> v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2+mapWithKey f (InsOrdHashMap i m) =+ InsOrdHashMap i $ HashMap.mapWithKey f' m+ where+ f' k (P j x) = P j (f k x)++traverseWithKey :: Applicative f => (k -> a -> f b) -> InsOrdHashMap k a -> f (InsOrdHashMap k b)+traverseWithKey f (InsOrdHashMap i m) =+ InsOrdHashMap i <$> HashMap.traverseWithKey f' m+ where+ f' k (P j x) = P j <$> f k x++-------------------------------------------------------------------------------+-- Difference and intersection+-------------------------------------------------------------------------------++difference+ :: (Eq k, Hashable k)+ => InsOrdHashMap k v -> InsOrdHashMap k w -> InsOrdHashMap k v+difference (InsOrdHashMap i a) (InsOrdHashMap _ b) =+ InsOrdHashMap i $ HashMap.difference a b++intersection+ :: (Eq k, Hashable k)+ => InsOrdHashMap k v -> InsOrdHashMap k w -> InsOrdHashMap k v+intersection = intersectionWith const++intersectionWith+ :: (Eq k, Hashable k)+ => (v1 -> v2 -> v3)+ -> InsOrdHashMap k v1 -> InsOrdHashMap k v2 -> InsOrdHashMap k v3+intersectionWith f = intersectionWithKey (\_ -> f)++intersectionWithKey+ :: (Eq k, Hashable k)+ => (k -> v1 -> v2 -> v3)+ -> InsOrdHashMap k v1 -> InsOrdHashMap k v2 -> InsOrdHashMap k v3+intersectionWithKey f (InsOrdHashMap i a) (InsOrdHashMap _ b) =+ InsOrdHashMap i $ HashMap.intersectionWithKey f' a b+ where+ f' k (P j x) (P _ y) = P j (f k x y)++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++foldl' :: (a -> v -> a) -> a -> InsOrdHashMap k v -> a+foldl' f x = F.foldl' f' x . toList+ where+ f' a (_, v) = f a v++foldlWithKey' :: (a -> k -> v -> a) -> a -> InsOrdHashMap k v -> a+foldlWithKey' f x = F.foldl' f' x . toList+ where+ f' a (k, v) = f a k v++foldr :: (v -> a -> a) -> a -> InsOrdHashMap k v -> a+foldr f x = F.foldr f' x . toList+ where+ f' (_, v) a = f v a++foldrWithKey :: (k -> v -> a -> a) -> a -> InsOrdHashMap k v -> a+foldrWithKey f x = F.foldr f' x . toList+ where+ f' (k, v) a = f k v a++-------------------------------------------------------------------------------+-- Filter+-------------------------------------------------------------------------------++filter :: (v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v+filter f (InsOrdHashMap i m) =+ InsOrdHashMap i $ HashMap.filter (f . getPV) m++filterWithKey :: (k -> v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v+filterWithKey f (InsOrdHashMap i m) =+ InsOrdHashMap i $ HashMap.filterWithKey f' m+ where+ f' k (P _ x) = f k x++mapMaybe :: (v1 -> Maybe v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2+mapMaybe f (InsOrdHashMap i m) = InsOrdHashMap i $ HashMap.mapMaybe f' m+ where+ f' (P j x) = P j <$> f x++mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2+mapMaybeWithKey f (InsOrdHashMap i m) =+ InsOrdHashMap i $ HashMap.mapMaybeWithKey f' m+ where+ f' k (P j x) = P j <$> f k x++-------------------------------------------------------------------------------+-- Conversions+-------------------------------------------------------------------------------++keys :: InsOrdHashMap k v -> [k]+keys = fmap fst . toList+{-# INLINABLE keys #-}++elems :: InsOrdHashMap k v -> [v]+elems = fmap snd . toList+{-# INLINABLE elems #-}++fromList :: forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v+fromList+ = mk+ . flip runState 0+ . (traverse . _2) newP+ where+ mk :: ([(k, P v)], Int) -> InsOrdHashMap k v+ mk (m, i) = InsOrdHashMap i (HashMap.fromList m)++toList :: InsOrdHashMap k v -> [(k, v)]+toList+ = fmap (second getPV)+ . sortBy (comparing (getPK . snd))+ . HashMap.toList+ . getInsOrdHashMap++toRevList :: InsOrdHashMap k v -> [(k, v)]+toRevList+ = fmap (second getPV)+ . sortBy (flip $ comparing (getPK . snd))+ . HashMap.toList+ . getInsOrdHashMap++fromHashMap :: HashMap k v -> InsOrdHashMap k v+fromHashMap = mk . flip runState 0 . traverse newP+ where+ mk (m, i) = InsOrdHashMap i m++toHashMap :: InsOrdHashMap k v -> HashMap k v+toHashMap (InsOrdHashMap _ m) = fmap getPV m++-------------------------------------------------------------------------------+-- Internal+-------------------------------------------------------------------------------++-- | Test if the internal map structure is valid.+valid :: InsOrdHashMap k v -> Bool+valid (InsOrdHashMap i m) = indexesDistinct && indexesSmaller+ where+ indexes :: [Int]+ indexes = getPK <$> HashMap.elems m++ indexesDistinct = indexes == nub indexes+ indexesSmaller = all (< i) indexes++newP :: a -> State Int (P a)+newP x = state $ \s -> (P s x, s + 1)
+ test/Tests.hs view
@@ -0,0 +1,140 @@+module Main (main) where++import Prelude ()+import Prelude.Compat++import Data.Function (on)+import Data.Hashable (Hashable (..))+import Data.List (nubBy)+import Data.Semigroup ((<>))+import Data.Word (Word8)+import Text.Read (readMaybe)++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashMap.Strict.InsOrd as InsOrd++import Test.QuickCheck.Function+import Test.Tasty+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain $ testGroup "Properties" $+ [ testProperty "toList . fromList ~= id" $ toListFromList+ , testProperty "toList distributes over mappend" $ toListMappendDistribute+ , testProperty "behaves like HashMap" $ operationModel+ , testProperty "valid" $ validProperty+ , testProperty "Hashable agree" $ hashableProperty+ , testProperty "aeson roundtrip" $ aesonRoundtrip+ , testProperty "show . read = id" showReadRoundtrip+ ]++toListFromList :: [(Int, Int)] -> Property+toListFromList l = l' === InsOrd.toList (InsOrd.fromList l)+ where l' = reverse . nubBy (on (==) fst) . reverse $ l++toListMappendDistribute :: [(Int, Int)] -> [(Int, Int)] -> Property+toListMappendDistribute a b = rhs === lhs+ where+ a' = InsOrd.fromList a+ b' = foldr InsOrd.delete (InsOrd.fromList b) (InsOrd.keys a')+ rhs = InsOrd.toList (a' <> b')+ lhs = InsOrd.toList a' <> InsOrd.toList b'++-------------------------------------------------------------------------------+-- Model+-------------------------------------------------------------------------------++data Operation k v+ = FromList [(k, v)]+ | Empty+ | Singleton k v+ | Insert k v (Operation k v)+ | Delete k (Operation k v)+ | Union (Operation k v) (Operation k v)+ | Difference (Operation k v) (Operation k v)+ | Intersection (Operation k v) (Operation k v)+ | Filter (Fun v Bool) (Operation k v)+ deriving (Show)++instance (Arbitrary k, Arbitrary v, Function v, CoArbitrary v) => Arbitrary (Operation k v) where+ arbitrary = sized a+ where+ term =+ [ FromList <$> arbitrary+ , pure Empty+ , Singleton <$> arbitrary <*> arbitrary+ ]+ a 0 = oneof term+ a n = oneof $ term +++ [ Insert <$> arbitrary <*> arbitrary <*> aMinus1+ , Delete <$> arbitrary <*> aMinus1+ , Union <$> aDiv2 <*> aDiv2+ , Difference <$> aDiv2 <*> aDiv2+ , Intersection <$> aDiv2 <*> aDiv2+ , Filter <$> arbitrary <*> aMinus1+ ]+ where+ aMinus1 = a (n - 1)+ aDiv2 = a (n `div` 2)++evalOpInsOrd+ :: (Eq k, Hashable k)+ => Operation k v -> InsOrd.InsOrdHashMap k v+evalOpInsOrd op = case op of+ FromList l -> InsOrd.fromList l+ Empty -> InsOrd.empty+ Singleton k v -> InsOrd.singleton k v+ Insert k v a -> InsOrd.insert k v (evalOpInsOrd a)+ Delete k a -> InsOrd.delete k (evalOpInsOrd a)+ Union a b -> InsOrd.union (evalOpInsOrd a) (evalOpInsOrd b)+ Difference a b -> InsOrd.difference (evalOpInsOrd a) (evalOpInsOrd b)+ Intersection a b -> InsOrd.intersection (evalOpInsOrd a) (evalOpInsOrd b)+ Filter (Fun _ f) a -> InsOrd.filter f (evalOpInsOrd a)++evalOpHashMap+ :: (Eq k, Hashable k)+ => Operation k v-> HashMap.HashMap k v+evalOpHashMap op = case op of+ FromList l -> HashMap.fromList l+ Empty -> HashMap.empty+ Singleton k v -> HashMap.singleton k v+ Insert k v a -> HashMap.insert k v (evalOpHashMap a)+ Delete k a -> HashMap.delete k (evalOpHashMap a)+ Union a b -> HashMap.union (evalOpHashMap a) (evalOpHashMap b)+ Difference a b -> HashMap.difference (evalOpHashMap a) (evalOpHashMap b)+ Intersection a b -> HashMap.intersection (evalOpHashMap a) (evalOpHashMap b)+ Filter (Fun _ f) a -> HashMap.filter f (evalOpHashMap a)++operationModel :: Operation Word8 Int -> Property+operationModel op = rhs === lhs+ where+ iom = evalOpInsOrd op+ lhs = InsOrd.toHashMap iom+ rhs = evalOpHashMap op++validProperty :: Operation Word8 Int -> Property+validProperty op = property $ InsOrd.valid iom+ where+ iom = evalOpInsOrd op++hashableProperty :: Operation Word8 Int -> Int -> Property+hashableProperty op salt = rhs === lhs+ where+ iom = evalOpInsOrd op+ lhs = hashWithSalt salt $ iom+ rhs = hashWithSalt salt $ evalOpHashMap op++aesonRoundtrip :: Operation Int Int -> Property+aesonRoundtrip op = rhs === lhs+ where+ iom = evalOpInsOrd op+ rhs = Right iom + lhs = Aeson.eitherDecode $ Aeson.encode iom++showReadRoundtrip :: Operation Word8 Int -> Property+showReadRoundtrip op = rhs === lhs+ where+ iom = evalOpInsOrd op+ rhs = Just iom+ lhs = readMaybe $ show iom