Example generic tests in Haskell (hspec and QuickCheck)

FrequencyTableSpec.hs

module Compression.AC.FrequencyTableSpec
  ( spec
  )
where

import           Compression.AC.FrequencyTable            ( FrequencyTable )
import qualified Compression.AC.FrequencyTable as FT
import           Data.Map                                 ( Map
                                                          , (!)
                                                          )
import qualified Data.Map                      as Map
import           Data.List                                ( nub )
import           Test.Hspec
import           Test.QuickCheck
import           Test.QuickCheck.Gen

import           System.Random

spec :: Spec
spec = do
  describe "(De)constructing" $ do
    it "fromList . toList == id" $ property $ \tree ->
      FT.fromList (FT.toList tree) == (tree :: FrequencyTable Key Value)
    it "toList . fromList == id" $ property $ \(KeyValues list) ->
      FT.toList (FT.fromList list) == (list :: [(Key, Value)])
  describe "Querying" $ do
    it "query" $ property $ \(QueryCase k tree) ->
      let kvs      = FT.toList (tree :: FrequencyTable Key Value)
          expected = sum $ map snd $ takeWhile ((<= k) . fst) kvs
      in  FT.query k tree `shouldBe` expected
    it "freq" $ property $ \(QueryCase k tree) ->
      let kvs = FT.toList (tree :: FrequencyTable Key Value)
          map = Map.fromList kvs
      in  FT.freq k tree `shouldBe` map ! k
    it "iquery" $ property $ \(InvQueryCase v tree) ->
      let kvs = FT.toList (tree :: FrequencyTable Key Value)
          kss = map fst kvs `zip` scanl1 (+) (map snd kvs)
          safeLast [] = Nothing
          safeLast xs = Just (last xs)
          expected = safeLast [ k | (k, s) <- kss, s <= v ]
      in  FT.iquery v tree `shouldBe` expected
  describe "Updating" $ do
    it "update" $ property $ \(UpdateCase k v tree) ->
      let tree' = FT.update (+ v) k (tree :: FrequencyTable Key Value)
      in  FT.query k tree' `shouldBe` (FT.query k tree + v)
    it "scale(Integral)" $ property $ \(UpdateCase k _ tree) ->
      let tree' = FT.scaleIntegral (tree :: FrequencyTable Key Value)
      in  FT.freq k tree' `shouldBe` (FT.freq k tree `div` 2)

type Key = Int
type Value = Int

instance (Ord k, Num v, Arbitrary k, Arbitrary v) => Arbitrary (FrequencyTable k v) where
  arbitrary = do
    (KeyValues kvs) <- arbitrary
    return $! FT.fromList kvs

-- | Wrapper that contains key-values list with distinct keys.
newtype KeyValues k v = KeyValues [(k, v)] deriving (Show)

instance (Ord k, Num v, Arbitrary k, Arbitrary v) => Arbitrary (KeyValues k v) where
  arbitrary = do
    keys   <- suchThat orderedList distinctElems
    values <- infiniteList
    return $! KeyValues (zip keys values)
    where distinctElems xs = nub xs == xs

-- | Wrapper that contains test cases for query cases.
data QueryCase k v = QueryCase k (FrequencyTable k v) deriving (Show)

instance (Ord k, Num v, Arbitrary k, Arbitrary v) => Arbitrary (QueryCase k v) where
  arbitrary = do
    (KeyValues kvs) <- suchThat arbitrary nonEmpty
    (k, _)          <- elements kvs
    return $! QueryCase k (FT.fromList kvs)
    where nonEmpty (KeyValues kvs) = not (null kvs)

-- | Wrapper that contains test cases for inverse query cases.
data InvQueryCase k v = InvQueryCase v (FrequencyTable k v) deriving (Show)

instance (Ord k, Num v, Random v, Arbitrary k, Arbitrary v) => Arbitrary (InvQueryCase k v) where
  arbitrary = do
    (KeyValues kvs) <- suchThat arbitrary nonEmpty
    let kvs' = map (\(k, v) -> (k, abs v)) kvs
    let tree = FT.fromList kvs'
    v <- choose
      (FT.query (fst (head kvs')) tree, FT.query (fst (last kvs')) tree)
    return $! InvQueryCase v (FT.fromList kvs')
    where nonEmpty (KeyValues kvs) = not (null kvs)

-- | Wrapper that contains test cases for updating functions.
data UpdateCase k v = UpdateCase k v (FrequencyTable k v) deriving (Show)

instance (Ord k, Num v, Random v, Arbitrary k, Arbitrary v) => Arbitrary (UpdateCase k v) where
  arbitrary = do
    (QueryCase k tree) <- arbitrary
    v                  <- arbitrary
    return $! UpdateCase k v tree