psqueues (empty) → 0.1.0.0
raw patch · 19 files changed
+3279/−0 lines, 19 filesdep +HUnitdep +PSQueuedep +QuickChecksetup-changed
Dependencies added: HUnit, PSQueue, QuickCheck, array, base, containers, criterion, deepseq, fingertree-psqueue, ghc-prim, hashable, mtl, psqueues, random, tagged, test-framework, test-framework-hunit, test-framework-quickcheck2, unordered-containers
Files
- LICENSE +31/−0
- Setup.hs +6/−0
- benchmarks/Main.hs +53/−0
- psqueues.cabal +110/−0
- src/Data/BitUtil.hs +66/−0
- src/Data/HashPSQ.hs +50/−0
- src/Data/HashPSQ/Internal.hs +445/−0
- src/Data/IntPSQ.hs +53/−0
- src/Data/IntPSQ/Internal.hs +696/−0
- src/Data/OrdPSQ.hs +61/−0
- src/Data/OrdPSQ/Internal.hs +652/−0
- tests/Data/HashPSQ/Tests.hs +91/−0
- tests/Data/IntPSQ/Tests.hs +116/−0
- tests/Data/OrdPSQ/Tests.hs +89/−0
- tests/Data/PSQ/Class.hs +149/−0
- tests/Data/PSQ/Class/Gen.hs +75/−0
- tests/Data/PSQ/Class/Tests.hs +425/−0
- tests/Data/PSQ/Class/Util.hs +80/−0
- tests/Main.hs +31/−0
+ LICENSE view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ benchmarks/Main.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE BangPatterns #-}+module Main where++import Criterion.Main+import System.Random++import BenchmarkTypes++import qualified Data.OrdPSQ.Benchmark as OrdPSQ+import qualified Data.IntPSQ.Benchmark as IntPSQ+import qualified Data.HashPSQ.Benchmark as HashPSQ+import qualified Data.PSQueue.Benchmark as PSQueue+import qualified Data.FingerTree.PSQueue.Benchmark as FingerPSQ++benchmarkSize :: Int+benchmarkSize = 2 ^ (12 :: Int)++{-# NOINLINE increasing #-}+increasing :: [BElem]+increasing = [(n, n, ()) | n <- [1 .. benchmarkSize]]++{-# NOINLINE decreasing #-}+decreasing :: [BElem]+decreasing = reverse increasing++{-# NOINLINE semirandom #-}+semirandom :: [BElem]+semirandom =+ [ (x, y, ())+ | (_, x, y) <- zip3 [1 .. benchmarkSize] (randoms gen1) (randoms gen2)+ ]+ where+ gen1 = mkStdGen 1234+ gen2 = mkStdGen 5678++main :: IO ()+main = defaultMain $ runBenchmark+ [ IntPSQ.benchmark "IntPSQ increasing" increasing+ , IntPSQ.benchmark "IntPSQ decreasing" decreasing+ , IntPSQ.benchmark "IntPSQ semirandom" semirandom+ , HashPSQ.benchmark "HashPSQ increasing" increasing+ , HashPSQ.benchmark "HashPSQ decreasing" decreasing+ , HashPSQ.benchmark "HashPSQ semirandom" semirandom+ , OrdPSQ.benchmark "OrdPSQ increasing" increasing+ , OrdPSQ.benchmark "OrdPSQ decreasing" decreasing+ , OrdPSQ.benchmark "OrdPSQ semirandom" semirandom+ , PSQueue.benchmark "PSQueue increasing" increasing+ , PSQueue.benchmark "PSQueue decreasing" decreasing+ , PSQueue.benchmark "PSQueue semirandom" semirandom+ , FingerPSQ.benchmark "FingerTree PSQueue increasing" increasing+ , FingerPSQ.benchmark "FingerTree PSQueue decreasing" decreasing+ , FingerPSQ.benchmark "FingerTree PSQueue semirandom" semirandom+ ]
+ psqueues.cabal view
@@ -0,0 +1,110 @@+name: psqueues+version: 0.1.0.0+license: BSD3+license-file: LICENSE+maintainer: haskell@better.com+bug-reports: https://github.com/bttr/psqueues/issues+synopsis: Pure priority search queues+category: Data Structures+description:+ A priority search queue manages a set of triples of the form+ @(key, priority, value)@ and allows for efficient lookup by key, and+ efficient lookup and removal of the element with minimal priority. This+ package contains three, performant implementations of priority search+ queues, which differ in the requirements on the type of keys.+ .+ * 'IntPSQ's are the most efficient structure, but require the keys to be+ of type 'Int'.+ .+ * 'OrdPSQ's just require the key to implement the `Ord` typeclass, but are+ the slowest structures of the three.+ .+ * 'HashPSQ's require the key to implement both the 'Ord' and 'Hashable'+ typeclasses. They use an 'IntMap' over the hash of the keys combined+ with a 'OrdPSQ' to manage collisions. Except for keys with a very fast+ comparison and small smaps 'HashPSQ's are faster than 'OrdPSQ's.+ .+ Typical use cases for priority search queues are LRU caches, where the+ priority is the time of the last access, and timeout management, where the+ priority is the time at which the timeout should trigger.+build-type: Simple+cabal-version: >=1.8+extra-source-files:++source-repository head+ type: git+ location: http://github.com/bttr/psqueues.git++Library+ ghc-options: -O2 -Wall+ hs-source-dirs: src++ build-depends:+ base >= 4.2 && < 5+ , deepseq >= 1.2 && < 1.4+ , hashable >= 1.2.1 && < 1.3++ if impl(ghc>=6.10)+ build-depends: ghc-prim++ exposed-modules:+ Data.HashPSQ+ Data.IntPSQ+ Data.OrdPSQ+ other-modules:+ Data.BitUtil+ Data.HashPSQ.Internal+ Data.IntPSQ.Internal+ Data.OrdPSQ.Internal++benchmark psqueues-benchmarks+ type: exitcode-stdio-1.0+ hs-source-dirs: src benchmarks+ main-is: Main.hs+ ghc-options: -Wall++ build-depends:+ containers >= 0.5+ , unordered-containers >= 0.2.4+ , criterion >= 0.8+ , mtl >= 2.1+ , fingertree-psqueue >= 0.3+ , PSQueue >= 1.1+ , random >= 1.0++ , base+ , deepseq+ , ghc-prim+ , hashable+ , psqueues++Test-suite psqueues-tests+ cpp-options: -DTESTING -DSTRICT+ ghc-options: -Wall+ hs-source-dirs: src tests+ main-is: Main.hs+ type: exitcode-stdio-1.0++ other-modules:+ Data.PSQ.Class+ Data.PSQ.Class.Gen+ Data.PSQ.Class.Tests+ Data.PSQ.Class.Util+ Data.HashPSQ.Tests+ Data.IntPSQ.Tests+ Data.OrdPSQ.Tests++ build-depends:+ HUnit >= 1.2 && < 1.3+ , QuickCheck >= 2.7 && < 2.8+ , test-framework >= 0.8 && < 0.9+ , test-framework-hunit >= 0.3 && < 0.4+ , test-framework-quickcheck2 >= 0.3 && < 0.4++ , base+ , array+ , deepseq+ , ghc-prim+ , hashable+ , psqueues+ , tagged
+ src/Data/BitUtil.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+#endif+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.BitUtil+-- Copyright : (c) Clark Gaebel 2012+-- (c) Johan Tibel 2012+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+-----------------------------------------------------------------------------++module Data.BitUtil+ ( highestBitMask+ ) where++-- On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+#if defined(__GLASGOW_HASKELL__)+# include "MachDeps.h"+#endif++import Data.Bits ((.|.), xor)++#if __GLASGOW_HASKELL__+import GHC.Exts (Word(..), Int(..))+import GHC.Prim (uncheckedShiftRL#)+#else+import Data.Word (shiftL, shiftR)+#endif++-- The highestBitMask implementation is based on+-- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2+-- which has been put in the public domain.++-- | Return a word where only the highest bit is set.+highestBitMask :: Word -> Word+highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1+ x3 = x2 .|. x2 `shiftRL` 2+ x4 = x3 .|. x3 `shiftRL` 4+ x5 = x4 .|. x4 `shiftRL` 8+ x6 = x5 .|. x5 `shiftRL` 16+#if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32)+ x7 = x6 .|. x6 `shiftRL` 32+ in x7 `xor` (x7 `shiftRL` 1)+#else+ in x6 `xor` (x6 `shiftRL` 1)+#endif+{-# INLINE highestBitMask #-}++-- Right and left logical shifts.+shiftRL :: Word -> Int -> Word+#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+ GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i)+#else+shiftRL x i = shiftR x i+#endif+{-# INLINE shiftRL #-}
+ src/Data/HashPSQ.hs view
@@ -0,0 +1,50 @@+-- | A 'HashPSQ' offers very similar performance to 'IntPSQ'. In case of+-- collisions, it uses an 'OrdPSQ' locally to solve those.+--+-- This means worst case complexity is usually given by /O(min(n,W), log n)/,+-- where /W/ is the number of bits in an 'Int'. This simplifies to /O(min(n,W))/+-- since /log n/ is always smaller than /W/ on current machines.+module Data.HashPSQ+ ( -- * Type+ HashPSQ++ -- * Query+ , null+ , size+ , member+ , lookup+ , findMin++ -- * Construction+ , empty+ , singleton++ -- * Insertion+ , insert++ -- * Delete/update+ , delete+ , alter+ , alterMin++ -- * Lists+ , fromList+ , toList+ , keys++ -- * Views+ , insertView+ , deleteView+ , minView++ -- * Traversal+ , map+ , fold'++ -- * Validity check+ , valid+ ) where++import Prelude hiding (foldr, lookup, map, null)++import Data.HashPSQ.Internal
+ src/Data/HashPSQ/Internal.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.HashPSQ.Internal+ ( -- * Type+ Bucket (..)+ , mkBucket+ , HashPSQ (..)++ -- * Query+ , null+ , size+ , member+ , lookup+ , findMin++ -- * Construction+ , empty+ , singleton++ -- * Insertion+ , insert++ -- * Delete/update+ , delete+ , alter+ , alterMin++ -- * Lists+ , fromList+ , toList+ , keys++ -- * Views+ , insertView+ , deleteView+ , minView++ -- * Traversal+ , map+ , fold'++ -- * Unsafe operations+ , unsafeLookupIncreasePriority+ , unsafeInsertIncreasePriority+ , unsafeInsertIncreasePriorityView++ -- * Validity check+ , valid+ ) where++import Control.DeepSeq (NFData (..))+import Data.Foldable (Foldable (foldr))+import Data.Hashable+import Data.Maybe (isJust)+import Prelude hiding (foldr, lookup, map, null)+import qualified Data.List as List++import qualified Data.IntPSQ.Internal as IntPSQ+import qualified Data.OrdPSQ as OrdPSQ++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++data Bucket k p v = B !k !v !(OrdPSQ.OrdPSQ k p v)+ deriving (Show)++-- | Smart constructor which takes care of placing the minimum element directly+-- in the 'Bucket'.+{-# INLINABLE mkBucket #-}+mkBucket+ :: (Ord k, Ord p)+ => k -> p -> v -> OrdPSQ.OrdPSQ k p v -> (p, Bucket k p v)+mkBucket k p x opsq =+ -- TODO (jaspervdj): We could do an 'unsafeInsertNew' here for all call+ -- sites.+ case toBucket (OrdPSQ.insert k p x opsq) of+ Just bucket -> bucket+ Nothing -> error $ "mkBucket: internal error"++toBucket :: (Ord k, Ord p) => OrdPSQ.OrdPSQ k p v -> Maybe (p, Bucket k p v)+toBucket opsq = case OrdPSQ.minView opsq of+ Just (k, p, x, opsq') -> Just (p, B k x opsq')+ Nothing -> Nothing++instance (NFData k, NFData p, NFData v) => NFData (Bucket k p v) where+ rnf (B k v x) = rnf k `seq` rnf v `seq` rnf x++-- | A priority search queue with keys of type @k@ and priorities of type @p@+-- and values of type @v@. It is strict in keys, priorities and values.+newtype HashPSQ k p v = HashPSQ (IntPSQ.IntPSQ p (Bucket k p v))+ deriving (NFData, Show)++instance (Eq k, Eq p, Eq v, Hashable k, Ord k, Ord p) =>+ Eq (HashPSQ k p v) where+ x == y = case (minView x, minView y) of+ (Nothing , Nothing ) -> True+ (Just (xk, xp, xv, x'), (Just (yk, yp, yv, y'))) ->+ xk == yk && xp == yp && xv == yv && x' == y'+ (Just _ , Nothing ) -> False+ (Nothing , Just _ ) -> False++instance Foldable (HashPSQ k p) where+ foldr f z0 (HashPSQ ipsq) =+ foldr f' z0 ipsq+ where+ f' (B _ x opsq) z = f x (foldr f z opsq)++instance Functor (HashPSQ k p) where+ fmap f = map (\_ _ v -> f v)+++------------------------------------------------------------------------------+-- Query+------------------------------------------------------------------------------++-- | /O(1)/ True if the queue is empty.+{-# INLINABLE null #-}+null :: HashPSQ k p v -> Bool+null (HashPSQ ipsq) = IntPSQ.null ipsq++-- | /O(n)/ The number of elements stored in the PSQ.+{-# INLINABLE size #-}+size :: (Hashable k, Ord p) => HashPSQ k p v -> Int+size (HashPSQ ipsq) = IntPSQ.fold'+ (\_ _ (B _ _ opsq) acc -> 1 + OrdPSQ.size opsq + acc)+ 0+ ipsq++-- | /O(min(n,W))/ Check if a key is present in the the queue.+{-# INLINABLE member #-}+member :: (Hashable k, Ord k, Ord p) => k -> HashPSQ k p v -> Bool+member k = isJust . lookup k++-- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the+-- key is not bound.+{-# INLINABLE lookup #-}+lookup :: (Ord k, Hashable k, Ord p) => k -> HashPSQ k p v -> Maybe (p, v)+lookup k (HashPSQ ipsq) = do+ (p0, B k0 v0 os) <- IntPSQ.lookup (hash k) ipsq+ if k0 == k+ then return (p0, v0)+ else OrdPSQ.lookup k os++-- | /O(1)/ The element with the lowest priority.+findMin :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> Maybe (k, p, v)+findMin (HashPSQ ipsq) = case IntPSQ.findMin ipsq of+ Nothing -> Nothing+ Just (_, p, B k x _) -> Just (k, p, x)+++--------------------------------------------------------------------------------+-- Construction+--------------------------------------------------------------------------------++-- | /O(1)/ The empty queue.+empty :: HashPSQ k p v+empty = HashPSQ IntPSQ.empty++-- | /O(1)/ Build a queue with one element.+singleton :: (Hashable k, Ord k, Ord p) => k -> p -> v -> HashPSQ k p v+singleton k p v = insert k p v empty+++--------------------------------------------------------------------------------+-- Insertion+--------------------------------------------------------------------------------++-- | /O(min(n,W))/ Insert a new key, priority and value in the queue. If the key+-- is already present in the queue, the associated priority and value are+-- replaced with the supplied priority and value.+{-# INLINABLE insert #-}+insert+ :: (Ord k, Hashable k, Ord p)+ => k -> p -> v -> HashPSQ k p v -> HashPSQ k p v+insert k p v (HashPSQ ipsq) =+ case IntPSQ.alter (\x -> ((), ins x)) (hash k) ipsq of+ ((), ipsq') -> HashPSQ ipsq'+ where+ ins Nothing = Just (p, B k v (OrdPSQ.empty))+ ins (Just (p', B k' v' os))+ | k' == k =+ -- Tricky: p might have less priority than an item in 'os'.+ Just (mkBucket k p v os)+ | p' < p || (p == p' && k' < k) =+ Just (p', B k' v' (OrdPSQ.insert k p v os))+ | OrdPSQ.member k os =+ -- This is a bit tricky: k might already be present in 'os' and we+ -- don't want to end up with duplicate keys.+ Just (p, B k v (OrdPSQ.insert k' p' v' (OrdPSQ.delete k os)))+ | otherwise =+ Just (p , B k v (OrdPSQ.insert k' p' v' os))+++--------------------------------------------------------------------------------+-- Delete/update+--------------------------------------------------------------------------------++-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When+-- the key is not a member of the queue, the original queue is returned.+{-# INLINE delete #-}+delete+ :: (Hashable k, Ord k, Ord p) => k -> HashPSQ k p v -> HashPSQ k p v+delete k t = case deleteView k t of+ Nothing -> t+ Just (_, _, t') -> t'++-- | /O(min(n,W))/ The expression @alter f k map@ alters the value @x@ at @k@,+-- or absence thereof. 'alter' can be used to insert, delete, or update a value+-- in a queue. It also allows you to calculate an additional value @b@.+{-# INLINABLE alter #-}+alter :: (Hashable k, Ord k, Ord p)+ => (Maybe (p, v) -> (b, Maybe (p, v)))+ -> k -> HashPSQ k p v -> (b, HashPSQ k p v)+alter f k (HashPSQ ipsq) = case IntPSQ.deleteView h ipsq of+ Nothing -> case f Nothing of+ (b, Nothing) -> (b, HashPSQ ipsq)+ (b, Just (p, x)) ->+ (b, HashPSQ $ IntPSQ.unsafeInsertNew h p (B k x OrdPSQ.empty) ipsq)+ Just (bp, B bk bx opsq, ipsq')+ | k == bk -> case f (Just (bp, bx)) of+ (b, Nothing) -> case toBucket opsq of+ Nothing -> (b, HashPSQ ipsq')+ Just (bp', bucket') ->+ (b, HashPSQ $ IntPSQ.unsafeInsertNew h bp' bucket' ipsq')+ (b, Just (p, x)) -> case mkBucket k p x opsq of+ (bp', bucket') ->+ (b, HashPSQ $ IntPSQ.unsafeInsertNew h bp' bucket' ipsq')+ | otherwise -> case OrdPSQ.alter f k opsq of+ (b, opsq') -> case mkBucket bk bp bx opsq' of+ (bp', bucket') ->+ (b, HashPSQ $ IntPSQ.unsafeInsertNew h bp' bucket' ipsq')+ where+ h = hash k++-- | /O(min(n,W))/ A variant of 'alter' which works on the element with the+-- minimum priority. Unlike 'alter', this variant also allows you to change the+-- key of the element.+{-# INLINABLE alterMin #-}+alterMin+ :: (Hashable k, Ord k, Ord p)+ => (Maybe (k, p, v) -> (b, Maybe (k, p, v)))+ -> HashPSQ k p v+ -> (b, HashPSQ k p v)+alterMin f t0 =+ let (t, mbX) = case minView t0 of+ Nothing -> (t0, Nothing)+ Just (k, p, x, t0') -> (t0', Just (k, p, x))+ in case f mbX of+ (b, mbX') ->+ (b, maybe t (\(k, p, x) -> insert k p x t) mbX')+++--------------------------------------------------------------------------------+-- Lists+--------------------------------------------------------------------------------++-- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples.+-- If the list contains more than one priority and value for the same key, the+-- last priority and value for the key is retained.+{-# INLINABLE fromList #-}+fromList :: (Hashable k, Ord k, Ord p) => [(k, p, v)] -> HashPSQ k p v+fromList = List.foldl' (\psq (k, p, x) -> insert k p x psq) empty++-- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The+-- order of the list is not specified.+{-# INLINABLE toList #-}+toList :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> [(k, p, v)]+toList (HashPSQ ipsq) =+ [ (k', p', x')+ | (_, p, (B k x opsq)) <- IntPSQ.toList ipsq+ , (k', p', x') <- (k, p, x) : OrdPSQ.toList opsq+ ]++-- | /O(n)/ Obtain the list of present keys in the queue.+{-# INLINABLE keys #-}+keys :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> [k]+keys t = [k | (k, _, _) <- toList t]+++--------------------------------------------------------------------------------+-- Views+--------------------------------------------------------------------------------++-- | /O(min(n,W))/ Insert a new key, priority and value in the queue. If the key+-- is already present in the queue, then the evicted priority and value can be+-- found the first element of the returned tuple.+{-# INLINABLE insertView #-}+insertView+ :: (Hashable k, Ord k, Ord p)+ => k -> p -> v -> HashPSQ k p v -> (Maybe (p, v), HashPSQ k p v)+insertView k p x t =+ -- TODO (jaspervdj): Can be optimized easily+ case deleteView k t of+ Nothing -> (Nothing, insert k p x t)+ Just (p', x', _) -> (Just (p', x'), insert k p x t)++-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If+-- the key was present, the associated priority and value are returned in+-- addition to the updated queue.+{-# INLINABLE deleteView #-}+deleteView+ :: forall k p v. (Hashable k, Ord k, Ord p)+ => k -> HashPSQ k p v -> Maybe (p, v, HashPSQ k p v)+deleteView k (HashPSQ ipsq) = case IntPSQ.alter f (hash k) ipsq of+ (Nothing, _ ) -> Nothing+ (Just (p, x), ipsq') -> Just (p, x, HashPSQ ipsq')+ where+ f :: Maybe (p, Bucket k p v) -> (Maybe (p, v), Maybe (p, Bucket k p v))+ f Nothing = (Nothing, Nothing)+ f (Just (p, B bk bx opsq))+ | k == bk = case OrdPSQ.minView opsq of+ Nothing -> (Just (p, bx), Nothing)+ Just (k', p', x', opsq') -> (Just (p, bx), Just (p', B k' x' opsq'))+ | otherwise = case OrdPSQ.deleteView k opsq of+ Nothing -> (Nothing, Nothing)+ Just (p', x', opsq') -> (Just (p', x'), Just (p, B bk bx opsq'))++-- | /O(min(n,W))/ Retrieve the binding with the least priority, and the+-- rest of the queue stripped of that binding.+{-# INLINABLE minView #-}+minView+ :: (Hashable k, Ord k, Ord p)+ => HashPSQ k p v -> Maybe (k, p, v, HashPSQ k p v)+minView (HashPSQ ipsq ) =+ case IntPSQ.alterMin f ipsq of+ (Nothing , _ ) -> Nothing+ (Just (k, p, x), ipsq') -> Just (k, p, x, HashPSQ ipsq')+ where+ f Nothing = (Nothing, Nothing)+ f (Just (h, p, B k x os)) = case OrdPSQ.minView os of+ Nothing ->+ (Just (k, p, x), Nothing)+ Just (k', p', x', os') ->+ (Just (k, p, x), Just (h, p', B k' x' os'))+++--------------------------------------------------------------------------------+-- Traversals+--------------------------------------------------------------------------------++-- | /O(n)/ Modify every value in the queueu.+{-# INLINABLE map #-}+map :: (k -> p -> v -> w) -> HashPSQ k p v -> HashPSQ k p w+map f (HashPSQ ipsq) = HashPSQ (IntPSQ.map (\_ p v -> mapBucket p v) ipsq)+ where+ mapBucket p (B k v opsq) = B k (f k p v) (OrdPSQ.map f opsq)++-- | /O(n)/ Strict fold over every key, priority and value in the map. The order+-- in which the fold is performed is not specified.+{-# INLINABLE fold' #-}+fold' :: (k -> p -> v -> a -> a) -> a -> HashPSQ k p v -> a+fold' f acc0 (HashPSQ ipsq) = IntPSQ.fold' goBucket acc0 ipsq+ where+ goBucket _ p (B k v opsq) acc =+ let !acc1 = f k p v acc+ !acc2 = OrdPSQ.fold' f acc1 opsq+ in acc2+++--------------------------------------------------------------------------------+-- Unsafe operations+--------------------------------------------------------------------------------++{-# INLINABLE unsafeLookupIncreasePriority #-}+unsafeLookupIncreasePriority+ :: (Hashable k, Ord k, Ord p)+ => k -> p -> HashPSQ k p v -> (Maybe (p, v), HashPSQ k p v)+unsafeLookupIncreasePriority k p (HashPSQ ipsq) =+ (mbPV, HashPSQ ipsq')+ where+ (!mbPV, !ipsq') = IntPSQ.unsafeLookupIncreasePriority+ (\bp b@(B bk bx opsq) ->+ if k == bk+ then let (bp', b') = mkBucket k p bx opsq+ in (Just (bp, bx), bp', b')+ -- TODO (jaspervdj): Still a lookup-insert here: 3 traversals?+ else case OrdPSQ.lookup k opsq of+ Nothing -> (Nothing, bp, b)+ Just (p', x) ->+ let b' = B bk bx (OrdPSQ.insert k p x opsq)+ in (Just (p', x), bp, b'))+ (hash k)+ ipsq++{-# INLINABLE unsafeInsertIncreasePriority #-}+unsafeInsertIncreasePriority+ :: (Hashable k, Ord k, Ord p)+ => k -> p -> v -> HashPSQ k p v -> HashPSQ k p v+unsafeInsertIncreasePriority k p x (HashPSQ ipsq) = HashPSQ $+ IntPSQ.unsafeInsertWithIncreasePriority+ (\_ _ bp (B bk bx opsq) ->+ if k == bk+ then mkBucket k p x opsq+ else (bp, B bk bx (OrdPSQ.insert k p x opsq)))+ (hash k)+ p+ (B k x OrdPSQ.empty)+ ipsq++{-# INLINABLE unsafeInsertIncreasePriorityView #-}+unsafeInsertIncreasePriorityView+ :: (Hashable k, Ord k, Ord p)+ => k -> p -> v -> HashPSQ k p v -> (Maybe (p, v), HashPSQ k p v)+unsafeInsertIncreasePriorityView k p x (HashPSQ ipsq) =+ (mbEvicted, HashPSQ ipsq')+ where+ (mbBucket, ipsq') = IntPSQ.unsafeInsertWithIncreasePriorityView+ (\_ _ bp (B bk bx opsq) ->+ if k == bk+ then mkBucket k p x opsq+ else (bp, B bk bx (OrdPSQ.insert k p x opsq)))+ (hash k)+ p+ (B k x OrdPSQ.empty)+ ipsq++ mbEvicted = case mbBucket of+ Nothing -> Nothing+ Just (bp, B bk bv opsq)+ | k == bk -> Just (bp, bv)+ | otherwise -> OrdPSQ.lookup k opsq+++--------------------------------------------------------------------------------+-- Validity check+--------------------------------------------------------------------------------++-- | /O(n^2)/ Internal function to check if the 'OrdPSQ' is valid, i.e. if all+-- invariants hold. This should always be the case.+valid :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> Bool+valid t@(HashPSQ ipsq) =+ not (hasDuplicateKeys t) &&+ and [validBucket k p bucket | (k, p, bucket) <- IntPSQ.toList ipsq]++hasDuplicateKeys :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> Bool+hasDuplicateKeys = any (> 1) . List.map length . List.group . List.sort . keys++validBucket :: (Hashable k, Ord k, Ord p) => Int -> p -> Bucket k p v -> Bool+validBucket h p (B k _ opsq) =+ OrdPSQ.valid opsq &&+ -- Check that the first element of the bucket has lower priority than all+ -- the other elements.+ and [(p, k) < (p', k') && hash k' == h | (k', p', _) <- OrdPSQ.toList opsq]
+ src/Data/IntPSQ.hs view
@@ -0,0 +1,53 @@+-- | 'IntPSQ' fixes the key type to 'Int'. It is generally much faster than+-- an 'OrdPSQ'.+--+-- Many operations have a worst-case complexity of O(min(n,W)). This means that+-- the operation can -- become linear in the number of elements with a maximum+-- of W -- the number of bits in an Int (32 or 64).+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UnboxedTuples #-}+module Data.IntPSQ+ ( -- * Type+ IntPSQ++ -- * Query+ , null+ , size+ , member+ , lookup+ , findMin++ -- * Construction+ , empty+ , singleton++ -- * Insertion+ , insert++ -- * Delete/update+ , delete+ , alter+ , alterMin++ -- * Lists+ , fromList+ , toList+ , keys++ -- * Views+ , insertView+ , deleteView+ , minView++ -- * Traversal+ , map+ , fold'++ -- * Validity check+ , valid+ ) where++import Prelude hiding (lookup, map, filter, foldr, foldl, null)++import Data.IntPSQ.Internal
+ src/Data/IntPSQ/Internal.hs view
@@ -0,0 +1,696 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnboxedTuples #-}+module Data.IntPSQ.Internal+ ( -- * Type+ Nat+ , Key+ , Mask+ , IntPSQ (..)++ -- * Query+ , null+ , size+ , member+ , lookup+ , findMin++ -- * Construction+ , empty+ , singleton++ -- * Insertion+ , insert++ -- * Delete/update+ , delete+ , alter+ , alterMin++ -- * Lists+ , fromList+ , toList+ , keys++ -- * Views+ , insertView+ , deleteView+ , minView++ -- * Traversal+ , map+ , fold'++ -- * Unsafe manipulation+ , unsafeInsertNew+ , unsafeInsertIncreasePriority+ , unsafeInsertIncreasePriorityView+ , unsafeInsertWithIncreasePriority+ , unsafeInsertWithIncreasePriorityView+ , unsafeLookupIncreasePriority++ -- * Testing+ , valid+ , hasBadNils+ , hasDuplicateKeys+ , hasMinHeapProperty+ , validMask+ ) where++import Control.DeepSeq (NFData(rnf))+import Control.Applicative ((<$>), (<*>))++import Data.BitUtil+import Data.Bits+import Data.List (foldl')+import Data.Maybe (isJust)+import Data.Word (Word)+import Data.Foldable (Foldable (foldr))++import qualified Data.List as List++import Prelude hiding (lookup, map, filter, foldr, foldl, null)++-- TODO (SM): get rid of bang patterns++{-+-- Use macros to define strictness of functions.+-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.+-- We do not use BangPatterns, because they are not in any standard and we+-- want the compilers to be compiled by as many compilers as possible.+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined+-}+++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word++type Key = Int++-- | We store masks as the index of the bit that determines the branching.+type Mask = Int++-- | A priority search queue with @Int@ keys and priorities of type @p@ and+-- values of type @v@. It is strict in keys, priorities and values.+data IntPSQ p v+ = Bin {-# UNPACK #-} !Key !p !v {-# UNPACK #-} !Mask !(IntPSQ p v) !(IntPSQ p v)+ | Tip {-# UNPACK #-} !Key !p !v+ | Nil+ deriving (Show)++instance (NFData p, NFData v) => NFData (IntPSQ p v) where+ rnf (Bin _k p v _m l r) = rnf p `seq` rnf v `seq` rnf l `seq` rnf r+ rnf (Tip _k p v) = rnf p `seq` rnf v+ rnf Nil = ()++instance (Ord p, Eq v) => Eq (IntPSQ p v) where+ x == y = case (minView x, minView y) of+ (Nothing , Nothing ) -> True+ (Just (xk, xp, xv, x'), (Just (yk, yp, yv, y'))) ->+ xk == yk && xp == yp && xv == yv && x' == y'+ (Just _ , Nothing ) -> False+ (Nothing , Just _ ) -> False++instance Foldable (IntPSQ p) where+ foldr _ z Nil = z+ foldr f z (Tip _ _ v) = f v z+ foldr f z (Bin _ _ v _ l r) = f v z''+ where+ z' = foldr f z l+ z'' = foldr f z' r++instance Functor (IntPSQ p) where+ fmap f = map (\_ _ v -> f v)+++-- bit twiddling+----------------++{-# INLINE natFromInt #-}+natFromInt :: Key -> Nat+natFromInt = fromIntegral++{-# INLINE intFromNat #-}+intFromNat :: Nat -> Key+intFromNat = fromIntegral++{-# INLINE zero #-}+zero :: Key -> Mask -> Bool+zero i m+ = (natFromInt i) .&. (natFromInt m) == 0++{-# INLINE nomatch #-}+nomatch :: Key -> Key -> Mask -> Bool+nomatch k1 k2 m =+ natFromInt k1 .&. m' /= natFromInt k2 .&. m'+ where+ m' = maskW (natFromInt m)++{-# INLINE maskW #-}+maskW :: Nat -> Nat+maskW m = complement (m-1) `xor` m++{-# INLINE branchMask #-}+branchMask :: Key -> Key -> Mask+branchMask k1 k2 =+ intFromNat (highestBitMask (natFromInt k1 `xor` natFromInt k2))+++------------------------------------------------------------------------------+-- Query+------------------------------------------------------------------------------++-- | /O(1)/ True if the queue is empty.+null :: IntPSQ p v -> Bool+null Nil = True+null _ = False++-- | /O(n)/ The number of elements stored in the PSQ.+size :: IntPSQ p v -> Int+size Nil = 0+size (Tip _ _ _) = 1+size (Bin _ _ _ _ l r) = 1 + size l + size r+-- TODO (SM): benchmark this against a tail-recursive variant++-- | /O(min(n,W))/ Check if a key is present in the the queue.+member :: Int -> IntPSQ p v -> Bool+member k = isJust . lookup k++-- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the+-- key is not bound.+lookup :: Int -> IntPSQ p v -> Maybe (p, v)+lookup k = go+ where+ go t = case t of+ Nil -> Nothing++ Tip k' p' x'+ | k == k' -> Just (p', x')+ | otherwise -> Nothing++ Bin k' p' x' m l r+ | nomatch k k' m -> Nothing+ | k == k' -> Just (p', x')+ | zero k m -> go l+ | otherwise -> go r++-- | /O(1)/ The element with the lowest priority.+findMin :: Ord p => IntPSQ p v -> Maybe (Int, p, v)+findMin t = case t of+ Nil -> Nothing+ Tip k p x -> Just (k, p, x)+ Bin k p x _ _ _ -> Just (k, p, x)+++------------------------------------------------------------------------------+--- Construction+------------------------------------------------------------------------------++-- | /O(1)/ The empty queue.+empty :: IntPSQ p v+empty = Nil++-- | /O(1)/ Build a queue with one element.+singleton :: Ord p => Int -> p -> v -> IntPSQ p v+singleton = Tip+++------------------------------------------------------------------------------+-- Insertion+------------------------------------------------------------------------------++-- | /O(min(n,W))/ Insert a new key, priority and value in the queue. If the key+-- is already present in the queue, the associated priority and value are+-- replaced with the supplied priority and value.+insert :: Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v+insert k p x t0 = unsafeInsertNew k p x (delete k t0)++-- | Internal function to insert a key that is *not* present in the priority+-- queue.+{-# INLINABLE unsafeInsertNew #-}+unsafeInsertNew :: Ord p => Key -> p -> v -> IntPSQ p v -> IntPSQ p v+unsafeInsertNew k p x = go+ where+ go t = case t of+ Nil -> Tip k p x++ Tip k' p' x'+ | (p, k) < (p', k') -> link k p x k' t Nil+ | otherwise -> link k' p' x' k (Tip k p x) Nil++ Bin k' p' x' m l r+ | nomatch k k' m ->+ if (p, k) < (p', k')+ then link k p x k' t Nil+ else link k' p' x' k (Tip k p x) (merge m l r)++ | otherwise ->+ if (p, k) < (p', k')+ then+ if zero k' m+ then Bin k p x m (unsafeInsertNew k' p' x' l) r+ else Bin k p x m l (unsafeInsertNew k' p' x' r)+ else+ if zero k m+ then Bin k' p' x' m (unsafeInsertNew k p x l) r+ else Bin k' p' x' m l (unsafeInsertNew k p x r)++-- | Link+link :: Key -> p -> v -> Key -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v+link k p x k' k't otherTree+ | zero m k' = Bin k p x m k't otherTree+ | otherwise = Bin k p x m otherTree k't+ where+ m = branchMask k k'+++------------------------------------------------------------------------------+-- Delete/Alter+------------------------------------------------------------------------------++-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When+-- the key is not a member of the queue, the original queue is returned.+{-# INLINABLE delete #-}+delete :: Ord p => Int -> IntPSQ p v -> IntPSQ p v+delete k = go+ where+ go t = case t of+ Nil -> Nil++ Tip k' _ _+ | k == k' -> Nil+ | otherwise -> t++ Bin k' p' x' m l r+ | nomatch k k' m -> t+ | k == k' -> merge m l r+ | zero k m -> binShrinkL k' p' x' m (go l) r+ | otherwise -> binShrinkR k' p' x' m l (go r)++-- | /O(min(n,W))/ The expression @alter f k map@ alters the value @x@ at @k@,+-- or absence thereof. 'alter' can be used to insert, delete, or update a value+-- in a queue. It also allows you to calculate an additional value @b@.+{-# INLINE alter #-}+alter+ :: Ord p+ => (Maybe (p, v) -> (b, Maybe (p, v)))+ -> Int+ -> IntPSQ p v+ -> (b, IntPSQ p v)+alter f = \k t0 ->+ let (t, mbX) = case deleteView k t0 of+ Nothing -> (t0, Nothing)+ Just (p, v, t0') -> (t0', Just (p, v))+ in case f mbX of+ (b, mbX') ->+ (b, maybe t (\(p, v) -> unsafeInsertNew k p v t) mbX')++-- | /O(min(n,W))/ A variant of 'alter' which works on the element with the+-- minimum priority. Unlike 'alter', this variant also allows you to change the+-- key of the element.+{-# INLINE alterMin #-}+alterMin :: Ord p+ => (Maybe (Int, p, v) -> (b, Maybe (Int, p, v)))+ -> IntPSQ p v+ -> (b, IntPSQ p v)+alterMin f t = case t of+ Nil -> case f Nothing of+ (b, Nothing) -> (b, Nil)+ (b, Just (k', p', x')) -> (b, Tip k' p' x')++ Tip k p x -> case f (Just (k, p, x)) of+ (b, Nothing) -> (b, Nil)+ (b, Just (k', p', x')) -> (b, Tip k' p' x')++ Bin k p x m l r -> case f (Just (k, p, x)) of+ (b, Nothing) -> (b, merge m l r)+ (b, Just (k', p', x'))+ | k /= k' -> (b, insert k' p' x' (merge m l r))+ | p' <= p -> (b, Bin k p' x' m l r)+ | otherwise -> (b, unsafeInsertNew k p' x' (merge m l r))++-- | Smart constructor for a 'Bin' node whose left subtree could have become+-- 'Nil'.+{-# INLINE binShrinkL #-}+binShrinkL :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v+binShrinkL k p x m Nil r = case r of Nil -> Tip k p x; _ -> Bin k p x m Nil r+binShrinkL k p x m l r = Bin k p x m l r++-- | Smart constructor for a 'Bin' node whose right subtree could have become+-- 'Nil'.+{-# INLINE binShrinkR #-}+binShrinkR :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v+binShrinkR k p x m l Nil = case l of Nil -> Tip k p x; _ -> Bin k p x m l Nil+binShrinkR k p x m l r = Bin k p x m l r+++------------------------------------------------------------------------------+-- Lists+------------------------------------------------------------------------------++-- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples.+-- If the list contains more than one priority and value for the same key, the+-- last priority and value for the key is retained.+{-# INLINABLE fromList #-}+fromList :: Ord p => [(Int, p, v)] -> IntPSQ p v+fromList = foldl' (\im (k, p, x) -> insert k p x im) empty++-- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The+-- order of the list is not specified.+toList :: IntPSQ p v -> [(Int, p, v)]+toList =+ go []+ where+ go acc Nil = acc+ go acc (Tip k' p' x') = (k', p', x') : acc+ go acc (Bin k' p' x' _m l r) = (k', p', x') : go (go acc r) l++-- | /O(n)/ Obtain the list of present keys in the queue.+keys :: IntPSQ p v -> [Int]+keys t = [k | (k, _, _) <- toList t]+-- TODO (jaspervdj): More efficient implementations possible+++------------------------------------------------------------------------------+-- Views+------------------------------------------------------------------------------++-- | /O(min(n,W))/ Insert a new key, priority and value in the queue. If the key+-- is already present in the queue, then the evicted priority and value can be+-- found the first element of the returned tuple.+insertView :: Ord p => Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)+insertView k p x t0 = case deleteView k t0 of+ Nothing -> (Nothing, unsafeInsertNew k p x t0)+ Just (p', v', t) -> (Just (p', v'), unsafeInsertNew k p x t)++-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If+-- the key was present, the associated priority and value are returned in+-- addition to the updated queue.+{-# INLINABLE deleteView #-}+deleteView :: Ord p => Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v)+deleteView k t0 =+ case delFrom t0 of+ (# _, Nothing #) -> Nothing+ (# t, Just (p, x) #) -> Just (p, x, t)+ where+ delFrom t = case t of+ Nil -> (# Nil, Nothing #)++ Tip k' p' x'+ | k == k' -> (# Nil, Just (p', x') #)+ | otherwise -> (# t, Nothing #)++ Bin k' p' x' m l r+ | nomatch k k' m -> (# t, Nothing #)+ | k == k' -> let t' = merge m l r+ in t' `seq` (# t', Just (p', x') #)++ | zero k m -> case delFrom l of+ (# l', mbPX #) -> let t' = binShrinkL k' p' x' m l' r+ in t' `seq` (# t', mbPX #)++ | otherwise -> case delFrom r of+ (# r', mbPX #) -> let t' = binShrinkR k' p' x' m l r'+ in t' `seq` (# t', mbPX #)++-- | /O(min(n,W))/ Retrieve the binding with the least priority, and the+-- rest of the queue stripped of that binding.+{-# INLINE minView #-}+minView :: Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)+minView t = case t of+ Nil -> Nothing+ Tip k p x -> Just (k, p, x, Nil)+ Bin k p x m l r -> Just (k, p, x, merge m l r)+++------------------------------------------------------------------------------+-- Traversal+------------------------------------------------------------------------------++-- | /O(n)/ Modify every value in the queueu.+{-# INLINABLE map #-}+map :: (Int -> p -> v -> w) -> IntPSQ p v -> IntPSQ p w+map f =+ go+ where+ go t = case t of+ Nil -> Nil+ Tip k p x -> Tip k p (f k p x)+ Bin k p x m l r -> Bin k p (f k p x) m (go l) (go r)++-- | /O(n)/ Strict fold over every key, priority and value in the map. The order+-- in which the fold is performed is not specified.+{-# INLINABLE fold' #-}+fold' :: (Int -> p -> v -> a -> a) -> a -> IntPSQ p v -> a+fold' f = go+ where+ go !acc Nil = acc+ go !acc (Tip k' p' x') = f k' p' x' acc+ go !acc (Bin k' p' x' _m l r) =+ let !acc1 = f k' p' x' acc+ !acc2 = go acc1 l+ !acc3 = go acc2 r+ in acc3+++-- | Internal function that merges two *disjoint* 'IntPSQ's that share the+-- same prefix mask.+{-# INLINABLE merge #-}+merge :: Ord p => Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v+merge m l r = case l of+ Nil -> r++ Tip lk lp lx ->+ case r of+ Nil -> l+ Tip rk rp rx+ | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r+ | otherwise -> Bin rk rp rx m l Nil+ Bin rk rp rx rm rl rr+ | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r+ | otherwise -> Bin rk rp rx m l (merge rm rl rr)++ Bin lk lp lx lm ll lr ->+ case r of+ Nil -> l+ Tip rk rp rx+ | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r+ | otherwise -> Bin rk rp rx m l Nil+ Bin rk rp rx rm rl rr+ | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r+ | otherwise -> Bin rk rp rx m l (merge rm rl rr)+++------------------------------------------------------------------------------+-- Improved insert performance for special cases+------------------------------------------------------------------------------++-- TODO (SM): Make benchmarks run again, integrate this function with insert+-- and test how benchmarks times change.++-- | Internal function to insert a key with priority larger than the+-- maximal priority in the heap. This is always the case when using the PSQ+-- as the basis to implement a LRU cache, which associates a+-- access-tick-number with every element.+{-# INLINE unsafeInsertIncreasePriority #-}+unsafeInsertIncreasePriority+ :: Ord p => Key -> p -> v -> IntPSQ p v -> IntPSQ p v+unsafeInsertIncreasePriority =+ unsafeInsertWithIncreasePriority (\newP newX _ _ -> (newP, newX))++{-# INLINE unsafeInsertIncreasePriorityView #-}+unsafeInsertIncreasePriorityView+ :: Ord p => Key -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)+unsafeInsertIncreasePriorityView =+ unsafeInsertWithIncreasePriorityView (\newP newX _ _ -> (newP, newX))++-- | This name is not chosen well anymore. This function:+--+-- - Either inserts a value at a new key with a prio higher than the max of the+-- entire PSQ.+-- - Or, overrides the value at the key with a prio strictly higher than the+-- original prio at that key (but not necessarily the max of the entire PSQ).+{-# INLINABLE unsafeInsertWithIncreasePriority #-}+unsafeInsertWithIncreasePriority+ :: Ord p+ => (p -> v -> p -> v -> (p, v))+ -> Key -> p -> v -> IntPSQ p v -> IntPSQ p v+unsafeInsertWithIncreasePriority f k p x t0 =+ -- TODO (jaspervdj): Maybe help inliner a bit here, check core.+ go t0+ where+ go t = case t of+ Nil -> Tip k p x++ Tip k' p' x'+ | k == k' -> case f p x p' x' of (!fp, !fx) -> Tip k fp fx+ | otherwise -> link k' p' x' k (Tip k p x) Nil++ Bin k' p' x' m l r+ | nomatch k k' m -> link k' p' x' k (Tip k p x) (merge m l r)+ | k == k' -> case f p x p' x' of+ (!fp, !fx)+ | zero k m -> merge m (unsafeInsertNew k fp fx l) r+ | otherwise -> merge m l (unsafeInsertNew k fp fx r)+ | zero k m -> Bin k' p' x' m (go l) r+ | otherwise -> Bin k' p' x' m l (go r)++{-# INLINABLE unsafeInsertWithIncreasePriorityView #-}+unsafeInsertWithIncreasePriorityView+ :: Ord p+ => (p -> v -> p -> v -> (p, v))+ -> Key -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)+unsafeInsertWithIncreasePriorityView f k p x t0 =+ -- TODO (jaspervdj): Maybe help inliner a bit here, check core.+ case go t0 of+ (# t, mbPX #) -> (mbPX, t)+ where+ go t = case t of+ Nil -> (# Tip k p x, Nothing #)++ Tip k' p' x'+ | k == k' -> case f p x p' x' of+ (!fp, !fx) -> (# Tip k fp fx, Just (p', x') #)+ | otherwise -> (# link k' p' x' k (Tip k p x) Nil, Nothing #)++ Bin k' p' x' m l r+ | nomatch k k' m ->+ let t' = merge m l r+ in t' `seq`+ let t'' = link k' p' x' k (Tip k p x) t'+ in t'' `seq` (# t'', Nothing #)++ | k == k' -> case f p x p' x' of+ (!fp, !fx)+ | zero k m ->+ let t' = merge m (unsafeInsertNew k fp fx l) r+ in t' `seq` (# t', Just (p', x') #)+ | otherwise ->+ let t' = merge m l (unsafeInsertNew k fp fx r)+ in t' `seq` (# t', Just (p', x') #)++ | zero k m -> case go l of+ (# l', mbPX #) -> l' `seq` (# Bin k' p' x' m l' r, mbPX #)++ | otherwise -> case go r of+ (# r', mbPX #) -> r' `seq` (# Bin k' p' x' m l r', mbPX #)++-- | This can NOT be used to delete elements.+{-# INLINABLE unsafeLookupIncreasePriority #-}+unsafeLookupIncreasePriority+ :: Ord p+ => (p -> v -> (Maybe b, p, v))+ -> Key+ -> IntPSQ p v+ -> (Maybe b, IntPSQ p v)+unsafeLookupIncreasePriority f k t0 =+ -- TODO (jaspervdj): Maybe help inliner a bit here, check core.+ case go t0 of+ (# t, mbB #) -> (mbB, t)+ where+ go t = case t of+ Nil -> (# Nil, Nothing #)++ Tip k' p' x'+ | k == k' -> case f p' x' of+ (!fb, !fp, !fx) -> (# Tip k fp fx, fb #)+ | otherwise -> (# t, Nothing #)++ Bin k' p' x' m l r+ | nomatch k k' m -> (# t, Nothing #)++ | k == k' -> case f p' x' of+ (!fb, !fp, !fx)+ | zero k m ->+ let t' = merge m (unsafeInsertNew k fp fx l) r+ in t' `seq` (# t', fb #)+ | otherwise ->+ let t' = merge m l (unsafeInsertNew k fp fx r)+ in t' `seq` (# t', fb #)++ | zero k m -> case go l of+ (# l', mbB #) -> l' `seq` (# Bin k' p' x' m l' r, mbB #)++ | otherwise -> case go r of+ (# r', mbB #) -> r' `seq` (# Bin k' p' x' m l r', mbB #)+++------------------------------------------------------------------------------+-- Validity checks for the datastructure invariants+------------------------------------------------------------------------------++-- | /O(n^2)/ Internal function to check if the 'OrdPSQ' is valid, i.e. if all+-- invariants hold. This should always be the case.+valid :: Ord p => IntPSQ p v -> Bool+valid psq =+ not (hasBadNils psq) &&+ not (hasDuplicateKeys psq) &&+ hasMinHeapProperty psq &&+ validMask psq++hasBadNils :: IntPSQ p v -> Bool+hasBadNils psq = case psq of+ Nil -> False+ Tip _ _ _ -> False+ Bin _ _ _ _ Nil Nil -> True+ Bin _ _ _ _ l r -> hasBadNils l || hasBadNils r++hasDuplicateKeys :: IntPSQ p v -> Bool+hasDuplicateKeys psq =+ any ((> 1) . length) (List.group . List.sort $ collectKeys [] psq)+ where+ collectKeys :: [Int] -> IntPSQ p v -> [Int]+ collectKeys ks Nil = ks+ collectKeys ks (Tip k _ _) = k : ks+ collectKeys ks (Bin k _ _ _ l r) =+ let ks' = collectKeys (k : ks) l+ in collectKeys ks' r++hasMinHeapProperty :: Ord p => IntPSQ p v -> Bool+hasMinHeapProperty psq = case psq of+ Nil -> True+ Tip _ _ _ -> True+ Bin _ p _ _ l r -> go p l && go p r+ where+ go :: Ord p => p -> IntPSQ p v -> Bool+ go _ Nil = True+ go parentPrio (Tip _ prio _) = parentPrio <= prio+ go parentPrio (Bin _ prio _ _ l r) =+ parentPrio <= prio && go prio l && go prio r++data Side = L | R++validMask :: IntPSQ p v -> Bool+validMask Nil = True+validMask (Tip _ _ _) = True+validMask (Bin _ _ _ m left right ) =+ maskOk m left right && go m L left && go m R right+ where+ go :: Mask -> Side -> IntPSQ p v -> Bool+ go parentMask side psq = case psq of+ Nil -> True+ Tip k _ _ -> checkMaskAndSideMatchKey parentMask side k+ Bin k _ _ mask l r ->+ checkMaskAndSideMatchKey parentMask side k &&+ maskOk mask l r &&+ go mask L l &&+ go mask R r++ checkMaskAndSideMatchKey parentMask side key =+ case side of+ L -> parentMask .&. key == 0+ R -> parentMask .&. key == parentMask++ maskOk :: Mask -> IntPSQ p v -> IntPSQ p v -> Bool+ maskOk mask l r = case xor <$> childKey l <*> childKey r of+ Nothing -> True+ Just xoredKeys ->+ fromIntegral mask == highestBitMask (fromIntegral xoredKeys)++ childKey Nil = Nothing+ childKey (Tip k _ _) = Just k+ childKey (Bin k _ _ _ _ _) = Just k
+ src/Data/OrdPSQ.hs view
@@ -0,0 +1,61 @@+-- | An 'OrdPSQ' uses the 'Ord' instance of the key type to build a priority+-- search queue.+--+-- It is based on Ralf Hinze's work.+--+-- * Hinze, R., A Simple Implementation Technique for Priority Search Queues,+-- ICFP 2001, pp. 110-121+--+-- <http://citeseer.ist.psu.edu/hinze01simple.html>+--+-- This means it is similar to the+-- <http://hackage.haskell.org/package/PSQueue-1.1 PSQueue> package but+-- our benchmarks showed it perform quite a bit faster.+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE BangPatterns #-}+module Data.OrdPSQ+ ( -- * Type+ OrdPSQ++ -- * Query+ , null+ , size+ , member+ , lookup+ , findMin++ -- * Construction+ , empty+ , singleton++ -- * Insertion+ , insert++ -- * Delete/Update+ , delete+ , alter+ , alterMin++ -- * Conversion+ , fromList+ , toList+ , toAscList+ , keys++ -- * Views+ , insertView+ , deleteView+ , minView++ -- * Traversals+ , map+ , fold'++ -- * Validity check+ , valid+ ) where++import Prelude hiding (map, lookup, null, foldr)++import Data.OrdPSQ.Internal
+ src/Data/OrdPSQ/Internal.hs view
@@ -0,0 +1,652 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE BangPatterns #-}+module Data.OrdPSQ.Internal+ ( -- * Type+ OrdPSQ (..)+ , LTree (..)+ , Elem (..)++ -- * Query+ , null+ , size+ , member+ , lookup+ , findMin++ -- * Construction+ , empty+ , singleton++ -- * Insertion+ , insert++ -- * Delete/Update+ , delete+ , alter+ , alterMin++ -- * Conversion+ , fromList+ , toList+ , toAscList+ , keys++ -- * Views+ , insertView+ , deleteView+ , minView++ -- * Traversals+ , map+ , fold'++ -- * Tournament view+ , TourView (..)+ , tourView+ , play++ -- * Balancing internals+ , left+ , right+ , maxKey+ , lsingleLeft+ , rsingleLeft+ , lsingleRight+ , rsingleRight+ , ldoubleLeft+ , rdoubleLeft+ , ldoubleRight+ , rdoubleRight++ -- * Validity check+ , valid+ ) where++import Prelude hiding (map, lookup, null, foldr)+import Control.DeepSeq (NFData(rnf))+import Data.Maybe (isJust)+import Data.Foldable (Foldable (foldr))+import qualified Data.List as List++--------------------------------------------------------------------------------+-- Types+--------------------------------------------------------------------------------++-- | @E k p v@ binds the key @k@ to the value @v@ with priority @p@.+data Elem k p v = E !k !p !v+ deriving (Show)++instance (NFData k, NFData p, NFData v) => NFData (Elem k p v) where+ rnf (E k p v) = rnf k `seq` rnf p `seq` rnf v++-- | A mapping from keys @k@ to priorites @p@ and values @v@. It is strict in+-- keys, priorities and values.+data OrdPSQ k p v+ = Void+ | Winner !(Elem k p v)+ !(LTree k p v)+ !k+ deriving (Show)++instance (NFData k, NFData p, NFData v) => NFData (OrdPSQ k p v) where+ rnf Void = ()+ rnf (Winner e t m) = rnf e `seq` rnf m `seq` rnf t++instance (Ord k, Ord p, Eq v) => Eq (OrdPSQ k p v) where+ x == y = case (minView x, minView y) of+ (Nothing , Nothing ) -> True+ (Just (xk, xp, xv, x'), (Just (yk, yp, yv, y'))) ->+ xk == yk && xp == yp && xv == yv && x' == y'+ (Just _ , Nothing ) -> False+ (Nothing , Just _ ) -> False++instance Foldable (OrdPSQ k p) where+ foldr _ z Void = z+ foldr f z (Winner (E _ _ x) l _) = f x (foldr f z l)++instance Functor (OrdPSQ k p) where+ fmap f = map (\_ _ v -> f v)++type Size = Int++data LTree k p v+ = Start+ | LLoser {-# UNPACK #-} !Size+ {-# UNPACK #-} !(Elem k p v)+ !(LTree k p v)+ !k -- split key+ !(LTree k p v)+ | RLoser {-# UNPACK #-} !Size+ {-# UNPACK #-} !(Elem k p v)+ !(LTree k p v)+ !k -- split key+ !(LTree k p v)+ deriving (Show)++instance (NFData k, NFData p, NFData v) => NFData (LTree k p v) where+ rnf Start = ()+ rnf (LLoser _ e l k r) = rnf e `seq` rnf l `seq` rnf k `seq` rnf r+ rnf (RLoser _ e l k r) = rnf e `seq` rnf l `seq` rnf k `seq` rnf r++instance Foldable (LTree k p) where+ foldr _ z Start = z+ foldr f z (LLoser _ (E _ _ x) l _ r) = f x (foldr f (foldr f z r) l)+ foldr f z (RLoser _ (E _ _ x) l _ r) = f x (foldr f (foldr f z r) l)+++--------------------------------------------------------------------------------+-- Query+--------------------------------------------------------------------------------++-- | /O(1)/ True if the queue is empty.+null :: OrdPSQ k p v -> Bool+null Void = True+null (Winner _ _ _) = False++-- | /O(1)/ The number of elements in a queue.+size :: (Ord p) => OrdPSQ k p v -> Int+size Void = 0+size (Winner _ lt _) = 1 + size' lt++-- | /O(log n)/ Check if a key is present in the the queue.+member :: Ord k => k -> OrdPSQ k p v -> Bool+member k = isJust . lookup k++-- | /O(log n)/ The priority and value of a given key, or 'Nothing' if the key+-- is not bound.+lookup :: (Ord k) => k -> OrdPSQ k p v -> Maybe (p, v)+lookup k = go+ where+ go t = case tourView t of+ Null -> Nothing+ Single (E k' p v)+ | k == k' -> Just (p, v)+ | otherwise -> Nothing+ Play tl tr+ | k <= maxKey tl -> go tl+ | otherwise -> go tr++-- | /O(1)/ The element with the lowest priority.+findMin :: OrdPSQ k p v -> Maybe (k, p, v)+findMin Void = Nothing+findMin (Winner (E k p v) _ _) = Just (k, p, v)+++--------------------------------------------------------------------------------+-- Construction+--------------------------------------------------------------------------------++-- | /O(1)/ The empty queue.+empty :: OrdPSQ k p v+empty = Void++-- | /O(1)/ Build a queue with one element.+singleton :: k -> p -> v -> OrdPSQ k p v+singleton k p v = Winner (E k p v) Start k+++--------------------------------------------------------------------------------+-- Insertion+--------------------------------------------------------------------------------++-- | /O(log n)/ Insert a new key, priority and value in the queue. If the key is+-- already present in the queue, the associated priority and value are replaced+-- with the supplied priority and value.+{-# INLINABLE insert #-}+insert :: (Ord k, Ord p) => k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v+insert k p v = go+ where+ go t = case t of+ Void -> singleton k p v+ Winner (E k' p' v') Start _ -> case compare k k' of+ LT -> singleton k p v `play` singleton k' p' v'+ EQ -> singleton k p v+ GT -> singleton k' p' v' `play` singleton k p v+ Winner e (RLoser _ e' tl m tr) m'+ | k <= m -> go (Winner e tl m) `play` (Winner e' tr m')+ | otherwise -> (Winner e tl m) `play` go (Winner e' tr m')+ Winner e (LLoser _ e' tl m tr) m'+ | k <= m -> go (Winner e' tl m) `play` (Winner e tr m')+ | otherwise -> (Winner e' tl m) `play` go (Winner e tr m')+++--------------------------------------------------------------------------------+-- Delete/update+--------------------------------------------------------------------------------++-- | /O(log n)/ Delete a key and its priority and value from the queue. When the+-- key is not a member of the queue, the original queue is returned.+{-# INLINABLE delete #-}+delete :: (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v+delete k = go+ where+ go t = case t of+ Void -> empty+ Winner (E k' p v) Start _+ | k == k' -> empty+ | otherwise -> singleton k' p v+ Winner e (RLoser _ e' tl m tr) m'+ | k <= m -> go (Winner e tl m) `play` (Winner e' tr m')+ | otherwise -> (Winner e tl m) `play` go (Winner e' tr m')+ Winner e (LLoser _ e' tl m tr) m'+ | k <= m -> go (Winner e' tl m) `play` (Winner e tr m')+ | otherwise -> (Winner e' tl m) `play` go (Winner e tr m')++-- | /O(log n)/ The expression @alter f k map@ alters the value @x@ at @k@, or+-- absence thereof. 'alter' can be used to insert, delete, or update a value+-- in a queue. It also allows you to calculate an additional value @b@.+{-# INLINE alter #-}+alter+ :: (Ord k, Ord p)+ => (Maybe (p, v) -> (b, Maybe (p, v)))+ -> k+ -> OrdPSQ k p v+ -> (b, OrdPSQ k p v)+alter f k psq0 =+ let (psq1, mbPV) = case deleteView k psq0 of+ Nothing -> (psq0, Nothing)+ Just (p, v, psq) -> (psq, Just (p, v))+ (!b, mbPV') = f mbPV+ in case mbPV' of+ Nothing -> (b, psq1)+ Just (p, v) -> (b, insert k p v psq1)++-- | /O(log n)/ A variant of 'alter' which works on the element with the minimum+-- priority. Unlike 'alter', this variant also allows you to change the key of+-- the element.+{-# INLINE alterMin #-}+alterMin :: (Ord k, Ord p)+ => (Maybe (k, p, v) -> (b, Maybe (k, p, v)))+ -> OrdPSQ k p v+ -> (b, OrdPSQ k p v)+alterMin f psq0 =+ case minView psq0 of+ Nothing -> let (!b, mbKPV) = f Nothing+ in (b, insertMay mbKPV psq0)+ Just (k,p,v, psq1) -> let (!b, mbKPV) = f $ Just (k, p, v)+ in (b, insertMay mbKPV psq1)+ where+ insertMay Nothing psq = psq+ insertMay (Just (k, p, v)) psq = insert k p v psq+++--------------------------------------------------------------------------------+-- Conversion+--------------------------------------------------------------------------------++-- | /O(n*log n)/ Build a queue from a list of (key, priority, value) tuples.+-- If the list contains more than one priority and value for the same key, the+-- last priority and value for the key is retained.+{-# INLINABLE fromList #-}+fromList :: (Ord k, Ord p) => [(k, p, v)] -> OrdPSQ k p v+fromList = foldr (\(k, p, v) q -> insert k p v q) empty++-- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The+-- order of the list is not specified.+toList :: OrdPSQ k p v -> [(k, p, v)]+toList = toAscList++-- | /O(n)/ Obtain the list of present keys in the queue.+keys :: OrdPSQ k p v -> [k]+keys t = [k | (k, _, _) <- toList t]+-- TODO (jaspervdj): There must be faster implementations.++-- | /O(n)/ Convert to an ascending list.+toAscList :: OrdPSQ k p v -> [(k, p, v)]+toAscList q = seqToList (toAscLists q)+ where+ toAscLists :: OrdPSQ k p v -> Sequ (k, p, v)+ toAscLists t = case tourView t of+ Null -> emptySequ+ Single (E k p v) -> singleSequ (k, p, v)+ Play tl tr -> toAscLists tl <> toAscLists tr+++--------------------------------------------------------------------------------+-- Views+--------------------------------------------------------------------------------++-- | /O(log n)/ Insert a new key, priority and value in the queue. If the key is+-- already present in the queue, then the evicted priority and value can be+-- found the first element of the returned tuple.+{-# INLINABLE insertView #-}+insertView+ :: (Ord k, Ord p)+ => k -> p -> v -> OrdPSQ k p v -> (Maybe (p, v), OrdPSQ k p v)+insertView k p x t = case deleteView k t of+ Nothing -> (Nothing, insert k p x t)+ Just (p', x', _) -> (Just (p', x'), insert k p x t)++-- | /O(log n)/ Delete a key and its priority and value from the queue. If the+-- key was present, the associated priority and value are returned in addition+-- to the updated queue.+{-# INLINABLE deleteView #-}+deleteView :: (Ord k, Ord p) => k -> OrdPSQ k p v -> Maybe (p, v, OrdPSQ k p v)+deleteView k psq = case psq of+ Void -> Nothing+ Winner (E k' p v) Start _+ | k == k' -> Just (p, v, empty)+ | otherwise -> Nothing+ Winner e (RLoser _ e' tl m tr) m'+ | k <= m -> fmap (\(p,v,q) -> (p, v, q `play` (Winner e' tr m'))) (deleteView k (Winner e tl m))+ | otherwise -> fmap (\(p,v,q) -> (p, v, (Winner e tl m) `play` q )) (deleteView k (Winner e' tr m'))+ Winner e (LLoser _ e' tl m tr) m'+ | k <= m -> fmap (\(p,v,q) -> (p, v, q `play` (Winner e tr m'))) (deleteView k (Winner e' tl m))+ | otherwise -> fmap (\(p,v,q) -> (p, v, (Winner e' tl m) `play` q )) (deleteView k (Winner e tr m'))++-- | /O(log n)/ Retrieve the binding with the least priority, and the+-- rest of the queue stripped of that binding.+{-# INLINABLE minView #-}+minView :: (Ord k, Ord p) => OrdPSQ k p v -> Maybe (k, p, v, OrdPSQ k p v)+minView Void = Nothing+minView (Winner (E k p v) t m) = Just (k, p, v, secondBest t m)++secondBest :: (Ord k, Ord p) => LTree k p v -> k -> OrdPSQ k p v+secondBest Start _ = Void+secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m'+secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m'+++--------------------------------------------------------------------------------+-- Traversals+--------------------------------------------------------------------------------++-- | /O(n)/ Modify every value in the queueu.+{-# INLINABLE map #-}+map :: forall k p v w. (k -> p -> v -> w) -> OrdPSQ k p v -> OrdPSQ k p w+map f =+ goPSQ+ where+ goPSQ :: OrdPSQ k p v -> OrdPSQ k p w+ goPSQ Void = Void+ goPSQ (Winner e l k) = Winner (goElem e) (goLTree l) k++ goElem :: Elem k p v -> Elem k p w+ goElem (E k p x) = E k p (f k p x)++ goLTree :: LTree k p v -> LTree k p w+ goLTree Start = Start+ goLTree (LLoser s e l k r) = LLoser s (goElem e) (goLTree l) k (goLTree r)+ goLTree (RLoser s e l k r) = RLoser s (goElem e) (goLTree l) k (goLTree r)+++-- | /O(n)/ Strict fold over every key, priority and value in the map. The order+-- in which the fold is performed is not specified.+{-# INLINE fold' #-}+fold' :: (k -> p -> v -> a -> a) -> a -> OrdPSQ k p v -> a+fold' f =+ \acc0 psq -> case psq of+ Void -> acc0+ (Winner (E k p v) t _) ->+ let !acc1 = f k p v acc0+ in go acc1 t+ where+ go !acc Start = acc+ go !acc (LLoser _ (E k p v) lt _ rt) = go (f k p v (go acc lt)) rt+ go !acc (RLoser _ (E k p v) lt _ rt) = go (f k p v (go acc lt)) rt+++--------------------------------------------------------------------------------+-- Tournament view+--------------------------------------------------------------------------------++data TourView k p v+ = Null+ | Single {-# UNPACK #-} !(Elem k p v)+ | Play (OrdPSQ k p v) (OrdPSQ k p v)++tourView :: OrdPSQ k p v -> TourView k p v+tourView Void = Null+tourView (Winner e Start _) = Single e+tourView (Winner e (RLoser _ e' tl m tr) m') =+ Winner e tl m `Play` Winner e' tr m'+tourView (Winner e (LLoser _ e' tl m tr) m') =+ Winner e' tl m `Play` Winner e tr m'++-- | Take two pennants and returns a new pennant that is the union of+-- the two with the precondition that the keys in the first tree are+-- strictly smaller than the keys in the second tree.+{-# INLINABLE play #-}+play :: (Ord p, Ord k) => OrdPSQ k p v -> OrdPSQ k p v -> OrdPSQ k p v+Void `play` t' = t'+t `play` Void = t+Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m'+ | (p, k) `beats` (p', k') = Winner e (rbalance k' p' v' t m t') m'+ | otherwise = Winner e' (lbalance k p v t m t') m'++-- | When priorities are equal, the tree with the lowest key wins. This is+-- important to have a deterministic `==`, which requires on `minView` pulling+-- out the elements in the right order.+beats :: (Ord p, Ord k) => (p, k) -> (p, k) -> Bool+beats (p, !k) (p', !k') = p < p' || (p == p' && k < k')+{-# INLINE beats #-}+++--------------------------------------------------------------------------------+-- Balancing internals+--------------------------------------------------------------------------------++-- | Balance factor+omega :: Int+omega = 4 -- Has to be greater than 3.75 because Hinze's paper said so.++size' :: LTree k p v -> Size+size' Start = 0+size' (LLoser s _ _ _ _) = s+size' (RLoser s _ _ _ _) = s++left, right :: LTree k p v -> LTree k p v++left Start = moduleError "left" "empty loser tree"+left (LLoser _ _ tl _ _ ) = tl+left (RLoser _ _ tl _ _ ) = tl++right Start = moduleError "right" "empty loser tree"+right (LLoser _ _ _ _ tr) = tr+right (RLoser _ _ _ _ tr) = tr++maxKey :: OrdPSQ k p v -> k+maxKey Void = moduleError "maxKey" "empty queue"+maxKey (Winner _ _ m) = m++lloser, rloser :: k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr+rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr++lbalance, rbalance+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+lbalance k p v l m r+ | size' l + size' r < 2 = lloser k p v l m r+ | size' r > omega * size' l = lbalanceLeft k p v l m r+ | size' l > omega * size' r = lbalanceRight k p v l m r+ | otherwise = lloser k p v l m r++rbalance k p v l m r+ | size' l + size' r < 2 = rloser k p v l m r+ | size' r > omega * size' l = rbalanceLeft k p v l m r+ | size' l > omega * size' r = rbalanceRight k p v l m r+ | otherwise = rloser k p v l m r++lbalanceLeft+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+lbalanceLeft k p v l m r+ | size' (left r) < size' (right r) = lsingleLeft k p v l m r+ | otherwise = ldoubleLeft k p v l m r++lbalanceRight+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+lbalanceRight k p v l m r+ | size' (left l) > size' (right l) = lsingleRight k p v l m r+ | otherwise = ldoubleRight k p v l m r++rbalanceLeft+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+rbalanceLeft k p v l m r+ | size' (left r) < size' (right r) = rsingleLeft k p v l m r+ | otherwise = rdoubleLeft k p v l m r++rbalanceRight+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+rbalanceRight k p v l m r+ | size' (left l) > size' (right l) = rsingleRight k p v l m r+ | otherwise = rdoubleRight k p v l m r++lsingleLeft+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3)+ | (p1, k1) `beats` (p2, k2) =+ lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3+ | otherwise =+ lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3+lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =+ rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3+lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree"++rsingleLeft :: k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =+ rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3+rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =+ rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3+rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree"++lsingleRight :: k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =+ lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3)+lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =+ lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)+lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree"++rsingleRight+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =+ lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)+rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3+ | (p1, k1) `beats` (p2, k2) =+ rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)+ | otherwise =+ rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)+rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree"++ldoubleLeft+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =+ lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)+ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =+ lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)+ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree"++ldoubleRight+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =+ lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3+ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =+ lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3+ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree"++rdoubleLeft+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =+ rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)+rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =+ rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)+rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree"++rdoubleRight+ :: (Ord k, Ord p)+ => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v+rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =+ rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3+rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =+ rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3+rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree"+++--------------------------------------------------------------------------------+-- Validity check+--------------------------------------------------------------------------------++-- | /O(n^2)/ Internal function to check if the 'OrdPSQ' is valid, i.e. if all+-- invariants hold. This should always be the case.+valid :: (Ord k, Ord p) => OrdPSQ k p v -> Bool+valid t =+ not (hasDuplicateKeys t) &&+ hasMinHeapProperty t &&+ hasBinarySearchTreeProperty t &&+ hasCorrectSizeAnnotations t++hasDuplicateKeys :: Ord k => OrdPSQ k p v -> Bool+hasDuplicateKeys = any (> 1) . List.map length . List.group . List.sort . keys++hasMinHeapProperty :: forall k p v. (Ord k, Ord p) => OrdPSQ k p v -> Bool+hasMinHeapProperty Void = True+hasMinHeapProperty (Winner (E k0 p0 _) t0 _) = go k0 p0 t0+ where+ go :: k -> p -> LTree k p v -> Bool+ go _ _ Start = True+ go k p (LLoser _ (E k' p' _) l _ r) =+ (p, k) < (p', k') && go k' p' l && go k p r+ go k p (RLoser _ (E k' p' _) l _ r) =+ (p, k) < (p', k') && go k p l && go k' p' r++hasBinarySearchTreeProperty+ :: forall k p v. (Ord k, Ord p) => OrdPSQ k p v -> Bool+hasBinarySearchTreeProperty t = case tourView t of+ Null -> True+ Single _ -> True+ Play l r ->+ all (<= k) (keys l) &&+ all (>= k) (keys r) &&+ hasBinarySearchTreeProperty l &&+ hasBinarySearchTreeProperty r+ where+ k = maxKey l++hasCorrectSizeAnnotations :: OrdPSQ k p v -> Bool+hasCorrectSizeAnnotations Void = True+hasCorrectSizeAnnotations (Winner _ t0 _) = go t0+ where+ go :: LTree k p v -> Bool+ go t@Start = calculateSize t == 0+ go t@(LLoser s _ l _ r) = calculateSize t == s && go l && go r+ go t@(RLoser s _ l _ r) = calculateSize t == s && go l && go r++ calculateSize :: LTree k p v -> Int+ calculateSize Start = 0+ calculateSize (LLoser _ _ l _ r) = 1 + calculateSize l + calculateSize r+ calculateSize (RLoser _ _ l _ r) = 1 + calculateSize l + calculateSize r+++--------------------------------------------------------------------------------+-- Utility functions+--------------------------------------------------------------------------------++moduleError :: String -> String -> a+moduleError fun msg = error ("Data.OrdPSQ.Internal." ++ fun ++ ':' : ' ' : msg)+{-# NOINLINE moduleError #-}++-- | Hughes's efficient sequence type+newtype Sequ a = Sequ ([a] -> [a])++emptySequ :: Sequ a+emptySequ = Sequ (\as -> as)++singleSequ :: a -> Sequ a+singleSequ a = Sequ (\as -> a : as)++(<>) :: Sequ a -> Sequ a -> Sequ a+Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as))+infixr 5 <>++seqToList :: Sequ a -> [a]+seqToList (Sequ x) = x []
+ tests/Data/HashPSQ/Tests.hs view
@@ -0,0 +1,91 @@+module Data.HashPSQ.Tests+ ( tests+ ) where++import Prelude hiding (lookup)++import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Property, arbitrary,+ forAll)+import Test.HUnit (Assertion, assert)++import Data.HashPSQ.Internal+import qualified Data.OrdPSQ as OrdPSQ+import Data.PSQ.Class.Gen+import Data.PSQ.Class.Util+++--------------------------------------------------------------------------------+-- Index of tests+--------------------------------------------------------------------------------++tests :: [Test]+tests =+ [ testCase "showBucket" test_showBucket+ , testCase "toBucket" test_toBucket+ , testProperty "unsafeLookupIncreasePriority"+ prop_unsafeLookupIncreasePriority+ , testProperty "unsafeInsertIncreasePriority"+ prop_unsafeInsertIncreasePriority+ , testProperty "unsafeInsertIncreasePriorityView"+ prop_unsafeInsertIncreasePriorityView+ ]+++--------------------------------------------------------------------------------+-- Unit tests+--------------------------------------------------------------------------------++test_showBucket :: Assertion+test_showBucket =+ assert $ length (coverShowInstance bucket) > 0+ where+ bucket :: Bucket Int Int Char+ bucket = B 1 'a' OrdPSQ.empty++test_toBucket :: Assertion+test_toBucket =+ assert True+ -- TODO (jaspervdj)+ -- assert $ mkBucket (OrdPSQ.empty :: OrdPSQ.OrdPSQ Int Int Char)+++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++prop_unsafeLookupIncreasePriority :: Property+prop_unsafeLookupIncreasePriority =+ forAll arbitraryPSQ $ \t ->+ forAll arbitrary $ \k ->+ let newP = maybe 0 ((+ 1) . fst) (lookup k t)+ (mbPx, t') = unsafeLookupIncreasePriority k newP t+ expect = case mbPx of+ Nothing -> Nothing+ Just (p, x) -> Just (p + 1, x)+ in valid (t' :: HashPSQ LousyHashedInt Int Char) &&+ lookup k t' == expect &&+ lookup k t == mbPx++prop_unsafeInsertIncreasePriority :: Property+prop_unsafeInsertIncreasePriority =+ forAll arbitraryPSQ $ \t ->+ forAll arbitrary $ \k ->+ forAll arbitrary $ \x ->+ let prio = largerThanMaxPrio t+ t' = unsafeInsertIncreasePriority k prio x t+ in valid (t' :: HashPSQ LousyHashedInt Int Char) &&+ lookup k t' == Just (prio, x)++prop_unsafeInsertIncreasePriorityView :: Property+prop_unsafeInsertIncreasePriorityView =+ forAll arbitraryPSQ $ \t ->+ forAll arbitrary $ \k ->+ forAll arbitrary $ \x ->+ let prio = largerThanMaxPrio t+ (mbPx, t') = unsafeInsertIncreasePriorityView k prio x t+ in valid (t' :: HashPSQ LousyHashedInt Int Char) &&+ lookup k t' == Just (prio, x) &&+ lookup k t == mbPx
+ tests/Data/IntPSQ/Tests.hs view
@@ -0,0 +1,116 @@+module Data.IntPSQ.Tests+ where++import Prelude hiding (lookup)++import Test.QuickCheck (Property, arbitrary,+ forAll)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion, assert)++import Data.IntPSQ.Internal+import Data.PSQ.Class.Gen+import Data.PSQ.Class.Util++--------------------------------------------------------------------------------+-- Index of tests+--------------------------------------------------------------------------------++tests :: [Test]+tests =+ [ testCase "hasBadNils" test_hasBadNils+ , testProperty "unsafeInsertIncreasePriority"+ prop_unsafeInsertIncreasePriority+ , testProperty "unsafeInsertIncreasePriorityView"+ prop_unsafeInsertIncreasePriorityView+ , testProperty "unsafeInsertWithIncreasePriority"+ prop_unsafeInsertWithIncreasePriority+ , testProperty "unsafeInsertWithIncreasePriorityView"+ prop_unsafeInsertWithIncreasePriorityView+ , testProperty "unsafeLookupIncreasePriority"+ prop_unsafeLookupIncreasePriority+ ]+++--------------------------------------------------------------------------------+-- Unit tests+--------------------------------------------------------------------------------++-- 100% test coverage...+test_hasBadNils :: Assertion+test_hasBadNils =+ assert $ hasBadNils (Bin 1 (2 :: Int) 'x' 0 Nil Nil)+++--------------------------------------------------------------------------------+-- QuickCheck properties+--------------------------------------------------------------------------------++prop_unsafeInsertIncreasePriority :: Property+prop_unsafeInsertIncreasePriority =+ forAll arbitraryPSQ $ \t ->+ forAll arbitrary $ \k ->+ forAll arbitrary $ \x ->+ let prio = largerThanMaxPrio t+ t' = unsafeInsertIncreasePriority k prio x t+ in valid (t' :: IntPSQ Int Char) && lookup k t' == Just (prio, x)++prop_unsafeInsertIncreasePriorityView :: Property+prop_unsafeInsertIncreasePriorityView =+ forAll arbitraryPSQ $ \t ->+ forAll arbitrary $ \k ->+ forAll arbitrary $ \x ->+ let prio = largerThanMaxPrio t+ (mbPx, t') = unsafeInsertIncreasePriorityView k prio x t+ in valid (t' :: IntPSQ Int Char) &&+ lookup k t' == Just (prio, x) &&+ lookup k t == mbPx++prop_unsafeInsertWithIncreasePriority :: Property+prop_unsafeInsertWithIncreasePriority =+ forAll arbitraryPSQ $ \t0 ->+ forAll arbitrary $ \k ->+ forAll arbitrary $ \x ->+ let t = fmap (\e -> [e]) t0 :: IntPSQ Int [Char]+ prio = largerThanMaxPrio t+ f = \newP newX oldP oldX ->+ (min newP oldP + 1, newX ++ oldX)+ t' = unsafeInsertWithIncreasePriority f k prio [x] t+ expect = case lookup k t of+ Nothing -> (prio, [x])+ Just (p, y) -> (min prio p + 1, [x] ++ y)+ in valid t' && lookup k t' == Just expect++prop_unsafeInsertWithIncreasePriorityView :: Property+prop_unsafeInsertWithIncreasePriorityView =+ forAll arbitraryPSQ $ \t0 ->+ forAll arbitrary $ \k ->+ forAll arbitrary $ \x ->+ let t = fmap (\e -> [e]) t0 :: IntPSQ Int [Char]+ prio = largerThanMaxPrio t+ f = \newP newX oldP oldX ->+ (min newP oldP + 1, newX ++ oldX)+ (mbPx, t') = unsafeInsertWithIncreasePriorityView f k prio [x] t+ expect = case mbPx of+ Nothing -> (prio, [x])+ Just (p, y) -> (min prio p + 1, [x] ++ y)+ in valid t' &&+ lookup k t' == Just expect &&+ lookup k t == mbPx++prop_unsafeLookupIncreasePriority :: Property+prop_unsafeLookupIncreasePriority =+ forAll arbitraryPSQ $ \t0 ->+ forAll arbitrary $ \k ->+ let t = fmap (\e -> [e]) t0 :: IntPSQ Int [Char]+ f = \oldP oldX ->+ (Just (oldP, oldX), oldP + 1, oldX ++ "k")+ (mbPx, t') = unsafeLookupIncreasePriority f k t+ expect = case mbPx of+ Nothing -> Nothing+ Just (p, x) -> Just (p + 1, x ++ "k")+ in valid t' &&+ lookup k t' == expect &&+ lookup k t == mbPx
+ tests/Data/OrdPSQ/Tests.hs view
@@ -0,0 +1,89 @@+module Data.OrdPSQ.Tests+ ( tests+ ) where++import Data.List (isInfixOf)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion, assert)++import Data.OrdPSQ.Internal+import Data.PSQ.Class.Gen ()+import Data.PSQ.Class.Util++--------------------------------------------------------------------------------+-- Index of tests+--------------------------------------------------------------------------------++tests :: [Test]+tests =+ [ testCase "showElem" test_showElem+ , testCase "showLTree" test_showLTree+ , testCase "invalidLTree" test_invalidLTree+ , testCase "balanceErrors" test_balanceErrors+ , testProperty "toAscList" prop_toAscList+ ]+++--------------------------------------------------------------------------------+-- Tests the result of 'moduleError' for internal issues+--------------------------------------------------------------------------------++assertModuleError :: String -> String -> a -> Assertion+assertModuleError fun msg = assertErrorCall $ \e -> do+ assert $ fun `isInfixOf` e+ assert $ msg `isInfixOf` e+++--------------------------------------------------------------------------------+-- HUnit tests+--------------------------------------------------------------------------------++test_showElem :: Assertion+test_showElem =+ assert $ length (coverShowInstance (E 0 0 'A' :: Elem Int Int Char)) > 0++test_showLTree :: Assertion+test_showLTree = do+ assert $ length (coverShowInstance t1) > 0+ assert $ length (coverShowInstance t2) > 0+ assert $ length (coverShowInstance t3) > 0+ where+ t1, t2, t3 :: LTree Int Int Char+ t1 = Start+ t2 = LLoser 1 e Start 0 Start+ t3 = RLoser 1 e Start 0 Start+ e = E 0 0 'A'++test_invalidLTree :: Assertion+test_invalidLTree = do+ assertModuleError "left" "empty" (left (Start :: LTree Int Int Char))+ assertModuleError "right" "empty" (right (Start :: LTree Int Int Char))+ assertModuleError "maxKey" "empty" (maxKey (empty :: OrdPSQ Int Int Char))++test_balanceErrors :: Assertion+test_balanceErrors = do+ assertModuleError "lsingleLeft" msg (lsingleLeft 0 0 'A' nil 0 nil)+ assertModuleError "rsingleLeft" msg (rsingleLeft 0 0 'A' nil 0 nil)+ assertModuleError "lsingleRight" msg (lsingleRight 0 0 'A' nil 0 nil)+ assertModuleError "rsingleRight" msg (rsingleRight 0 0 'A' nil 0 nil)+ assertModuleError "ldoubleLeft" msg (ldoubleLeft 0 0 'A' nil 0 nil)+ assertModuleError "rdoubleLeft" msg (rdoubleLeft 0 0 'A' nil 0 nil)+ assertModuleError "ldoubleRight" msg (ldoubleRight 0 0 'A' nil 0 nil)+ assertModuleError "rdoubleRight" msg (rdoubleRight 0 0 'A' nil 0 nil)+ where+ nil = Start :: LTree Int Int Char+ msg = "malformed"+++--------------------------------------------------------------------------------+-- QuickCheck properties+--------------------------------------------------------------------------------++prop_toAscList :: OrdPSQ Int Int Char -> Bool+prop_toAscList t = isUniqueSorted [k | (k, _, _) <- toAscList t]+ where+ isUniqueSorted (x : y : zs) = x < y && isUniqueSorted (y : zs)+ isUniqueSorted [_] = True+ isUniqueSorted [] = True
+ tests/Data/PSQ/Class.hs view
@@ -0,0 +1,149 @@+-- | Generic class with properties and methods that are available for all+-- different implementations ('IntPSQ', 'OrdPSQ' and 'HashPSQ').+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.PSQ.Class+ ( PSQ (..)+ ) where++import Data.Hashable (Hashable)++import qualified Data.IntPSQ as IntPSQ+import qualified Data.HashPSQ as HashPSQ+import qualified Data.OrdPSQ as OrdPSQ++class PSQ (psq :: * -> * -> *) where+ type Key psq :: *++ -- Query+ null+ :: Ord p => psq p v -> Bool+ size+ :: Ord p => psq p v -> Int+ member+ :: Ord p => Key psq -> psq p v -> Bool+ lookup+ :: Ord p => Key psq -> psq p v -> Maybe (p, v)+ findMin+ :: Ord p => psq p v -> Maybe (Key psq, p, v)++ -- Construction+ empty+ :: Ord p => psq p v+ singleton+ :: Ord p => Key psq -> p -> v -> psq p v++ -- Insertion+ insert+ :: Ord p => Key psq -> p -> v -> psq p v -> psq p v++ -- Delete/update+ delete+ :: Ord p => Key psq -> psq p v -> psq p v+ alter+ :: Ord p+ => (Maybe (p, v) -> (b, Maybe (p, v)))+ -> Key psq -> psq p v -> (b, psq p v)+ alterMin+ :: Ord p+ => (Maybe (Key psq, p, v) -> (b, Maybe (Key psq, p, v)))+ -> psq p v -> (b, psq p v)++ -- Lists+ fromList+ :: Ord p => [(Key psq, p, v)] -> psq p v+ toList+ :: Ord p => psq p v -> [(Key psq, p, v)]+ keys+ :: Ord p => psq p v -> [Key psq]++ -- Views+ insertView+ :: Ord p => Key psq -> p -> v -> psq p v -> (Maybe (p, v), psq p v)+ deleteView+ :: Ord p => Key psq -> psq p v -> Maybe (p, v, psq p v)+ minView+ :: Ord p => psq p v -> Maybe (Key psq, p, v, psq p v)++ -- Traversals+ map :: Ord p => (Key psq -> p -> v -> w) -> psq p v -> psq p w+ fold'+ :: Ord p => (Key psq -> p -> v -> a -> a) -> a -> psq p v -> a++ -- Validity check+ valid+ :: Ord p => psq p v -> Bool++instance PSQ IntPSQ.IntPSQ where+ type Key IntPSQ.IntPSQ = Int++ null = IntPSQ.null+ size = IntPSQ.size+ member = IntPSQ.member+ lookup = IntPSQ.lookup+ findMin = IntPSQ.findMin+ empty = IntPSQ.empty+ singleton = IntPSQ.singleton+ insert = IntPSQ.insert+ delete = IntPSQ.delete+ alter = IntPSQ.alter+ alterMin = IntPSQ.alterMin+ fromList = IntPSQ.fromList+ toList = IntPSQ.toList+ keys = IntPSQ.keys+ insertView = IntPSQ.insertView+ deleteView = IntPSQ.deleteView+ minView = IntPSQ.minView+ map = IntPSQ.map+ fold' = IntPSQ.fold'+ valid = IntPSQ.valid++instance forall k. Ord k => PSQ (OrdPSQ.OrdPSQ k) where+ type Key (OrdPSQ.OrdPSQ k) = k++ null = OrdPSQ.null+ size = OrdPSQ.size+ member = OrdPSQ.member+ lookup = OrdPSQ.lookup+ findMin = OrdPSQ.findMin+ empty = OrdPSQ.empty+ singleton = OrdPSQ.singleton+ insert = OrdPSQ.insert+ delete = OrdPSQ.delete+ alter = OrdPSQ.alter+ alterMin = OrdPSQ.alterMin+ fromList = OrdPSQ.fromList+ toList = OrdPSQ.toList+ keys = OrdPSQ.keys+ insertView = OrdPSQ.insertView+ deleteView = OrdPSQ.deleteView+ minView = OrdPSQ.minView+ map = OrdPSQ.map+ fold' = OrdPSQ.fold'+ valid = OrdPSQ.valid++instance forall k. (Hashable k, Ord k) => PSQ (HashPSQ.HashPSQ k) where+ type Key (HashPSQ.HashPSQ k) = k++ null = HashPSQ.null+ size = HashPSQ.size+ member = HashPSQ.member+ lookup = HashPSQ.lookup+ findMin = HashPSQ.findMin+ empty = HashPSQ.empty+ singleton = HashPSQ.singleton+ insert = HashPSQ.insert+ delete = HashPSQ.delete+ alter = HashPSQ.alter+ alterMin = HashPSQ.alterMin+ fromList = HashPSQ.fromList+ toList = HashPSQ.toList+ keys = HashPSQ.keys+ insertView = HashPSQ.insertView+ deleteView = HashPSQ.deleteView+ minView = HashPSQ.minView+ map = HashPSQ.map+ fold' = HashPSQ.fold'+ valid = HashPSQ.valid
+ tests/Data/PSQ/Class/Gen.hs view
@@ -0,0 +1,75 @@+-- | Higher-quality random generator for PSQ structures which generates a PSQ+-- from a series of actions+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.PSQ.Class.Gen+ ( arbitraryPSQ+ ) where++import Control.Applicative (pure, (<$>), (<*>))+import Test.QuickCheck (Gen, Arbitrary (..), frequency, choose,+ elements)+import Control.Monad (foldM, replicateM)+import Data.Hashable (Hashable)++import Data.PSQ.Class (PSQ (..))+import Data.PSQ.Class.Util+import qualified Data.OrdPSQ as OrdPSQ+import qualified Data.IntPSQ as IntPSQ+import qualified Data.HashPSQ as HashPSQ++data Action k p v+ = Insert k p v+ | DeleteRandomMember+ | DeleteMin+ deriving (Show, Eq)++arbitraryAction+ :: (Arbitrary k, Arbitrary v)+ => Gen (Action k Int v)+arbitraryAction = frequency+ [ (10, Insert <$> arbitrary <*> arbitraryPriority <*> arbitrary)+ , (2, pure DeleteRandomMember)+ , (2, pure DeleteMin)+ ]++apply+ :: PSQ psq => Action (Key psq) Int v -> psq Int v -> Gen (psq Int v)+apply (Insert k p x) t = return $ insert k p x t+apply DeleteRandomMember t = do+ key <- elements (keys t)+ return $ delete key t+apply DeleteMin t = return $ case minView t of+ Nothing -> t+ Just (_, _, _, t') -> t'++arbitraryPSQ+ :: forall psq v. (Arbitrary (Key psq), Arbitrary v, PSQ psq)+ => Gen (psq Int v)+arbitraryPSQ = do+ numActions <- choose (0, 100)+ actions <- replicateM numActions arbitraryAction+ foldM (\t a -> apply a t) (empty :: psq Int v) actions++shrinkPSQ+ :: forall psq p v. (Ord p, PSQ psq)+ => psq p v -> [psq p v]+shrinkPSQ t = [delete k t | k <- keys t]++instance forall k v. (Arbitrary k, Arbitrary v, Ord k) =>+ Arbitrary (OrdPSQ.OrdPSQ k Int v) where+ arbitrary = arbitraryPSQ+ shrink = shrinkPSQ++instance forall v. (Arbitrary v) => Arbitrary (IntPSQ.IntPSQ Int v) where+ arbitrary = arbitraryPSQ+ shrink = shrinkPSQ++instance forall k v. (Arbitrary k, Arbitrary v,+ Hashable k, Ord k) =>+ Arbitrary (HashPSQ.HashPSQ k Int v) where+ arbitrary = arbitraryPSQ+ shrink = shrinkPSQ
+ tests/Data/PSQ/Class/Tests.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module Data.PSQ.Class.Tests+ ( tests+ ) where++import Prelude hiding (null, lookup, map, foldr)+import Control.Applicative ((<$>))+import Control.DeepSeq (NFData, rnf)+import Data.Tagged (Tagged (..), untag)+import qualified Data.List as List+import Data.Char (isPrint, isAlphaNum, ord, toLower)+import Data.Foldable (Foldable, foldr)++import Test.QuickCheck (Arbitrary (..), Property,+ (==>), forAll)+import Test.HUnit (Assertion, assert, (@?=))+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Data.PSQ.Class+import Data.PSQ.Class.Gen+import Data.PSQ.Class.Util+++--------------------------------------------------------------------------------+-- Index of tests+--------------------------------------------------------------------------------++tests+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Foldable (psq Int),+ Functor (psq Int),+ NFData (psq Int Char),+ Show (psq Int Char))+ => Tagged psq [Test]+tests = Tagged+ [ testCase "rnf" (untag' test_rnf)+ , testCase "equality" (untag' test_equality)+ , testCase "size" (untag' test_size)+ , testCase "size2" (untag' test_size2)+ , testCase "empty" (untag' test_empty)+ , testCase "lookup" (untag' test_lookup)+ , testCase "findMin" (untag' test_findMin)+ , testCase "alter" (untag' test_alter)+ , testCase "alterMin" (untag' test_alterMin)+ , testCase "fromList" (untag' test_fromList)+ , testCase "foldr" (untag' test_foldr)++ , testProperty "show" (untag' prop_show)+ , testProperty "rnf" (untag' prop_rnf)+ , testProperty "size" (untag' prop_size)+ , testProperty "singleton" (untag' prop_singleton)+ , testProperty "memberLookup" (untag' prop_memberLookup)+ , testProperty "insertLookup" (untag' prop_insertLookup)+ , testProperty "insertDelete" (untag' prop_insertDelete)+ , testProperty "insertDeleteView" (untag' prop_insertDeleteView)+ , testProperty "deleteNonMember" (untag' prop_deleteNonMember)+ , testProperty "alter" (untag' prop_alter)+ , testProperty "alterMin" (untag' prop_alterMin)+ , testProperty "toList" (untag' prop_toList)+ , testProperty "keys" (untag' prop_keys)+ , testProperty "insertView" (untag' prop_insertView)+ , testProperty "deleteView" (untag' prop_deleteView)+ , testProperty "map" (untag' prop_map)+ , testProperty "fmap" (untag' prop_fmap)+ , testProperty "fold'" (untag' prop_fold')+ , testProperty "foldr" (untag' prop_foldr)+ , testProperty "valid" (untag' prop_valid)+ ]+ where+ untag' :: Tagged psq test -> test+ untag' = untag+++--------------------------------------------------------------------------------+-- HUnit tests+--------------------------------------------------------------------------------++test_rnf+ :: forall psq. (PSQ psq, TestKey (Key psq),+ NFData (psq Int Char))+ => Tagged psq Assertion+test_rnf = Tagged $+ rnf (empty :: psq Int Char) `seq` return ()++test_equality+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Eq (psq Int Char))+ => Tagged psq Assertion+test_equality = Tagged $ do+ -- Mostly to get 100% coverage+ assert $ e /= s+ assert $ s /= e+ where+ e = empty :: psq Int Char+ s = singleton 3 100 'a' :: psq Int Char++test_size+ :: forall psq. (PSQ psq, TestKey (Key psq))+ => Tagged psq Assertion+test_size = Tagged $ do+ null (empty :: psq Int Char) @?= True+ null (singleton 1 100 'a' :: psq Int Char) @?= False++test_size2+ :: forall psq. (PSQ psq, TestKey (Key psq))+ => Tagged psq Assertion+test_size2 = Tagged $ do+ size (empty :: psq Int ()) @?= 0+ size (singleton 1 100 'a' :: psq Int Char) @?= 1+ size (fromList [(1, 100, 'a'), (2, 101, 'c'), (3, 102, 'b')]+ :: psq Int Char) @?= 3++test_empty+ :: forall psq. (PSQ psq, TestKey (Key psq))+ => Tagged psq Assertion+test_empty = Tagged $ do+ toList (empty :: psq Int ()) @?= []+ size (empty :: psq Char Int) @?= 0++test_lookup+ :: forall psq. (PSQ psq, TestKey (Key psq))+ => Tagged psq Assertion+test_lookup = Tagged $ do+ employeeCurrency 1 @?= Just 1+ employeeCurrency 2 @?= Nothing+ where+ employeeDept = fromList [(1, 100, 2), (3, 101, 1)] :: psq Int Int+ deptCountry = fromList [(1, 102, 1), (2, 103, 2)] :: psq Int Int+ countryCurrency = fromList [(1, 104, 2), (2, 105, 1)] :: psq Int Int++ employeeCurrency :: Int -> Maybe Int+ employeeCurrency name = do+ dept <- snd <$> lookup (toTestKey name) employeeDept+ country <- snd <$> lookup (toTestKey dept) deptCountry+ snd <$> lookup (toTestKey country) countryCurrency++test_findMin+ :: forall psq. (PSQ psq, TestKey (Key psq))+ => Tagged psq Assertion+test_findMin = Tagged $ do+ findMin (empty :: psq Int Char) @?= Nothing+ findMin (fromList [(5, 101, 'a'), (3, 100, 'b')] :: psq Int Char) @?=+ Just (3, 100, 'b')++test_alter+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Eq (psq Int Char), Show (psq Int Char))+ => Tagged psq Assertion+test_alter = Tagged $ do+ alter f 3 (empty :: psq Int Char) @?= ("Hello", singleton 3 100 'a')+ alter f 3 (singleton 3 100 'a' :: psq Int Char) @?= ("World", empty)+ alter f 3 (singleton 3 100 'b' :: psq Int Char) @?=+ ("Cats", singleton 3 101 'b')+ where+ f Nothing = ("Hello", Just (100, 'a'))+ f (Just (100, 'a')) = ("World", Nothing)+ f (Just _) = ("Cats", Just (101, 'b'))++test_alterMin+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Eq (psq Int Char), Show (psq Int Char))+ => Tagged psq Assertion+test_alterMin = Tagged $ do+ alterMin (\_ -> ((), Nothing)) (empty :: psq Int Char) @?= ((), empty)+ alterMin (\_ -> ((), Nothing)) (singleton 3 100 'a' :: psq Int Char) @?=+ ((), empty)++test_fromList+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Eq (psq Int Char), Show (psq Int Char))+ => Tagged psq Assertion+test_fromList = Tagged $+ let ls = [(1, 0, 'A'), (2, 0, 'B'), (3, 0, 'C'), (4, 0, 'D')]+ in (fromList ls :: psq Int Char) @?= fromList (reverse ls)++test_foldr+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Foldable (psq Int))+ => Tagged psq Assertion+test_foldr = Tagged $+ foldr (\x acc -> acc + ord x) 0 (empty :: psq Int Char) @?= 0+++--------------------------------------------------------------------------------+-- QuickCheck properties+--------------------------------------------------------------------------------++-- | For 100% test coverage...+prop_show+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Show (psq Int Char))+ => Tagged psq Property+prop_show = Tagged $+ forAll arbitraryPSQ $ \t ->+ length (coverShowInstance (t :: psq Int Char)) > 0++-- | For 100% test coverage...+prop_rnf+ :: forall psq. (PSQ psq, TestKey (Key psq),+ NFData (psq Int Char), Show (psq Int Char))+ => Tagged psq Property+prop_rnf = Tagged $+ forAll arbitraryPSQ $ \t ->+ rnf (t :: psq Int Char) `seq` True++prop_size+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_size = Tagged $ \t ->+ size (t :: psq Int Char) == length (toList t)++prop_singleton+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Eq (psq Int Char))+ => Tagged psq Property+prop_singleton = Tagged $+ forAll arbitraryTestKey $ \k ->+ forAll arbitraryPriority $ \p ->+ forAll arbitrary $ \x ->+ insert k p x empty == (singleton k p x :: psq Int Char)++prop_memberLookup+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_memberLookup = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ case lookup k (t :: psq Int Char) of+ Nothing -> not (member k t)+ Just _ -> member k t++prop_insertLookup+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_insertLookup = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ forAll arbitraryPriority $ \p ->+ forAll arbitrary $ \c ->+ lookup k (insert k p c (t :: psq Int Char)) == Just (p, c)++prop_insertDelete+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_insertDelete = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ forAll arbitraryPriority $ \p ->+ forAll arbitrary $ \c ->+ (lookup k t == Nothing) ==>+ (delete k (insert k p c t) == (t :: psq Int Char))++prop_insertDeleteView+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_insertDeleteView = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ forAll arbitraryPriority $ \p ->+ forAll arbitrary $ \c ->+ case deleteView k (insert k p c (t :: psq Int Char)) of+ Nothing -> False+ Just (p', c', t')+ | member k t -> p' == p && c' == c && size t' < size t+ | otherwise -> p' == p && c' == c && t' == t++prop_deleteNonMember+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_deleteNonMember = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ (lookup k t == Nothing) ==> (delete k t == (t :: psq Int Char))++prop_alter+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_alter = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ let ((), t') = alter f k t :: ((), psq Int Char)+ in case lookup k t of+ Just _ -> (size t - 1) == size t' && lookup k t' == Nothing+ Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing+ where+ f Nothing = ((), Just (100, 'a'))+ f (Just _) = ((), Nothing)++prop_alterMin+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_alterMin = Tagged $ \t ->+ let (mbMin, t') = alterMin f (t :: psq Int Char)+ in case mbMin of+ Nothing -> t' == singleton 3 100 'a'+ Just (k, p, v) ->+ findMin t == Just (k, p, v) &&+ member k t &&+ (case () of+ _ | isAlphaNum v -> lookup k t' == Just (fromTestKey k, v)+ | isPrint v -> lookup (toTestKey $ ord v) t' ==+ Just (ord v, v)+ | otherwise -> not (member k t'))+ where+ f Nothing = (Nothing, Just (3, 100, 'a'))+ f (Just (k, p, v))+ | isAlphaNum v = (Just (k, p, v), Just (k, fromTestKey k, v))+ | isPrint v = (Just (k, p, v), Just (toTestKey (ord v), ord v, v))+ | otherwise = (Just (k, p, v), Nothing)++prop_toList+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_toList = Tagged $ \t ->+ (t :: psq Int Char) == fromList (toList t)++prop_keys+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_keys = Tagged $ \t ->+ List.sort (keys (t :: psq Int Char)) ==+ List.sort [k | (k, _, _) <- toList t]++prop_insertView+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_insertView = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ forAll arbitraryPriority $ \p ->+ forAll arbitrary $ \x ->+ case insertView k p x (t :: psq Int Char) of+ (mbPx, t') ->+ lookup k t == mbPx && lookup k t' == Just (p, x)++prop_deleteView+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Property)+prop_deleteView = Tagged $ \t ->+ forAll arbitraryTestKey $ \k ->+ case deleteView k (t :: psq Int Char) of+ Nothing -> not (member k t)+ Just (p, v, t') -> lookup k t == Just (p, v) && not (member k t')++prop_map+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_map = Tagged $ \t ->+ map f (t :: psq Int Char) ==+ fromList (List.map (\(k, p, x) -> (k, p, f k p x)) (toList t))+ where+ f k p x = if fromEnum k > p then x else 'a'++prop_fmap+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Eq (psq Int Char),+ Functor (psq Int),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_fmap = Tagged $ \t ->+ fmap toLower (t :: psq Int Char) ==+ fromList (List.map (\(p, v, x) -> (p, v, toLower x)) (toList t))++prop_fold'+ :: forall psq. (PSQ psq, TestKey (Key psq),+ Arbitrary (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_fold' = Tagged $ \t ->+ fold' f acc0 (t :: psq Int Char) ==+ List.foldl' (\acc (k, p, x) -> f k p x acc) acc0 (toList t)+ where+ -- Needs to be commutative+ f k p x (kpSum, xs) = (kpSum + fromEnum k + p, List.sort (x : xs))+ acc0 = (0, [])++prop_foldr+ :: forall psq. (PSQ psq,+ Arbitrary (psq Int Char),+ Foldable (psq Int),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_foldr = Tagged $ \t ->+ foldr f 0 (t :: psq Int Char) ==+ List.foldr (\(_, _, x) acc -> f x acc) 0 (toList t)+ where+ f x acc = acc + ord x++prop_valid+ :: forall psq. (PSQ psq,+ Arbitrary (psq Int Char),+ Show (psq Int Char))+ => Tagged psq (psq Int Char -> Bool)+prop_valid = Tagged valid
+ tests/Data/PSQ/Class/Util.hs view
@@ -0,0 +1,80 @@+-- | Various test utilities+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.PSQ.Class.Util+ ( LousyHashedInt (..)+ , TestKey (..)+ , arbitraryInt+ , arbitraryPriority+ , arbitraryTestKey+ , coverShowInstance+ , assertErrorCall+ , largerThanMaxPrio+ ) where++import Control.Applicative ((<$>))+import Data.Hashable (Hashable (..))+import Control.Exception (ErrorCall (..), fromException, handle)+import Test.HUnit (Assertion, assertFailure)+import Test.QuickCheck (Arbitrary (..), Gen, arbitrary, choose)+import Control.DeepSeq (NFData)++import Data.PSQ.Class++-- | A type we used a key in the PSQs in the tests. It intentionally has a+-- really bad 'Hashable' instance so we get lots of collisions.+newtype LousyHashedInt = LousyHashedInt Int+ deriving (Enum, Eq, Integral, NFData, Num, Ord, Real, Show)++instance Arbitrary LousyHashedInt where+ arbitrary = LousyHashedInt <$> arbitraryInt++instance Hashable LousyHashedInt where+ hashWithSalt salt (LousyHashedInt x) = hashWithSalt salt x `mod` 100++class (Arbitrary a, Enum a, Eq a, Num a, Ord a, Show a) => TestKey a where+ toTestKey :: Int -> a+ toTestKey = toEnum++ fromTestKey :: a -> Int+ fromTestKey = fromEnum++instance TestKey LousyHashedInt where++instance TestKey Int where++arbitraryInt :: Gen Int+arbitraryInt = arbitrary++-- | Makes sure the priorities are taken from a small set so we have some+-- collisions.+arbitraryPriority :: Gen Int+arbitraryPriority = choose (-10, 10)++arbitraryTestKey :: TestKey a => Gen a+arbitraryTestKey = toEnum <$> arbitraryInt++-- | This is a bit ridiculous. We need to call all 'Show' methods to get 100%+-- coverage.+coverShowInstance :: Show a => a -> String+coverShowInstance x =+ showsPrec 0 x $+ showList [x] $+ show x++-- | Check that evaluating the second argument to Whitney Houston Normal Form+-- results in a call to `error`. The error message is passed to the first+-- handler, so you can perform checks on it.+assertErrorCall :: (String -> Assertion) -> a -> Assertion+assertErrorCall handler x = handle+ (\e -> case fromException e of+ Just (ErrorCall str) -> handler str+ Nothing -> assertFailure $+ "assertErrorCall: expected `error` but got: " ++ show e)+ (x `seq` assertFailure+ "assertErrorCall: evaluated to WHNF and no exception was thrown")++largerThanMaxPrio :: PSQ psq => psq Int v -> Int+largerThanMaxPrio = maybe 3 (+ 1) . fold' (\_ p _ acc -> max' p acc) Nothing+ where+ max' x Nothing = Just x+ max' x (Just y) = Just (max x y)
+ tests/Main.hs view
@@ -0,0 +1,31 @@+import Data.Tagged (Tagged (..), untag)++import Test.Framework (Test, defaultMain, testGroup)++import qualified Data.HashPSQ as HashPSQ+import qualified Data.HashPSQ.Tests+import qualified Data.IntPSQ as IntPSQ+import qualified Data.IntPSQ.Tests+import qualified Data.OrdPSQ as OrdPSQ+import qualified Data.OrdPSQ.Tests+import qualified Data.PSQ.Class.Tests+import Data.PSQ.Class.Util++main :: IO ()+main = defaultMain+ [ testGroup "Data.IntPSQ.Tests"+ Data.IntPSQ.Tests.tests+ , testGroup "Data.HashPSQ.Tests"+ Data.HashPSQ.Tests.tests+ , testGroup "Data.OrdPSQ.Tests"+ Data.OrdPSQ.Tests.tests+ , testGroup "Data.PSQ.Class.Tests IntPSQ" $ untag+ (Data.PSQ.Class.Tests.tests+ :: Tagged IntPSQ.IntPSQ [Test])+ , testGroup "Data.PSQ.Class.Tests PSQ" $ untag+ (Data.PSQ.Class.Tests.tests+ :: Tagged (OrdPSQ.OrdPSQ Int) [Test])+ , testGroup "Data.PSQ.Class.Tests HashPSQ" $ untag+ (Data.PSQ.Class.Tests.tests+ :: Tagged (HashPSQ.HashPSQ LousyHashedInt) [Test])+ ]