This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via 21f2ea5bd9970997fadc1a943ed10fa999981076 (commit)
from b387fc5affd788791ea0368ff205df162f4c8821 (commit)
Summary of changes:
snap-server.cabal | 1 +
src/Data/HashMap/Concurrent.hs | 46 +++++++-------
src/Data/HashMap/Concurrent/Internal.hs | 16 +++++
test/runTestsAndCoverage.sh | 2 +
test/snap-server-testsuite.cabal | 1 +
test/suite/Data/HashMap/Concurrent/Tests.hs | 96 ++++++++++++++++++++++++++-
6 files changed, 136 insertions(+), 26 deletions(-)
create mode 100644 src/Data/HashMap/Concurrent/Internal.hs
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 21f2ea5bd9970997fadc1a943ed10fa999981076
Author: Gregory Collins <[email protected]>
Date: Mon Aug 16 22:38:09 2010 -0400
HashMap: select arch-specific hash function using TH, test coverage
diff --git a/snap-server.cabal b/snap-server.cabal
index 37cfb24..e714cab 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -118,6 +118,7 @@ Library
network == 2.2.1.*,
old-locale,
snap-core >= 0.2.10 && <0.3,
+ template-haskell,
time,
transformers,
unix-compat,
diff --git a/src/Data/HashMap/Concurrent.hs b/src/Data/HashMap/Concurrent.hs
index 0f82317..88b271a 100644
--- a/src/Data/HashMap/Concurrent.hs
+++ b/src/Data/HashMap/Concurrent.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
module Data.HashMap.Concurrent
( HashMap
@@ -35,44 +36,44 @@ import GHC.Conc (numCapabilities)
import Prelude hiding (lookup, null)
import qualified Prelude
-
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts ( Word(..), Int(..), shiftRL# )
-import Data.Word (Word32, Word64)
#else
import Data.Word
#endif
-whichHash :: (a -> Word32) -> (a -> Word64) -> a -> Word
-whichHash as32 as64 x = if bitSize (undefined :: Word) == 32
- then fromIntegral $ as32 x
- else fromIntegral $ as64 x
+import Data.HashMap.Concurrent.Internal
hashString :: String -> Word
-hashString = whichHash hashString32 hashString64
- where
- hashString32 s = Murmur.asWord32 $ Murmur.hash32 s
- hashString64 s = Murmur.asWord64 $ Murmur.hash64 s
+hashString = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]
+ [| Murmur.asWord64 . Murmur.hash64 |])
{-# INLINE hashString #-}
hashInt :: Int -> Word
-hashInt = whichHash h32 h64
- where
- h32 x = Murmur.asWord32 $ Murmur.hash32 x
- h64 x = Murmur.asWord64 $ Murmur.hash64 x
+hashInt = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]
+ [| Murmur.asWord64 . Murmur.hash64 |])
{-# INLINE hashInt #-}
hashBS :: B.ByteString -> Word
-hashBS = whichHash h32 h64
- where
- h32 !s = Murmur.asWord32 $ B.foldl' f32 (Murmur.hash32 ([] :: [Int])) s
- h64 !s = Murmur.asWord64 $ B.foldl' f64 (Murmur.hash64 ([] :: [Int])) s
-
- f32 !h !c = Murmur.hash32AddInt (fromEnum c) h
- f64 !h !c = Murmur.hash64AddInt (fromEnum c) h
+hashBS =
+ $(let h32 = [| \s -> s `seq`
+ Murmur.asWord32 $
+ B.foldl' (\h c -> h `seq` c `seq`
+ Murmur.hash32AddInt (fromEnum c) h)
+ (Murmur.hash32 ([] :: [Int]))
+ s
+ |]
+ h64 = [| \s -> s `seq`
+ Murmur.asWord64 $
+ B.foldl' (\h c -> h `seq` c `seq`
+ Murmur.hash64AddInt (fromEnum c) h)
+ (Murmur.hash64 ([] :: [Int]))
+ s
+ |]
+ in whichHash h32 h64)
{-# INLINE hashBS #-}
@@ -215,8 +216,7 @@ delSubmap hashcode key m =
where
f l = let l' = del l in if Prelude.null l' then Nothing else Just l'
- del [] = []
- del (x:xs) = if fst x == key then xs else x:(del xs)
+ del = filter ((/= key) . fst)
lookupSubmap :: (Eq k) => Word -> k -> Submap k v -> Maybe v
diff --git a/src/Data/HashMap/Concurrent/Internal.hs
b/src/Data/HashMap/Concurrent/Internal.hs
new file mode 100644
index 0000000..dce6bcb
--- /dev/null
+++ b/src/Data/HashMap/Concurrent/Internal.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.HashMap.Concurrent.Internal where
+
+import Data.Bits
+import Data.Word
+import Language.Haskell.TH
+
+
+whichHash :: ExpQ -> ExpQ -> Q Exp
+whichHash as32 as64 = if bitSize (undefined :: Word) == 32
+ then [| \x -> fromIntegral $ $as32 x |]
+ else [| \x -> fromIntegral $ $as64 x |]
diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh
index 7795f0a..ee76cdf 100755
--- a/test/runTestsAndCoverage.sh
+++ b/test/runTestsAndCoverage.sh
@@ -25,6 +25,8 @@ mkdir -p $DIR
EXCLUDES='Main
Data.CIByteString
+Data.HashMap.Concurrent.Tests
+Paths_snap_server
Snap.Internal.Http.Parser.Tests
Snap.Internal.Http.Server.Tests
Snap.Internal.Http.Types.Tests
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index f768c71..a9f31ed 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -170,6 +170,7 @@ Executable testserver
network == 2.2.1.7,
network-bytestring >= 0.1.2 && < 0.2,
snap-core >= 0.2.9 && <0.3,
+ template-haskell,
time,
transformers,
unix-compat,
diff --git a/test/suite/Data/HashMap/Concurrent/Tests.hs
b/test/suite/Data/HashMap/Concurrent/Tests.hs
index 025b5a8..2ea7e8f 100644
--- a/test/suite/Data/HashMap/Concurrent/Tests.hs
+++ b/test/suite/Data/HashMap/Concurrent/Tests.hs
@@ -5,27 +5,117 @@
module Data.HashMap.Concurrent.Tests
( tests ) where
+import Data.ByteString.Char8 (ByteString)
import Data.List
-import Test.Framework
+import Data.Word
+import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
import Test.QuickCheck.Monadic
import qualified Data.HashMap.Concurrent as H
+import Snap.Test.Common ()
tests :: [Test]
-tests = [ testFromTo ]
+tests = [ testFromTo
+ , testLookup
+ , testDeletes
+ , testUpdate
+ ]
+
+
+-- make sure we generate two strings which hash to the same bucket.
+bogoHash :: ByteString -> Word
+bogoHash "qqq" = 12345
+bogoHash "zzz" = 12345
+bogoHash x = H.hashBS x
testFromTo :: Test
testFromTo = testProperty "HashMap/fromList/toList" $
monadicIO $ forAllM arbitrary prop
where
+ prop :: [(Int,Int)] -> PropertyM IO ()
prop l = do
- ht <- run $ H.fromList H.hashInt (l :: [(Int,Int)])
+ ht <- run $ H.fromList H.hashInt l
l' <- run $ H.toList ht
let s1 = sort l
let s2 = sort l'
assert $ s1 == s2
+
+
+testDeletes :: Test
+testDeletes = testProperty "HashMap/deletes" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: [(ByteString,ByteString)] -> PropertyM IO ()
+ prop l' = do
+ pre (not $ null l')
+ let l = [("qqq","QQQ"),("zzz","ZZZ")] ++ l'
+ let h = head l'
+
+ ht <- run $ H.fromList bogoHash l
+ v1 <- run $ H.lookup "qqq" ht
+ v2 <- run $ H.lookup "zzz" ht
+
+ run $ H.delete "qqq" ht
+ v3 <- run $ H.lookup "qqq" ht
+ v4 <- run $ H.lookup "zzz" ht
+
+ run $ H.delete (fst h) ht
+ run $ H.delete (fst h) ht
+
+ v5 <- run $ H.lookup (fst h) ht
+
+ assert $ v1 == Just "QQQ"
+ assert $ v2 == Just "ZZZ"
+ assert $ v3 == Nothing
+ assert $ v4 == Just "ZZZ"
+ assert $ v5 == Nothing
+
+
+testLookup :: Test
+testLookup = testProperty "HashMap/lookup" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: [(ByteString,ByteString)] -> PropertyM IO ()
+ prop l' = do
+ pre (not $ null l')
+ let h = head l'
+ let l = filter ((/= (fst h)) . fst) $ tail l'
+
+ ht <- run $ H.fromList H.hashBS (h:l)
+
+ v1 <- run $ H.lookup (fst h) ht
+ run $ H.delete (fst h) ht
+ v2 <- run $ H.lookup (fst h) ht
+
+ assert $ v1 == (Just $ snd h)
+ assert $ v2 == Nothing
+
+
+testUpdate :: Test
+testUpdate = testProperty "HashMap/update" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: [(ByteString,ByteString)] -> PropertyM IO ()
+ prop l' = do
+ pre (not $ null l')
+ let h = head l'
+ let l = filter ((/= (fst h)) . fst) $ tail l'
+
+ ht <- run $ H.fromList H.hashBS (h:l)
+ e1 <- run $ H.update (fst h) "qqq" ht
+ v1 <- run $ H.lookup (fst h) ht
+ run $ H.delete (fst h) ht
+ v2 <- run $ H.lookup (fst h) ht
+ e2 <- run $ H.update (fst h) "zzz" ht
+ v3 <- run $ H.lookup (fst h) ht
+
+ assert e1
+ assert $ v1 == Just "qqq"
+ assert $ v2 == Nothing
+ assert $ not e2
+ assert $ v3 == Just "zzz"
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
