Util.hs

-- | 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
            _                    -> 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)