module Data.Generics.Fixplate.Util.Hash.Table
( HashTable , Bucket(..) , Leaf(..)
, getHashValue , unHashTable
, empty , singleton
, fromList , toList
, null
, bag
, lookup , member
, insert , insertWith
, delete
, union , unionWith
, unionsWith , unionsWith'
, intersection, intersectionWith
, intersectionsWith , intersectionsWith'
, difference , differenceWith
, getUniqueIndex
, keysWith
, mapWithUniqueIndices
#ifdef WITH_QUICKCHECK
, runtests_HashTable
, prop_insert , prop_delete
, prop_insertDelete , prop_deleteInsert
, prop_insertInsert , prop_deleteDelete
, prop_fromListToList
, prop_intersection , prop_intersectionWith
, prop_union , prop_unionWith
, prop_difference , prop_differenceWith
, prop_uniqueValues
#endif
)
where
import Prelude hiding ( lookup , null )
import Data.List ( foldl' )
import qualified Data.Map as Map ; import Data.Map (Map)
#ifdef WITH_QUICKCHECK
import Test.QuickCheck
import Test.QuickCheck.Modifiers
import Data.Generics.Fixplate.Misc
import Data.List ( sort , group , nubBy , nub , (\\) , foldl' , scanl )
import Control.Monad
import Control.Applicative ( (<$>) )
import Debug.Trace
#endif
mapInsertWith :: Ord k => (a -> v) -> (a -> v -> v) -> k -> a -> Map k v -> Map k v
mapInsertWith f g k x = x `seq` Map.alter worker k where
worker Nothing = Just $! (f x)
worker (Just y) = y `seq` (Just $! (g x y))
data Leaf v = Leaf !Int v
data Bucket k v = Bucket !Int !(Map k (Leaf v))
fromLeaf :: Leaf v -> v
fromLeaf (Leaf _ x) = x
emptyBucket :: Bucket k v
emptyBucket = Bucket 0 (Map.empty)
bucketSingleton :: k -> v -> Bucket k v
bucketSingleton k x = Bucket 1 (Map.singleton k (Leaf 0 x))
bucketInsert :: Ord k => k -> v -> Bucket k v -> Bucket k v
bucketInsert = bucketInsertWith id const
bucketInsertWith :: Ord k => (a -> v) -> (a -> v -> v) -> k -> a -> Bucket k v -> Bucket k v
bucketInsertWith f g k x (Bucket n table) = x `seq` new where
new = Bucket (n+1) (Map.alter worker k table)
worker Nothing = Just $! (Leaf n (f x))
worker (Just (Leaf j y)) = y `seq` (Just $! (Leaf j (g x y)))
data HashTable hash k v = HashTable
{ getHashValue :: k -> hash
, unHashTable :: Map hash (Bucket k v)
}
empty :: (Ord hash, Ord k) => (k -> hash) -> HashTable hash k v
empty gethash = HashTable gethash (Map.empty)
singleton :: (Ord hash, Ord k) => (k -> hash) -> k -> v -> HashTable hash k v
singleton gethash k v = HashTable gethash $ Map.singleton h (bucketSingleton k v) where
h = gethash k
fromList :: (Ord hash, Ord k) => (k -> hash) -> [(k,v)] -> HashTable hash k v
fromList gethash = foldl' (\old (k,v) -> insert k v old) (empty gethash)
toList :: Ord k => HashTable hash k v -> [(k,v)]
toList (HashTable _ table) =
[ (k,v)
| Bucket _ sub <- Map.elems table
, (k, Leaf _ v) <- Map.toList sub
]
null :: (Ord hash, Ord k) => HashTable hash k v -> Bool
null t = case toList t of
[] -> True
_ -> False
keysWith :: Ord k => (k -> hash -> Int -> a) -> HashTable hash k v -> [a]
keysWith f (HashTable _ table) =
[ f k hash j
| (hash, Bucket _ sub) <- Map.toList table
, (k, Leaf j _) <- Map.toList sub
]
lookup :: (Ord hash, Ord k) => k -> HashTable hash k v -> Maybe v
lookup key (HashTable gethash table) =
case Map.lookup h table of
Just (Bucket n sub) -> case Map.lookup key sub of
Just (Leaf _ v) -> Just v
Nothing -> Nothing
Nothing -> Nothing
where
h = gethash key
getUniqueIndex :: (Ord hash, Ord k) => (hash -> Int -> a) -> k -> HashTable hash k v -> Maybe a
getUniqueIndex f key (HashTable gethash table) =
case Map.lookup h table of
Just bucket@(Bucket _ sub) -> case Map.lookup key sub of
Just (Leaf j _) -> Just (f h j)
Nothing -> Nothing
Nothing -> Nothing
where
h = gethash key
member :: (Ord hash, Ord k) => k -> HashTable hash k v -> Bool
member key table = case lookup key table of
Just _ -> True
Nothing -> False
insert :: (Ord hash, Ord k) => k -> v -> HashTable hash k v -> HashTable hash k v
insert k v (HashTable gethash table) = HashTable gethash $ mapInsertWith f g h v table where
h = gethash k
f v = bucketSingleton k v
g v sub = bucketInsert k v sub
insertWith :: (Ord hash, Ord k) => (a -> v) -> (a -> v -> v) -> k -> a -> HashTable hash k v -> HashTable hash k v
insertWith ff gg k x (HashTable gethash table) = HashTable gethash $ mapInsertWith f g h x table where
h = gethash k
f x = bucketSingleton k (ff x)
g x sub = bucketInsertWith ff gg k x sub
delete :: (Ord hash, Ord k) => k -> HashTable hash k v -> HashTable hash k v
delete k (HashTable gethash table) = HashTable gethash $ Map.alter worker h table where
h = gethash k
worker Nothing = Nothing
worker (Just (Bucket n sub)) = Just $ Bucket n (Map.delete k sub)
union :: (Ord hash, Ord k) => HashTable hash k a -> HashTable hash k a -> HashTable hash k a
union = unionWith const
unionWith :: (Ord hash, Ord k) => (v -> v -> v) -> HashTable hash k v -> HashTable hash k v -> HashTable hash k v
unionWith g (HashTable gethash table1) (HashTable _ table2) = HashTable gethash (Map.unionWith worker table1 table2)
where
worker (Bucket n sub1) (Bucket m sub2) = Bucket (n+m) (Map.unionWith h sub1 $ Map.map offset sub2) where
h (Leaf i x) (Leaf _ y) = Leaf i (g x y)
offset (Leaf j y) = Leaf (n+j) y
unionsWith :: (Ord hash, Ord k) => (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v
unionsWith g tables = case tables of
[x] -> x
[] -> error "HashTable/unionsWith: empty list"
xs -> foldl1 (unionWith g) xs
unionsWith' :: (Ord hash, Ord k) => (k -> hash) -> (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v
unionsWith' gethash g tables = case tables of
[x] -> x
[] -> empty gethash
xs -> foldl1 (unionWith g) xs
intersection :: (Ord hash, Ord k) => HashTable hash k a -> HashTable hash k b -> HashTable hash k a
intersection = intersectionWith const
intersectionWith :: (Ord hash, Ord k) => (a -> b -> c) -> HashTable hash k a -> HashTable hash k b -> HashTable hash k c
intersectionWith g (HashTable gethash table1) (HashTable _ table2) =
HashTable gethash (Map.union a_minus_b a_cap_b) where
a_cap_b = Map.intersectionWith cap_worker table1 table2
a_minus_b = Map.map empty_worker (Map.difference table1 table2)
cap_worker (Bucket n sub1) (Bucket _ sub2) = Bucket n (Map.intersectionWith h sub1 sub2) where
h (Leaf i x) (Leaf _ y) = Leaf i (g x y)
empty_worker (Bucket n sub1) = Bucket n (Map.empty)
intersectionsWith :: (Ord hash, Ord k) => (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v
intersectionsWith g tables = case tables of
[x] -> x
[] -> error "HashTable/intersectionWith: empty list"
xs -> foldl1 (intersectionWith g) xs
intersectionsWith' :: (Ord hash, Ord k) => (k -> hash) -> (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v
intersectionsWith' gethash g tables = case tables of
[x] -> x
[] -> empty gethash
xs -> foldl1 (intersectionWith g) xs
difference :: (Ord hash, Ord k) => HashTable hash k a -> HashTable hash k b -> HashTable hash k a
difference = differenceWith (\_ _ -> Nothing)
differenceWith :: (Ord hash, Ord k) => (a -> b -> Maybe a) -> HashTable hash k a -> HashTable hash k b -> HashTable hash k a
differenceWith g (HashTable gethash table1) (HashTable _ table2) = HashTable gethash (Map.differenceWith worker table1 table2)
where
worker (Bucket n sub1) (Bucket _ sub2) = Just (Bucket n (Map.differenceWith h sub1 sub2)) where
h (Leaf i x) (Leaf _ y) = case g x y of
Just z -> Just (Leaf i z)
Nothing -> Nothing
bag :: (Ord hash, Ord k) => (k -> hash) -> [k] -> HashTable hash k Int
bag gethash = foldl' (\old k -> insertWith id (+) k 1 old) (empty gethash)
mapWithUniqueIndices :: (Ord hash, Ord k) => (hash -> Int -> a -> b) -> HashTable hash k a -> HashTable hash k b
mapWithUniqueIndices user (HashTable gethash table) = HashTable gethash (Map.mapWithKey worker table) where
worker hash (Bucket n sub) = Bucket n (Map.map g sub) where
g (Leaf j x) = Leaf j (user hash j x)
#ifdef WITH_QUICKCHECK
runtests_HashTable :: IO ()
runtests_HashTable = do
quickCheck prop_insert
quickCheck prop_delete
quickCheck prop_insertDelete
quickCheck prop_deleteInsert
quickCheck prop_insertInsert
quickCheck prop_deleteDelete
quickCheck prop_fromListToList
quickCheck prop_intersection
quickCheck prop_intersectionWith
quickCheck prop_union
quickCheck prop_unionWith
quickCheck prop_difference
quickCheck prop_differenceWith
replicateM_ 5 $ quickCheck prop_uniqueValues
debug x y = trace ("-- " ++ show x ++ " --") y
newtype Key = Key Int deriving (Eq,Ord,Show)
instance (Ord k, Ord hash, Show k, Show v) => Show (HashTable hash k v) where
show t = "HashTable<< " ++ show (toList t) ++ " >>"
instance Arbitrary Key where
arbitrary = do
n <- choose (0, 255)
return (Key n)
newtype Hash = Hash Int deriving (Eq,Ord,Show)
calcHash :: Key -> Hash
calcHash (Key k) = Hash (mod k 17)
newtype Table v = Table (HashTable Hash Key v) deriving Show
instance Arbitrary v => Arbitrary (Table v) where
arbitrary = do
xs <- arbitrary
let t = fromList calcHash xs
return (Table t)
newtype NonEmptyTable v = NonEmptyTable (HashTable Hash Key v) deriving Show
instance Arbitrary v => Arbitrary (NonEmptyTable v) where
arbitrary = do
NonEmpty xs <- arbitrary
let t = fromList calcHash xs
return (NonEmptyTable t)
data Pointed v = Pointed (HashTable Hash Key v) (Key,v) deriving Show
instance Arbitrary v => Arbitrary (Pointed v) where
arbitrary = do
NonEmptyTable t <- arbitrary
let list = toList t
n = length list
i <- choose (0,n1)
let kv =list!!i
return (Pointed t kv)
sortedToList :: Ord a => HashTable Hash Key a -> [(Key,a)]
sortedToList = sort . toList
data Step v
= Insert Key v
| InsertWith Key v
| Delete Key
| Union (Table v)
| Intersect (Table v)
| Difference (Table v)
deriving Show
instance Arbitrary v => Arbitrary (Step v) where
arbitrary = do
frequency
[ ( 10 , do { k<-arbitrary ; v<-arbitrary ; return (Insert k v) } )
, ( 5 , do { k<-arbitrary ; v<-arbitrary ; return (InsertWith k v) } )
, ( 10 , do { k<-arbitrary ; return (Delete k) } )
, ( 3 , do { t<-arbitrary ; return (Union t ) } )
, ( 2 , do { t<-arbitrary ; return (Difference t ) } )
, ( 1 , do { t<-arbitrary ; return (Intersect t ) } )
]
newtype NoDeleteStep v = NoDeleteStep (Step v)
instance Arbitrary v => Arbitrary (NoDeleteStep v) where
arbitrary = NoDeleteStep <$> do
frequency
[ ( 10 , do { k<-arbitrary ; v<-arbitrary ; return (Insert k v) } )
, ( 5 , do { k<-arbitrary ; v<-arbitrary ; return (InsertWith k v) } )
, ( 3 , do { t<-arbitrary ; return (Union t ) } )
]
step :: (v -> v -> v) -> Step v -> HashTable Hash Key v -> HashTable Hash Key v
step f step old = case step of
Insert k v -> insert k v old
InsertWith k v -> insertWith id f k v old
Delete k -> delete k old
Union (Table t) -> union old t
Intersect (Table t) -> intersection old t
Difference (Table t) -> difference old t
type History v = [Step v]
runHistory :: (v -> v -> v) -> History v -> HashTable Hash Key v -> [HashTable Hash Key v]
runHistory f steps ini = scanl (flip (step f)) ini steps
data U = U Hash Int deriving (Eq,Ord,Show)
prop_insert :: Key -> Char -> Table Char -> Bool
prop_insert k v (Table table) = lookup k (insert k v table) == Just v
prop_delete :: Pointed Char -> Bool
prop_delete (Pointed table (k,_)) = lookup k (delete k table) == Nothing
prop_insertInsert :: Key -> Char -> Table Char -> Bool
prop_insertInsert k v (Table table) = toList (insert k v table) == toList (insert k v (insert k v table))
prop_deleteDelete :: Pointed Char -> Bool
prop_deleteDelete (Pointed table (k,_)) = toList (delete k table) == toList (delete k (delete k table))
prop_insertDelete :: Key -> Char -> Table Char -> Bool
prop_insertDelete k v (Table table) = lookup k (delete k $ insert k v table) == Nothing
prop_deleteInsert :: Pointed Char -> Bool
prop_deleteInsert (Pointed table (k,v)) = lookup k (insert k v $ delete k table) == Just v
prop_fromListToList :: [(Key,Char)] -> Bool
prop_fromListToList xs = sortedToList (fromList calcHash xs) == Map.toList (Map.fromList xs)
prop_intersection :: [(Key,Char)] -> [(Key,Bool)] -> Bool
prop_intersection xs ys = sortedToList (intersection t1 t2) == Map.toList (Map.intersection m1 m2) where
t1 = fromList calcHash xs
t2 = fromList calcHash ys
m1 = Map.fromList xs
m2 = Map.fromList ys
prop_intersectionWith :: [(Key,Char)] -> [(Key,String)] -> Bool
prop_intersectionWith xs ys = sortedToList (intersectionWith (:) t1 t2) == Map.toList (Map.intersectionWith (:) m1 m2) where
t1 = fromList calcHash xs
t2 = fromList calcHash ys
m1 = Map.fromList xs
m2 = Map.fromList ys
prop_union :: [(Key,Char)] -> [(Key,Char)] -> Bool
prop_union xs ys = sortedToList (union t1 t2) == Map.toList (Map.union m1 m2) where
t1 = fromList calcHash xs
t2 = fromList calcHash ys
m1 = Map.fromList xs
m2 = Map.fromList ys
prop_unionWith :: [(Key,String)] -> [(Key,String)] -> Bool
prop_unionWith xs ys = sortedToList (unionWith (++) t1 t2) == Map.toList (Map.unionWith (++) m1 m2) where
t1 = fromList calcHash xs
t2 = fromList calcHash ys
m1 = Map.fromList xs
m2 = Map.fromList ys
prop_difference :: [(Key,Char)] -> [(Key,Bool)] -> Bool
prop_difference xs ys = sortedToList (difference t1 t2) == Map.toList (Map.difference m1 m2) where
t1 = fromList calcHash xs
t2 = fromList calcHash ys
m1 = Map.fromList xs
m2 = Map.fromList ys
prop_differenceWith :: [(Key,Char)] -> [(Key,Bool)] -> Bool
prop_differenceWith xs ys = sortedToList (differenceWith f t1 t2) == Map.toList (Map.differenceWith f m1 m2) where
t1 = fromList calcHash xs
t2 = fromList calcHash ys
m1 = Map.fromList xs
m2 = Map.fromList ys
f x b = if b then Just x else Nothing
prop_uniqueValues :: History Float -> Table Float -> Bool
prop_uniqueValues history (Table initial) = areUnique && areInjective where
worldline = runHistory (\x y -> xy) history initial :: [HashTable Hash Key Float]
lists = ((flip map) worldline $ \table -> keysWith (\k h j -> (U h j, k)) table) :: [[(U,Key)]]
areUnique = and [ isUnique xs | xs <- lists ]
isUnique uks = let us = map fst uks in sort us == sort (nub us)
areInjective = and $ map test $ groupSortOn fst $ concat lists where
test :: [(U,Key)] -> Bool
test xs = (length (groupSortOn fst xs) == 1)
&& (length (groupSortOn snd xs) == 1)
#endif