hash-cons 0.1.0.0 → 0.2.0.0

raw patch · 10 files changed

+643/−91 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hash-cons.cabal +11/−3
• src/Data/HashCons.hs +2/−0
• src/Data/HashCons/IntMap.hs +105/−0
• src/Data/HashCons/IntMap/Internal.hs +1/−0
• src/Data/HashCons/Internal.hs +70/−23
• src/Data/HashCons/WordMap.hs +29/−0
• src/Data/HashCons/WordMap/Internal.hs +286/−0
• test/Data/HashCons/IntMap/Test.hs +63/−0
• test/Data/HashCons/Internal/Test.hs +71/−0
• test/Main.hs +5/−65

@@ -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,

@@ -1,7 +1,9 @@+{-# LANGUAGE PatternSynonyms #-} module Data.HashCons (module X) where  import Data.HashCons.Internal as X   ( HashCons+  , pattern HashCons   , hashCons   , unHashCons   )

@@ -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

@@ -0,0 +1,1 @@+module Data.HashCons.IntMap.Internal where

@@ -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 <x>" 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 #-}

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)