identifiers 0.2.1.0 → 0.3.0.0
raw patch · 6 files changed
+381/−14 lines, 6 filesdep +ListLikedep +textdep ~base
Dependencies added: ListLike, text
Dependency ranges changed: base
Files
- bench/Identifiers.hs +36/−0
- bench/IdentifiersListLike.hs +36/−0
- identifiers.cabal +40/−7
- src/Data/Identifiers/ListLike.hs +151/−0
- src/Data/TrieMap.hs +103/−0
- test/TestAll.hs +15/−7
+ bench/Identifiers.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.DeepSeq+import Criterion.Main+import Data.Binary+import Data.Identifiers+import Data.Text (Text, pack)+ +genNames :: Int -> [Text]+genNames n = map (pack . show) . take n $ ([100000000..] :: [Int])++fromListI :: [Text] -> Identifiers Word32 Text+fromListI = fromList++main :: IO ()+main = do+ let setA = genNames 2000+ setB = genNames 200000+ idA = fromListI setA+ idB = fromListI setB+ defaultMain+ [ bgroup "fromList"+ [ setA `deepseq` bench " 2,000" $ nf fromListI setA+ , setB `deepseq` bench "200,000" $ nf fromListI setB+ ]+ , bgroup "lookupKey"+ [ idA `deepseq` bench " 2,000" $ nf (`lookupKey` 500) idA+ , idB `deepseq` bench "200,000" $ nf (`lookupKey` 50000) idB+ ]+ , bgroup "lookupId"+ [ bench " 2,000" $ nf (`lookupId` "100000500") idA+ , bench "200,000" $ nf (`lookupId` "100050000") idB+ ]+ ]+
+ bench/IdentifiersListLike.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.DeepSeq+import Criterion.Main+import Data.Binary+import Data.Identifiers.ListLike+import Data.Text (Text, pack)+ +genNames :: Int -> [Text]+genNames n = map (pack . show) . take n $ ([100000000..] :: [Int])++fromListI :: [Text] -> Identifiers Word32 Text Char+fromListI = fromList++main :: IO ()+main = do+ let setA = genNames 2000+ setB = genNames 200000+ idA = fromListI setA+ idB = fromListI setB+ defaultMain+ [ bgroup "fromList"+ [ setA `deepseq` bench " 2,000" $ nf fromListI setA+ , setB `deepseq` bench "200,000" $ nf fromListI setB+ ]+ , bgroup "lookupKey"+ [ idA `deepseq` bench " 2,000" $ nf (`lookupKey` 500) idA+ , idB `deepseq` bench "200,000" $ nf (`lookupKey` 50000) idB+ ]+ , bgroup "lookupId"+ [ bench " 2,000" $ nf (`lookupId` "100000500") idA+ , bench "200,000" $ nf (`lookupId` "100050000") idB+ ]+ ]+
identifiers.cabal view
@@ -1,5 +1,5 @@ name: identifiers-version: 0.2.1.0+version: 0.3.0.0 synopsis: Numeric identifiers for values. description: Useful for situations where repeated-storage requirements of values become too costly.@@ -16,23 +16,26 @@ location: https://github.com/awagner83/identifiers.git library- exposed-modules: Data.Identifiers- build-depends: base >=4.6 && <4.7,+ exposed-modules: Data.Identifiers Data.Identifiers.ListLike+ other-modules: Data.TrieMap+ build-depends: base >=4.6 && <4.8, binary ==0.7.*, cereal <0.5, containers ==0.5.*, deepseq ==1.3.*, hashable ==1.2.*,+ ListLike <4.1,+ text <1.2, unordered-containers ==0.2.3.* hs-source-dirs: src default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -O2 -funbox-strict-fields benchmark bench-builder-all type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: BenchAll.hs- build-depends: base >=4.6 && <4.7,+ build-depends: base >=4.6 && <4.8, criterion, binary ==0.7.*, cereal <0.5,@@ -41,12 +44,42 @@ identifiers default-language: Haskell2010 ghc-options: -Wall -rtsopts -with-rtsopts=-t- ++benchmark identifiers-generic+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Identifiers.hs+ build-depends: base >=4.6 && <4.8,+ criterion,+ binary ==0.7.*,+ cereal <0.5,+ deepseq ==1.3.*,+ text <1.2,+ bytestring ==0.10.*,+ identifiers+ default-language: Haskell2010+ ghc-options: -Wall -rtsopts -with-rtsopts=-t++benchmark identifiers-listlike+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: IdentifiersListLike.hs+ build-depends: base >=4.6 && <4.8,+ criterion,+ binary ==0.7.*,+ cereal <0.5,+ deepseq ==1.3.*,+ text <1.2,+ bytestring ==0.10.*,+ identifiers+ default-language: Haskell2010+ ghc-options: -Wall -rtsopts -with-rtsopts=-t -O2 -funbox-strict-fields+ test-suite main type: exitcode-stdio-1.0 main-is: TestAll.hs ghc-options: -Wall- build-depends: base >=4.6 && <4.7,+ build-depends: base >=4.6 && <4.8, identifiers, QuickCheck ==2.6.*, test-framework ==0.8.*,
+ src/Data/Identifiers/ListLike.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE ViewPatterns #-}+module Data.Identifiers.ListLike+ ( Identifiers ()+ + -- * Construction+ , empty+ , fromList+ + -- * Insertion+ , insert+ , insertMany++ -- * Info+ , size+ + -- * Extraction+ , toList++ -- * Lookups+ , lookupId+ , lookupKey+ , lookupKeys+ , unsafeLookupId+ , unsafeLookupKey+ , (!)++ -- * Properties+ , prop_hasId+ , prop_stableId+ , prop_keyRetrieval+ , prop_keyRetrievalUnsafe+ , prop_idempotent++ ) where++import Control.Applicative hiding (empty)+import Control.DeepSeq+import Data.Binary+import Data.List (foldl')+import Data.Maybe+import Data.Sequence (Seq, (|>))+import Data.Serialize (Serialize)+import Data.ListLike (ListLike)+import Data.TrieMap (TrieMap)+import qualified Data.TrieMap as TM+import qualified Data.Sequence as S+import qualified Data.Serialize as C+import qualified Data.Foldable as F+import qualified Data.ListLike as LL+++data Identifiers i n u = Identifiers { ids :: !(TrieMap u i)+ , names :: !(Seq n)+ } deriving Eq++instance (Show n) => Show (Identifiers i n u) where+ show s = "insertMany empty " ++ show (F.toList (names s))++instance (Binary n, ListLike n u, Integral i, Eq u)+ => Binary (Identifiers i n u) where+ put = put . toList+ get = fromList <$> get++instance (Serialize n, ListLike n u, Integral i, Eq u)+ => Serialize (Identifiers i n u) where+ put = C.put . toList+ get = fromList <$> C.get+ +instance (NFData i, NFData n, NFData u) => NFData (Identifiers i n u) where+ rnf (Identifiers i n) = rnf (i, n)++-- | The empty Identifiers+empty :: Identifiers i n u+empty = Identifiers TM.empty S.empty++-- | New Identifiers from list+fromList :: (ListLike n u, Eq u, Integral i) => [n] -> Identifiers i n u+fromList = insertMany empty++-- | Insert item into set (given it a new id)+insert :: (ListLike n u, Eq u, Integral i)+ => Identifiers i n u -> n -> Identifiers i n u+insert xs v@(LL.toList -> v') = case TM.lookup (ids xs) v' of+ Just _ -> xs+ Nothing -> Identifiers (TM.insert (ids xs) v' next) (names xs |> v)+ where next = fromIntegral $ S.length $ names xs++-- | Insert many items into set+insertMany :: (ListLike n u, Eq u, Integral i)+ => Identifiers i n u -> [n] -> Identifiers i n u+insertMany = foldl' insert++-- | New List from Identifiers+toList :: Identifiers i n u -> [n]+toList = F.toList . names++-- | Find id for given key+lookupId :: (Eq u, ListLike n u) => Identifiers i n u -> n -> Maybe i+lookupId (ids -> m) (LL.toList -> k) = TM.lookup m k++size :: Identifiers i n u -> Int+size = S.length . names++unsafeLookupId :: (ListLike n u, Eq u) => Identifiers i n u -> n -> i+unsafeLookupId (ids -> m) (LL.toList -> k) = m TM.! k++-- | Find key for given id+lookupKey :: (Integral i) => Identifiers i n u -> i -> Maybe n+lookupKey ident x = let xs = names ident+ in if S.length xs < fromIntegral x+ then Nothing+ else Just $ unsafeLookupKey ident x++-- | Given many ids, return many keys+lookupKeys :: (Integral i) => Identifiers i n u -> [i] -> [n]+lookupKeys s = mapMaybe (lookupKey s)++unsafeLookupKey :: Integral i => Identifiers i n u -> i -> n+unsafeLookupKey xs x = S.index (names xs) (fromIntegral x)++(!) :: Integral i => Identifiers i n u -> i -> n+(!) = unsafeLookupKey++-- | Items inserted are given ids+prop_hasId :: String -> Bool+prop_hasId x = isJust . lookupId (insert (empty :: Identifiers Int String Char) x) $ x++-- | Inserted items have stable ids+prop_stableId :: String -> Bool+prop_stableId x = isJust a && a == b+ where a = lookupId firstSet x+ b = lookupId secondSet x+ firstSet = insert (empty :: Identifiers Int String Char) x+ secondSet = insert firstSet x++-- | Given id can be used to fetch inserted item+prop_keyRetrievalUnsafe :: [String] -> Bool+prop_keyRetrievalUnsafe xs = all (\x -> ret x == x) xs+ where ret = unsafeLookupKey s . unsafeLookupId s+ s = insertMany (empty :: Identifiers Int String Char) xs++-- | Given id can be used to fetch inserted item+prop_keyRetrieval :: [String] -> Bool+prop_keyRetrieval xs = all (\x -> ret x == Just (Just x)) xs+ where ret x = lookupKey s <$> lookupId s x+ s = insertMany (empty :: Identifiers Int String Char) xs++-- | Inserting something more than once does not change the set+prop_idempotent :: String -> Bool+prop_idempotent x = insert (empty :: Identifiers Int String Char) x+ == insert (insert empty x) x
+ src/Data/TrieMap.hs view
@@ -0,0 +1,103 @@+module Data.TrieMap where++import Control.DeepSeq+import Data.List (foldl')+import Prelude hiding (lookup)+++data TrieMap k v = Map !(Maybe v) [TrieNode k v] deriving (Show, Eq)+data TrieNode k v = EmptyNode !k [TrieNode k v]+ | ValueNode !k !v [TrieNode k v]+ | ValueEnd !k !v+ deriving (Show, Eq)++instance (NFData k, NFData v) => NFData (TrieMap k v) where+ rnf (Map v ns) = rnf (v, ns)++instance (NFData k, NFData v) => NFData (TrieNode k v) where+ rnf (EmptyNode k ns) = rnf (k, ns)+ rnf (ValueNode k v ns) = rnf (k, v, ns)+ rnf (ValueEnd k v) = rnf (k, v)+++-- | The empty TrieMap+empty :: TrieMap k v+empty = Map Nothing []++-- | Create map from list of associations+fromList :: Eq k => [([k], v)] -> TrieMap k v+fromList = foldl' go empty+ where go m (ks, v) = insert m ks v++-- | Search for a value in the map+lookup :: Eq k => TrieMap k v -> [k] -> Maybe v+lookup (Map Nothing []) _ = Nothing+lookup (Map v _) [] = v+lookup (Map _ ns) ks = go ns ks where+ go [] _ = Nothing+ go _ [] = Nothing+ go (EmptyNode j next:ns') ks'@(k:ks'') | j == k = go next ks''+ | otherwise = go ns' ks'+ go (ValueNode j v _:ns') ks'@[k] | j == k = Just v+ | otherwise = go ns' ks'+ go (ValueNode j _ next:ns') ks'@(k:ks'') | j == k = go next ks''+ | otherwise = go ns' ks'+ go (ValueEnd j v:ns') ks'@[k] | j == k = Just v+ | otherwise = go ns' ks'+ go (ValueEnd j _:ns') ks'@(k:_) | j == k = Nothing+ | otherwise = go ns' ks'+++(!) :: Eq k => TrieMap k v -> [k] -> v+m ! k | Just v <- lookup m k = v+ | otherwise = error "oh noes!"++-- | Insert new word into map+insert :: Eq k => TrieMap k v -> [k] -> v -> TrieMap k v+insert (Map Nothing ns) [] v = Map (Just v) ns+insert m [] _ = m -- Don't clobber existing values+insert (Map v ns) ks v' = Map v $ go ns ks where+ go _ [] = [] -- Not sure how we got here; try to handle anyway.+ go [] (x:[]) = [ValueEnd x v']+ go [] (x:xs) = [EmptyNode x (go [] xs)]++ -- Last key unit vs ValueNode+ go ns''@(n@(ValueNode j _ _):ns') xs'@[x]+ | j == x = ns'' -- No clobber+ | otherwise = n : go ns' xs'++ -- Last key unit vs EmptyNode+ go (n@(EmptyNode j next):ns') xs'@[x]+ | j == x = ValueNode j v' next : ns' -- Promote to ValueNode+ | otherwise = n : go ns' xs'++ -- Last key unit vs ValueEnd+ go ns''@(n@(ValueEnd j _):ns') xs@[x]+ | j == x = ns'' -- No clobber+ | otherwise = n : go ns' xs++ -- Key unit vs ValueNode+ go (n@(ValueNode j w next):ns') xs'@(x:xs)+ | j == x = ValueNode j w (go next xs) : ns' -- Decend into node+ | otherwise = n : go ns' xs'++ -- Key unit vs EmptyNode+ go (n@(EmptyNode j next):ns') xs'@(x:xs)+ | j == x = EmptyNode j (go next xs) : ns' -- Decend into node+ | otherwise = n : go ns' xs'++ -- Key unit vs ValueEnd+ go (n@(ValueEnd j w):ns') xs'@(x:xs)+ | j == x = ValueNode j w (go [] xs) : ns' -- Promote to ValueNode+ | otherwise = n : go ns' xs'+++{-+insert [] (k:[]) v = [R k (Just v) []]+insert [] (k:ks) v = [R k Nothing (insert [] ks v)]+insert (R j _ next : rs) (k:[]) v' | j == k = R j (Just v') next : rs+insert (R j v next : rs) (k:ks) v' | j == k = R j v (insert next ks v') : rs+insert xs [] _ = xs+insert (r:rows) ks v = r : insert rows ks v+-}+
test/TestAll.hs view
@@ -4,18 +4,26 @@ import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Data.Identifiers+import qualified Data.Identifiers as G+import qualified Data.Identifiers.ListLike as L main :: IO () main = defaultMain tests tests :: [Test]-tests = [ testGroup "QuickCheck PowerMap.Data.IdSet"- [ testProperty "hasId" prop_hasId- , testProperty "stableId" prop_stableId- , testProperty "keyRetrieval" prop_keyRetrieval- , testProperty "keyRetrievalUnsafe" prop_keyRetrievalUnsafe- , testProperty "idempotent" prop_idempotent+tests = [ testGroup "QuickCheck Data.Identifiers"+ [ testProperty "hasId" G.prop_hasId+ , testProperty "stableId" G.prop_stableId+ , testProperty "keyRetrieval" G.prop_keyRetrieval+ , testProperty "keyRetrievalUnsafe" G.prop_keyRetrievalUnsafe+ , testProperty "idempotent" G.prop_idempotent+ ]+ , testGroup "QuickCheck Data.Identifiers.ListLike"+ [ testProperty "hasId" L.prop_hasId+ , testProperty "stableId" L.prop_stableId+ , testProperty "keyRetrieval" L.prop_keyRetrieval+ , testProperty "keyRetrievalUnsafe" L.prop_keyRetrievalUnsafe+ , testProperty "idempotent" L.prop_idempotent ] ]