1 files changed, 278 insertions, 0 deletions
diff --git a/testsuite/tests/programs/maessen-hashtab/HashTest.hs b/testsuite/tests/programs/maessen-hashtab/HashTest.hs
new file mode 100644
index 0000000000..51c60c0640
--- /dev/null
+++ b/testsuite/tests/programs/maessen-hashtab/HashTest.hs
@@ -0,0 +1,278 @@
+{- Test code for Data.HashTable -}
+
+module Main(main) where
+
+import Prelude hiding (lookup)
+import qualified Prelude (lookup)
+import Data.Maybe(isJust,isNothing)
+import Data.Int(Int32)
+import Test.QuickCheck
+import System.IO.Unsafe(unsafePerformIO)
+import Data.HashTab
+import Control.Monad(liftM2, foldM)
+import System.Random
+import System.Environment
+
+infixr 0 ==.
+infixr 0 ==~
+infixr 0 ~~
+
+type HT = HashTable Int Int
+newtype HashFun = HF {unHF :: (Int -> Int32)}
+data Empty = E {e :: (IO HT), hfe :: HashFun}
+data MkH   = H {h :: (IO HT), hfh :: HashFun}
+newtype List a = L [a]
+
+data Action = Lookup Int
+            | Insert Int Int
+            | Delete Int
+            | Update Int Int
+            deriving (Show)
+
+instance Arbitrary Action where
+  arbitrary = frequency [(10,fmap Lookup arbitrary),
+                         (5, liftM2 Insert arbitrary arbitrary),
+                         (3, liftM2 Update arbitrary arbitrary),
+                         (1, fmap Delete arbitrary)]
+  coarbitrary = error "coarbitrary Action"
+
+simA :: [Action] -> [Either Bool [Int]]
+simA = fst . foldl sim ([],[])
+  where sim :: ([Either Bool [Int]], [Action]) -> Action ->
+               ([Either Bool [Int]], [Action])
+        sim (res, past) (Lookup k)   = (Right (lkup k past) : res, past)
+        sim (res, past) (Insert k v) = (res, Insert k v : past)
+        sim (res, past) (Delete k)   = (res, Delete k   : past)
+        sim (res, past) (Update k v) =
+          (Left (not (null l)) : res, Update k v : past)
+          where l = lkup k past
+        lkup _ [] = []
+        lkup k (Delete k' : _)
+          | k==k' = []
+        lkup k (Update k' v : _)
+          | k==k'     = [v]
+        lkup k (Insert k' v : past)
+          | k==k'     = v:lkup k past
+        lkup k (_ : past) = lkup k past
+
+runA :: HashFun -> [Action] -> IO [Either Bool (Maybe Int)]
+runA hf acts = do
+  ht <- new (==) (unHF hf)
+  let run res (Lookup a) = fmap (lkup res) $ lookup ht a
+      run res (Insert k v) = insert ht k v >> return res
+      run res (Delete k)   = delete ht k   >> return res
+      run res (Update k v) = fmap (upd res) $ update ht k v
+      lkup res m = Right m : res
+      upd res b = Left b : res
+  foldM run [] acts
+
+(~~) :: IO [Either Bool (Maybe Int)] -> [Either Bool [Int]] -> Bool
+acts ~~ sims = and $ zipWith same (unsafePerformIO acts) sims
+  where same (Left b)         (Left b')  = b==b'
+        same (Right Nothing)  (Right []) = True
+        same (Right (Just a)) (Right xs) = a `elem` xs
+        same _                _          = False
+
+lookups :: HT -> [Int] -> IO [Maybe Int]
+lookups ht ks = mapM (lookup ht) ks
+
+instance Show HashFun where
+  showsPrec _ (HF hf) r
+      | hf 1 == 0 = "degenerate"++r
+      | otherwise = "usual"++r
+
+instance Show Empty where
+  showsPrec _ ee r = shows (hfe ee) r
+
+instance Show MkH where
+  showsPrec _ hh r = shows (hfh hh) $
+                     ("; "++shows (unsafePerformIO (h hh >>= toList)) r)
+
+instance Show a => Show (List a) where
+  showsPrec _ (L l) r = shows l r
+
+instance Arbitrary HashFun where
+  arbitrary = frequency [(20,return (HF hashInt)),
+                         (1,return (HF (const 0)))]
+  coarbitrary = error "coarbitrary HashFun"
+
+instance Arbitrary Empty where
+  arbitrary = fmap mkE arbitrary
+    where mkE (HF hf) = E {e = new (==) hf, hfe=HF hf}
+  coarbitrary = error "coarbitrary Empty"
+
+instance Arbitrary a => Arbitrary (List a) where
+  arbitrary = do
+    sz <- frequency [(50, sized return),
+                     (1,return (4096*2)),
+                     (0, return (1024*1024))]
+    resize sz $ fmap L $ sized vector
+  coarbitrary = error "coarbitrary (List a)"
+
+instance Arbitrary MkH where
+  arbitrary = do
+    hf <- arbitrary
+    L list <- arbitrary
+    let mkH act = H { h = act, hfh = hf }
+    return (mkH . fromList (unHF hf) $ list)
+  coarbitrary = error "coarbitrary MkH"
+
+(==~) :: (Eq a) => IO a -> IO a -> Bool
+act1 ==~ act2 = unsafePerformIO act1 == unsafePerformIO act2
+
+(==.) :: (Eq a) => IO a -> a -> Bool
+act ==. v = unsafePerformIO act == v
+
+notin :: (Testable a) => Int -> MkH -> a -> Property
+k `notin` hh = \prop ->
+  let f = (not . isJust . unsafePerformIO) (h hh >>= flip lookup k) in
+  f `trivial` prop
+
+prop_emptyLookup :: Empty -> Int -> Bool
+prop_emptyLookup ee k =
+  isNothing . unsafePerformIO $
+  (do mt <- e ee
+      lookup mt k)
+
+prop_emptyToList :: Empty -> Bool
+prop_emptyToList ee =
+  (do mt <- e ee
+      toList mt) ==. []
+
+prop_emptyFromList :: HashFun -> Int -> Bool
+prop_emptyFromList hf k =
+  (do mt <- new (==) (unHF hf) :: IO HT
+      lookup mt k) ==~
+  (do mt <- fromList (unHF hf) []
+      lookup mt k)
+
+prop_insert :: MkH -> Int -> Int -> Bool
+prop_insert hh k v =
+  (do ht <- h hh
+      insert ht k v
+      lookup ht k) ==. Just v
+
+prop_insertu :: MkH -> Int -> Int -> List Int -> Bool
+prop_insertu hh k v (L ks) =
+  let ks' = filter (k /=) ks in
+  (do ht <- h hh
+      insert ht k v
+      lookups ht ks') ==~
+  (do ht <- h hh
+      lookups ht ks')
+
+prop_delete :: MkH -> Int -> Property
+prop_delete hh k =
+  k `notin` hh $
+  isNothing . unsafePerformIO $
+  (do ht <- h hh
+      delete ht k
+      lookup ht k)
+
+prop_deleteu :: MkH -> Int -> List Int -> Bool
+prop_deleteu hh k (L ks) =
+  let ks' = filter (k /=) ks in
+  (do ht <- h hh
+      delete ht k
+      lookups ht ks') ==~
+  (do ht <- h hh
+      lookups ht ks')
+
+naiveUpdate :: HT -> Int -> Int -> IO ()
+naiveUpdate ht k v = do
+  delete ht k
+  insert ht k v
+
+prop_update :: MkH -> Int -> Int -> List Int -> Bool
+prop_update hh k v (L ks) =
+  (do ht <- h hh
+      _ <- update ht k v
+      lookups ht ks) ==~
+  (do ht <- h hh
+      naiveUpdate ht k v
+      lookups ht ks)
+
+prop_updatec :: MkH -> Int -> Int -> Bool
+prop_updatec hh k v =
+  (do ht <- h hh
+      _ <- update ht k v
+      lookup ht k) ==. Just v
+
+prop_updateLookup :: MkH -> Int -> Int -> Property
+prop_updateLookup hh k v =
+  k `notin` hh $
+  (do ht <- h hh
+      update ht k v) ==~
+  (do ht <- h hh
+      fmap isJust (lookup ht k))
+
+prop_simulation :: HashFun -> List Action -> Property
+prop_simulation hf (L acts) =
+  (null acts `trivial`) $
+  runA hf acts ~~ simA acts
+
+{-
+
+For "fromList" and "toList" properties we're a bit sloppy: we perform
+multiple insertions for a key (potentially) but give nor promises
+about which one we will retrieve with lookup, or what order they'll be
+returned by toList (or if they'll all be returned at all).  Thus we
+insert all occurrences of a key with the same value, and do all
+checking via lookups.
+
+-}
+
+prop_fromList :: HashFun -> List Int -> List Int -> Property
+prop_fromList hf (L l) (L ks) =
+  null l `trivial`
+  let assocs = map (\t -> (t,t)) l in
+  ( do ht <- fromList (unHF hf) assocs
+       lookups ht ks) ==. (map (`Prelude.lookup` assocs) ks)
+
+prop_fromListInsert :: HashFun -> List (Int,Int) -> Int -> Int -> List Int -> Property
+prop_fromListInsert hf (L l) k v (L ks) =
+  null l `trivial`
+  (( do ht <- fromList (unHF hf) l
+        insert ht k v
+        lookups ht ks) ==~
+   ( do ht <- fromList (unHF hf) (l++[(k,v)])
+        lookups ht ks))
+
+prop_toList :: HashFun -> List Int -> List Int -> Property
+prop_toList hf (L l) (L ks) =
+  null l `trivial`
+  let assocs = map (\t -> (t,t)) l in
+  ( do ht <- fromList (unHF hf) assocs
+       lookups ht ks) ==~
+  ( do ht <- fromList (unHF hf) assocs
+       fmap (\as -> map (`Prelude.lookup` as) ks) $ toList ht )
+
+te :: (Testable a) => String -> a -> IO ()
+-- te name prop = putStrLn name >> verboseCheck prop
+te name prop = do
+  putStr name
+  check (defaultConfig{configMaxTest = 500,
+                               configMaxFail = 10000,
+                               configEvery = \_ _ -> "" }) prop
+
+main :: IO ()
+main = do
+  [r] <- getArgs
+  setStdGen (mkStdGen (read r :: Int))
+  sequence_ $
+    [ te "emptyLookup:" prop_emptyLookup,
+      te "emptyToList:" prop_emptyToList,
+      te "emptyFromList:" prop_emptyFromList,
+      te "insert:" prop_insert,
+      te "insertu:" prop_insertu,
+      te "delete:" prop_delete,
+      te "deleteu:" prop_deleteu,
+      te "update:" prop_update,
+      te "updatec:" prop_updatec,
+      te "updateLookup:" prop_updateLookup,
+      te "fromList:" prop_fromList,
+      te "fromListInsert:" prop_fromListInsert,
+      te "toList:" prop_toList,
+      te "simulation:" prop_simulation
+    ]
+  putStrLn "OK"