diff --git a/hash-cons.cabal b/hash-cons.cabal --- a/hash-cons.cabal +++ b/hash-cons.cabal @@ -1,5 +1,5 @@ name: hash-cons -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Opportunistic hash-consing data structure description: Provides a pure interface for hash-consing values. license: BSD3 @@ -12,8 +12,13 @@ library hs-source-dirs: src - exposed-modules: Data.HashCons - Data.HashCons.Internal + exposed-modules: + Data.HashCons + Data.HashCons.IntMap + Data.HashCons.IntMap.Internal + Data.HashCons.Internal + Data.HashCons.WordMap + Data.HashCons.WordMap.Internal build-depends: base >=4.9 && <5, hashable >= 1.4.0 && < 1.5 default-language: Haskell2010 @@ -22,6 +27,9 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + other-modules: + Data.HashCons.Internal.Test + Data.HashCons.IntMap.Test build-depends: base >=4.9 && <5, async, hash-cons, diff --git a/src/Data/HashCons.hs b/src/Data/HashCons.hs --- a/src/Data/HashCons.hs +++ b/src/Data/HashCons.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} module Data.HashCons (module X) where import Data.HashCons.Internal as X ( HashCons + , pattern HashCons , hashCons , unHashCons ) diff --git a/src/Data/HashCons/IntMap.hs b/src/Data/HashCons/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashCons/IntMap.hs @@ -0,0 +1,105 @@ +-- | This module provides an efficient implementation of maps from 'Int' keys to values. +-- It is a thin wrapper around 'Data.HashCons.WordMap', converting 'Int' keys to 'Word'. + +module Data.HashCons.IntMap + ( IntMap + , empty + , singleton + , singletonNonEmpty + , insert + , insertNonEmpty + , lookup + , lookupNonEmpty + , map + , mapWithKey + , traverseWithKey + , union + , unionNonEmpty + , intersection + , intersectionNonEmpty + , difference + , differenceNonEmpty + , member + ) where + +import Prelude hiding (lookup, map) +import Data.HashCons.WordMap (WordMap, NonEmptyWordMap) +import qualified Data.HashCons.WordMap as WordMap +import Data.Word +import Data.Hashable + +newtype IntMap a = IntMap { unWordMap :: WordMap a } + +newtype NonEmptyIntMap a = NonEmptyIntMap { unNonEmptyWordMap :: NonEmptyWordMap a } + +-- | /O(1)/. Create an empty map. +empty :: IntMap a +empty = IntMap WordMap.empty + +-- | /O(1)/. Create a map with a single key-value pair. +singleton :: Hashable a => Int -> a -> IntMap a +singleton k v = IntMap $ WordMap.singleton (fromIntegral k) v + +-- | /O(1)/. Create a map with a single key-value pair. +singletonNonEmpty :: Hashable a => Int -> a -> NonEmptyIntMap a +singletonNonEmpty k v = NonEmptyIntMap $ WordMap.singletonNonEmpty (fromIntegral k) v + +-- | /O(log n)/. Insert a key-value pair into the map. +insert :: Hashable a => Int -> a -> IntMap a -> IntMap a +insert k v (IntMap m) = IntMap $ WordMap.insert (fromIntegral k) v m + +-- | /O(log n)/. Insert a key-value pair into the map. +insertNonEmpty :: Hashable a => Int -> a -> NonEmptyIntMap a -> NonEmptyIntMap a +insertNonEmpty k v (NonEmptyIntMap m) = NonEmptyIntMap $ WordMap.insertNonEmpty (fromIntegral k) v m + +-- | /O(log n)/. Lookup the value at a key in the map. +lookup :: Int -> IntMap a -> Maybe a +lookup k (IntMap m) = WordMap.lookup (fromIntegral k) m + +-- | /O(log n)/. Lookup the value at a key in the map. +lookupNonEmpty :: Int -> NonEmptyIntMap a -> Maybe a +lookupNonEmpty k (NonEmptyIntMap m) = WordMap.lookupNonEmpty (fromIntegral k) m + +-- | /O(n)/. Map a function over all values in the map. +map :: Hashable b => (a -> b) -> IntMap a -> IntMap b +map f (IntMap m) = IntMap $ WordMap.map f m + +-- | /O(n)/. Map a function over all key-value pairs in the map. +mapWithKey :: Hashable b => (Int -> a -> b) -> IntMap a -> IntMap b +mapWithKey f (IntMap m) = IntMap $ WordMap.mapWithKey (\k v -> f (fromIntegral k) v) m + +-- | /O(n)/. Traverse the map with a function that accesses keys. +traverseWithKey :: (Applicative t, Hashable b) => (Int -> a -> t b) -> IntMap a -> t (IntMap b) +traverseWithKey f (IntMap m) = IntMap <$> WordMap.traverseWithKey (\k v -> f (fromIntegral k) v) m + +-- | /O(n)/. The union of two maps. If a key occurs in both maps, the value from the left map is used. +union :: Hashable a => IntMap a -> IntMap a -> IntMap a +union (IntMap m1) (IntMap m2) = IntMap $ WordMap.union m1 m2 + +-- | /O(n)/. The union of two maps. If a key occurs in both maps, the value from the left map is used. +unionNonEmpty :: Hashable a => NonEmptyIntMap a -> IntMap a -> NonEmptyIntMap a +unionNonEmpty (NonEmptyIntMap m1) (IntMap m2) = NonEmptyIntMap $ WordMap.unionNonEmpty m1 m2 + +-- | /O(n)/. Intersection of two maps. Only keys present in both maps are included. +intersection :: Hashable a => IntMap a -> IntMap a -> IntMap a +intersection (IntMap m1) (IntMap m2) = IntMap $ WordMap.intersection m1 m2 + +-- | /O(n)/. Intersection of two maps. Only keys present in both maps are included. +intersectionNonEmpty :: Hashable a => NonEmptyIntMap a -> IntMap a -> IntMap a +intersectionNonEmpty (NonEmptyIntMap m1) (IntMap m2) = IntMap $ WordMap.intersectionNonEmpty m1 m2 + +-- | /O(n)/. Difference of two maps. Keys in the first map but not in the second are included. +difference :: Hashable a => IntMap a -> IntMap a -> IntMap a +difference (IntMap m1) (IntMap m2) = IntMap $ WordMap.difference m1 m2 + +-- | /O(n)/. Intersection of two maps. Only keys present in both maps are included. +differenceNonEmpty :: Hashable a => NonEmptyIntMap a -> IntMap a -> IntMap a +differenceNonEmpty (NonEmptyIntMap m1) (IntMap m2) = IntMap $ WordMap.differenceNonEmpty m1 m2 + +-- | Check if a key is present in the map. +member :: Int -> IntMap a -> Bool +member k (IntMap m) = WordMap.member (fromIntegral k) m + +-- | Check if a key is present in the map. +memberNonEmpty :: Int -> NonEmptyIntMap a -> Bool +memberNonEmpty k (NonEmptyIntMap m) = WordMap.memberNonEmpty (fromIntegral k) m diff --git a/src/Data/HashCons/IntMap/Internal.hs b/src/Data/HashCons/IntMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashCons/IntMap/Internal.hs @@ -0,0 +1,1 @@ +module Data.HashCons.IntMap.Internal where diff --git a/src/Data/HashCons/Internal.hs b/src/Data/HashCons/Internal.hs --- a/src/Data/HashCons/Internal.hs +++ b/src/Data/HashCons/Internal.hs @@ -1,34 +1,48 @@ {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.HashCons.Internal where +import Control.Exception import Control.Monad (when) import Data.Hashable (Hashable, hash, hashWithSalt) import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import GHC.Base (compareInt#, Int#, IO (..), anyToAddr#, addr2Int#) +import GHC.Exts (Any, Addr#, unsafeCoerce#) import System.IO.Unsafe (unsafeDupablePerformIO) import Text.ParserCombinators.ReadPrec (step) import Text.Read (Read(..), lexP, parens, prec) import Text.Read.Lex (Lexeme (Ident)) -import GHC.Exts (reallyUnsafePtrEquality#) +import Debug.Trace + -- | 'HashCons' with a precomputed hash and an 'IORef' to the value. -- -- WARNING: Do not use this type to wrap types whose Eq or Ord instances -- allow distinguishable values to compare as equal; this will result in -- nondeterminism or even visible mutation of semantically-immutable -- values at runtime. -data HashCons a = HashCons +data HashCons a = HashConsC { _hashCons_hash :: {-# UNPACK #-} !Int -- ^ Precomputed hash , _hashCons_ref :: {-# UNPACK #-} !(IORef a) -- ^ Reference to the value } +pattern HashCons :: Hashable a => () => a -> HashCons a +pattern HashCons x <- (unHashCons -> x) where + HashCons x = hashCons x + -- | Create a new 'HashCons'. hashCons :: Hashable a => a -> HashCons a -hashCons a = HashCons (hash a) $ unsafeDupablePerformIO $ newIORef a +hashCons a = HashConsC (hash a) $ unsafeDupablePerformIO $ newIORef a +{-# INLINE hashCons #-} -- | Extract the value from a 'HashCons'. unHashCons :: HashCons a -> a -unHashCons (HashCons _ ref) = unsafeDupablePerformIO $ readIORef ref +unHashCons (HashConsC _ ref) = unsafeDupablePerformIO $ readIORef ref +{-# INLINE unHashCons #-} -- | Show instance that displays 'HashCons' in the format "hashCons " instance Show a => Show (HashCons a) where @@ -45,33 +59,66 @@ pure $ hashCons a instance Eq a => Eq (HashCons a) where - HashCons h1 ref1 == HashCons h2 ref2 + HashConsC h1 ref1 == HashConsC h2 ref2 | ref1 == ref2 = True | h1 /= h2 = False - | otherwise = unsafeDupablePerformIO $ do - a1 <- readIORef ref1 - a2 <- readIORef ref2 - let eq = a1 == a2 - when eq $ case reallyUnsafePtrEquality# a1 a2 of - 0# -> writeIORef ref1 a2 - _ -> pure () - pure eq + | otherwise = compareAndSubstitute ((==) :: a -> a -> Bool) True ref1 ref2 + {- INLINE (==) #-} -- | NOTE: This instance orders by hash first, and only secondarily by -- the 'Ord' instance of 'a', to improve performance. instance Ord a => Ord (HashCons a) where - compare (HashCons h1 ref1) (HashCons h2 ref2) = case compare h1 h2 of + compare (HashConsC h1 ref1) (HashConsC h2 ref2) = case compare h1 h2 of EQ -> if ref1 == ref2 then EQ - else unsafeDupablePerformIO $ do - a1 <- readIORef ref1 - a2 <- readIORef ref2 - let result = compare a1 a2 - when (result == EQ) $ case reallyUnsafePtrEquality# a1 a2 of - 0# -> writeIORef ref1 a2 - _ -> pure () - pure result + else compareAndSubstitute compare EQ ref1 ref2 result -> result + {-# INLINE compare #-} instance Eq a => Hashable (HashCons a) where - hashWithSalt salt (HashCons h _) = hashWithSalt salt h + hashWithSalt salt (HashConsC h _) = hashWithSalt salt h + {-# INLINE hashWithSalt #-} + +-- Compare the values in the IORefs with the given comparator, and if the result +-- indicates that they are equal, replace one with the other, preferring the one +-- whose pointer is lower. This is not expected to be totally stable, but it +-- should be *somewhat* stable, and should push us in direction of coalescing +-- more values. Without this, if you have a, b, and c, all with equal but +-- distinct values, and compare b == a and b == c repeatedly, but never compare +-- a == c, you could end up with the value of b flapping between that of a and +-- c, costing the worst-case equality check time repeatedly, and never settling +-- on a particular representation of the value. With this, you should settle on +-- a single value unless you get extremely unlucky with the way that addresses +-- move around. +compareAndSubstitute + :: Eq r + => (a -> a -> r) + -> r + -> IORef a + -> IORef a + -> r +compareAndSubstitute cmp eq ref1 ref2 = unsafeDupablePerformIO $ do + a1 <- readIORef ref1 + a2 <- readIORef ref2 + let result = a1 `cmp` a2 + when (result == eq) $ do + -- NOTE: These should already be forced by (==), but in the unlikely event + -- that they are not (i.e. because (==) on their type unconditionally + -- returns True), we need to ensure they are not thunks, according to the + -- documentation of anyToAddr# + evaluate a1 + evaluate a2 + -- NOTE: There is a race condition here: the addresses could change in + -- between when they are read. However, since either (or neither) swap is + -- fine, we are OK with this only working "most" of the time (which we + -- expect to be a very high fraction). + addrCmpResult <- IO $ \s -> + case anyToAddr# (unsafeCoerce# a1 :: Any) s of + (# s', addr1 #) -> case anyToAddr# (unsafeCoerce# a2 :: Any) s' of + (# s'', addr2 #) -> (# s'', addr2Int# addr1 `compareInt#` addr2Int# addr2 #) + case addrCmpResult of + LT -> writeIORef ref2 a1 + GT -> writeIORef ref1 a2 + EQ -> pure () + pure result +{-# INLINE compareAndSubstitute #-} diff --git a/src/Data/HashCons/WordMap.hs b/src/Data/HashCons/WordMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashCons/WordMap.hs @@ -0,0 +1,29 @@ +module Data.HashCons.WordMap + ( WordMap + , NonEmptyWordMap + , empty + , singleton + , singletonNonEmpty + , insert + , insertNonEmpty + , lookup + , lookupNonEmpty + , map + , mapNonEmpty + , mapWithKey + , mapWithKeyNonEmpty + , traverseWithKey + , traverseWithKeyNonEmpty + , union + , unionNonEmpty + , intersection + , intersectionNonEmpty + , difference + , differenceNonEmpty + , member + , memberNonEmpty + ) where + +import Prelude () + +import Data.HashCons.WordMap.Internal diff --git a/src/Data/HashCons/WordMap/Internal.hs b/src/Data/HashCons/WordMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashCons/WordMap/Internal.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | This module provides an efficient implementation of maps from 'Word' keys to values. +-- It uses a Patricia trie with hash-consing to enable fast structural sharing and +-- O(1) equality checks. The 'HashCons' type wraps the internal nodes to take advantage +-- of O(1) 'Eq' and 'Ord' operations provided by hash-consing. +-- +-- Note: This is an internal module. Users should prefer the public interface provided +-- by 'Data.HashCons.WordMap'. + +module Data.HashCons.WordMap.Internal where + +import Prelude hiding (lookup, map) +import Data.Bits +import Data.Hashable +import Data.HashCons +import GHC.Generics + +-- | The main 'WordMap' data type. +data WordMap a + = Empty + | NonEmptyMap !(HashCons (NonEmptyWordMap a)) + deriving (Show, Eq, Ord, Generic) + +instance Hashable a => Hashable (WordMap a) + +-- | Non-empty trie nodes. +data NonEmptyWordMap a + = Leaf !Word a + | Bin !Word !Word (WordMap a) (WordMap a) + deriving (Show, Eq, Ord, Generic) + +instance Hashable a => Hashable (NonEmptyWordMap a) + +-- | /O(1)/. Create an empty map. +empty :: WordMap a +empty = Empty + +-- | /O(1)/. Create a map with a single key-value pair. +singleton :: Hashable a => Word -> a -> WordMap a +singleton k v = NonEmptyMap (hashCons (Leaf k v)) + +-- | /O(1)/. Create a map with a single key-value pair. +singletonNonEmpty :: Hashable a => Word -> a -> NonEmptyWordMap a +singletonNonEmpty = Leaf + +-- | /O(log n)/. Insert a key-value pair into the map. +-- If the key is already present, the value is replaced. +insert :: Hashable a => Word -> a -> WordMap a -> WordMap a +insert k v Empty = singleton k v +insert k v (NonEmptyMap hc) = + let t = unHashCons hc + t' = insertNonEmpty k v t + in if t' == t -- Exploit O(1) 'Eq' from 'HashCons' + then NonEmptyMap hc -- No change needed + else NonEmptyMap (hashCons t') + +insertNonEmpty :: Hashable a => Word -> a -> NonEmptyWordMap a -> NonEmptyWordMap a +insertNonEmpty k v t@(Leaf k' _) + | k == k' = Leaf k v -- Replace the existing value + | otherwise = join k (Leaf k v) k' t +insertNonEmpty k v t@(Bin p m l r) + | match k p m = if zero k m + then + let l' = insert k v l + in if l' == l then t else Bin p m l' r + else + let r' = insert k v r + in if r' == r then t else Bin p m l r' + | otherwise = join k (Leaf k v) p t + +-- | /O(log n)/. Lookup the value at a key in the map. +lookup :: Word -> WordMap a -> Maybe a +lookup _ Empty = Nothing +lookup k (NonEmptyMap hc) = lookupNonEmpty k (unHashCons hc) + +lookupNonEmpty :: Word -> NonEmptyWordMap a -> Maybe a +lookupNonEmpty k (Leaf k' v) + | k == k' = Just v + | otherwise = Nothing +lookupNonEmpty k (Bin p m l r) + | match k p m = if zero k m then lookup k l else lookup k r + | otherwise = Nothing + +-- | /O(n)/. Map a function over all values in the map. +map :: Hashable b => (a -> b) -> WordMap a -> WordMap b +map _ Empty = Empty +map f (NonEmptyMap hc) = NonEmptyMap (hashCons (mapNonEmpty f (unHashCons hc))) + +mapNonEmpty :: Hashable b => (a -> b) -> NonEmptyWordMap a -> NonEmptyWordMap b +mapNonEmpty f (Leaf k v) = Leaf k (f v) +mapNonEmpty f (Bin p m l r) = Bin p m (map f l) (map f r) + +-- | /O(n)/. Map a function over all key-value pairs in the map. +mapWithKey :: Hashable b => (Word -> a -> b) -> WordMap a -> WordMap b +mapWithKey _ Empty = Empty +mapWithKey f (NonEmptyMap hc) = NonEmptyMap (hashCons (mapWithKeyNonEmpty f (unHashCons hc))) + +mapWithKeyNonEmpty :: Hashable b => (Word -> a -> b) -> NonEmptyWordMap a -> NonEmptyWordMap b +mapWithKeyNonEmpty f (Leaf k v) = Leaf k (f k v) +mapWithKeyNonEmpty f (Bin p m l r) = Bin p m (mapWithKey f l) (mapWithKey f r) + +-- | /O(n)/. Traverse the map with a function that accesses keys. +traverseWithKey :: (Applicative t, Hashable b) => (Word -> a -> t b) -> WordMap a -> t (WordMap b) +traverseWithKey _ Empty = pure Empty +traverseWithKey f (NonEmptyMap hc) = NonEmptyMap . hashCons <$> traverseWithKeyNonEmpty f (unHashCons hc) + +traverseWithKeyNonEmpty :: (Applicative t, Hashable b) => (Word -> a -> t b) -> NonEmptyWordMap a -> t (NonEmptyWordMap b) +traverseWithKeyNonEmpty f (Leaf k v) = Leaf k <$> f k v +traverseWithKeyNonEmpty f (Bin p m l r) = Bin p m <$> traverseWithKey f l <*> traverseWithKey f r + +-- | /O(n)/. The union of two maps. If a key occurs in both maps, the value from the left map is used. +union :: Hashable a => WordMap a -> WordMap a -> WordMap a +union t1 Empty = t1 +union Empty t2 = t2 +union t1@(NonEmptyMap hc1) t2@(NonEmptyMap hc2) + | hc1 == hc2 = t1 -- O(1) comparison via 'HashCons' +union (NonEmptyMap hc1) t2 = + NonEmptyMap (hashCons (unionNonEmpty (unHashCons hc1) t2)) + +unionNonEmpty :: Hashable a => NonEmptyWordMap a -> WordMap a -> NonEmptyWordMap a +unionNonEmpty t1 Empty = t1 +unionNonEmpty t1 (NonEmptyMap hc2) = unionNonEmptyNonEmpty t1 (unHashCons hc2) + +unionNonEmptyNonEmpty :: Hashable a => NonEmptyWordMap a -> NonEmptyWordMap a -> NonEmptyWordMap a +unionNonEmptyNonEmpty t1 t2 + | t1 == t2 = t1 -- O(1) comparison via 'HashCons' +unionNonEmptyNonEmpty t1@(Leaf k1 v1) t2@(Leaf k2 _) + | k1 == k2 = t1 -- Prefer left map's value + | otherwise = join k1 t1 k2 t2 +unionNonEmptyNonEmpty t1@(Leaf k1 v1) t2@(Bin p2 m2 l2 r2) + | match k1 p2 m2 = if zero k1 m2 + then Bin p2 m2 (union (singleton k1 v1) l2) r2 + else Bin p2 m2 l2 (union (singleton k1 v1) r2) + | otherwise = join k1 t1 p2 t2 +unionNonEmptyNonEmpty t1@(Bin p1 m1 l1 r1) t2@(Leaf k2 v2) + | match k2 p1 m1 = if zero k2 m1 + then Bin p1 m1 (union l1 (singleton k2 v2)) r1 + else Bin p1 m1 l1 (union r1 (singleton k2 v2)) + | otherwise = join p1 t1 k2 t2 +unionNonEmptyNonEmpty t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | t1 == t2 = t1 -- O(1) comparison via 'HashCons' + | shorter m1 m2 = + if match p2 p1 m1 + then if zero p2 m1 + then Bin p1 m1 (union l1 (NonEmptyMap (hashCons t2))) r1 + else Bin p1 m1 l1 (union r1 (NonEmptyMap (hashCons t2))) + else join p1 t1 p2 t2 + | shorter m2 m1 = + if match p1 p2 m2 + then if zero p1 m2 + then Bin p2 m2 (union (NonEmptyMap (hashCons t1)) l2) r2 + else Bin p2 m2 l2 (union (NonEmptyMap (hashCons t1)) r2) + else join p1 t1 p2 t2 + | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2) + | otherwise = join p1 t1 p2 t2 + +-- | /O(n)/. Intersection of two maps. Only keys present in both maps are included. +intersection :: Hashable a => WordMap a -> WordMap a -> WordMap a +intersection Empty _ = Empty +intersection _ Empty = Empty +intersection t1@(NonEmptyMap hc1) t2@(NonEmptyMap hc2) + | hc1 == hc2 = t1 -- O(1) comparison via 'HashCons' +intersection (NonEmptyMap hc1) t2 = + intersectionNonEmpty (unHashCons hc1) t2 + +intersectionNonEmpty :: Hashable a => NonEmptyWordMap a -> WordMap a -> WordMap a +intersectionNonEmpty _ Empty = Empty +intersectionNonEmpty t1 (NonEmptyMap hc2) = + case t1 of + Leaf k1 v1 -> if member k1 (NonEmptyMap hc2) + then singleton k1 v1 + else Empty + Bin p1 m1 l1 r1 -> case unHashCons hc2 of + Leaf k2 a2 + | match k2 p1 m1 -> if zero k2 m1 + then intersection l1 (singleton k2 a2) + else intersection r1 (singleton k2 a2) + | otherwise -> Empty + Bin p2 m2 l2 r2 + | shorter m1 m2 -> + if match p2 p1 m1 + then if zero p2 m1 + then intersection l1 (NonEmptyMap hc2) + else intersection r1 (NonEmptyMap hc2) + else Empty + | shorter m2 m1 -> + if match p1 p2 m2 + then if zero p1 m2 + then intersection (NonEmptyMap (hashCons t1)) l2 + else intersection (NonEmptyMap (hashCons t1)) r2 + else Empty + | p1 == p2 -> let l = intersection l1 l2 + r = intersection r1 r2 + in combine p1 m1 l r + | otherwise -> Empty + +-- | /O(n)/. Difference of two maps. Keys in the first map but not in the second are included. +difference :: Hashable a => WordMap a -> WordMap a -> WordMap a +difference Empty _ = Empty +difference t1 Empty = t1 +difference t1@(NonEmptyMap hc1) t2@(NonEmptyMap hc2) + | hc1 == hc2 = Empty -- O(1) comparison via 'HashCons' +difference (NonEmptyMap hc1) t2 = + differenceNonEmpty (unHashCons hc1) t2 + +differenceNonEmpty :: Hashable a => NonEmptyWordMap a -> WordMap a -> WordMap a +differenceNonEmpty t1 Empty = NonEmptyMap (hashCons t1) +differenceNonEmpty t1 (NonEmptyMap hc2) = + case t1 of + Leaf k1 v1 -> if member k1 (NonEmptyMap hc2) + then Empty + else singleton k1 v1 + Bin p1 m1 l1 r1 -> case unHashCons hc2 of + Leaf k2 a2 + | match k2 p1 m1 -> if zero k2 m1 + then combine p1 m1 (difference l1 (singleton k2 a2)) r1 + else combine p1 m1 l1 (difference r1 (singleton k2 a2)) + | otherwise -> NonEmptyMap (hashCons t1) + Bin p2 m2 l2 r2 + | shorter m1 m2 -> + if match p2 p1 m1 + then if zero p2 m1 + then combine p1 m1 (difference l1 (NonEmptyMap hc2)) r1 + else combine p1 m1 l1 (difference r1 (NonEmptyMap hc2)) + else NonEmptyMap (hashCons t1) + | shorter m2 m1 -> + if match p1 p2 m2 + then if zero p1 m2 + then difference (NonEmptyMap (hashCons t1)) l2 + else difference (NonEmptyMap (hashCons t1)) r2 + else NonEmptyMap (hashCons t1) + | p1 == p2 -> let l = difference l1 l2 + r = difference r1 r2 + in combine p1 m1 l r + | otherwise -> NonEmptyMap (hashCons t1) + +-- | Check if a key is present in the map. +member :: Word -> WordMap a -> Bool +member _ Empty = False +member k (NonEmptyMap hc) = memberNonEmpty k (unHashCons hc) + +memberNonEmpty :: Word -> NonEmptyWordMap a -> Bool +memberNonEmpty k (Leaf k' _) + | k == k' = True + | otherwise = False +memberNonEmpty k (Bin p m l r) + | match k p m = if zero k m then member k l else member k r + | otherwise = False + +-- | Helper function to combine two subtrees. +combine :: Hashable a => Word -> Word -> WordMap a -> WordMap a -> WordMap a +combine _ _ Empty Empty = Empty +combine p m l r = NonEmptyMap (hashCons (Bin p m l r)) + +-- | Helper functions. + +join :: Hashable a => Word -> NonEmptyWordMap a -> Word -> NonEmptyWordMap a -> NonEmptyWordMap a +join p1 t1 p2 t2 = + let m = branchingBit p1 p2 + p = mask p1 m + in if zero p1 m + then Bin p m (NonEmptyMap (hashCons t1)) (NonEmptyMap (hashCons t2)) + else Bin p m (NonEmptyMap (hashCons t2)) (NonEmptyMap (hashCons t1)) + +match :: Word -> Word -> Word -> Bool +match k p m = mask k m == p + +mask :: Word -> Word -> Word +mask k m = k .&. (complement (m - 1) `xor` m) + +zero :: Word -> Word -> Bool +zero k m = (k .&. m) == 0 + +branchingBit :: Word -> Word -> Word +branchingBit p1 p2 = highestBitMask (p1 `xor` p2) + +highestBitMask :: Word -> Word +highestBitMask x + | x == 0 = 0 + | otherwise = bit (finiteBitSize x - 1 - countLeadingZeros x) + +shorter :: Word -> Word -> Bool +shorter m1 m2 = m1 > m2 diff --git a/test/Data/HashCons/IntMap/Test.hs b/test/Data/HashCons/IntMap/Test.hs new file mode 100644 --- /dev/null +++ b/test/Data/HashCons/IntMap/Test.hs @@ -0,0 +1,63 @@ +module Data.HashCons.IntMap.Test (tests) where + +import Prelude hiding (lookup) +import Test.Tasty +import Test.Tasty.QuickCheck as QC +import Data.Maybe (isJust, isNothing) +import Data.HashCons.IntMap +import Data.Hashable + +tests :: TestTree +tests = testGroup "Data.HashCons.IntMap" + [ QC.testProperty "Insert and Lookup" prop_insertLookup + , QC.testProperty "Insert overwrites existing key" prop_insertOverwrite + , QC.testProperty "Insert preserves other keys" prop_insertPreservesOtherKeys + , QC.testProperty "Union contains all keys" prop_unionContainsAllKeys + , QC.testProperty "Intersection contains only common keys" prop_intersectionCommonKeys + , QC.testProperty "Difference removes keys" prop_differenceRemovesKeys + ] + +-- Property: Inserting a key and then looking it up gives back the value +prop_insertLookup :: Int -> Int -> Bool +prop_insertLookup k v = + lookup k (insert k v empty) == Just v + +-- Property: Inserting a key overwrites the existing value +prop_insertOverwrite :: Int -> Int -> Int -> Bool +prop_insertOverwrite k v1 v2 = + lookup k (insert k v2 (insert k v1 empty)) == Just v2 + +-- Property: Inserting a key does not affect other keys +prop_insertPreservesOtherKeys :: Int -> Int -> Int -> Int -> Property +prop_insertPreservesOtherKeys k1 v1 k2 v2 = + k1 /= k2 ==> lookup k1 (insert k2 v2 (insert k1 v1 empty)) == Just v1 + +-- Property: Union contains all keys from both maps +prop_unionContainsAllKeys :: [(Int, Int)] -> [(Int, Int)] -> Int -> Bool +prop_unionContainsAllKeys kvs1 kvs2 k = + let m1 = fromList kvs1 + m2 = fromList kvs2 + mu = union m1 m2 + in lookup k mu == case lookup k m1 of + Just v -> Just v + Nothing -> lookup k m2 + +-- Property: Intersection contains only keys common to both maps +prop_intersectionCommonKeys :: [(Int, Int)] -> [(Int, Int)] -> Int -> Bool +prop_intersectionCommonKeys kvs1 kvs2 k = + let m1 = fromList kvs1 + m2 = fromList kvs2 + mi = intersection m1 m2 + in lookup k mi == if isJust (lookup k m1) && isJust (lookup k m2) then lookup k m1 else Nothing + +-- Property: Difference removes keys present in the second map from the first map +prop_differenceRemovesKeys :: [(Int, Int)] -> [(Int, Int)] -> Int -> Bool +prop_differenceRemovesKeys kvs1 kvs2 k = + let m1 = fromList kvs1 + m2 = fromList kvs2 + md = difference m1 m2 + in lookup k md == if isJust (lookup k m1) && isNothing (lookup k m2) then lookup k m1 else Nothing + +-- Helper function to create a map from a list of key-value pairs +fromList :: Hashable a => [(Int, a)] -> IntMap a +fromList = foldr (\(k,v) m -> insert k v m) empty diff --git a/test/Data/HashCons/Internal/Test.hs b/test/Data/HashCons/Internal/Test.hs new file mode 100644 --- /dev/null +++ b/test/Data/HashCons/Internal/Test.hs @@ -0,0 +1,71 @@ +module Data.HashCons.Internal.Test (tests) where + +import Control.Concurrent.Async +import Control.Monad +import Data.HashCons.Internal +import Data.Hashable +import Data.IORef +import System.Mem.StableName +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +tests :: TestTree +tests = testGroup "Data.HashCons.Internal" + [ QC.testProperty "Reflexivity" prop_reflexivity + , QC.testProperty "Symmetry" prop_symmetry + , QC.testProperty "Consistency of unHashCons" prop_consistency_unHashCons + , QC.testProperty "Deduplication" prop_deduplication + , QC.testProperty "Ord and Eq Consistency" prop_ord_eq_consistency + , QC.testProperty "Ord Transitivity" prop_ord_transitivity + ] + +prop_reflexivity :: Int -> Property +prop_reflexivity x = let hx = hashCons x in hx === hx + +prop_symmetry :: Int -> Int -> Property +prop_symmetry x y = let hx = hashCons x; hy = hashCons y in (hx == hy) === (hy == hx) + +prop_consistency_unHashCons :: Int -> Int -> Property +prop_consistency_unHashCons x y = let hx = hashCons x; hy = hashCons y in + (hx == hy) === (unHashCons hx == unHashCons hy) + +prop_deduplication :: Int -> Int -> Property +prop_deduplication x y = ioProperty $ do + let hx = hashCons x + hy = hashCons y + -- Perform the equality check to trigger deduplication + areEqual <- eqHashConsIO hx hy + if areEqual + then do + -- Read the contents of both IORefs + a1 <- readIORef (_hashCons_ref hx) + a2 <- readIORef (_hashCons_ref hy) + -- Create StableNames for both contents + sn1 <- makeStableName a1 + sn2 <- makeStableName a2 + -- Check if the StableNames are equal (pointer equality) + return $ sn1 == sn2 + else return True -- If not equal, deduplication isn't expected + +-- Helper function to perform equality check in IO +eqHashConsIO :: Eq a => HashCons a -> HashCons a -> IO Bool +eqHashConsIO (HashConsC h1 ref1) (HashConsC h2 ref2) + | h1 /= h2 = return False + | ref1 == ref2 = return True + | otherwise = do + a1 <- readIORef ref1 + a2 <- readIORef ref2 + if a1 == a2 + then do + writeIORef ref1 a2 + return True + else return False + +prop_ord_eq_consistency :: Int -> Int -> Bool +prop_ord_eq_consistency x y = let hx = hashCons x; hy = hashCons y in + (hx == hy) == (compare hx hy == EQ) + +prop_ord_transitivity :: Int -> Int -> Int -> Property +prop_ord_transitivity x y z = let hx = hashCons x; hy = hashCons y; hz = hashCons z in + (compare hx hy == LT && compare hy hz == LT) ==> (compare hx hz == LT) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,74 +1,14 @@ module Main (main) where -import Control.Concurrent.Async -import Control.Monad -import Data.HashCons.Internal -import Data.Hashable -import Data.IORef -import System.Mem.StableName import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC +import qualified Data.HashCons.Internal.Test +import qualified Data.HashCons.IntMap.Test main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "HashCons Tests" - [ QC.testProperty "Reflexivity" prop_reflexivity - , QC.testProperty "Symmetry" prop_symmetry - , QC.testProperty "Consistency of unHashCons" prop_consistency_unHashCons - , QC.testProperty "Deduplication" prop_deduplication - , QC.testProperty "Ord and Eq Consistency" prop_ord_eq_consistency - , QC.testProperty "Ord Transitivity" prop_ord_transitivity +tests = testGroup "hash-cons" + [ Data.HashCons.Internal.Test.tests + , Data.HashCons.IntMap.Test.tests ] - -prop_reflexivity :: Int -> Property -prop_reflexivity x = let hx = hashCons x in hx === hx - -prop_symmetry :: Int -> Int -> Property -prop_symmetry x y = let hx = hashCons x; hy = hashCons y in (hx == hy) === (hy == hx) - -prop_consistency_unHashCons :: Int -> Int -> Property -prop_consistency_unHashCons x y = let hx = hashCons x; hy = hashCons y in - (hx == hy) === (unHashCons hx == unHashCons hy) - -prop_deduplication :: Int -> Int -> Property -prop_deduplication x y = ioProperty $ do - let hx = hashCons x - hy = hashCons y - -- Perform the equality check to trigger deduplication - areEqual <- eqHashConsIO hx hy - if areEqual - then do - -- Read the contents of both IORefs - a1 <- readIORef (_hashCons_ref hx) - a2 <- readIORef (_hashCons_ref hy) - -- Create StableNames for both contents - sn1 <- makeStableName a1 - sn2 <- makeStableName a2 - -- Check if the StableNames are equal (pointer equality) - return $ sn1 == sn2 - else return True -- If not equal, deduplication isn't expected - --- Helper function to perform equality check in IO -eqHashConsIO :: Eq a => HashCons a -> HashCons a -> IO Bool -eqHashConsIO (HashCons h1 ref1) (HashCons h2 ref2) - | h1 /= h2 = return False - | ref1 == ref2 = return True - | otherwise = do - a1 <- readIORef ref1 - a2 <- readIORef ref2 - if a1 == a2 - then do - writeIORef ref1 a2 - return True - else return False - -prop_ord_eq_consistency :: Int -> Int -> Bool -prop_ord_eq_consistency x y = let hx = hashCons x; hy = hashCons y in - (hx == hy) == (compare hx hy == EQ) - -prop_ord_transitivity :: Int -> Int -> Int -> Property -prop_ord_transitivity x y z = let hx = hashCons x; hy = hashCons y; hz = hashCons z in - (compare hx hy == LT && compare hy hz == LT) ==> (compare hx hz == LT)