diff --git a/src/wordmap/TimerWheel/Internal/WordMap.hs b/src/wordmap/TimerWheel/Internal/WordMap.hs index 34a5b93..883eac3 100644 --- a/src/wordmap/TimerWheel/Internal/WordMap.hs +++ b/src/wordmap/TimerWheel/Internal/WordMap.hs @@ -20,7 +20,7 @@ where import Data.Bits import Data.Word -import TimerWheel.Internal.Prelude +import Prelude hiding (lookup, null) data WordMap a = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(WordMap1 a) !(WordMap1 a) diff --git a/test/wordmap/Main.hs b/test/wordmap/Main.hs new file mode 100644 index 0000000..2dcf828 --- /dev/null +++ b/test/wordmap/Main.hs @@ -0,0 +1,67 @@ +module Main (main) where + +import Data.Foldable (for_) +import qualified Data.List as List +import qualified Data.Set as Set +import Data.Word +import GHC.Conc (atomically) +import Hedgehog ((===)) +import qualified Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Main as Hedgehog +import qualified Hedgehog.Range as Range +import qualified Ki +import TimerWheel.Internal.WordMap (WordMap) +import qualified TimerWheel.Internal.WordMap as WordMap +import Prelude + +main :: IO () +main = do + Ki.scoped \scope -> do + mainThread <- Ki.fork scope main1 + atomically (Ki.await mainThread) + +main1 :: IO () +main1 = + Hedgehog.defaultMain [Hedgehog.checkParallel (Hedgehog.Group "Wordmap tests" tests)] + +tests :: [(Hedgehog.PropertyName, Hedgehog.Property)] +tests = + [ ( "insert-lookup", + Hedgehog.property do + keys <- Hedgehog.forAll (Gen.list (Range.linear 1 1000) (Gen.word64 Range.linearBounded)) + let m = listToWordMap (map (,()) keys) + for_ keys \key -> + WordMap.lookup key m === Just () + ), + ( "insert-pop", + Hedgehog.property do + keys <- Set.toList <$> Hedgehog.forAll (Gen.set (Range.linear 1 1000) (Gen.word64 Range.linearBounded)) + keys === wordMapKeysList (listToWordMap (map (,()) keys)) + ), + ( "insert-splitL", + Hedgehog.property do + keys <- Hedgehog.forAll (Gen.list (Range.linear 1 1000) (Gen.word64 Range.linearBounded)) + key <- Hedgehog.forAll (Gen.word64 Range.linearBounded) + let WordMap.Pair xs ys = WordMap.splitL key (listToWordMap (map (,()) keys)) + Hedgehog.assert (all (<= key) (wordMapKeysList xs)) + Hedgehog.assert (all (> key) (wordMapKeysList ys)) + ) + ] + +listToWordMap :: [(Word64, a)] -> WordMap a +listToWordMap = + foldr (\(k, v) -> WordMap.insert k v) WordMap.empty + +wordMapKeysList :: WordMap a -> [Word64] +wordMapKeysList = + map fst . wordMapToList + +wordMapToList :: WordMap a -> [(Word64, a)] +wordMapToList = + List.unfoldr + ( \m0 -> + case WordMap.pop m0 of + WordMap.PopNada -> Nothing + WordMap.PopAlgo k v m1 -> Just ((k, v), m1) + ) diff --git a/timer-wheel.cabal b/timer-wheel.cabal index 1ee9be4..098467b 100644 --- a/timer-wheel.cabal +++ b/timer-wheel.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.2 +cabal-version: 3.0 author: Mitchell Rosen bug-reports: https://github.com/awkward-squad/timer-wheel/issues @@ -45,6 +45,7 @@ common component NamedFieldPuns NoImplicitPrelude NumericUnderscores + OverloadedStrings ScopedTypeVariables TupleSections TypeApplications @@ -56,6 +57,10 @@ common component -Wno-implicit-prelude -Wno-missing-import-lists -Wno-unsafe + -- Buggy false-positives on unused-top-binds + if impl(ghc == 8.6.*) || impl(ghc == 8.8.*) + ghc-options: + -Wno-unused-top-binds if impl(ghc >= 8.10) ghc-options: -Wno-missing-safe-haskell-mode @@ -70,15 +75,22 @@ library atomic-primops ^>= 0.8, ki ^>= 1.0.0, primitive ^>= 0.7 || ^>= 0.8, + wordmap, exposed-modules: TimerWheel - hs-source-dirs: src, src/wordmap + hs-source-dirs: src other-modules: TimerWheel.Internal.Counter TimerWheel.Internal.Nanoseconds TimerWheel.Internal.Prelude TimerWheel.Internal.Timestamp + +library wordmap + import: component + exposed-modules: TimerWheel.Internal.WordMap + hs-source-dirs: src/wordmap + visibility: private test-suite timer-wheel-tests import: component @@ -91,6 +103,18 @@ test-suite timer-wheel-tests main-is: Main.hs type: exitcode-stdio-1.0 +test-suite wordmap-tests + import: component + build-depends: + containers ^>= 0.6 || ^>= 0.7, + hedgehog ^>= 1.4, + ki, + wordmap, + ghc-options: -threaded -with-rtsopts=-N2 + hs-source-dirs: test/wordmap + main-is: Main.hs + type: exitcode-stdio-1.0 + benchmark bench import: component build-depends: