data-stringmap (empty) → 0.9
raw patch · 12 files changed
+2323/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, binary, containers, data-stringmap, deepseq, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- Data/StringMap.hs +111/−0
- Data/StringMap/Base.hs +1030/−0
- Data/StringMap/FuzzySearch.hs +113/−0
- Data/StringMap/Lazy.hs +130/−0
- Data/StringMap/Strict.hs +198/−0
- Data/StringMap/StringSet.hs +133/−0
- Data/StringMap/Types.hs +26/−0
- LICENSE +21/−0
- Setup.hs +2/−0
- benchmarks/StringMap.hs +101/−0
- data-stringmap.cabal +59/−0
- tests/StringMapProperties.hs +399/−0
+ Data/StringMap.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ Facade for prefix tree implementation+ +-}++-- ----------------------------------------------------------------------------++module Data.StringMap+ (+ -- * Map type+ StringMap -- (..) I don't think we should export the constructor.+ , Key++ -- * Operators+ , (!)++ -- * Query+ , value+ , valueWithDefault+ , null+ , size+ , member+ , lookup+ , findWithDefault + , prefixFind+ , prefixFindWithKey+ , prefixFindWithKeyBF++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey++ -- ** Delete\/Update+ , delete+ , update+ , updateWithKey++ -- * Combine+ -- ** Union+ , union+ , unionWith+ , unionWithKey++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey+++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapM+ , mapWithKeyM++ -- * Folds+ , fold+ , foldWithKey++ -- * Conversion+ , keys+ , elems++ -- ** Lists+ , fromList+ , toList+ , toListBF++ -- ** Maps+ , fromMap+ , toMap++ -- * Debugging+ , space+ , keyChars++ -- * Prefix and Fuzzy Search+ , prefixFindCaseWithKey -- fuzzy search+ , prefixFindNoCaseWithKey+ , prefixFindNoCase+ , lookupNoCase++ , prefixFindCaseWithKeyBF+ , prefixFindNoCaseWithKeyBF+ , lookupNoCaseBF+ )+where++import Prelude hiding ( succ, lookup, map, mapM, null )++import Data.StringMap.Base+import Data.StringMap.FuzzySearch+import Data.StringMap.Types
+ Data/StringMap/Base.hs view
@@ -0,0 +1,1030 @@+{-# OPTIONS -XBangPatterns #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap.Base+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ An efficient implementation of maps from strings to arbitrary values.++ Values can associated with an arbitrary byte key. Searching for keys is very fast, but+ the prefix tree probably consumes more memory than "Data.Map". The main differences are the special+ 'prefixFind' functions, which can be used to perform prefix queries. The interface is+ heavily borrowed from "Data.Map" and "Data.IntMap".++ Most other function names clash with "Prelude" names, therefore this module is usually+ imported @qualified@, e.g.++ > import Data.StringMap (StringMap)+ > import qualified Data.StringMap as T++ Many functions have a worst-case complexity of /O(min(n,L))/. This means that the operation+ can become linear with the number of elements with a maximum of /L/, the length of the+ key (the number of bytes in the list). The functions for searching a prefix have a worst-case+ complexity of /O(max(L,R))/. This means that the operation can become linear with+ /R/, the number of elements found for the prefix, with a minimum of /L/.++ The module exports include the internal data types, their constructors and access+ functions for ultimate flexibility. Derived modules should not export these+ (as shown in "Holumbus.Data.StrMap") to provide only a restricted interface.++-}++-- ----------------------------------------------------------------------------++module Data.StringMap.Base+ (+ -- * Map type+ StringMap (Empty, Val, Branch)-- (..) I don't think we should export the constructors.+ , Key++ -- * Operators+ , (!)++ -- * Query+ , value+ , valueWithDefault+ , null+ , size+ , member+ , lookup+ , findWithDefault+ , prefixFind+ , prefixFindWithKey+ , prefixFindWithKeyBF++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey++ -- ** Delete\/Update+ , delete+ , update+ , updateWithKey++ -- * Combine+ -- ** Union+ , union+ , unionWith+ , unionWithKey++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey+++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapM+ , mapWithKeyM++ -- * Folds+ , fold+ , foldWithKey++ -- * Conversion+ , keys+ , elems++ -- ** Lists+ , fromList+ , toList+ , toListBF++ -- ** Maps+ , fromMap+ , toMap++ -- * Debugging+ , space+ , keyChars++ -- Internal+ , cutPx'+ , cutAllPx'+ , branch+ , val+ , norm+ , normError+ )+where++import Prelude hiding ( succ, lookup, map, mapM, null )++import Control.Arrow+import Control.DeepSeq++import qualified Data.Foldable++import Data.Binary+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe++import Data.StringMap.Types+import Data.StringMap.StringSet++data StringMap v = Empty+ | Val { value' :: v+ , tree :: ! (StringMap v)+ }+ | Branch { sym :: {-# UNPACK #-}+ ! Sym+ , child :: ! (StringMap v)+ , next :: ! (StringMap v)+ }++ -- the space optimisation nodes, these+ -- will be normalized during access into+ -- the three constructors Empty, Val and Branch++ | Leaf { value' :: v -- a value at a leaf of the tree+ }+ | Last { sym :: {-# UNPACK #-}+ ! Sym -- the last entry in a branch list+ , child :: ! (StringMap v) -- or no branch but a single child+ }+ | LsSeq { syms :: ! Key1 -- a sequence of single childs+ , child :: ! (StringMap v) -- in a last node+ } + | BrSeq { syms :: ! Key1 -- a sequence of single childs+ , child :: ! (StringMap v) -- in a branch node+ , next :: ! (StringMap v)+ } + | LsSeL { syms :: ! Key1 -- a sequence of single childs+ , value' :: v -- with a leaf + } + | BrSeL { syms :: ! Key1 -- a sequence of single childs+ , value' :: v -- with a leaf in a branch node+ , next :: ! (StringMap v)+ } + | BrVal { sym :: {-# UNPACK #-}+ ! Sym -- a branch with a single char+ , value' :: v -- and a value+ , next :: ! (StringMap v)+ }+ | LsVal { sym :: {-# UNPACK #-}+ ! Sym -- a last node with a single char+ , value' :: v -- and a value+ }+ deriving (Show, Eq, Ord)++-- | strict list of chars with unpacked fields+--+-- for internal use in prefix tree to optimize space efficiency++data Key1 = Nil+ | Cons {-# UNPACK #-}+ ! Sym+ ! Key1 + deriving (Eq, Ord)++instance Show Key1 where+ show k = show (toKey k)++(.++.) :: Key1 -> Key1 -> Key1+Nil .++. k2 = k2+(Cons k k1) .++. k2 = Cons k (k1 .++. k2)++toKey :: Key1 -> Key+toKey Nil = []+toKey (Cons c k1) = c : toKey k1++fromKey :: Key -> Key1+fromKey k1 = foldr Cons Nil k1++length1 :: Key1 -> Int+length1 = length . toKey++-- ----------------------------------------++-- smart constructors++empty :: StringMap v+empty = Empty++{-# INLINE empty #-}++val :: v -> StringMap v -> StringMap v+val v Empty = Leaf v+val v t = Val v t++{-# INLINE val #-}++branch :: Sym -> StringMap v -> StringMap v -> StringMap v+branch !_k Empty n = n++branch !k (Leaf v ) Empty = LsVal k v+branch !k (LsVal k1 v) Empty = LsSeL (Cons k (Cons k1 Nil)) v+branch !k (LsSeL ks v) Empty = LsSeL (Cons k ks) v+branch !k (Last k1 c) Empty = lsseq (Cons k (Cons k1 Nil)) c+branch !k (LsSeq ks c) Empty = lsseq (Cons k ks) c+branch !k c Empty = Last k c++branch !k (Leaf v ) n = BrVal k v n+branch !k (LsVal k1 v) n = BrSeL (Cons k (Cons k1 Nil)) v n+branch !k (LsSeL ks v) n = BrSeL (Cons k ks) v n+branch !k (Last k1 c) n = brseq (Cons k (Cons k1 Nil)) c n+branch !k (LsSeq ks c) n = brseq (Cons k ks) c n+branch !k c n = Branch k c n++lsseq :: Key1 -> StringMap v -> StringMap v+lsseq !k (Leaf v) = LsSeL k v+lsseq !k c = LsSeq k c++{-# INLINE lsseq #-}++brseq :: Key1 -> StringMap v -> StringMap v -> StringMap v+brseq !k (Leaf v) n = BrSeL k v n+brseq !k c n = BrSeq k c n++{-# INLINE brseq #-}++siseq :: Key1 -> StringMap v -> StringMap v+siseq Nil c = c+siseq (Cons k1 Nil) c = Last k1 c+siseq k c = LsSeq k c++{-# INLINE siseq #-}++-- smart selectors++norm :: StringMap v -> StringMap v+norm (Leaf v) = Val v empty+norm (Last k c) = Branch k c empty+norm (LsSeq (Cons k Nil) c) = Branch k c empty+norm (LsSeq (Cons k ks ) c) = Branch k (siseq ks c) empty +norm (BrSeq (Cons k Nil) c n) = Branch k c n+norm (BrSeq (Cons k ks ) c n) = Branch k (siseq ks c) n +norm (LsSeL ks v) = norm (LsSeq ks (val v empty))+norm (BrSeL ks v n) = norm (BrSeq ks (val v empty) n)+norm (LsVal k v) = norm (LsSeq (Cons k Nil) (val v empty))+norm (BrVal k v n) = norm (BrSeq (Cons k Nil) (val v empty) n)+norm t = t++-- ----------------------------------------++deepNorm :: StringMap v -> StringMap v+deepNorm t0+ = case norm t0 of+ Empty -> Empty+ Val v t -> Val v (deepNorm t)+ Branch c s n -> Branch c (deepNorm s) (deepNorm n)+ _ -> normError "deepNorm"++-- ----------------------------------------++normError :: String -> a+normError f = error (f ++ ": pattern match error, prefix tree not normalized")++-- ----------------------------------------++-- | /O(1)/ Is the map empty?++null :: StringMap a -> Bool+null Empty = True+null _ = False++{-# INLINE null #-}++-- | /O(1)/ Create a map with a single element.++singleton :: Key -> a -> StringMap a+singleton k v = foldr (\ c r -> branch c r empty) (val v empty) $ k -- siseq k (val v empty)++{-# INLINE singleton #-}++-- | /O(1)/ Extract the value of a node (if there is one)+-- TODO: INTERNAL++value :: Monad m => StringMap a -> m a+value t = case norm t of+ Val v _ -> return v+ _ -> fail "StringMap.value: no value at this node"++{-# INLINE value #-}++-- | /O(1)/ Extract the value of a node or return a default value if no value exists.++valueWithDefault :: a -> StringMap a -> a+valueWithDefault d t = fromMaybe d . value $ t+++-- | /O(1)/ Extract the successors of a node++succ :: StringMap a -> StringMap a+succ t = case norm t of+ Val _ t' -> succ t'+ t' -> t'+{-# INLINE succ #-}++-- ----------------------------------------++-- | /O(min(n,L))/ Find the value associated with a key. The function will @return@ the result in+-- the monad or @fail@ in it if the key isn't in the map.++lookup :: Monad m => Key -> StringMap a -> m a+lookup k t = case lookup' k t of+ Just v -> return v+ Nothing -> fail "StringMap.lookup: Key not found"+{-# INLINE lookup #-}++-- | /O(min(n,L))/ Find the value associated with a key. The function will @return@ the result in+-- the monad or @fail@ in it if the key isn't in the map.++findWithDefault :: a -> Key -> StringMap a -> a+findWithDefault v0 k = fromMaybe v0 . lookup' k++{-# INLINE findWithDefault #-}++-- | /O(min(n,L))/ Is the key a member of the map?++member :: Key -> StringMap a -> Bool+member k = isJust . lookup k++{-# INLINE member #-}++-- | /O(min(n,L))/ Find the value at a key. Calls error when the element can not be found.++(!) :: StringMap a -> Key -> a+(!) = flip $ findWithDefault (error "StringMap.! : element not in the map")++-- | /O(min(n,L))/ Insert a new key and value into the map. If the key is already present in+-- the map, the associated value will be replaced with the new value.++insert :: Key -> a -> StringMap a -> StringMap a+insert = insertWith const++{-# INLINE insert #-}++-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map,+-- the value of @f new_value old_value@ will be inserted.++insertWith :: (a -> a -> a) -> Key -> a -> StringMap a -> StringMap a+insertWith f = flip $ insert' f++{-# INLINE insertWith #-}++-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map,+-- the value of @f key new_value old_value@ will be inserted.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> StringMap a -> StringMap a+insertWithKey f k = insertWith (f k) k+++{-# INLINE insertWithKey #-}++-- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- element if the result of the updating function is 'Nothing'. If the key is not found, the trie+-- is returned unchanged.++update :: (a -> Maybe a) -> Key -> StringMap a -> StringMap a+update = update'++{-# INLINE update #-}++-- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- element if the result of the updating function is 'Nothing'. If the key is not found, the trie+-- is returned unchanged.++updateWithKey :: (Key -> a -> Maybe a) -> Key -> StringMap a -> StringMap a+updateWithKey f k = update' (f k) k++{-# INLINE updateWithKey #-}++-- | /O(min(n,L))/ Delete an element from the map. If no element exists for the key, the map +-- remains unchanged.++delete :: Key -> StringMap a -> StringMap a+delete = update' (const Nothing)++{-# INLINE delete #-}++-- ----------------------------------------++lookupPx' :: Key -> StringMap a -> StringMap a+lookupPx' k0 = look k0 . norm+ where+ look [] t = t+ look k@(c : k1) (Branch c' s' n')+ | c < c' = empty+ | c == c' = lookupPx' k1 s'+ | otherwise = lookupPx' k n'+ look _ Empty = empty+ look k (Val _v' t') = lookupPx' k t'++ look _ _ = normError "lookupPx'"++-- Internal lookup function which is generalised for arbitrary monads above.++lookup' :: Key -> StringMap a -> Maybe a+lookup' k t+ = case lookupPx' k t of+ Val v _ -> Just v+ _ -> Nothing++-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key.++prefixFind :: Key -> StringMap a -> [a]+prefixFind k = elems . lookupPx' k++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key and include the keys +-- in the result.++prefixFindWithKey :: Key -> StringMap a -> [(Key, a)]+prefixFindWithKey k = fmap (first (k ++)) . toList . lookupPx' k++-- ----------------------------------------++insert' :: (a -> a -> a) -> a -> Key -> StringMap a -> StringMap a+insert' f v k0 = ins k0 . norm+ where+ ins' = insert' f v++ ins k (Branch c' s' n')+ = case k of+ [] -> val v (branch c' s' n')+ (c : k1)+ | c < c' -> branch c (singleton k1 v) (branch c' s' n')+ | c == c' -> branch c (ins' k1 s') n'+ | otherwise -> branch c' s' (ins' k n')++ ins k Empty = singleton k v++ ins k (Val v' t')+ = case k of+ [] -> val (f v v') t'+ _ -> val v' (ins' k t')++ ins _ _ = normError "insert'"++-- ----------------------------------------++update' :: (a -> Maybe a) -> Key -> StringMap a -> StringMap a+update' f k0 = upd k0 . norm+ where+ upd' = update' f++ upd k (Branch c' s' n')+ = case k of+ [] -> branch c' s' n'+ (c : k1)+ | c < c' -> branch c' s' n'+ | c == c' -> branch c (upd' k1 s') n'+ | otherwise -> branch c' s' (upd' k n')++ upd _ Empty = empty++ upd k (Val v' t')+ = case k of+ [] -> maybe t' (flip val t') $ f v'+ _ -> val v' (upd' k t')+ upd _ _ = normError "update'"++-- ----------------------------------------++-- | /O(n+m)/ Left-biased union of two maps. It prefers the first map when duplicate keys are +-- encountered, i.e. ('union' == 'unionWith' 'const').++union :: StringMap a -> StringMap a -> StringMap a+union = union' const++-- | /O(n+m)/ Union with a combining function.++unionWith :: (a -> a -> a) -> StringMap a -> StringMap a -> StringMap a+unionWith = union'++union' :: (a -> a -> a) -> StringMap a -> StringMap a -> StringMap a+union' f pt1 pt2 = uni (norm pt1) (norm pt2)+ where+ uni' t1' t2' = union' f (norm t1') (norm t2')++ uni Empty Empty = empty+ uni Empty (Val v2 t2) = val v2 t2+ uni Empty (Branch c2 s2 n2)+ = branch c2 s2 n2++ uni (Val v1 t1) Empty = val v1 t1+ uni (Val v1 t1) (Val v2 t2) = val (f v1 v2) (uni' t1 t2)+ uni (Val v1 t1) t2@(Branch _ _ _) = val v1 (uni' t1 t2)++ uni (Branch c1 s1 n1) Empty = branch c1 s1 n1+ uni t1@(Branch _ _ _ ) (Val v2 t2) = val v2 (uni' t1 t2) + uni t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = branch c1 s1 (uni' n1 t2)+ | c1 > c2 = branch c2 s2 (uni' t1 n2)+ | otherwise = branch c1 (uni' s1 s2) (uni' n1 n2)+ uni _ _ = normError "union'"++-- ----------------------------------------++-- | /O(n+m)/ Union with a combining function, including the key.++unionWithKey :: (Key -> a -> a -> a) -> StringMap a -> StringMap a -> StringMap a+unionWithKey f = union'' f id++union'' :: (Key -> a -> a -> a) -> (Key -> Key) -> StringMap a -> StringMap a -> StringMap a+union'' f kf pt1 pt2 = uni (norm pt1) (norm pt2)+ where+ uni' t1' t2' = union'' f kf (norm t1') (norm t2')++ uni Empty Empty = empty+ uni Empty (Val v2 t2) = val v2 t2+ uni Empty (Branch c2 s2 n2)+ = branch c2 s2 n2++ uni (Val v1 t1) Empty = val v1 t1+ uni (Val v1 t1) (Val v2 t2) = val (f (kf []) v1 v2) (uni' t1 t2)+ uni (Val v1 t1) t2@(Branch _ _ _) = val v1 (uni' t1 t2)++ uni (Branch c1 s1 n1) Empty = branch c1 s1 n1+ uni t1@(Branch _ _ _ ) (Val v2 t2) = val v2 (uni' t1 t2) + uni t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = branch c1 s1 (uni' n1 t2)+ | c1 > c2 = branch c2 s2 (uni' t1 n2)+ | otherwise = branch c1 (union'' f (kf . (c1:)) s1 s2) (uni' n1 n2)++ uni _ _ = normError "union''"++-- ----------------------------------------+--+-- | /(O(min(n,m))/ Difference between two tries (based on keys).++difference :: StringMap a -> StringMap b -> StringMap a+difference = differenceWith (const (const Nothing))++-- | /(O(min(n,m))/ Difference with a combining function. If the combining function always returns+-- 'Nothing', this is equal to proper set difference.++differenceWith :: (a -> b -> Maybe a) -> StringMap a -> StringMap b -> StringMap a+differenceWith f = differenceWithKey (const f)++-- | /O(min(n,m))/ Difference with a combining function, including the key. If two equal keys are+-- encountered, the combining function is applied to the key and both values. If it returns+-- 'Nothing', the element is discarded, if it returns 'Just' a value, the element is updated+-- with the new value.++differenceWithKey :: (Key -> a -> b -> Maybe a) -> StringMap a -> StringMap b -> StringMap a+differenceWithKey f = diff'' f id++diff'' :: (Key -> a -> b -> Maybe a) ->+ (Key -> Key) ->+ StringMap a -> StringMap b -> StringMap a+diff'' f kf pt1 pt2 = dif (norm pt1) (norm pt2)+ where+ dif' t1' t2' = diff'' f kf (norm t1') (norm t2')++ dif Empty _ = empty++ dif (Val v1 t1) Empty = val v1 t1+ dif (Val v1 t1) (Val v2 t2) =+ case f (kf []) v1 v2 of+ Nothing -> dif' t1 t2+ Just nv -> val nv (dif' t1 t2)+ dif (Val v1 t1) t2@(Branch _ _ _) = val v1 (dif' t1 t2)++ dif (Branch c1 s1 n1) Empty = branch c1 s1 n1+ dif t1@(Branch _ _ _ ) (Val _ t2) = dif' t1 t2 + dif t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = branch c1 s1 (dif' n1 t2)+ | c1 > c2 = dif' t1 n2+ | otherwise = branch c1 (diff'' f (kf . (c1:)) s1 s2) (dif' n1 n2)+ dif _ _ = normError "diff''"+++-- ----------------------------------------++-- | cut off all branches from a tree @t2@ that are not part of set @t1@+--+-- the following laws must holds+--+-- @lookup' k' . cutPx' (singlePS k) $ t == lookup' k t@ for every @k'@ with @k@ prefix of @k'@+--+-- @lookup' k' . cutPx' (singlePS k) $ t == Nothing@ for every @k'@ with @k@ not being a prefix of @k'@ + +cutPx'' :: (StringMap a -> StringMap a) -> StringSet -> StringMap a -> StringMap a+cutPx'' cf s1' t2' = cut s1' (norm t2')+ where+ cut PSempty _t2 = empty+ cut (PSelem _s1) t2 = cf t2+ cut (PSnext _ _ _ ) Empty = empty+ cut t1@(PSnext _ _ _ ) (Val _ t2) = cut t1 (norm t2)+ cut t1@(PSnext c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = cut n1 t2+ | c1 > c2 = cut t1 (norm n2)+ | otherwise = branch c1 (cutPx'' cf s1 s2) (cutPx'' cf n1 n2)+ cut _ _ = normError "cutPx''"++cutPx' :: StringSet -> StringMap a -> StringMap a+cutPx' = cutPx'' id++cutAllPx' :: StringSet -> StringMap a -> StringMap a+cutAllPx' = cutPx'' (cv . norm)+ where+ cv (Val v _) = val v empty+ cv _ = empty++-- ----------------------------------------++-- | /O(n)/ Map a function over all values in the prefix tree.++map :: (a -> b) -> StringMap a -> StringMap b+map f = mapWithKey (const f)+++mapWithKey :: (Key -> a -> b) -> StringMap a -> StringMap b+mapWithKey f = map' f id+++map' :: (Key -> a -> b) -> (Key -> Key) -> StringMap a -> StringMap b+map' _ _ (Empty) = Empty+map' f k (Val v t) = Val (f (k []) v) (map' f k t)+map' f k (Branch c s n) = Branch c (map' f ((c :) . k) s) (map' f k n)+map' f k (Leaf v) = Leaf (f (k []) v)+map' f k (Last c s) = Last c (map' f ((c :) . k) s)+map' f k (LsSeq cs s) = LsSeq cs (map' f ((toKey cs ++) . k) s)+map' f k (BrSeq cs s n) = BrSeq cs (map' f ((toKey cs ++) . k) s) (map' f k n)+map' f k (LsSeL cs v) = LsSeL cs (f (k []) v)+map' f k (BrSeL cs v n) = BrSeL cs (f (k []) v) (map' f k n)+map' f k (LsVal c v) = LsVal c (f (k []) v)+map' f k (BrVal c v n) = BrVal c (f (k []) v) (map' f k n)++-- ----------------------------------------++{- not yet used++-- | Variant of map that works on normalized trees++mapN :: (a -> b) -> StringMap a -> StringMap b+mapN f = mapWithKeyN (const f)+++mapWithKeyN :: (Key -> a -> b) -> StringMap a -> StringMap b+mapWithKeyN f = map'' f id++map'' :: (Key -> a -> b) -> (Key -> Key) -> StringMap a -> StringMap b+map'' f k = mapn . norm+ where+ mapn Empty = empty+ mapn (Val v t) = val (f (k []) v) (map'' f k t)+ mapn (Branch c s n) = branch c (map'' f ((c :) . k) s) (map'' f k n)+ mapn _ = normError "map''"+-- -}++-- ----------------------------------------++-- | Monadic map++mapM :: Monad m => (a -> m b) -> StringMap a -> m (StringMap b)+mapM f = mapWithKeyM (const f)++-- | Monadic mapWithKey++mapWithKeyM :: Monad m => (Key -> a -> m b) -> StringMap a -> m (StringMap b)+mapWithKeyM f = mapM'' f id++mapM'' :: Monad m => (Key -> a -> m b) -> (Key -> Key) -> StringMap a -> m (StringMap b)+mapM'' f k = mapn . norm+ where+ mapn Empty = return $ empty+ mapn (Val v t) = do+ v' <- f (k []) v+ t' <- mapM'' f k t+ return $ val v' t'+ mapn (Branch c s n) = do+ s' <- mapM'' f ((c :) . k) s+ n' <- mapM'' f k n+ return $ branch c s' n'+ mapn _ = normError "mapM''"++-- ----------------------------------------+--+-- A prefix tree visitor++data PrefixTreeVisitor a b = PTV+ { v_empty :: b+ , v_val :: a -> b -> b+ , v_branch :: Sym -> b -> b -> b+ , v_leaf :: a -> b+ , v_last :: Sym -> b -> b+ , v_lsseq :: Key1 -> b -> b+ , v_brseq :: Key1 -> b -> b -> b+ , v_lssel :: Key1 -> a -> b+ , v_brsel :: Key1 -> a -> b -> b+ , v_lsval :: Sym -> a -> b+ , v_brval :: Sym -> a -> b -> b+ }++visit :: PrefixTreeVisitor a b -> StringMap a -> b++visit v (Empty) = v_empty v+visit v (Val v' t) = v_val v v' (visit v t)+visit v (Branch c s n) = v_branch v c (visit v s) (visit v n)+visit v (Leaf v') = v_leaf v v'+visit v (Last c s) = v_last v c (visit v s)+visit v (LsSeq cs s) = v_lsseq v cs (visit v s)+visit v (BrSeq cs s n) = v_brseq v cs (visit v s) (visit v n)+visit v (LsSeL cs v') = v_lssel v cs v'+visit v (BrSeL cs v' n) = v_brsel v cs v' (visit v n)+visit v (LsVal c v') = v_lsval v c v'+visit v (BrVal c v' n) = v_brval v c v' (visit v n)++-- ----------------------------------------+--+-- | space required by a prefix tree (logically)+--+-- Singletons are counted as 0, all other n-ary constructors+-- are counted as n+1 (1 for the constructor and 1 for every field)+-- cons nodes of char lists are counted 2, 1 for the cons, 1 for the char+-- for values only the ref to the value is counted, not the space for the value itself+-- key chars are assumed to be unboxed++space :: StringMap a -> Int+space = visit $+ PTV+ { v_empty = 0+ , v_val = const (3+)+ , v_branch = const $ \ s n -> 4 + s + n+ , v_leaf = const 2+ , v_last = const (3+)+ , v_lsseq = \ cs s -> 3 + 2 * length1 cs + s+ , v_brseq = \ cs s n -> 4 + 2 * length1 cs + s + n+ , v_lssel = \ cs _ -> 3 + 2 * length1 cs+ , v_brsel = \ cs _ n -> 4 + 2 * length1 cs + n+ , v_lsval = \ _ _ -> 3+ , v_brval = \ _ _ n -> 4 + n+ }++keyChars :: StringMap a -> Int+keyChars = visit $+ PTV+ { v_empty = 0+ , v_val = \ _ t -> t+ , v_branch = \ _ s n -> 1 + s + n+ , v_leaf = \ _ -> 0+ , v_last = \ _ s -> 1 + s+ , v_lsseq = \ cs s -> length1 cs + s+ , v_brseq = \ cs s n -> length1 cs + s + n+ , v_lssel = \ cs _ -> length1 cs+ , v_brsel = \ cs _ n -> length1 cs + n+ , v_lsval = \ _ _ -> 1+ , v_brval = \ _ _ n -> 1 + n+ }++-- ----------------------------------------+--+-- | statistics about the # of different nodes in an optimized prefix tree++stat :: StringMap a -> StringMap Int+stat = visit $+ PTV+ { v_empty = singleton "empty" 1+ , v_val = \ _ t -> singleton "val" 1 `add` t+ , v_branch = \ _ s n -> singleton "branch" 1 `add` (s `add` n)+ , v_leaf = \ _ -> singleton "leaf" 1+ , v_last = \ _ s -> singleton "last" 1 `add` s+ , v_lsseq = \ cs s -> singleton ("lsseq-" ++ show (length1 cs)) 1 `add` s+ , v_brseq = \ cs s n -> singleton ("brseq-" ++ show (length1 cs)) 1 `add` (s `add` n)+ , v_lssel = \ cs _ -> singleton ("lssel-" ++ show (length1 cs)) 1+ , v_brsel = \ cs _ n -> singleton ("brseq-" ++ show (length1 cs)) 1 `add` n+ , v_lsval = \ _ _ -> singleton "lsval" 1+ , v_brval = \ _ _ n -> singleton "brval" 1 `add` n+ }+ where+ add = unionWith (+)++-- ----------------------------------------++-- | /O(n)/ Fold over all key\/value pairs in the map.++foldWithKey :: (Key -> a -> b -> b) -> b -> StringMap a -> b+foldWithKey f e = fold' f e id++{-# INLINE foldWithKey #-}++-- | /O(n)/ Fold over all values in the map.++fold :: (a -> b -> b) -> b -> StringMap a -> b+fold f = foldWithKey $ const f++{-# INLINE fold #-}++{- not yet used++foldTopDown :: (Key -> a -> b -> b) -> b -> (Key -> Key) -> StringMap a -> b+foldTopDown f r k0 = fo k0 . norm+ where+ fo kf (Branch c' s' n') = let r' = foldTopDown f r ((c' :) . kf) s' in foldTopDown f r' kf n'+ fo _ (Empty) = r+ fo kf (Val v' t') = let r' = f (kf []) v' r in foldTopDown f r' kf t'+ fo _ _ = normError "foldTopDown"+-- -}++fold' :: (Key -> a -> b -> b) -> b -> (Key -> Key) -> StringMap a -> b+fold' f r k0 = fo k0 . norm+ where+ fo kf (Branch c' s' n') = let r' = fold' f r kf n' in fold' f r' (kf . (c':)) s'+ fo _ (Empty) = r+ fo kf (Val v' t') = let r' = fold' f r kf t' in f (kf []) v' r'+ fo _ _ = normError "fold'"++-- | /O(n)/ Convert into an ordinary map.++toMap :: StringMap a -> M.Map Key a+toMap = foldWithKey M.insert M.empty++-- | /O(n)/ Convert an ordinary map into a Prefix tree++fromMap :: M.Map Key a -> StringMap a+fromMap = M.foldrWithKey insert empty++-- | /O(n)/ Returns all elements as list of key value pairs,++toList :: StringMap a -> [(Key, a)]+toList = foldWithKey (\k v r -> (k, v) : r) []++-- | /O(n)/ Creates a trie from a list of key\/value pairs.+fromList :: [(Key, a)] -> StringMap a+fromList = L.foldl' (\p (k, v) -> insert k v p) empty++-- | /O(n)/ The number of elements.+size :: StringMap a -> Int+size = fold (const (+1)) 0++-- | /O(n)/ Returns all values.+elems :: StringMap a -> [a]+elems = fold (:) []++-- | /O(n)/ Returns all values.+keys :: StringMap a -> [Key]+keys = foldWithKey (\ k _v r -> k : r) []++-- ----------------------------------------++-- | returns all key-value pairs in breadth first order (short words first)+-- this enables prefix search with upper bounds on the size of the result set+-- e.g. @ search ... >>> toListBF >>> take 1000 @ will give the 1000 shortest words+-- found in the result set and will ignore all long words+--+-- toList is derived from the following code found in the net when searching haskell breadth first search+--+-- Haskell Standard Libraray Implementation+--+-- > br :: Tree a -> [a]+-- > br t = map rootLabel $+-- > concat $+-- > takeWhile (not . null) $ +-- > iterate (concatMap subForest) [t]++toListBF :: StringMap v -> [(Key, v)]+toListBF = (\ t0 -> [(id, t0)])+ >>>+ iterate (concatMap (second norm >>> uncurry subForest))+ >>>+ takeWhile (not . L.null)+ >>>+ concat+ >>>+ concatMap (second norm >>> uncurry rootLabel)++rootLabel :: (Key -> Key) -> StringMap v -> [(Key, v)]+rootLabel kf (Val v _) = [(kf [], v)]+rootLabel _ _ = []++subForest :: (Key -> Key) -> StringMap v -> [(Key -> Key, StringMap v)]+subForest kf (Branch c s n) = (kf . (c:), s) : subForest kf (norm n)+subForest _ Empty = []+subForest kf (Val _ t) = subForest kf (norm t)+subForest _ _ = error "StringMap.Base.subForest: Pattern match failure"+ +-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key and include the keys +-- in the result. The result list contains short words first++prefixFindWithKeyBF :: Key -> StringMap a -> [(Key, a)]+prefixFindWithKeyBF k = fmap (first (k ++)) . toListBF . lookupPx' k++-- ----------------------------------------++instance Functor StringMap where+ fmap = map++instance Data.Foldable.Foldable StringMap where+ foldr = fold++{- for debugging not yet enabled++instance Show a => Show (StringMap a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++-- -}++-- ----------------------------------------++instance Read a => Read (StringMap a) where+ readsPrec p = readParen (p > 10) $+ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)++-- ----------------------------------------++instance NFData a => NFData (StringMap a) where+ rnf (Empty) = ()+ rnf (Val v t) = rnf v `seq` rnf t+ rnf (Branch _c s n) = rnf s `seq` rnf n+ rnf (Leaf v) = rnf v+ rnf (Last _c s) = rnf s+ rnf (LsSeq _ks s) = rnf s+ rnf (BrSeq _ks s n) = rnf s `seq` rnf n+ rnf (LsSeL _ks v) = rnf v+ rnf (BrSeL _ks v n) = rnf v `seq` rnf n+ rnf (LsVal k v) = rnf k `seq` rnf v+ rnf (BrVal k v n) = rnf k `seq` rnf v `seq` rnf n++-- ----------------------------------------+--+-- Provide native binary serialization (not via to-/fromList).++instance (Binary a) => Binary (StringMap a) where+ put (Empty) = put (0::Word8)+ put (Val v t) = put (1::Word8) >> put v >> put t+ put (Branch c s n) = put (2::Word8) >> put c >> put s >> put n+ put (Leaf v) = put (3::Word8) >> put v+ put (Last c s) = put (4::Word8) >> put c >> put s+ put (LsSeq k s) = put (5::Word8) >> put (toKey k) >> put s+ put (BrSeq k s n) = put (6::Word8) >> put (toKey k) >> put s >> put n+ put (LsSeL k v) = put (7::Word8) >> put (toKey k) >> put v+ put (BrSeL k v n) = put (8::Word8) >> put (toKey k) >> put v >> put n+ put (LsVal k v) = put (9::Word8) >> put k >> put v+ put (BrVal k v n) = put (10::Word8) >> put k >> put v >> put n++ get = do+ !tag <- getWord8+ case tag of+ 0 -> return Empty+ 1 -> do+ !v <- get+ !t <- get+ return $! Val v t+ 2 -> do+ !c <- get+ !s <- get+ !n <- get+ return $! Branch c s n+ 3 -> do+ !v <- get+ return $! Leaf v+ 4 -> do+ !c <- get+ !s <- get+ return $! Last c s+ 5 -> do+ !k <- get+ !s <- get+ return $! LsSeq (fromKey k) s+ 6 -> do+ !k <- get+ !s <- get+ !n <- get+ return $! BrSeq (fromKey k) s n+ 7 -> do+ !k <- get+ !v <- get+ return $! LsSeL (fromKey k) v+ 8 -> do+ !k <- get+ !v <- get+ !n <- get+ return $! BrSeL (fromKey k) v n+ 9 -> do+ !k <- get+ !v <- get+ return $! LsVal k v+ 10 -> do+ !k <- get+ !v <- get+ !n <- get+ return $! BrVal k v n+ _ -> fail "StringMap.get: error while decoding StringMap"++-- ----------------------------------------
+ Data/StringMap/FuzzySearch.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE BangPatterns #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap.FuzzySearch+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ Functions for fuzzy search in a prefix tree++-}++-- ----------------------------------------------------------------------------++module Data.StringMap.FuzzySearch+ ( prefixFindCaseWithKey+ , prefixFindNoCaseWithKey+ , prefixFindNoCase+ , lookupNoCase+ , lookupNoCaseBF --redundant+ , prefixFindCaseWithKeyBF+ , prefixFindNoCaseWithKeyBF+ , noCaseKeys+ , noLowerCaseKeys+ , noCasePS+ , noLowerCasePS+ , noUmlautPS+ )+where++import Data.Char++import Data.StringMap.Base+import Data.StringMap.StringSet++-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key.++prefixFindCaseWithKey :: Key -> StringMap a -> [(Key, a)]+prefixFindCaseWithKey k = toList . cutPx' (singlePS k)++prefixFindNoCaseWithKey :: Key -> StringMap a -> [(Key, a)]+prefixFindNoCaseWithKey k = toList . cutPx' (noCaseKeys k)++prefixFindNoCase :: Key -> StringMap a -> [a]+prefixFindNoCase k = elems . cutPx' (noCaseKeys k)++lookupNoCase :: Key -> StringMap a -> [(Key, a)]+lookupNoCase k = toList . cutAllPx' (noCaseKeys k)++-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key.+-- Breadth first variant, short words first in the result list++prefixFindCaseWithKeyBF :: Key -> StringMap a -> [(Key, a)]+prefixFindCaseWithKeyBF k = toListBF . cutPx' (singlePS k)++prefixFindNoCaseWithKeyBF :: Key -> StringMap a -> [(Key, a)]+prefixFindNoCaseWithKeyBF k = toListBF . cutPx' (noCaseKeys k)++lookupNoCaseBF :: Key -> StringMap a -> [(Key, a)]+lookupNoCaseBF k = toListBF . cutAllPx' (noCaseKeys k)++-- ----------------------------------------++noCaseKeys :: Key -> StringSet+noCaseKeys = noCasePS . singlePS++noLowerCaseKeys :: Key -> StringSet+noLowerCaseKeys = noLowerCasePS . singlePS++-- ----------------------------------------+++noCasePS :: StringSet -> StringSet+noCasePS = fuzzyCharPS (\ x -> [toUpper x, toLower x])++noLowerCasePS :: StringSet -> StringSet+noLowerCasePS = fuzzyCharPS (\ x -> [toUpper x, x])++-- ----------------------------------------++noUmlautPS :: StringSet -> StringSet+noUmlautPS = fuzzyCharsPS noUmlaut+ where+ noUmlaut '\196' = ["Ae"]+ noUmlaut '\214' = ["Oe"]+ noUmlaut '\220' = ["Ue"]+ noUmlaut '\228' = ["ae"]+ noUmlaut '\246' = ["oe"]+ noUmlaut '\252' = ["ue"]+ noUmlaut '\223' = ["ss"]+ noUmlaut c = [[c]]++-- ------------------------------------------------------------+{- a few simple tests++e1 = singlePS "abc"+e2 = prefixPS "abc"+e3 = foldl unionPS emptyPS . fmap singlePS $ ["zeus","anna","anton","an"]+e4 = noCasePS e3+e5 = noLowerCasePS . singlePS $ "Data"+e6 = noUmlautPS . singlePS $ "äöüzß"++-- -}+-- ------------------------------------------------------------
+ Data/StringMap/Lazy.hs view
@@ -0,0 +1,130 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap.Lazy+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ An efficient implementation of maps from strings to arbitrary values.++ Values can associated with an arbitrary byte key. Searching for keys is very fast, but+ the prefix tree probably consumes more memory than "Data.Map". The main differences are the special+ 'prefixFind' functions, which can be used to perform prefix queries. The interface is+ heavily borrowed from "Data.Map" and "Data.IntMap".++ Most other function names clash with "Prelude" names, therefore this module is usually+ imported @qualified@, e.g.++ > import Data.StringMap (StringMap)+ > import qualified Data.StringMap as T++ Many functions have a worst-case complexity of /O(min(n,L))/. This means that the operation+ can become linear with the number of elements with a maximum of /L/, the length of the+ key (the number of bytes in the list). The functions for searching a prefix have a worst-case+ complexity of /O(max(L,R))/. This means that the operation can become linear with+ /R/, the number of elements found for the prefix, with a minimum of /L/.++ The module exports include the internal data types, their constructors and access+ functions for ultimate flexibility. Derived modules should not export these+ (as shown in "Holumbus.Data.StrMap") to provide only a restricted interface.++-}++-- ----------------------------------------------------------------------------++module Data.StringMap.Lazy+ (+ -- * Map type+ StringMap -- (..) I don't think we should export the constructor.+ , Key++ -- * Operators+ , (!)++ -- * Query+ , value+ , valueWithDefault+ , null+ , size+ , member+ , lookup+ , findWithDefault+ , prefixFind+ , prefixFindWithKey+ , prefixFindWithKeyBF++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey++ -- ** Delete\/Update+ , delete+ , update+ , updateWithKey++ -- * Combine+ -- ** Union+ , union+ , unionWith+ , unionWithKey++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey+++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapM+ , mapWithKeyM++ -- * Folds+ , fold+ , foldWithKey++ -- * Conversion+ , keys+ , elems++ -- ** Lists+ , fromList+ , toList+ , toListBF++ -- ** Maps+ , fromMap+ , toMap++ -- * Debugging+ , space+ , keyChars++ -- * Prefix and Fuzzy Search+ , prefixFindCaseWithKey -- fuzzy search+ , prefixFindNoCaseWithKey+ , prefixFindNoCase+ , lookupNoCase++ , prefixFindCaseWithKeyBF+ , prefixFindNoCaseWithKeyBF+ , lookupNoCaseBF+ )+where++import Data.StringMap.Base+import Data.StringMap.FuzzySearch+import Prelude hiding (lookup, map, mapM, null,+ succ)+
+ Data/StringMap/Strict.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS -XBangPatterns #-}+-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap.Strict+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ An efficient implementation of maps from strings to arbitrary values.++ Values can associated with an arbitrary byte key. Searching for keys is very fast, but+ the prefix tree probably consumes more memory than "Data.Map". The main differences are the special+ 'prefixFind' functions, which can be used to perform prefix queries. The interface is+ heavily borrowed from "Data.Map" and "Data.IntMap".++ Most other function names clash with "Prelude" names, therefore this module is usually+ imported @qualified@, e.g.++ > import Data.StringMap (StringMap)+ > import qualified Data.StringMap as T++ Many functions have a worst-case complexity of /O(min(n,L))/. This means that the operation+ can become linear with the number of elements with a maximum of /L/, the length of the+ key (the number of bytes in the list). The functions for searching a prefix have a worst-case+ complexity of /O(max(L,R))/. This means that the operation can become linear with+ /R/, the number of elements found for the prefix, with a minimum of /L/.++ The module exports include the internal data types, their constructors and access+ functions for ultimate flexibility. Derived modules should not export these+ (as shown in "Holumbus.Data.StrMap") to provide only a restricted interface.++-}++-- ----------------------------------------------------------------------------++module Data.StringMap.Strict+ (+ -- * Map type+ StringMap+ , Key++ -- * Operators+ , (!)++ -- * Query+ , value+ , valueWithDefault+ , null+ , size+ , member+ , lookup+ , findWithDefault+ , prefixFind+ , prefixFindWithKey+ , prefixFindWithKeyBF++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey++ -- ** Delete\/Update+ , delete+ , update+ , updateWithKey++ -- * Combine+ -- ** Union+ , union+ , unionWith+ , unionWithKey++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey+++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapM+ , mapWithKeyM++ -- * Folds+ , fold+ , foldWithKey++ -- * Conversion+ , keys+ , elems++ -- ** Lists+ , fromList+ , toList+ , toListBF++ -- ** Maps+ , fromMap+ , toMap++ -- * Debugging+ , space+ , keyChars++ -- * Prefix and Fuzzy Search+ , prefixFindCaseWithKey -- fuzzy search+ , prefixFindNoCaseWithKey+ , prefixFindNoCase+ , lookupNoCase++ , prefixFindCaseWithKeyBF+ , prefixFindNoCaseWithKeyBF+ , lookupNoCaseBF+ )+where++import Data.StringMap.Base hiding+ (+ singleton+ , insert+ , insertWith+ , insertWithKey+ , fromList+ )+import Data.StringMap.FuzzySearch+import Prelude hiding (lookup, map, mapM, null,+ succ)++--import Data.Strict.Tuple+import qualified Data.List as L+--import Data.BitUtil+--import Data.StrictPair++-- | /O(1)/ Create a map with a single element.++singleton :: Key -> a -> StringMap a+singleton !k v = L.foldr (\ c r -> branch c r empty) (val v empty) $ k -- siseq k (val v empty)++{-# INLINE singleton #-}++-- | /O(min(n,L))/ Insert a new key and value into the map. If the key is already present in+-- the map, the associated value will be replaced with the new value.++insert :: Key -> a -> StringMap a -> StringMap a+insert !k !v = insertWith const k v++{-# INLINE insert #-}++-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map,+-- the value of @f new_value old_value@ will be inserted.++insertWith :: (a -> a -> a) -> Key -> a -> StringMap a -> StringMap a+insertWith f !k v t = insert' f v k t++{-# INLINE insertWith #-}++-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map,+-- the value of @f key new_value old_value@ will be inserted.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> StringMap a -> StringMap a+insertWithKey f !k = insertWith (f k) k+-- ----------------------------------------++insert' :: (a -> a -> a) -> a -> Key -> StringMap a -> StringMap a+insert' f v k0 = ins k0 . norm+ where+ ins' = insert' f v++ ins k (Branch c' s' n')+ = case k of+ [] -> val v (branch c' s' n')+ (c : k1)+ | c < c' -> branch c (singleton k1 v) (branch c' s' n')+ | c == c' -> branch c (ins' k1 s') n'+ | otherwise -> branch c' s' (ins' k n')++ ins k Empty = singleton k v++ ins k (Val v' t')+ = case k of+ [] -> flip val t' $! f v v'+ _ -> val v' (ins' k t')++ ins _ _ = normError "insert'"++-- | /O(n)/ Creates a trie from a list of key\/value pairs.+fromList :: [(Key, a)] -> StringMap a+fromList = L.foldl' (\p (k, v) -> insert k v p) empty
+ Data/StringMap/StringSet.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE BangPatterns #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap.StringSet+ Copyright : Copyright (C) 2010 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ A simplified version of StringMap for implementing sets.++ There is one important difference to the StringMap implementation:+ The fields are not marked to be strict. This enables building the+ set on the fly.++ This feature is used in fuzzy search, when an index tree is restricted+ to a set of keys, e.g. the set of all none case significant keys++-}++-- ----------------------------------------------------------------------------++module Data.StringMap.StringSet+where++import Data.List (nub, sort)++import Data.StringMap.Types++-- ----------------------------------------++-- | Set of strings implemented as lazy prefix tree.+-- @type StringSet = StringMap ()@ is not feasable because of+-- the strict fields in the StringMap definition++data StringSet = PSempty+ | PSelem StringSet+ | PSnext Sym StringSet StringSet+ deriving (Show)++emptyPS :: StringSet+emptyPS = PSempty++elemPS :: StringSet -> StringSet+elemPS s@(PSelem _) = s+elemPS s = PSelem s++elem0PS :: StringSet+elem0PS = elemPS emptyPS++nextPS :: Sym -> StringSet -> StringSet -> StringSet+nextPS _ PSempty n = n+nextPS s c n = PSnext s c n++lastPS :: Sym -> StringSet -> StringSet+lastPS s c = nextPS s c emptyPS++nullPS :: StringSet -> Bool+nullPS PSempty = True+nullPS _ = False++singlePS :: Key -> StringSet+singlePS = foldr lastPS elem0PS++-- ------------------------------------------------------------++prefixPS :: Key -> StringSet+prefixPS = foldr (\ c r -> elemPS (lastPS c r)) elem0PS++-- ------------------------------------------------------------++unionPS :: StringSet -> StringSet -> StringSet+unionPS PSempty ps2 = ps2+unionPS ps1 PSempty = ps1++unionPS (PSelem ps1) (PSelem ps2) = PSelem (unionPS ps1 ps2)+unionPS (PSelem ps1) ps2 = PSelem (unionPS ps1 ps2)+unionPS ps1 (PSelem ps2) = PSelem (unionPS ps1 ps2)++unionPS ps1@(PSnext c1 s1 n1)+ ps2@(PSnext c2 s2 n2)+ | c1 < c2 = nextPS c1 s1 (unionPS n1 ps2)+ | c1 > c2 = nextPS c2 s2 (unionPS ps1 n2)+ | otherwise = nextPS c1 (unionPS s1 s2) (unionPS n1 n2)++-- ------------------------------------------------------------++foldPS :: (Key -> b -> b) -> b -> (Key -> Key) -> StringSet -> b+foldPS _ r _ PSempty = r+foldPS f r kf (PSelem ps1) = let r' = foldPS f r kf ps1+ in+ f (kf []) r'+foldPS f r kf (PSnext c1 s1 n1) = let r' = foldPS f r kf n1+ in+ foldPS f r' (kf . (c1:)) s1++foldWithKeyPS :: (Key -> b -> b) -> b -> StringSet -> b+foldWithKeyPS f e = foldPS f e id++-- ------------------------------------------------------------++elemsPS :: StringSet -> [Key]+elemsPS = foldWithKeyPS (:) []++-- ------------------------------------------------------------++fuzzyCharPS :: (Sym -> [Sym]) -> StringSet -> StringSet+fuzzyCharPS _ PSempty = PSempty+fuzzyCharPS f (PSelem ps) = PSelem $ fuzzyCharPS f ps+fuzzyCharPS f (PSnext c s n) = unionPS ps1 (fuzzyCharPS f n)+ where+ s' = fuzzyCharPS f s+ cs = sort . nub . f $ c+ ps1 = foldr (\ c' r' -> nextPS c' s' r') emptyPS $ cs++-- ------------------------------------------------------------++fuzzyCharsPS :: (Sym -> [Key]) -> StringSet -> StringSet+fuzzyCharsPS _ PSempty = PSempty+fuzzyCharsPS f (PSelem ps) = PSelem $ fuzzyCharsPS f ps+fuzzyCharsPS f (PSnext c s n) = unionPS ps1 (fuzzyCharsPS f n)+ where+ s' = fuzzyCharsPS f s+ cs = sort . nub . f $ c+ ps1 = foldr (\ w' r' -> nextPSw w' s' r') emptyPS $ cs+ nextPSw [] _ r' = r'+ nextPSw (x:xs) s'' r' = nextPS x (foldr lastPS s'' xs) r'++-- ------------------------------------------------------------
+ Data/StringMap/Types.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap.Types+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: portable++ Data types used in all StringMap modules++-}++-- ----------------------------------------------------------------------------++module Data.StringMap.Types+where++type Sym = Char+type Key = [Sym]++-- ----------------------------------------------------------------------------
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License++Copyright (c) 2007 Sebastian M. Schlatt, Timo B. Hübel++Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation the+rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/StringMap.hs view
@@ -0,0 +1,101 @@+--{-# LANGUAGE BangPatterns #-}+module Main where++import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad.Trans (liftIO)+import Criterion.Config+import Criterion.Main+import Data.List (foldl')+import qualified Data.StringMap.Strict as M+import Data.Maybe (fromMaybe)+import Prelude hiding (lookup)++powerset :: [a] -> [[a]]+powerset [] = [[]]+powerset (x:xs) = powerset xs ++ map (x:) (powerset xs)++main = do+ dict <- readFile "en_US.dict"+ keys <- return $ lines dict+ elems <- return $ zip keys [1..]+ m <- return $ (M.fromList elems :: M.StringMap Int)+ defaultMainWith+ defaultConfig+ (liftIO . evaluate $ rnf [m])+ [ bench "lookup" $ whnf (lookup keys) m+ , bench "insert" $ whnf (ins elems) M.empty+ , bench "insertWith empty" $ whnf (insWith elems) M.empty+ , bench "insertWith update" $ whnf (insWith elems) m+-- , bench "insertWith' empty" $ whnf (insWith' elems) M.empty+-- , bench "insertWith' update" $ whnf (insWith' elems) m+ , bench "insertWithKey empty" $ whnf (insWithKey elems) M.empty+ , bench "insertWithKey update" $ whnf (insWithKey elems) m+-- , bench "insertWithKey' empty" $ whnf (insWithKey' elems) M.empty+-- , bench "insertWithKey' update" $ whnf (insWithKey' elems) m+-- , bench "insertLookupWithKey empty" $ whnf (insLookupWithKey elems) M.empty+-- , bench "insertLookupWithKey update" $ whnf (insLookupWithKey elems) m+ , bench "map" $ whnf (M.map (+ 1)) m+ --, bench "mapWithKey" $ whnf (M.mapWithKey (+)) m+ , bench "foldlWithKey" $ whnf (ins elems) m+-- , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m+-- , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m+ , bench "delete" $ whnf (del keys) m+ , bench "update" $ whnf (upd keys) m+-- , bench "updateLookupWithKey" $ whnf (upd' keys) m+-- , bench "alter" $ whnf (alt keys) m+-- , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m+-- , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m+ , bench "fromList" $ whnf M.fromList elems+-- , bench "fromAscList" $ whnf M.fromAscList elems+-- , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems+ ]+ where+ sum k v1 v2 = k + v1 + v2+ consPair k v xs = (k, v) : xs++add3 :: a -> Int -> Int -> Int+add3 _ y z = y + z+{-# INLINE add3 #-}++lookup :: [M.Key] -> M.StringMap Int -> Int+lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs++ins :: [(M.Key, Int)] -> M.StringMap Int -> M.StringMap Int+ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs++insWith :: [(M.Key, Int)] -> M.StringMap Int -> M.StringMap Int+insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs++insWithKey :: [(M.Key, Int)] -> M.StringMap Int -> M.StringMap Int+insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs++--insWith' :: [(Int, Int)] -> M.StringMap Int -> M.StringMap Int+--insWith' xs m = foldl' (\m (k, v) -> M.insertWith' (+) k v m) m xs++--insWithKey' :: [(Int, Int)] -> M.StringMap Int -> M.StringMap Int+--insWithKey' xs m = foldl' (\m (k, v) -> M.insertWithKey' add3 k v m) m xs++--data PairS a b = PS !a !b++--insLookupWithKey :: [(Int, Int)] -> M.StringMap Int -> (Int, M.StringMap Int)+--insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)+-- where+-- f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m+-- in PS (fromMaybe 0 n' + n) m'++del :: [M.Key] -> M.StringMap Int -> M.StringMap Int+del xs m = foldl' (flip M.delete) m xs++upd :: [M.Key] -> M.StringMap Int -> M.StringMap Int+upd xs m = foldl' (flip (M.update Just)) m xs++--upd' :: [Int] -> M.StringMap Int -> M.StringMap Int+--upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m xs++--alt :: [Int] -> M.StringMap Int -> M.StringMap Int+--alt xs m = foldl' (\m k -> M.alter id k m) m xs++maybeDel :: Int -> Maybe Int+maybeDel n | n `mod` 3 == 0 = Nothing+ | otherwise = Just n
+ data-stringmap.cabal view
@@ -0,0 +1,59 @@+name: data-stringmap+version: 0.9+license: MIT+license-file: LICENSE+author: Sebastian Philipp, Uwe Schmidt+maintainer: uwe@fh-wedel.de+bug-reports: https://github.com/sebastian-philipp/StringMap/issues+synopsis: An efficient implementation of maps from strings to arbitrary values+category: Data Structures+description: An efficient implementation of maps from strings to arbitrary values.+ Values can associated with an arbitrary byte key.+ Searching for keys is very fast, but+ the prefix tree probably consumes more memory than+ "Data.Map". The main differences are the special+ 'prefixFind' functions, which can be used to perform prefix queries.++build-type: Simple+cabal-version: >=1.8+extra-source-files:+ tests/*.hs+ benchmarks/*.hs++source-repository head+ type: git+ location: https://github.com/sebastian-philipp/StringMap.git++Library+ build-depends: base >= 4.5 && < 5,+ deepseq >= 1.2,+ binary >= 0.5,+ containers >= 0.4++ ghc-options: -O2 -Wall -fwarn-tabs -fno-warn-unused-binds++ exposed-modules:+ Data.StringMap+ Data.StringMap.StringSet+ Data.StringMap.Lazy+ Data.StringMap.Strict+ Data.StringMap.Types++ other-modules:+ Data.StringMap.Base+ Data.StringMap.FuzzySearch++test-suite properties+ type: exitcode-stdio-1.0+ main-is: StringMapProperties.hs+ build-depends: data-stringmap,+ base >= 4.5,+ containers >= 0.4,+ HUnit >= 1.2,+ QuickCheck >= 2.4,+ test-framework >= 0.6,+ test-framework-quickcheck2 >= 0.2,+ test-framework-hunit >= 0.2++ ghc-options: -Wall -fwarn-tabs+ hs-source-dirs: tests
+ tests/StringMapProperties.hs view
@@ -0,0 +1,399 @@+module Main+where+import Data.StringMap+++import qualified Data.Char as Char (intToDigit)+import qualified Data.List as List (nubBy, (!!))+import qualified Data.Map as Map (empty, fromList,+ map, toList)+import qualified Data.Set as Set (fromList)+import Prelude hiding (filter, foldl,+ foldr, lookup, map, null)++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding (Test, Testable)+import Text.Show.Functions ()+++default (Int)++main :: IO ()+main = defaultMain+ [+ -- testCase "exclamation" test_exclamation+ testCase "value" test_value+ , testCase "valueWithDefault" test_valueWithDefault+ , testCase "null" test_null+ , testCase "size" test_size+ , testCase "member" test_member+ , testCase "lookup" test_lookup+ , testCase "findWithDefault" test_findWithDefault+ , testCase "prefixFind" test_prefixFind+ , testCase "prefixFindWithKey" test_prefixFindWithKey+ , testCase "prefixFindWithKeyBF" test_prefixFindWithKeyBF+ , testCase "empty" test_empty+ , testCase "singleton" test_singleton+ , testCase "insert" test_insert+ , testCase "insertWith" test_insertWith+ , testCase "insertWithKey" test_insertWithKey+ , testCase "delete" test_delete+ , testCase "update" test_update+ , testCase "updateWithKey" test_updateWithKey+ , testCase "union" test_union+ , testCase "unionWith" test_unionWith+ , testCase "unionWithKey" test_unionWithKey+ , testCase "difference" test_difference+ , testCase "differenceWith" test_differenceWith+ , testCase "differenceWithKey" test_differenceWithKey+ , testCase "map" test_map+ , testCase "mapWithKey" test_mapWithKey+ -- , testCase "mapM" test_mapM+ -- , testCase "mapWithKeyM" test_mapWithKeyM+ , testCase "fold" test_fold+ , testCase "foldWithKey" test_foldWithKey+ , testCase "keys" test_keys+ , testCase "elems" test_elems+ , testCase "fromList" test_fromList+ , testCase "toList" test_toList+ , testCase "toListBF" test_toListBF+ , testCase "fromMap" test_fromMap+ , testCase "toMap" test_toMap+ -- , testCase "space" test_space+ -- , testCase "keyChars" test_keyChars+ , testCase "prefixFindCaseWithKey" test_prefixFindCaseWithKey -- fuzzy search+ , testCase "prefixFindNoCaseWithKey" test_prefixFindNoCaseWithKey+ , testCase "prefixFindNoCase" test_prefixFindNoCase+ , testCase "lookupNoCase" test_lookupNoCase+ , testCase "prefixFindCaseWithKeyBF" test_prefixFindCaseWithKeyBF+ , testCase "prefixFindNoCaseWithKeyBF" test_prefixFindNoCaseWithKeyBF+ -- , testCase "lookupNoCaseBF" test_lookupNoCaseBF+ , testProperty "insert to singleton" prop_singleton+ , testProperty "map a StringMap" prop_map+ , testProperty "fromList - toList" prop_fromListToList+ , testProperty "space" prop_space+ , testProperty "lookupNoCaseBF is redundant" prop_lookupNoCaseBF+ ]++------------------------------------------------------------------------++type UMap = StringMap ()+type IMap = StringMap Int+type SMap = StringMap String++cmpset :: (Eq a, Show a, Ord a) => [a] -> [a] -> Assertion+cmpset l r = (Set.fromList l) @?= (Set.fromList r)++cmpset' :: (Ord a) => [a] -> [a] -> Bool+cmpset' l r = (Set.fromList l) == (Set.fromList r)++mergeString :: String -> String -> String -> String+mergeString key l r = key ++ ":" ++ l ++ "|" ++ r++----------------------------------------------------------------+-- Unit tests+----------------------------------------------------------------++_1, _4 :: Int+_1 = 1+_4 = 4++test_exclamation :: Assertion+test_exclamation = undefined++test_value :: Assertion+test_value =+ let m1 = fromList [("" ,_1),("a", 2)] in+ let m2 = fromList [("x",_1),("a", 2)] in+ do+ value m1 @?= Just _1+ value m2 @?= Nothing++test_valueWithDefault :: Assertion+test_valueWithDefault =+ let m1 = fromList [("" ,_1),("a", 2)] in+ let m2 = fromList [("x",_1),("a", 2)] in+ do+ valueWithDefault 3 m1 @?= _1+ valueWithDefault 3 m2 @?= 3++test_null :: Assertion+test_null =+ let m = fromList [("a",_1), ("ab", 2)] in+ do+ null m @?= False+ null (empty :: UMap) @?= True++test_size :: Assertion+test_size = do+ size (fromList [("a",_1), ("ab", 2)]) @?= 2+ size (fromList [("a",_1), ("a", 2)]) @?= 1+ size (empty :: UMap) @?= 0++test_member :: Assertion+test_member = do+ member "ab" (fromList [("a",_1), ("ab", 2)]) @?= True+ member "aba" (fromList [("a",_1), ("ab", 2)]) @?= False+ member "" (empty :: UMap) @?= False++test_lookup :: Assertion+test_lookup = do+ lookup "ab" (fromList [("a",_1), ("ab", 2)]) @?= Just 2+ lookup "aba" (fromList [("a",_1), ("ab", 2)]) @?= Nothing+ lookup "" (empty :: UMap) @?= Nothing++test_findWithDefault :: Assertion+test_findWithDefault = do+ findWithDefault 7 "ab" (fromList [("a",_1), ("ab", 2)]) @?= 2+ findWithDefault 7 "aba" (fromList [("a",_1), ("ab", 2)]) @?= 7+ findWithDefault 7 "" (empty :: IMap) @?= 7++test_prefixFind :: Assertion+test_prefixFind = do+ prefixFind "a" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) `cmpset` [1, 2, 4]+ prefixFind "" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) `cmpset` [1, 2, 3, 4, 5]+ prefixFind "foo" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) @?= []+ prefixFind "" (empty :: UMap) @?= []++test_prefixFindWithKey :: Assertion+test_prefixFindWithKey = do+ prefixFindWithKey "a" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) `cmpset` [("a",_1), ("ab", 2), ("aaa", 4)]+ prefixFindWithKey "" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) `cmpset` [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]+ prefixFindWithKey "foo" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) @?= []+ prefixFindWithKey "" (empty :: UMap) @?= []++test_prefixFindWithKeyBF :: Assertion+test_prefixFindWithKeyBF = do+ prefixFindWithKeyBF "a" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) @?= [("a",_1), ("ab", 2), ("aaa", 4)]+ prefixFindWithKeyBF "" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) @?= [("a",_1), ("b", 5), ("ab", 2), ("aaa", 4), ("cab", 3)]+ prefixFindWithKeyBF "foo" (fromList [("a",_1), ("ab", 2), ("cab", 3), ("aaa", 4), ("b", 5)]) @?= []+ prefixFindWithKeyBF "" (empty :: UMap) @?= []++test_empty :: Assertion+test_empty = do+ (empty :: UMap) @?= fromList []+ size empty @?= 0+++test_singleton :: Assertion+test_singleton = do+ singleton "k" 'a' @?= fromList [("k", 'a')]+ size (singleton "k" 'a') @?= 1++test_insert :: Assertion+test_insert = do+ insert "5" 'x' (fromList [("5",'a'), ("3",'b')]) @?= fromList [("3", 'b'), ("5", 'x')]+ insert "7" 'x' (fromList [("5",'a'), ("3",'b')]) @?= fromList [("3", 'b'), ("5", 'a'), ("7", 'x')]+ insert "5" 'x' empty @?= singleton "5" 'x'++test_insertWith :: Assertion+test_insertWith = do+ insertWith (++) "5" "xxx" (fromList [("5","a"), ("3","b")]) @?= fromList [("3", "b"), ("5", "xxxa")]+ insertWith (++) "7" "xxx" (fromList [("5","a"), ("3","b")]) @?= fromList [("3", "b"), ("5", "a"), ("7", "xxx")]+ insertWith (++) "5" "xxx" empty @?= singleton "5" "xxx"++test_insertWithKey :: Assertion+test_insertWithKey = do+ insertWithKey mergeString "5" "xxx" (fromList [("5","a"), ("3","b")]) @?= fromList [("3", "b"), ("5", "5:xxx|a")]+ insertWithKey mergeString "7" "xxx" (fromList [("5","a"), ("3","b")]) @?= fromList [("3", "b"), ("5", "a"), ("7", "xxx")]+ insertWithKey mergeString "5" "xxx" empty @?= singleton "5" "xxx"++test_delete :: Assertion+test_delete = do+ delete "a" (fromList [("a",_1), ("ab", 2)]) @?= fromList [("ab", 2)]+ delete "ab" (fromList [("a",_1), ("ab", 2)]) @?= fromList [("a", 1)]+ delete "ab" (empty :: IMap) @?= empty++test_update :: Assertion+test_update = do+ update f "a" (fromList [("a",_1), ("ab", 2)]) @?= fromList [("a",777), ("ab", 2)]+ update f "a" (fromList [("a",_4), ("ab", 2)]) @?= fromList [("ab", 2)]+ update f "a" (empty :: IMap) @?= empty+ where+ f 1 = Just 777+ f _ = Nothing++test_updateWithKey :: Assertion+test_updateWithKey = do+ updateWithKey f "a" (fromList [("a","a"), ("ab","b")]) @?= fromList [("ab", "b"), ("a", "a:new a")]+ updateWithKey f "c" (fromList [("","a"), ("ab","b")]) @?= fromList [("ab", "b"), ("", "a")]+ updateWithKey f "ab" (fromList [("","a"), ("ab","b")]) @?= singleton "" "a"+ where+ f k x = if x == "a" then Just ((k) ++ ":new a") else Nothing++test_union :: Assertion+test_union = do+ union (fromList [("a",_1), ("ab", 3)]) (fromList [("a", 2), ("c",_4)]) @?= fromList [("a",_1), ("ab", 3), ("c",_4)]+ union empty (fromList [("a", 2), ("c",_4)]) @?= fromList [("a", 2), ("c",_4)]++test_unionWith :: Assertion+test_unionWith = do+ unionWith (+) (fromList [("a",_1), ("ab", 3)]) (fromList [("a", 2), ("c",_4)]) @?= fromList [("a", 3), ("ab", 3), ("c",_4)]+ unionWith (+) empty (fromList [("a", 2), ("c",_4)]) @?= fromList [("a", 2), ("c",_4)]+++test_unionWithKey :: Assertion+test_unionWithKey =+ unionWithKey mergeString (fromList [("a", "a"), ("ab", "b")]) (fromList [("a", "A"), ("c", "C")]) @?= fromList [("ab", "b"), ("a", "a:a|A"), ("c", "C")]++test_difference :: Assertion+test_difference =+ difference (fromList [("a", "a"), ("ab", "b")]) (fromList [("a", "A"), ("c", "C")]) @?= (singleton "ab" "b")++test_differenceWith :: Assertion+test_differenceWith =+ differenceWith f (fromList [("a", "a"), ("ab", "b")]) (fromList [("a", "A"), ("ab", "B"), ("c", "C")]) @?= singleton "ab" "b:B"+ where+ f al ar = if al== "b" then Just (al ++ ":" ++ ar) else Nothing++test_differenceWithKey :: Assertion+test_differenceWithKey =+ differenceWithKey f (fromList [("a", "a"), ("ab", "b")]) (fromList [("a", "A"), ("ab", "B"), ("c", "C")]) @?= singleton "ab" "ab:b|B"+ where+ f k al ar = if al == "b" then Just (mergeString k al ar) else Nothing++test_map :: Assertion+test_map =+ map (* 10) (fromList [("a",_1), ("ab",2)]) @?= fromList [("a", 10), ("ab", 20)]++test_mapWithKey :: Assertion+test_mapWithKey =+ mapWithKey (mergeString "") (fromList [("a","A"), ("ab","B")]) @?= fromList [("ab", ":a|B"), ("a", ":a|A")]++test_mapM :: Assertion+test_mapM = undefined++test_mapWithKeyM :: Assertion+test_mapWithKeyM = undefined++test_fold :: Assertion+test_fold = do+ fold (\ l r -> (Char.intToDigit $ fromIntegral l) : r) "0" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6)]) @?= "45260"+ error "In Which Order?"++test_foldWithKey :: Assertion+test_foldWithKey = do+ foldWithKey f "0" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6)]) @?= "a:4|aa:5|ab:2|b:6|0"+ error "In Which Order?"+ where+ f k l = mergeString k [Char.intToDigit $ fromIntegral l]++test_keys :: Assertion+test_keys =+ keys (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6)]) @?= ["a", "aa", "ab", "b"]++test_elems :: Assertion+test_elems =+ elems (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6)]) @?= [4, 5, 2, 6]++test_fromList :: Assertion+test_fromList = do+ fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6)] @?= fromList [("b", 6), ("ab", 2), ("a",_4), ("aa", 5)]+ fromList [] @?= (empty :: UMap)++test_toList :: Assertion+test_toList = do+ (toList.fromList) [("a",_4), ("ab", 2), ("aa", 5), ("b", 6)] @?= [("a",_4), ("aa", 5), ("ab", 2), ("b", 6)]+ toList (empty :: UMap) @?= []++test_toListBF :: Assertion+test_toListBF = do+ (toListBF.fromList) [("a",_4), ("Ab", 2)] @?= [("a",_4), ("Ab", 2)]+ (toListBF.fromList) [("a",_4), ("ab", 2), ("aa", 5), ("b", 6)] @?= [("a",_4), ("b", 6), ("aa", 5), ("ab", 2)]+ toListBF (empty :: UMap) @?= []+++test_fromMap :: Assertion+test_fromMap = do+ fromMap (Map.fromList [("a",_4),("aa",5),("ab",2),("b",6)]) @?= fromList [("a",_4),("aa",5),("ab",2),("b",6)]+ fromMap Map.empty @?= (empty :: UMap)+++test_toMap :: Assertion+test_toMap = do+ (toMap.fromList) [("a",_4),("aa",5),("ab",2),("b",6)] @?= Map.fromList [("a",_4),("aa",5),("ab",2),("b",6)]+ toMap (empty :: UMap) @?= Map.empty+++test_space :: Assertion+test_space = undefined++test_keyChars :: Assertion+test_keyChars = undefined++test_prefixFindCaseWithKey :: Assertion+test_prefixFindCaseWithKey = do+ prefixFindCaseWithKey "" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("Ab", 7), ("a",_4), ("aa", 5), ("ab", 2), ("b", 6)]+ prefixFindCaseWithKey "a" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("a",_4), ("aa", 5), ("ab", 2)]+ prefixFindCaseWithKey "b" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("b", 6)]+ prefixFindCaseWithKey "c" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= []++test_prefixFindNoCaseWithKey :: Assertion+test_prefixFindNoCaseWithKey = do+ prefixFindNoCaseWithKey "" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("Ab", 7), ("a",_4), ("aa", 5), ("ab", 2), ("b", 6)]+ prefixFindNoCaseWithKey "a" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("Ab", 7), ("a",_4), ("aa", 5), ("ab", 2)]+ prefixFindNoCaseWithKey "b" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("b", 6)]+ prefixFindNoCaseWithKey "c" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= []++test_prefixFindNoCase :: Assertion+test_prefixFindNoCase = do+ prefixFindNoCase "" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("aB", 7)]) @?= [4, 7, 5, 2, 6]+ prefixFindNoCase "a" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("aB", 7)]) @?= [4, 7, 5, 2]+ prefixFindNoCase "b" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("aB", 7)]) @?= [6]+ prefixFindNoCase "c" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("aB", 7)]) @?= []++test_lookupNoCase :: Assertion+test_lookupNoCase = do+ lookupNoCase "ab" (fromList [("a",_1), ("Ab", 2)]) @?= [("Ab", 2)]+ lookupNoCase "aB" (fromList [("a",_1), ("Ab", 2)]) @?= [("Ab", 2)]+ lookupNoCase "" (empty :: UMap) @?= []++test_prefixFindCaseWithKeyBF :: Assertion+test_prefixFindCaseWithKeyBF = do+ prefixFindCaseWithKeyBF "" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("a",_4), ("b", 6), ("Ab", 7), ("aa", 5), ("ab", 2)]+ prefixFindCaseWithKeyBF "a" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("a",_4), ("aa", 5), ("ab", 2)]+ prefixFindCaseWithKeyBF "b" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("b", 6)]+ prefixFindCaseWithKeyBF "c" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= []+++test_prefixFindNoCaseWithKeyBF :: Assertion+test_prefixFindNoCaseWithKeyBF = do+ prefixFindNoCaseWithKeyBF "" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("a",_4), ("b", 6), ("Ab", 7), ("aa", 5), ("ab", 2)]+ prefixFindNoCaseWithKeyBF "a" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("a",_4), ("Ab", 7), ("aa", 5), ("ab", 2)]+ prefixFindNoCaseWithKeyBF "b" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= [("b", 6)]+ prefixFindNoCaseWithKeyBF "c" (fromList [("a",_4), ("ab", 2), ("aa", 5), ("b", 6), ("Ab", 7)]) @?= []++test_lookupNoCaseBF :: Assertion+test_lookupNoCaseBF = undefined++----------------------------------------------------------------+-- QuickCheck+----------------------------------------------------------------++makeUnique :: [(Key, Int)] -> [(Key, Int)]+makeUnique = List.nubBy (\ (f,_) (s,_) -> f == s)++prop_singleton :: Key -> Key -> Bool+prop_singleton k x = insert k x empty == singleton k x++prop_map :: (Int -> Int) -> [(Key, Int)] -> Bool+prop_map f l = (toListBF.(map f).fromList) l `cmpset'` ((Map.toList).(Map.map f).(Map.fromList)) l++prop_fromListToList :: [(Key, Int)] -> Bool+prop_fromListToList l = ((toList.fromList.makeUnique) l) `cmpset'` (makeUnique l)++prop_space :: [(Key, Int)] -> Bool+prop_space [] = True+prop_space l = (space.fromList) l >= (space.fromList.tail) l++prop_lookupNoCaseBF :: [(Key, Int)] -> Int -> Bool+prop_lookupNoCaseBF [] _ = True+prop_lookupNoCaseBF l k = (test' lookupNoCaseBF) == (test' lookupNoCase)+ where+ ul = makeUnique l+ key :: Key+ key = fst $ ul List.!! (k `mod` length ul)+ test' :: (Key -> StringMap Int -> [(Key, Int)]) -> [(Key, Int)]+ test' f = f key (fromList ul)