data-stringmap 0.9.1 → 0.9.2
raw patch · 9 files changed
+635/−129 lines, 9 filesdep +ghc-heap-viewdep ~basedep ~binarydep ~containers
Dependencies added: ghc-heap-view
Dependency ranges changed: base, binary, containers, deepseq
Files
- Data/StringMap.hs +13/−7
- Data/StringMap/Base.hs +243/−93
- Data/StringMap/Lazy.hs +2/−1
- Data/StringMap/Strict.hs +135/−17
- benchmarks/StringMap.hs +2/−1
- data-stringmap.cabal +23/−5
- tests/SimpleStrictTest.hs +61/−0
- tests/StringMapProperties.hs +36/−5
- tests/StringMapStrict.hs +120/−0
Data/StringMap.hs view
@@ -12,7 +12,7 @@ Portability: not portable Facade for prefix tree implementation- + -} -- ----------------------------------------------------------------------------@@ -20,7 +20,7 @@ module Data.StringMap ( -- * Map type- StringMap -- (..) I don't think we should export the constructor.+ StringMap() -- Don't export the constructors , Key -- * Operators@@ -33,10 +33,11 @@ , size , member , lookup- , findWithDefault + , findWithDefault , prefixFind , prefixFindWithKey , prefixFindWithKeyBF+ , lookupRange -- * Construction , empty@@ -48,6 +49,8 @@ , insertWithKey -- ** Delete\/Update+ , adjust+ , adjustWithKey , delete , update , updateWithKey@@ -105,8 +108,11 @@ ) where -import Prelude hiding ( succ, lookup, map, mapM, null )+import Prelude hiding (lookup, map, mapM, null,+ succ) -import Data.StringMap.Base-import Data.StringMap.FuzzySearch-import Data.StringMap.Types+import Data.StringMap.Base+import Data.StringMap.FuzzySearch+import Data.StringMap.Types++-- ----------------------------------------
Data/StringMap/Base.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XBangPatterns #-}+{-# LANGUAGE BangPatterns #-} -- ---------------------------------------------------------------------------- @@ -30,9 +30,9 @@ 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+ The module export list includes 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.+ (as shown in "Data.StringMap") to provide only a restricted interface. -} @@ -41,7 +41,8 @@ module Data.StringMap.Base ( -- * Map type- StringMap (Empty, Val, Branch)-- (..) I don't think we should export the constructors.+ StringMap (Empty, Val, Branch) -- the constructors are exported for pattern matching only+ -- use cases occur in Data.StringMap.Strict , Key -- * Operators@@ -58,6 +59,9 @@ , prefixFind , prefixFindWithKey , prefixFindWithKeyBF+ , lookupGE+ , lookupLE+ , lookupRange -- * Construction , empty@@ -69,6 +73,8 @@ , insertWithKey -- ** Delete\/Update+ , adjust+ , adjustWithKey , delete , update , updateWithKey@@ -112,6 +118,7 @@ -- * Debugging , space+ , stat , keyChars -- Internal@@ -119,26 +126,31 @@ , cutAllPx' , branch , val+ , siseq+ , fromKey , norm- , normError+ , normError'+ , deepNorm ) where -import Prelude hiding ( succ, lookup, map, mapM, null )+import Prelude hiding (lookup, map, mapM, null, succ) import Control.Arrow import Control.DeepSeq -import qualified Data.Foldable+import qualified Data.Foldable as F import Data.Binary-import qualified Data.List as L-import qualified Data.Map as M-import Data.Maybe hiding ( mapMaybe )+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe hiding (mapMaybe) -import Data.StringMap.Types import Data.StringMap.StringSet+import Data.StringMap.Types +-- ----------------------------------------+ data StringMap v = Empty | Val { value' :: v , tree :: ! (StringMap v)@@ -159,58 +171,113 @@ ! 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)- } + | 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 - } + , 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+ ! Sym -- a last node with a single char , value' :: v -- and a value } deriving (Show, Eq, Ord) +-- ----------------------------------------+ -- | strict list of chars with unpacked fields+-- and packing of 2 or 3 chars into a single object -- -- for internal use in prefix tree to optimize space efficiency data Key1 = Nil- | Cons {-# UNPACK #-}- ! Sym- ! Key1 + | S1 {-# UNPACK #-} ! Sym+ | S2 {-# UNPACK #-} ! Sym {-# UNPACK #-} ! Sym+ | S3 {-# UNPACK #-} ! Sym {-# UNPACK #-} ! Sym {-# UNPACK #-} ! Sym+ | C1 {-# UNPACK #-} ! Sym+ ! Key1+ | C2 {-# UNPACK #-} ! Sym {-# UNPACK #-} ! Sym+ ! Key1+ | C3 {-# UNPACK #-} ! Sym {-# UNPACK #-} ! Sym {-# 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)+mk1 :: Sym -> Key1+mk1 s1 = S1 s1+-- mk1 s1 = C1 s1 Nil +mk2 :: Sym -> Sym -> Key1+mk2 s1 s2 = S2 s1 s2+-- mk2 s1 s2 = C1 s1 (mk1 s2)+-- mk2 s1 s2 = C1 s1 (C1 s2 Nil)++mk3 :: Sym -> Sym -> Sym -> Key1+mk3 s1 s2 s3 = S3 s1 s2 s3++cons1 :: Sym -> Key1 -> Key1+cons1 s Nil = mk1 s+cons1 s (S1 s2) = mk2 s s2+cons1 s (S2 s2 s3) = mk3 s s2 s3+cons1 s (C1 s2 k2) = C2 s s2 k2+cons1 s (C2 s2 s3 k3) = C3 s s2 s3 k3+cons1 s k = C1 s k++uncons1 :: Key1 -> (Sym, Key1)+uncons1 (S1 s) = (s, Nil)+uncons1 (S2 s s2) = (s, mk1 s2)+uncons1 (S3 s s2 s3) = (s, mk2 s2 s3)+uncons1 (C1 s k1) = (s, k1)+uncons1 (C2 s s2 k1) = (s, C1 s2 k1)+uncons1 (C3 s s2 s3 k1) = (s, C2 s2 s3 k1)+uncons1 Nil = error "uncons1 with Nil"++{-# INLINE mk1 #-}+{-# INLINE mk2 #-}+{-# INLINE mk3 #-}+{-# INLINE cons1 #-}+{-# INLINE uncons1 #-}++ toKey :: Key1 -> Key+toKey (C3 s1 s2 s3 k) = s1 : s2 : s3 : toKey k+toKey (C2 s1 s2 k) = s1 : s2 : toKey k+toKey (C1 s1 k) = s1 : toKey k+toKey (S3 s1 s2 s3) = s1 : s2 : s3 : []+toKey (S2 s1 s2 ) = s1 : s2 : []+toKey (S1 s1 ) = s1 : [] toKey Nil = []-toKey (Cons c k1) = c : toKey k1 fromKey :: Key -> Key1-fromKey k1 = foldr Cons Nil k1+fromKey k1 = foldr cons1 Nil k1 length1 :: Key1 -> Int length1 = length . toKey +space1 :: Key1 -> Int+space1 Nil = 0+space1 (S1 _) = 2+space1 (S2 _ _) = 3+space1 (S3 _ _ _) = 4+space1 (C1 _ k1) = 3 + space1 k1+space1 (C2 _ _ k1) = 4 + space1 k1+space1 (C3 _ _ _ k1) = 5 + space1 k1+ -- ---------------------------------------- -- smart constructors@@ -230,17 +297,17 @@ 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 (LsVal k1 v) Empty = LsSeL (mk2 k k1) v+branch !k (LsSeL ks v) Empty = LsSeL (cons1 k ks) v+branch !k (Last k1 c) Empty = lsseq (mk2 k k1) c+branch !k (LsSeq ks c) Empty = lsseq (cons1 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 (LsVal k1 v) n = BrSeL (mk2 k k1) v n+branch !k (LsSeL ks v) n = BrSeL (cons1 k ks) v n+branch !k (Last k1 c) n = brseq (mk2 k k1) c n+branch !k (LsSeq ks c) n = brseq (cons1 k ks) c n branch !k c n = Branch k c n lsseq :: Key1 -> StringMap v -> StringMap v@@ -257,24 +324,36 @@ siseq :: Key1 -> StringMap v -> StringMap v siseq Nil c = c-siseq (Cons k1 Nil) c = Last k1 c-siseq k c = LsSeq k c-+siseq k c = case uncons1 k of+ (k1, Nil) -> Last k1 c+ _ -> LsSeq k c {-# INLINE siseq #-} +anyseq :: Key1 -> StringMap v -> StringMap v+anyseq Nil c = c+anyseq k (Leaf v) = case uncons1 k of+ (k1, Nil) -> LsVal k1 v+ _ -> LsSeL k v+anyseq k c = case uncons1 k of+ (k1, Nil) -> Last k1 c+ _ -> LsSeq k c+{-# INLINE anyseq #-}+ -- 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 (LsSeq k' c) = case uncons1 k' of+ (k, Nil) -> Branch k c empty+ (k, ks) -> Branch k (siseq ks c) empty+norm (BrSeq k' c n) = case uncons1 k' of+ (k, Nil) -> Branch k c n+ (k, ks) -> 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 (LsVal k v) = norm (LsSeq (mk1 k) (val v empty))+norm (BrVal k v n) = norm (BrSeq (mk1 k) (val v empty) n) norm t = t -- ----------------------------------------@@ -289,8 +368,11 @@ -- ---------------------------------------- +normError' :: String -> String -> a+normError' m f = error (m ++ "." ++ f ++ ": pattern match error, prefix tree not normalized")+ normError :: String -> a-normError f = error (f ++ ": pattern match error, prefix tree not normalized")+normError = normError' "Data.StringMap.Base" -- ---------------------------------------- @@ -305,12 +387,11 @@ -- | /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)+singleton k v = anyseq (fromKey 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@@ -389,7 +470,7 @@ {-# INLINE insertWithKey #-} --- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- | /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. @@ -398,7 +479,7 @@ {-# INLINE update #-} --- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- | /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. @@ -407,7 +488,7 @@ {-# INLINE updateWithKey #-} --- | /O(min(n,L))/ Delete an element from the map. If no element exists for the key, the map +-- | /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@@ -415,6 +496,16 @@ {-# INLINE delete #-} +adjust :: (a -> a) -> Key -> StringMap a -> StringMap a+adjust f = update' (Just . f)++{-# INLINE adjust #-}++adjustWithKey :: (Key -> a -> a) -> Key -> StringMap a -> StringMap a+adjustWithKey f k = update' (Just . f k) k++{-# INLINE adjustWithKey #-}+ -- ---------------------------------------- lookupPx' :: Key -> StringMap a -> StringMap a@@ -430,7 +521,7 @@ look _ _ = normError "lookupPx'" --- Internal lookup function which is generalised for arbitrary monads above.+-- Internal lookup function lookup' :: Key -> StringMap a -> Maybe a lookup' k t@@ -440,12 +531,53 @@ -- ---------------------------------------- +-- | remove all entries from the map with key less than the argument key++lookupGE :: Key -> StringMap a -> StringMap a+lookupGE k0 = look k0 . norm+ where+ look [] t = t+ look k@(c : k1) t@(Branch c' s' n')+ | c < c' = t+ | c == c' = branch c' (lookupGE k1 s') n'+ | otherwise = lookupGE k n'+ look _ Empty = empty+ look k (Val _v' t') = lookupGE k t'++ look _ _ = normError "lookupGE"++-- | remove all entries from the map with keys not having the argument key+-- as prefix and are larger than the argument key++lookupLE :: Key -> StringMap a -> StringMap a+lookupLE k0 = look k0 . norm+ where+ look [] (Val v' _t') = (Val v' empty)+ look [] _t = empty+ look k@(c : k1) (Branch c' s' n')+ | c < c' = empty+ | c == c' = branch c' (lookupLE k1 s') empty+ | otherwise = branch c' s' (lookupLE k n')+ look _ Empty = empty+ look k (Val v' t') = val v' (lookupLE k t')++ look _ _ = normError "lookupLE"++-- | Combination of 'lookupLE' and 'lookupGE'+-- @keys $ lookupRange "a" "b" $ fromList $ zip ["", "a", "ab", "b", "ba", "c"] [1..] = ["a","ab","b"]@+-- For all keys in @k = keys $ lookupRange lb ub m@, this property holts true: @k >= ub && k <= lb@++lookupRange :: Key -> Key -> StringMap a -> StringMap a+lookupRange lb ub = lookupLE ub . lookupGE lb++-- ----------------------------------------+ -- | /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 +-- | /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)]@@ -496,11 +628,12 @@ = 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 +-- | /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@@ -526,7 +659,7 @@ 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 _ _ _ ) (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)@@ -555,7 +688,7 @@ 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 _ _ _ ) (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)@@ -601,7 +734,7 @@ 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 _ _ _ ) (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@@ -617,8 +750,8 @@ -- -- @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'@ - +-- @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@@ -682,6 +815,7 @@ upd (Val v' t') = maybe t (flip val t) $ f v' where t = upd' t' upd _ = normError "update'"+ -- ---------------------------------------- {- not yet used @@ -733,21 +867,21 @@ -- -- 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+data StringMapVisitor 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 :: StringMapVisitor a b -> StringMap a -> b visit v (Empty) = v_empty v visit v (Val v' t) = v_val v v' (visit v t)@@ -775,16 +909,16 @@ space = visit $ PTV { v_empty = 0- , v_val = const (3+)+ , 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_last = const (3 +)+ , v_lsseq = \ cs s -> space1 cs + s+ , v_brseq = \ cs s n -> 4 + space1 cs + s + n+ , v_lssel = \ cs _ -> 3 + space1 cs+ , v_brsel = \ cs _ n -> 4 + space1 cs + n , v_lsval = \ _ _ -> 3- , v_brval = \ _ _ n -> 4 + n+ , v_brval = \ _ _ n -> 4 + n } keyChars :: StringMap a -> Int@@ -811,19 +945,35 @@ 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_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_last = \ _ s -> singleton "last" 1+ `add` s+ , v_lsseq = \ cs s -> singleton (show' "lsseq" cs) 1+ `add` singleton "size-key1" (length1 cs)+ `add` singleton "space-key1" (space1 cs)+ `add` s+ , v_brseq = \ cs s n -> singleton (show' "brseq" cs) 1+ `add` singleton "size-key1" (length1 cs)+ `add` singleton "space-key1" (space1 cs)+ `add` (s `add` n)+ , v_lssel = \ cs _ -> singleton (show' "lssel" cs) 1+ `add` singleton "size-key1" (length1 cs)+ `add` singleton "space-key1" (space1 cs)+ , v_brsel = \ cs _ n -> singleton (show' "brseq" cs) 1+ `add` singleton "size-key1" (length1 cs)+ `add` singleton "space-key1" (space1 cs)+ `add` n , v_lsval = \ _ _ -> singleton "lsval" 1- , v_brval = \ _ _ n -> singleton "brval" 1 `add` n+ , v_brval = \ _ _ n -> singleton "brval" 1+ `add` n } where add = unionWith (+)+ show' c k1 = c ++ "-" ++ show (length1 k1) -- ---------------------------------------- @@ -905,7 +1055,7 @@ -- > br :: Tree a -> [a] -- > br t = map rootLabel $ -- > concat $--- > takeWhile (not . null) $ +-- > takeWhile (not . null) $ -- > iterate (concatMap subForest) [t] toListBF :: StringMap v -> [(Key, v)]@@ -928,10 +1078,10 @@ 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 +-- | /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)]@@ -942,7 +1092,7 @@ instance Functor StringMap where fmap = map -instance Data.Foldable.Foldable StringMap where+instance F.Foldable StringMap where foldr = fold {- for debugging not yet enabled
Data/StringMap/Lazy.hs view
@@ -39,7 +39,7 @@ module Data.StringMap.Lazy ( -- * Map type- StringMap -- (..) I don't think we should export the constructor.+ StringMap() -- (..) I don't think we should export the constructor. , Key -- * Operators@@ -56,6 +56,7 @@ , prefixFind , prefixFindWithKey , prefixFindWithKeyBF+ , lookupRange -- * Construction , empty
Data/StringMap/Strict.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -XBangPatterns #-}+{-# LANGUAGE BangPatterns #-}+ -- ---------------------------------------------------------------------------- {- |@@ -40,7 +41,7 @@ module Data.StringMap.Strict ( -- * Map type- StringMap+ StringMap() , Key -- * Operators@@ -57,6 +58,7 @@ , prefixFind , prefixFindWithKey , prefixFindWithKeyBF+ , lookupRange -- * Construction , empty@@ -68,6 +70,8 @@ , insertWithKey -- ** Delete\/Update+ , adjust+ , adjustWithKey , delete , update , updateWithKey@@ -125,27 +129,35 @@ ) where -import Data.StringMap.Base hiding- (- singleton- , insert- , insertWith- , insertWithKey- , fromList- )+import Data.StringMap.Base hiding (adjust, adjustWithKey,+ delete, fromList, insert,+ insertWith, insertWithKey,+ singleton, union, unionWith,+ update, updateWithKey)+import qualified Data.StringMap.Base as Base import Data.StringMap.FuzzySearch+ import Prelude hiding (lookup, map, mapM, null, succ) --import Data.Strict.Tuple-import qualified Data.List as L+import qualified Data.List as L --import Data.BitUtil --import Data.StrictPair +-- ----------------------------------------++normError :: String -> a+normError = normError' "Data.StringMap.Strict"++-- ----------------------------------------+ -- | /O(1)/ Create a map with a single element.+--+-- the attribute value is evaluated to WHNF 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)+singleton k !v = Base.singleton k v -- anyseq (fromKey k) (val v empty) {-# INLINE singleton #-} @@ -170,6 +182,50 @@ insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> StringMap a -> StringMap a insertWithKey f !k = insertWith (f k) k++-- | /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(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.+-- The updated value is evaluated to WHNF before insertion.++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.+-- The updated value is evaluated to WHNF before insertion.++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 #-}++adjust :: (a -> a) -> Key -> StringMap a -> StringMap a+adjust f = update' (Just . f)++{-# INLINE adjust #-}++adjustWithKey :: (Key -> a -> a) -> Key -> StringMap a -> StringMap a+adjustWithKey f k = update' (Just . f k) k++{-# INLINE adjustWithKey #-}+ -- ---------------------------------------- insert' :: (a -> a -> a) -> a -> Key -> StringMap a -> StringMap a@@ -185,15 +241,77 @@ | c == c' -> branch c (ins' k1 s') n' | otherwise -> branch c' s' (ins' k n') - ins k Empty = singleton k v+ ins k Empty = singleton k v -- WHNF for v is done in singleton ins k (Val v' t') = case k of- [] -> flip val t' $! f v v'+ [] -> flip val t' $! f v v' -- force WHNF of attr value _ -> 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+-- ----------------------------------------++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+ [] -> case f v' of+ Nothing -> t'+ Just !v'' -> val v'' t' -- force WHNF of new attr value+ _ -> 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'++-- like union' from Base, but attr value is evaluated to WHNF++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) = flip val (uni' t1 t2) $! (f v1 v2)+ -- force attr value evaluation to WHNF+ 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'"++-- ----------------------------------------
benchmarks/StringMap.hs view
@@ -1,4 +1,4 @@---{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-} module Main where import Control.DeepSeq@@ -49,6 +49,7 @@ , bench "fromList" $ whnf M.fromList elems -- , bench "fromAscList" $ whnf M.fromAscList elems -- , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems+ , bench "lookupRange" $ whnf (M.lookupRange "a" "b") m ] where sum k v1 v2 = k + v1 + v2
data-stringmap.cabal view
@@ -1,5 +1,5 @@ name: data-stringmap-version: 0.9.1+version: 0.9.2 license: MIT license-file: LICENSE author: Uwe Schmidt, Sebastian Philipp@@ -26,9 +26,9 @@ Library build-depends: base >= 4.5 && < 5,- deepseq >= 1.2,- binary >= 0.5,- containers >= 0.4+ deepseq >= 1.2 && < 2,+ binary >= 0.5 && < 1,+ containers >= 0.4 && < 1 ghc-options: -O2 -Wall -fwarn-tabs -fno-warn-unused-binds @@ -53,7 +53,25 @@ QuickCheck >= 2.4, test-framework >= 0.6, test-framework-quickcheck2 >= 0.2,- test-framework-hunit >= 0.2+ test-framework-hunit >= 0.2,+ ghc-heap-view >= 0.5,+ deepseq >= 1.2 && < 2++ ghc-options: -Wall -fwarn-tabs+ hs-source-dirs: tests+test-suite strict+ type: exitcode-stdio-1.0+ main-is: StringMapStrict.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-heap-view >= 0.5,+ deepseq >= 1.2 && < 2 ghc-options: -Wall -fwarn-tabs hs-source-dirs: tests
+ tests/SimpleStrictTest.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BangPatterns #-}++module SimpleStrictTest where++import Control.Arrow (second)+import Control.DeepSeq (($!!))+import Data.Monoid+import Data.StringMap.Strict+import GHC.AssertNF++newtype Attr = A [Int]+ deriving (Show)++instance Monoid Attr where+ mempty = mkA []+ mappend (A xs) (A ys) = mkA $ xs ++ ys++type Map = StringMap Attr++-- strict constructor for Attr++mkA :: [Int] -> Attr+mkA xs = A $!! xs++-- some simple test data+m0, m1, m2, m3, m5, m6 :: Map+m0 = insert "" (mkA [0,1+2]) empty+m1 = insert "abc" (mkA [1,2,3]) empty+m2 = insert "x" (mkA [0,1]) empty+m3 = insertWith mappend "abc" (mkA [4,5,6]) m1+m5 = singleton "abc" (mkA [42])+m6 = fromList l4++fromList' :: [(d, [Int])] -> [(d, Attr)]+fromList' = fmap (second mkA)++l4 :: [(String, Attr)]+l4 = fromList' [("a",[1]),("b",[2]),("c",[3]),("a",[2]),("ab",[22]),("a",[3])]++consA :: Int -> Attr -> Attr+consA n a = mkA [n] `mappend` a++check :: String -> Map -> IO ()+check msg !m = assertNFNamed msg m++main :: IO ()+main =+ do check "m0" m0+ check "m5" m5+ check "m1" m1+ check "m2" m2+ check "m3" m3+ check "fromList l4" (fromList l4)+ check "m2 union m3" (m2 `union` m3)+ check "m2 unionWith m2" (unionWith mappend m2 m2)+ check "adjust m6" (adjust (consA 42) "ab" m6)+ check "adjust m1" (adjust (consA 42) "xx" m1)+ check "delete m6" (delete "ab" m6)+ check "delete m1" (delete "xx" m1)++
tests/StringMapProperties.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE BangPatterns #-}+ module Main where import Data.StringMap import qualified Data.Char as Char (intToDigit)-import qualified Data.List as List (nubBy, (!!))+import qualified Data.List as List (nubBy, (!!), foldl) import qualified Data.Map as Map (empty, fromList, map, toList) import qualified Data.Set as Set (fromList)@@ -21,7 +23,8 @@ default (Int) main :: IO ()-main = defaultMain+main = do+ defaultMain [ -- testCase "exclamation" test_exclamation testCase "value" test_value@@ -71,11 +74,13 @@ , testCase "prefixFindCaseWithKeyBF" test_prefixFindCaseWithKeyBF , testCase "prefixFindNoCaseWithKeyBF" test_prefixFindNoCaseWithKeyBF -- , testCase "lookupNoCaseBF" test_lookupNoCaseBF+ , testCase "lookuprange" test_range , 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+ , testProperty "prop_range" prop_range ] ------------------------------------------------------------------------@@ -101,9 +106,6 @@ _1 = 1 _4 = 4 -test_exclamation :: Assertion-test_exclamation = undefined- test_value :: Assertion test_value = let m1 = fromList [("" ,_1),("a", 2)] in@@ -376,6 +378,12 @@ test_lookupNoCaseBF :: Assertion test_lookupNoCaseBF = undefined +test_range :: Assertion+test_range = do+ let m = fromList $ zip ["", "a", "aa", "ab", "ac", "b", "ba", "c"] [_1..]+ let inside = fromList $ zip ["a", "aa", "ab", "ac", "b"] [_1..]+ (keys $ lookupRange "a" "b" m) @?= (keys $ inside)+ ---------------------------------------------------------------- -- QuickCheck ----------------------------------------------------------------@@ -405,3 +413,26 @@ key = fst $ ul List.!! (k `mod` length ul) test' :: (Key -> StringMap Int -> [(Key, Int)]) -> [(Key, Int)] test' f = f key (fromList ul)+++prop_range :: [Key] -> Key -> Key -> Bool+prop_range l lower' upper' = validInside && validOutside+ where+ lower = min lower' upper'+ upper = max lower' upper'+ m = fromList $ zip l [1..]+ inside :: StringMap Int+ inside = lookupRange lower upper m+ outside :: StringMap Int+ outside = m `difference` inside+ validKeyInside :: Bool -> (Key, Int) -> Bool+ validKeyInside b (k, _) = b && k >= lower && k <= upper+ validKeyOutside :: Bool -> (Key, Int) -> Bool+ validKeyOutside b (k, _) = b && (k < lower || k > upper)+ validInside :: Bool+ validInside = List.foldl validKeyInside True (toList inside)+ validOutside :: Bool+ validOutside = List.foldl validKeyOutside True (toList outside)+++
+ tests/StringMapStrict.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main+where++import Prelude hiding (lookup, map, mapM, null, succ)+import Data.StringMap.Strict++import Control.Arrow (second)+import Control.DeepSeq (($!!))+import Data.Monoid++import GHC.AssertNF++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import qualified Test.QuickCheck as Q (arbitrary, Property)+import qualified Test.QuickCheck.Monadic as Q (assert, monadicIO, pick, run, PropertyM)+import Test.HUnit hiding (Test, Testable)++newtype Attr = A [Int]+ deriving (Show)++instance Monoid Attr where+ mempty = mkA []+ mappend (A xs) (A ys) = mkA $! xs ++ ys -- mappend needs to be strict, because the stingList won't evaluate A deep.+++type Map = StringMap Attr++-- strict constructor for Attr++mkA :: [Int] -> Attr+mkA xs = A $!! xs++consA :: Int -> Attr -> Attr+consA n a = mkA [n] `mappend` a++default (Int)++main :: IO ()+main = defaultMain+ [+ testCase "isNF" test_isNF+ , testCase "m0" (checkIsNF m0)+ , testCase "m1" (checkIsNF m1)+ , testCase "m2" (checkIsNF m2)+ , testCase "m3" (checkIsNF m3)+ , testCase "m5" (checkIsNF m3)+ , testCase "m6" (checkIsNF m3)+ , testCase "fromList l4" (checkIsNF $ fromList l4)+ , testCase "m2 union m3" (checkIsNF $ m2 `union` m3)+ , testCase "m2 unionWith m2" (checkIsNF $ unionWith mappend m2 m2)+ , testCase "adjust m6" (checkIsNF $ adjust (consA 42) "ab" m6)+ , testCase "adjust m1" (checkIsNF $ adjust (consA 42) "xx" m1)+ , testCase "delete m6" (checkIsNF $ delete "ab" m6)+ , testCase "delete m1" (checkIsNF $ delete "xx" m1) ++ , testProperty "prop_simple" prop_simple+ , testProperty "prop_union" prop_union+ , testProperty "prop_diff" prop_diff+ ]++test_isNF :: Assertion +test_isNF = fmap not (isNF [(1::Int)..10]) @? "isNF"++checkIsNF :: Map -> Assertion+checkIsNF !m = isNF m @? ("isNF " ++ show m)++-- some simple test data+m0, m1, m2, m3, m5, m6 :: Map+m0 = insert "" (mkA [0,1+2]) empty+m1 = insert "abc" (mkA [1,2,3]) empty+m2 = insert "x" (mkA [0,1]) empty+m3 = insertWith mappend "abc" (mkA [4,5,6]) m1+m5 = singleton "abc" (mkA [42])+m6 = fromList l4++fromList' :: [(d, [Int])] -> [(d, Attr)]+fromList' = fmap (second mkA)++fromList'' :: [(a, Int)] -> [(a, Attr)]+fromList'' = fmap (second $ mkA . return)++fromList''' :: [Key] -> StringMap Attr+fromList''' = fromList . fromList'' . flip zip [1..]++l4 :: [(String, Attr)]+l4 = fromList' [("a",[1]),("b",[2]),("c",[3]),("a",[2]),("ab",[22]),("a",[3])]+++prop_simple :: Q.Property+prop_simple = Q.monadicIO $ do+ l <- Q.pick Q.arbitrary+ passed <- Q.run $ isNF $! fromList''' l+ Q.assert passed++prop_union :: Q.Property+prop_union = Q.monadicIO $ do+ l1 <- Q.pick Q.arbitrary+ l2 <- Q.pick Q.arbitrary+ let sm = fromList''' l1 `union` fromList''' l2+ checkIsNFProp sm+ ++prop_diff :: Q.Property+prop_diff = Q.monadicIO $ do+ l1 <- Q.pick Q.arbitrary+ l2 <- Q.pick Q.arbitrary+ let sm = fromList''' l1 `difference` fromList''' l2+ checkIsNFProp sm++checkIsNFProp :: a -> Q.PropertyM IO () +checkIsNFProp sm = do+ passed <- Q.run $ isNF $! sm+ Q.run $ assertNF $! sm+ Q.assert passed