Refactored tests a bit with tasty-discover

net-mqtt.cabal

@@ -122,10 +122,13 @@ executable mqtt-watch
 
 test-suite mqtt-test
   type: exitcode-stdio-1.0
-  main-is: Spec.hs
+  main-is: Main.hs
   other-modules:
+      DecayingSpec
       Example1
       Example2
+      ExpiringSpec
+      Spec
       Paths_net_mqtt
   hs-source-dirs:
       test
@@ -152,6 +155,7 @@ test-suite mqtt-test
     , network-uri >=2.6.1 && <2.7
     , stm >=2.4.0 && <2.6
     , tasty
+    , tasty-discover
     , tasty-hunit
     , tasty-quickcheck
     , text >=1.2.3 && <2.1.0

package.yaml

@@ -69,7 +69,7 @@ executables:
 
 tests:
   mqtt-test:
-    main:                Spec.hs
+    main:                Main.hs
     source-dirs:         test
     ghc-options:
     - -threaded
@@ -81,5 +81,6 @@ tests:
     - tasty
     - tasty-hunit
     - tasty-quickcheck
+    - tasty-discover
     - checkers
     - mtl

src/Data/Map/Strict/Expiring.hs

@@ -80,12 +80,12 @@ removeAging g k = Map.update (nonNull . Set.delete k) g
 -- | 𝑂(log𝑛). Lookup a value in the map.
 -- This will not return any items that have expired.
 lookup :: (Ord k, Ord g) => k -> Map g k a -> Maybe a
-lookup k Map{..} = value <$> Map.lookup k map
+lookup k = fmap value . Map.lookup k . map
 
 -- | 𝑂(log𝑛). Delete an item.
 delete :: (Ord k, Ord g) => k -> Map g k a -> Map g k a
 delete k m@Map{..} = case Map.lookup k map of
-  Nothing -> m
+  Nothing        -> m
   Just Entry{..} -> m { map = Map.delete k map, aging = removeAging gen k aging }
 
 -- | 𝑂(𝑛). Return all current key/value associations.

test/DecayingSpec.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns      #-}
+
+module DecayingSpec where
+
+import           Control.Concurrent              (threadDelay)
+import           Control.Concurrent.STM          (STM, atomically)
+import           Control.Monad                   (foldM, mapM_)
+import qualified Data.Attoparsec.ByteString.Lazy as A
+import qualified Data.ByteString.Lazy            as L
+import           Data.Foldable                   (traverse_)
+import qualified Data.Map.Strict                 as Map
+import qualified Data.Map.Strict.Decaying        as DecayingMap
+import           Data.Set                        (Set)
+import qualified Data.Set                        as Set
+
+import           Test.QuickCheck
+
+prop_decayingMapWorks :: [Int] -> Property
+prop_decayingMapWorks keys = idempotentIOProperty $ do
+  m <- DecayingMap.new 60
+  atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys
+  found <- atomically $ traverse (\x -> DecayingMap.findWithDefault maxBound x m) keys
+  pure $ found === keys
+
+prop_decayingMapDecays :: [Int] -> Property
+prop_decayingMapDecays keys = idempotentIOProperty $ do
+  m <- DecayingMap.new 0.001
+  atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys
+  threadDelay 5000
+  DecayingMap.tick m
+  found <- atomically $ DecayingMap.elems m
+  pure $ found === []
+
+prop_decayingMapUpdates :: Set Int -> Property
+prop_decayingMapUpdates (Set.toList -> keys) = idempotentIOProperty $ do
+  m <- DecayingMap.new 60
+  atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys
+  updated <- atomically $ traverse (\x -> DecayingMap.updateLookupWithKey (\_ v -> Just (v + 1)) x m) keys
+  found <- atomically $ traverse (\x -> DecayingMap.findWithDefault maxBound x m) keys
+  pure $ (found === fmap (+ 1) keys .&&. Just found === sequenceA updated)
+
+prop_decayingMapDeletes :: Set Int -> Property
+prop_decayingMapDeletes (Set.toList -> keys) = (not . null) keys ==> idempotentIOProperty $ do
+  m <- DecayingMap.new 60
+  atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys
+  atomically $ traverse (`DecayingMap.delete` m) (tail keys)
+  found <- atomically $ DecayingMap.elems m
+  pure $ found === take 1 keys

test/ExpiringSpec.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
+
+module ExpiringSpec where
+
+import           Control.Monad.RWS.Strict (MonadWriter (tell), evalRWS, gets, modify)
+import           Data.Foldable            (toList, traverse_)
+import qualified Data.Map.Strict          as Map
+import qualified Data.Map.Strict.Expiring as ExpiringMap
+import           Data.Set                 (Set)
+import qualified Data.Set                 as Set
+
+import           Test.QuickCheck
+
+newtype SomeKey = SomeKey Char
+  deriving (Eq, Ord, Show)
+
+instance Arbitrary SomeKey where
+  arbitrary = SomeKey <$> elements ['a'..'e']
+
+data MapOp = Insert SomeKey Int
+           | Delete SomeKey
+           | Lookup SomeKey
+           | Update SomeKey Int
+           | UpdateNothing SomeKey
+  deriving Show
+
+instance Arbitrary MapOp where
+  arbitrary = oneof [Insert <$> arbitrary <*> arbitrary,
+                     Delete <$> arbitrary,
+                     Lookup <$> arbitrary,
+                     Update <$> arbitrary <*> arbitrary,
+                     UpdateNothing <$> arbitrary
+                     ]
+
+allOpTypes :: [String]
+allOpTypes = ["Insert", "Delete", "Lookup", "Update", "UpdateNothing"]
+
+prop_expMapDoesMapStuff :: [MapOp] -> Property
+prop_expMapDoesMapStuff ops =
+  coverTable "pkt types" ((,5) <$> allOpTypes) $
+  tabulate "pkt types" (lab <$> ops) $
+  checkCoverage $
+  massocs === eassocs
+  where
+    lab x = let (s,_) = break (== ' ') . show $ x in s
+    massocs = snd $ evalRWS (applyOpsM ops) () (mempty :: Map.Map SomeKey Int)
+    eassocs = snd $ evalRWS (applyOpsE ops) () (ExpiringMap.new 0)
+
+    applyOpsM = traverse_ \case
+      Insert k v -> do
+        modify $ Map.insert k v
+        tell =<< gets Map.assocs
+      Delete k -> do
+        modify $ Map.delete k
+        tell =<< gets Map.assocs
+      Lookup k -> do
+        gets (Map.lookup k) >>= \case
+          Nothing -> pure ()
+          Just v  -> tell [(k, v)]
+      Update k v -> do
+        modify $ (snd <$> Map.updateLookupWithKey (\_ _ -> Just v) k)
+        tell =<< gets Map.assocs
+      UpdateNothing k -> do
+        modify $ (snd <$> Map.updateLookupWithKey (\_ _ -> Nothing) k)
+        tell =<< gets Map.assocs
+
+    applyOpsE = traverse_ \case
+      Insert k v -> do
+        modify $ ExpiringMap.insert 1 k v
+        tell =<< gets ExpiringMap.assocs
+      Delete k -> do
+        modify $ ExpiringMap.delete k
+        tell =<< gets ExpiringMap.assocs
+      Lookup k -> do
+        gets (ExpiringMap.lookup k) >>= \case
+          Nothing -> pure ()
+          Just v  -> tell [(k, v)]
+      Update k v -> do
+        modify $ (snd <$> ExpiringMap.updateLookupWithKey 1 (\_ _ -> Just v) k)
+        tell =<< gets ExpiringMap.assocs
+      UpdateNothing k -> do
+        modify $ (snd <$> ExpiringMap.updateLookupWithKey 1 (\_ _ -> Nothing) k)
+        tell =<< gets ExpiringMap.assocs
+
+prop_expiringMapWorks :: Int -> [Int] -> Property
+prop_expiringMapWorks baseGen keys = Just keys === traverse (`ExpiringMap.lookup` m) keys
+  where
+    m = foldr (\x -> ExpiringMap.insert futureGen x x) (ExpiringMap.new baseGen) keys
+    futureGen = succ baseGen
+
+ulength :: (Ord a, Foldable t) => t a -> Int
+ulength = Set.size . Set.fromList . toList
+
+prop_expiringMapExpires :: Int -> [Int] -> Property
+prop_expiringMapExpires baseGen keys = (ulength keys, futureGen, ulength keys) === ExpiringMap.inspect m1 .&&. (0, lastGen, 0) === ExpiringMap.inspect m2
+  where
+    m1 = ExpiringMap.newGen futureGen $ foldr (\x -> ExpiringMap.insert futureGen x x) (ExpiringMap.new baseGen) keys
+    m2 = ExpiringMap.newGen lastGen m1
+    futureGen = succ baseGen
+    lastGen = succ futureGen
+
+prop_expiringMapCannotAcceptExpired :: Positive Int -> Positive Int -> Int -> Property
+prop_expiringMapCannotAcceptExpired (Positive lowGen) (Positive offset) k = ExpiringMap.inspect m === ExpiringMap.inspect m'
+  where
+    highGen = lowGen + offset
+    m = ExpiringMap.new highGen :: ExpiringMap.Map Int Int Int
+    m' = ExpiringMap.insert lowGen k k m
+
+prop_expiringMapUpdateMissing :: Int -> Int -> Property
+prop_expiringMapUpdateMissing gen k = mv === Nothing .&&. ExpiringMap.inspect m === ExpiringMap.inspect m'
+  where
+    m = ExpiringMap.new gen :: ExpiringMap.Map Int Int Bool
+    (mv, m') = ExpiringMap.updateLookupWithKey gen (\_ _ -> Just True) k m
+
+prop_expiringMapCannotUpdateExpired :: Positive Int -> Positive Int -> Int -> Property
+prop_expiringMapCannotUpdateExpired (Positive lowGen) (Positive offset) k = mv === Nothing .&&. ExpiringMap.lookup k m' === Just True
+  where
+    highGen = lowGen + offset
+    m = ExpiringMap.insert highGen k True $ ExpiringMap.new highGen
+    (mv, m') = ExpiringMap.updateLookupWithKey lowGen (\_ _ -> Just False) k m
+
+prop_expiringMapDelete :: Int -> [Int] -> Property
+prop_expiringMapDelete baseGen keys = (ulength keys, baseGen, ulength keys) === ExpiringMap.inspect m .&&. (0, baseGen, 0) === ExpiringMap.inspect m'
+  where
+    m = foldr (\x -> ExpiringMap.insert futureGen x x) (ExpiringMap.new baseGen) keys
+    m' = foldr ExpiringMap.delete m keys
+    futureGen = succ baseGen
+
+prop_expiringMapElems :: Int -> Set Int -> Property
+prop_expiringMapElems baseGen keys = keys === Set.fromList (toList m)
+  where
+    m = foldr (\x -> ExpiringMap.insert futureGen x x) (ExpiringMap.new baseGen) keys
+    futureGen = succ baseGen
+
+prop_expiringMapGen :: Int -> Int -> Property
+prop_expiringMapGen g1 g2 = ExpiringMap.inspect m === (0, max g1 g2, 0)
+  where
+    m :: ExpiringMap.Map Int Int Int
+    m = ExpiringMap.newGen g2 $ ExpiringMap.new g1

test/Main.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}