diff --git a/Data/StringMap.hs b/Data/StringMap.hs new file mode 100644 --- /dev/null +++ b/Data/StringMap.hs @@ -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 diff --git a/Data/StringMap/Base.hs b/Data/StringMap/Base.hs new file mode 100644 --- /dev/null +++ b/Data/StringMap/Base.hs @@ -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" + +-- ---------------------------------------- diff --git a/Data/StringMap/FuzzySearch.hs b/Data/StringMap/FuzzySearch.hs new file mode 100644 --- /dev/null +++ b/Data/StringMap/FuzzySearch.hs @@ -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ß" + +-- -} +-- ------------------------------------------------------------ diff --git a/Data/StringMap/Lazy.hs b/Data/StringMap/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/StringMap/Lazy.hs @@ -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) + diff --git a/Data/StringMap/Strict.hs b/Data/StringMap/Strict.hs new file mode 100644 --- /dev/null +++ b/Data/StringMap/Strict.hs @@ -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 diff --git a/Data/StringMap/StringSet.hs b/Data/StringMap/StringSet.hs new file mode 100644 --- /dev/null +++ b/Data/StringMap/StringSet.hs @@ -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' + +-- ------------------------------------------------------------ diff --git a/Data/StringMap/Types.hs b/Data/StringMap/Types.hs new file mode 100644 --- /dev/null +++ b/Data/StringMap/Types.hs @@ -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] + +-- ---------------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/StringMap.hs b/benchmarks/StringMap.hs new file mode 100644 --- /dev/null +++ b/benchmarks/StringMap.hs @@ -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 diff --git a/data-stringmap.cabal b/data-stringmap.cabal new file mode 100644 --- /dev/null +++ b/data-stringmap.cabal @@ -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 diff --git a/tests/StringMapProperties.hs b/tests/StringMapProperties.hs new file mode 100644 --- /dev/null +++ b/tests/StringMapProperties.hs @@ -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)