diff --git a/Data/StringMap.hs b/Data/StringMap.hs --- a/Data/StringMap.hs +++ b/Data/StringMap.hs @@ -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 + +-- ---------------------------------------- diff --git a/Data/StringMap/Base.hs b/Data/StringMap/Base.hs --- a/Data/StringMap/Base.hs +++ b/Data/StringMap/Base.hs @@ -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 diff --git a/Data/StringMap/Lazy.hs b/Data/StringMap/Lazy.hs --- a/Data/StringMap/Lazy.hs +++ b/Data/StringMap/Lazy.hs @@ -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 diff --git a/Data/StringMap/Strict.hs b/Data/StringMap/Strict.hs --- a/Data/StringMap/Strict.hs +++ b/Data/StringMap/Strict.hs @@ -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'" + +-- ---------------------------------------- diff --git a/benchmarks/StringMap.hs b/benchmarks/StringMap.hs --- a/benchmarks/StringMap.hs +++ b/benchmarks/StringMap.hs @@ -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 diff --git a/data-stringmap.cabal b/data-stringmap.cabal --- a/data-stringmap.cabal +++ b/data-stringmap.cabal @@ -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 diff --git a/tests/SimpleStrictTest.hs b/tests/SimpleStrictTest.hs new file mode 100644 --- /dev/null +++ b/tests/SimpleStrictTest.hs @@ -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) + + diff --git a/tests/StringMapProperties.hs b/tests/StringMapProperties.hs --- a/tests/StringMapProperties.hs +++ b/tests/StringMapProperties.hs @@ -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) + + + diff --git a/tests/StringMapStrict.hs b/tests/StringMapStrict.hs new file mode 100644 --- /dev/null +++ b/tests/StringMapStrict.hs @@ -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