bv-little-1.3.0: test/TestSuite.hs

{-|

Copyright   : © 2020 Alex Washburn
License     : BSD-3-Clause
Maintainer  : github@recursion.ninja
Stability   : Stable

-}

{-# Language FlexibleInstances #-}
{-# Language ImportQualifiedPost #-}

  -- We apply this to suppress the deprecated warning cause by calls to 'bitSize'
  -- If there is a more fine-grained way to suppress this warning without suppressing
  -- deprecated warnings for the whole module, that should be done instead.
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

module Main
    ( main
    ) where

import Control.DeepSeq
import Data.BitVector.LittleEndian
import Data.BitVector.LittleEndian.Instances ()
import Data.BitVector.Visual
import Data.Bits
import Data.Foldable
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Hashable
import Data.Maybe
import Data.MonoTraversable
import Data.MonoTraversable.Keys
import Data.Monoid ()
import Data.Semigroup
import GHC.Exts (IsList(..))
import Operator.Binary.Comparison
import Operator.Binary.Logical
import Operator.Unary.Logical
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck hiding (forAll, testProperty, (.&.))
import Test.Tasty.QuickCheck qualified as QC
import Test.Tasty.SmallCheck hiding (Property, testProperty, (==>))
import Test.Tasty.SmallCheck qualified as SC
import TextShow (TextShow(showb), toString)


infix 0 -=>
(-=>) :: QC.Testable p => Bool -> p -> Property
(-=>) p q = not p .||. q


{-|
Complete test suite for the 'BitVector' type.
-}
main :: IO ()
main = defaultMain testSuite


testSuite :: TestTree
testSuite = testGroup
    "BitVector tests"
    [ bitsTests
    , finiteBitsTests
    , hashableTests
    , monoAdjustableProperties
    , monoFunctorProperties
    , monoFoldableProperties
    , monoFoldableWithKeyProperties
    , monoKeyedProperties
    , monoTraversableProperties
    , monoTraversableWithKeyProperties
    , monoZipProperties
    , monoZipWithKeyProperties
    , monoidProperties
    , normalFormDataProperties
    , orderingProperties
    , semigroupProperties
    , showProperties
    , textshowProperties
    , bitVectorProperties
    , bitVectorRankSelect
    , monoFunctorEquivalence
    , monoFoldableEquivalence
    , monoZipEquivalence
    ]


bitsTests :: TestTree
bitsTests = testGroup
    "Properties of Bits"
    [ QC.testProperty "∀ i ≥ 0, clearBit zeroBits i === zeroBits" zeroBitsAndClearBit
    , QC.testProperty "∀ i ≥ 0, setBit   zeroBits i === bit i" zeroBitsAndSetBit
    , QC.testProperty "∀ i ≥ 0, testBit  zeroBits i === False" zeroBitsAndTestBit
    , testCase "         popCount zeroBits   === 0" zeroBitsAndPopCount
    , QC.testProperty "complement === omap not" complementOmapNot
    , QC.testProperty "(`setBit` i) === (.|. bit i)" setBitDefinition
    , QC.testProperty "(`clearBit` i) === (.&. complement (bit i))" clearBitDefinition
    , QC.testProperty "(`complementBit` i) === (`xor` bit i)" complementBitDefinition
    , QC.testProperty "(`testBit` i) . (`setBit` n)" testBitAndSetBit
    , QC.testProperty "not  . (`testBit` i) . (`clearBit` i)" testBitAndClearBit
    , QC.testProperty "(`shiftL`  i) === (`shift`   i)" leftShiftPositiveShift
    , QC.testProperty "(`shiftR`  i) === (`shift`  -i)" rightShiftNegativeShift
    , QC.testProperty "(`rotateL` i) === (`rotate`  i)" leftRotatePositiveRotate
    , QC.testProperty "(`rotateR` i) === (`rotate` -i)" rightRotateNegativeRotate
    , QC.testProperty "(`rotateR` i) . (`rotateL` i) === id" leftRightRotateIdentity
    , QC.testProperty "(`rotateL` i) . (`rotateR` i) === id" rightLeftRotateIdentity
    ]
    where
        zeroBitsAndClearBit :: NonNegative Int -> Property
        zeroBitsAndClearBit (NonNegative i) = clearBit (zeroBits :: BitVector) i === zeroBits

        zeroBitsAndSetBit :: NonNegative Int -> Property
        zeroBitsAndSetBit (NonNegative i) = setBit (zeroBits :: BitVector) i === bit i

        zeroBitsAndTestBit :: NonNegative Int -> Property
        zeroBitsAndTestBit (NonNegative i) = testBit (zeroBits :: BitVector) i === False

        zeroBitsAndPopCount :: Assertion
        zeroBitsAndPopCount = popCount (zeroBits :: BitVector) @?= 0

        complementOmapNot :: BitVector -> Property
        complementOmapNot bv = complement bv === omap not bv

        setBitDefinition :: NonNegative Int -> BitVector -> Property
        setBitDefinition (NonNegative i) bv = bv `setBit` i === bv .|. bit i

        clearBitDefinition :: NonNegative Int -> BitVector -> Property
        clearBitDefinition (NonNegative i) bv =
            i < (fromEnum . dimension) bv -=> (bv `clearBit` i === bv .&. complement (zed .|. bit i))
            where zed = fromNumber (dimension bv) (0 :: Integer)

        complementBitDefinition :: NonNegative Int -> BitVector -> Property
        complementBitDefinition (NonNegative i) bv = bv `complementBit` i === bv `xor` bit i

        testBitAndSetBit :: NonNegative Int -> BitVector -> Bool
        testBitAndSetBit (NonNegative i) = (`testBit` i) . (`setBit` i)

        testBitAndClearBit :: NonNegative Int -> BitVector -> Bool
        testBitAndClearBit (NonNegative i) = not . (`testBit` i) . (`clearBit` i)

        leftShiftPositiveShift :: NonNegative Int -> BitVector -> Property
        leftShiftPositiveShift (NonNegative i) bv = bv `shiftL` i === bv `shift` i

        rightShiftNegativeShift :: NonNegative Int -> BitVector -> Property
        rightShiftNegativeShift (NonNegative i) bv = bv `shiftR` i === bv `shift` (-i)

        leftRotatePositiveRotate :: NonNegative Int -> BitVector -> Property
        leftRotatePositiveRotate (NonNegative i) bv = bv `rotateL` i === bv `rotate` i

        rightRotateNegativeRotate :: NonNegative Int -> BitVector -> Property
        rightRotateNegativeRotate (NonNegative i) bv = bv `rotateR` i === bv `rotate` (-i)

        leftRightRotateIdentity :: NonNegative Int -> BitVector -> Property
        leftRightRotateIdentity (NonNegative i) bv = ((`rotateR` i) . (`rotateL` i)) bv === bv

        rightLeftRotateIdentity :: NonNegative Int -> BitVector -> Property
        rightLeftRotateIdentity (NonNegative i) bv = ((`rotateL` i) . (`rotateR` i)) bv === bv


finiteBitsTests :: TestTree
finiteBitsTests = testGroup
    "Properties of FiniteBits"
    [ QC.testProperty "bitSize === finiteBitSize" finiteBitSizeIsBitSize
    , QC.testProperty "bitSizeMaybe === Just . finiteBitSize" finiteBitSizeIsBitSizeMaybe
    , QC.testProperty "dimension === finiteBitSize" finiteBitSizeIsDimension
    , QC.testProperty "countLeadingZeros <= finiteBitSize" finiteBitSizeIsGreaterThanLeadingZeros
    , QC.testProperty "countTrailingZeros <= finiteBitSize" finiteBitSizeIsGreaterThanTrailingZeros
    , QC.testProperty "length . toBits === finiteBitSize" finiteBitSizeIsBitLength
    , QC.testProperty "length . takeWhile not === countLeadingZeros . fromBits" countLeadingZeroAndFromBits
    , QC.testProperty "length . takeWhile not . toBits === countLeadingZeros" countLeadingZeroAndToBits
    , QC.testProperty
        "length . takeWhile not . reverse === countTrailingZeros . fromBits"
        countTrailingZeroAndFromBits
    , QC.testProperty
        "length . takeWhile not . reverse . toBits === countTrailingZeros"
        countTrailingZeroAndToBits
    ]
    where
        finiteBitSizeIsBitSize :: BitVector -> Property
        finiteBitSizeIsBitSize bv = bitSize bv === finiteBitSize bv

        finiteBitSizeIsBitSizeMaybe :: BitVector -> Property
        finiteBitSizeIsBitSizeMaybe bv = bitSizeMaybe bv === (Just . finiteBitSize) bv

        finiteBitSizeIsDimension :: BitVector -> Property
        finiteBitSizeIsDimension bv = (fromEnum . dimension) bv === finiteBitSize bv

        finiteBitSizeIsGreaterThanLeadingZeros :: BitVector -> Bool
        finiteBitSizeIsGreaterThanLeadingZeros bv = countLeadingZeros bv <= finiteBitSize bv

        finiteBitSizeIsGreaterThanTrailingZeros :: BitVector -> Bool
        finiteBitSizeIsGreaterThanTrailingZeros bv = countTrailingZeros bv <= finiteBitSize bv

        finiteBitSizeIsBitLength :: BitVector -> Property
        finiteBitSizeIsBitLength bv = (length . toBits) bv === finiteBitSize bv

        countLeadingZeroAndFromBits :: [Bool] -> Property
        countLeadingZeroAndFromBits bs = (length . takeWhile not) bs === (countLeadingZeros . fromBits) bs

        countLeadingZeroAndToBits :: BitVector -> Property
        countLeadingZeroAndToBits bv = (length . takeWhile not . toBits) bv === countLeadingZeros bv

        countTrailingZeroAndFromBits :: [Bool] -> Property
        countTrailingZeroAndFromBits bs =
            (length . takeWhile not . reverse) bs === (countTrailingZeros . fromBits) bs

        countTrailingZeroAndToBits :: BitVector -> Property
        countTrailingZeroAndToBits bv =
            (length . takeWhile not . reverse . toBits) bv === countTrailingZeros bv


hashableTests :: TestTree
hashableTests = testGroup
    "Properties of Hashable"
    [ localOption (QuickCheckTests 10000)
        $ QC.testProperty "a == b -=> (hashWithSalt a) === (hashWithSalt b)" differentSaltsDifferentHashes
    ]
    where
        differentSaltsDifferentHashes :: BitVector -> Int -> Int -> Property
        differentSaltsDifferentHashes bv salt1 salt2 =
            salt1 /= salt2 -=> hashWithSalt salt1 bv /= hashWithSalt salt2 bv


monoAdjustableProperties :: TestTree
monoAdjustableProperties = testGroup
    "Properties of a MonoAdjustable"
    [ QC.testProperty "oadjust id k === id" oadjustId
    , QC.testProperty "oadjust (f . g) k === oadjust f k . oadjust g k" oadjustComposition
    , QC.testProperty "oadjust f k === omapWithKey (\\i -> if i == k then f else id)" omapConditionality
    , QC.testProperty "oreplace k v === oreplace k v . oadjust f k" oreplaceNullification
    , QC.testProperty "oreplace (f v) k === oadjust f k . oreplace k v" oreplaceApplication
    ]
    where
        oadjustId :: Word -> BitVector -> Property
        oadjustId k bv = oadjust id k bv === bv

        oadjustComposition :: Blind (Bool -> Bool) -> Blind (Bool -> Bool) -> Word -> BitVector -> Property
        oadjustComposition (Blind f) (Blind g) k bv = oadjust (f . g) k bv === (oadjust f k . oadjust g k) bv

        omapConditionality :: Blind (Bool -> Bool) -> Word -> BitVector -> Property
        omapConditionality (Blind f) k bv =
            oadjust f k bv === omapWithKey (\i -> if i == k then f else id) bv

        oreplaceNullification :: Blind (Bool -> Bool) -> Word -> Bool -> BitVector -> Property
        oreplaceNullification (Blind f) k v bv = oreplace k v bv === (oreplace k v . oadjust f k) bv

        oreplaceApplication :: Blind (Bool -> Bool) -> Word -> Bool -> BitVector -> Property
        oreplaceApplication (Blind f) k v bv = oreplace k (f v) bv === (oadjust f k . oreplace k v) bv


monoFunctorProperties :: TestTree
monoFunctorProperties = testGroup
    "Properties of a MonoFunctor"
    [ QC.testProperty "omap id === id" omapId
    , QC.testProperty "omap (f . g)  === omap f . omap g" omapComposition
    ]
    where
        omapId :: BitVector -> Property
        omapId bv = omap id bv === bv

        omapComposition :: Blind (Bool -> Bool) -> Blind (Bool -> Bool) -> BitVector -> Property
        omapComposition (Blind f) (Blind g) bv = omap (f . g) bv === (omap f . omap g) bv


monoFoldableProperties :: TestTree
monoFoldableProperties = testGroup
    "Properties of MonoFoldable"
    [ QC.testProperty "ofoldr f z t === appEndo (ofoldMap (Endo . f) t ) z" testFoldrFoldMap
    , QC.testProperty
        "ofoldl' f z t === appEndo (getDual (ofoldMap (Dual . Endo . flip f) t)) z"
        testFoldlFoldMap
    , QC.testProperty "ofoldr f z === ofoldr f z . otoList" testFoldr
    , QC.testProperty "ofoldl' f z === ofoldl' f z . otoList" testFoldl
    , QC.testProperty "ofoldr1Ex f === foldr1 f . otoList" testFoldr1
    , QC.testProperty "ofoldl1Ex' f === foldl1 f . otoList" testFoldl1
    , QC.testProperty "oall f === getAll . ofoldMap (All . f)" testAll
    , QC.testProperty "oany f === getAny . ofoldMap (Any . f)" testAny
    , QC.testProperty "olength === length . otoList" testLength
    , QC.testProperty "onull === (0 ==) . olength" testNull
    , QC.testProperty "headEx === getFirst . ofoldMap1Ex First" testHead
    , QC.testProperty "lastEx === getLast . ofoldMap1Ex Last" testTail
    , QC.testProperty "oelem e /== onotElem e" testInclusionConsistency
    ]
    where
        testFoldrFoldMap :: Blind (Bool -> Word -> Word) -> Word -> BitVector -> Property
        testFoldrFoldMap (Blind f) z bv = ofoldr f z bv === appEndo (ofoldMap (Endo . f) bv) z

        testFoldlFoldMap :: Blind (Word -> Bool -> Word) -> Word -> BitVector -> Property
        testFoldlFoldMap (Blind f) z bv =
            ofoldl' f z bv === appEndo (getDual (ofoldMap (Dual . Endo . flip f) bv)) z

        testFoldr :: Blind (Bool -> Word -> Word) -> Word -> BitVector -> Property
        testFoldr (Blind f) z bv = ofoldr f z bv === (ofoldr f z . otoList) bv

        testFoldl :: Blind (Word -> Bool -> Word) -> Word -> BitVector -> Property
        testFoldl (Blind f) z bv = ofoldl' f z bv === (ofoldl' f z . otoList) bv

    --    testFoldr1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property
        testFoldr1 :: BinaryLogicalOperator -> BitVector -> Property
    --    testFoldr1 (Blind f) bv =
        testFoldr1 x bv = (not . onull) bv -=> ofoldr1Ex f bv === (foldr1 f . otoList) bv
            where f = getBinaryLogicalOperator x

        testFoldl1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property
        testFoldl1 (Blind f) bv = (not . onull) bv -=> ofoldl1Ex' f bv === (foldl1 f . otoList) bv

        testAll :: Blind (Bool -> Bool) -> BitVector -> Property
        testAll (Blind f) bv = oall f bv === (getAll . ofoldMap (All . f)) bv

        testAny :: Blind (Bool -> Bool) -> BitVector -> Property
        testAny (Blind f) bv = oany f bv === (getAny . ofoldMap (Any . f)) bv

        testLength :: BitVector -> Property
        testLength bv = olength bv === (length . otoList) bv

        testNull :: BitVector -> Property
        testNull bv = onull bv === ((0 ==) . olength) bv

        testHead :: BitVector -> Property
        testHead bv = (not . onull) bv -=> headEx bv === (getFirst . ofoldMap1Ex First) bv

        testTail :: BitVector -> Property
        testTail bv = (not . onull) bv -=> lastEx bv === (getLast . ofoldMap1Ex Last) bv

        testInclusionConsistency :: (Bool, BitVector) -> Property
        testInclusionConsistency (e, bv) = oelem e bv === (not . onotElem e) bv


monoFoldableWithKeyProperties :: TestTree
monoFoldableWithKeyProperties = testGroup
    "Properties of MonoFoldableWithKey"
    [ QC.testProperty "otoKeyedList === zip [0..] . otoList" testNaturalKeyedList
    , QC.testProperty "ofoldMapWithKey (const f) === ofoldMap f" testConstantFoldMap
    , QC.testProperty "ofoldrWithKey (const f) === ofoldr f" testConstantFoldr
    , QC.testProperty "ofoldlWithKey (const . f) === ofoldl f" testConstantFoldl
    , QC.testProperty "ofoldMapWithKey f === foldMap (uncurry f) . otoKeyedList" testUncurriedFoldMap
    , QC.testProperty "ofoldrWithKey f === foldr (uncurry f) . otoKeyedList" testUncurriedFoldr
    , QC.testProperty "ofoldlWithKey f === foldl (uncurry . f) . otoKeyedList" testUncurriedFoldl
    ]
    where
        testNaturalKeyedList :: BitVector -> Property
        testNaturalKeyedList bv = otoKeyedList bv === (zip [0 ..] . otoList) bv

        testConstantFoldMap :: Blind (Bool -> [Word]) -> BitVector -> Property
        testConstantFoldMap (Blind f) bv = ofoldMapWithKey (const f) bv === ofoldMap f bv

        testConstantFoldr :: Blind (Bool -> Word -> Word) -> Word -> BitVector -> Property
        testConstantFoldr (Blind f) e bv = ofoldrWithKey (const f) e bv === ofoldr f e bv

        testConstantFoldl :: Blind (Word -> Bool -> Word) -> Word -> BitVector -> Property
        testConstantFoldl (Blind f) e bv = ofoldlWithKey (const . f) e bv === ofoldl' f e bv

        testUncurriedFoldMap :: Blind (Word -> Bool -> [Word]) -> BitVector -> Property
        testUncurriedFoldMap (Blind f) bv = ofoldMapWithKey f bv === (foldMap (uncurry f) . otoKeyedList) bv

        testUncurriedFoldr :: Blind (Word -> Bool -> Word -> Word) -> Word -> BitVector -> Property
        testUncurriedFoldr (Blind f) e bv = ofoldrWithKey f e bv === (foldr (uncurry f) e . otoKeyedList) bv

        testUncurriedFoldl :: Blind (Word -> Word -> Bool -> Word) -> Word -> BitVector -> Property
        testUncurriedFoldl (Blind f) e bv =
            ofoldlWithKey f e bv === (foldl (uncurry . f) e . otoKeyedList) bv


monoKeyedProperties :: TestTree
monoKeyedProperties = testGroup
    "Properties of a MonoKeyed"
    [ QC.testProperty "omapWithKey (const id) === id" omapId
    , QC.testProperty "omapWithKey (\\k -> f k . g k)  === omapWithKey f . omapWithKey g" omapComposition
    ]
    where
        omapId :: BitVector -> Property
        omapId bv = omapWithKey (const id) bv === bv

        omapComposition
            :: Blind (Word -> Bool -> Bool) -> Blind (Word -> Bool -> Bool) -> BitVector -> Property
        omapComposition (Blind f) (Blind g) bv =
            omapWithKey (\k -> f k . g k) bv === (omapWithKey f . omapWithKey g) bv


monoTraversableProperties :: TestTree
monoTraversableProperties = testGroup
    "Properties of MonoTraversable"
    [ QC.testProperty "t . otraverse f === otraverse (t . f)" testNaturality
    , QC.testProperty "otraverse Identity === Identity" testIdentity
    , QC.testProperty
        "otraverse (Compose . fmap g . f) === Compose . fmap (otraverse g) . otraverse f"
        testComposition
    , QC.testProperty "otraverse === omapM" testDefinitionEquality
    ]
    where
        testNaturality :: Blind (Bool -> [Bool]) -> BitVector -> Property
        testNaturality (Blind f) bv = (headMay . otraverse f) bv === otraverse (headMay . f) bv

        testIdentity :: BitVector -> Property
        testIdentity bv = otraverse Identity bv === Identity bv

        testComposition
            :: Blind (Bool -> Either Word Bool) -> Blind (Bool -> Maybe Bool) -> BitVector -> Property
        testComposition (Blind f) (Blind g) bv =
            otraverse (Compose . fmap g . f) bv === (Compose . fmap (otraverse g) . otraverse f) bv

        testDefinitionEquality :: Blind (Bool -> Maybe Bool) -> BitVector -> Property
        testDefinitionEquality (Blind f) bv = otraverse f bv === omapM f bv


monoTraversableWithKeyProperties :: TestTree
monoTraversableWithKeyProperties = testGroup
    "Properties of MonoTraversableWithKey"
    [ QC.testProperty "t . otraverseWithKey f === otraverseWithKey (\\k -> t . f k)" testNaturality
    , QC.testProperty "otraverseWithKey (const Identity) === Identity" testIdentity
    , QC.testProperty
        "otraverseWithKey (\\k -> Compose . fmap (g k) . f k) === Compose . fmap (otraverseWithKey g) . otraverseWithKey f"
        testComposition
    , QC.testProperty "otraverseWithKey === omapWithKeyM" testDefinitionEquality
    ]
    where
        testNaturality :: Blind (Word -> Bool -> [Bool]) -> BitVector -> Property
        testNaturality (Blind f) bv =
            (headMay . otraverseWithKey f) bv === otraverseWithKey (\k -> headMay . f k) bv

        testIdentity :: BitVector -> Property
        testIdentity bv = otraverseWithKey (const Identity) bv === Identity bv

        testComposition
            :: Blind (Word -> Bool -> Either Word Bool)
            -> Blind (Word -> Bool -> Maybe Bool)
            -> BitVector
            -> Property
        testComposition (Blind f) (Blind g) bv = otraverseWithKey (\k -> Compose . fmap (g k) . f k) bv
            === (Compose . fmap (otraverseWithKey g) . otraverseWithKey f) bv

        testDefinitionEquality :: Blind (Word -> Bool -> Maybe Bool) -> BitVector -> Property
        testDefinitionEquality (Blind f) bv = otraverseWithKey f bv === omapWithKeyM f bv


monoZipProperties :: TestTree
monoZipProperties = testGroup
    "Properties of a MonoZip"
    [ QC.testProperty "ozipWith const u u === ozipWith (const id) u u === u" ozipWithConst
    , QC.testProperty "ozipWith (flip f) x y === ozipWith f y x" ozipWithTransposition
    , QC.testProperty
        "ozipWith (\\a b -> f (g a) (h b)) x y === ozipWith f (omap g x) (omap h y)"
        ozipWithComposition
    ]
    where
        ozipWithConst :: BitVector -> Property
        ozipWithConst u = ozipWith const u u === u .&&. ozipWith (const id) u u === u

        ozipWithTransposition :: Blind (Bool -> Bool -> Bool) -> BitVector -> BitVector -> Property
        ozipWithTransposition (Blind f) x y = ozipWith (flip f) x y === ozipWith f y x

        ozipWithComposition
            :: Blind (Bool -> Bool -> Bool)
            -> Blind (Bool -> Bool)
            -> Blind (Bool -> Bool)
            -> BitVector
            -> BitVector
            -> Property
        ozipWithComposition (Blind f) (Blind g) (Blind h) x y =
            ozipWith (\a b -> f (g a) (h b)) x y === ozipWith f (omap g x) (omap h y)


monoZipWithKeyProperties :: TestTree
monoZipWithKeyProperties = testGroup
    "Properties of a MonoZipWithKey"
    [QC.testProperty "ozipWithKey (const f) === ozipWith f" ozipWithKeyConst]
    where
        ozipWithKeyConst :: Blind (Bool -> Bool -> Bool) -> BitVector -> BitVector -> Property
        ozipWithKeyConst (Blind f) x y = ozipWithKey (const f) x y === ozipWith f x y


{- HLINT ignore monoidProperties "Monoid law, left identity" -}
{- HLINT ignore monoidProperties "Monoid law, right identity" -}
{- HLINT ignore monoidProperties "Use fold" -}
monoidProperties :: TestTree
monoidProperties = testGroup
    "Properties of a Monoid"
    [ QC.testProperty "left identity" leftIdentity
    , QC.testProperty "right identity" rightIdentity
    , QC.testProperty "mempty is associative" operationAssociativity
    , QC.testProperty "mconcat === foldr (<>) mempty" foldableApplication
    ]
    where
        leftIdentity :: BitVector -> Property
        leftIdentity a = mempty `mappend` a === a

        rightIdentity :: BitVector -> Property
        rightIdentity a = a `mappend` mempty === a

        operationAssociativity :: BitVector -> BitVector -> BitVector -> Property
        operationAssociativity a b c = a `mappend` (b `mappend` c) === (a `mappend` b) `mappend` c

        foldableApplication :: [BitVector] -> Property
        foldableApplication bvs = mconcat bvs === foldr mappend mempty bvs


normalFormDataProperties :: TestTree
normalFormDataProperties = testGroup
    "Properties of NFData"
    [QC.testProperty "rnf result is finite" finiteReduction]
    where
        finiteReduction :: BitVector -> Property
        finiteReduction bv = rnf bv === ()


orderingProperties :: TestTree
orderingProperties = testGroup
    "Properties of an Ordering"
    [ QC.testProperty "ordering preserves symmetry" symmetry
    , QC.testProperty "ordering is transitive (total)" transitivity
    ]
    where
        symmetry :: BitVector -> BitVector -> Bool
        symmetry lhs rhs = case (lhs `compare` rhs, rhs `compare` lhs) of
            (EQ, EQ) -> True
            (GT, LT) -> True
            (LT, GT) -> True
            _        -> False

        transitivity :: BitVector -> BitVector -> BitVector -> Property
        transitivity a b c = caseOne .||. caseTwo
            where
                caseOne = (a <= b && b <= c) -=> a <= c
                caseTwo = (a >= b && b >= c) -=> a >= c


semigroupProperties :: TestTree
semigroupProperties = testGroup
    "Properties of a Semigroup"
    [ localOption (QuickCheckTests 10000) $ QC.testProperty "(<>) is associative" operationAssociativity
    , QC.testProperty "sconcat === foldr1 (<>)" foldableApplication
    , QC.testProperty "stimes n === mconcat . replicate n" repeatedApplication
    ]
    where
        operationAssociativity :: BitVector -> BitVector -> BitVector -> Property
        operationAssociativity a b c = a <> (b <> c) === (a <> b) <> c

        foldableApplication :: NonEmptyList BitVector -> Property
        foldableApplication manyBVs = sconcat bvs === foldr1 mappend bvs
            where
            -- We do this because there is currently no Arbitrary instance for NonEmpty
                  bvs = fromList $ getNonEmpty manyBVs

        repeatedApplication :: NonNegative Int -> BitVector -> Property
        repeatedApplication (NonNegative i) bv = stimes i bv === (mconcat . replicate i) bv


showProperties :: TestTree
showProperties = testGroup
    "Properties of Show"
    [ QC.testProperty "show result is finite" finiteString
    , QC.testProperty "show result is non-null" nonNullString
    ]
    where
        finiteString :: BitVector -> Property
        finiteString bv = show bv === show bv

        nonNullString :: BitVector -> Bool
        nonNullString = not . null . show



textshowProperties :: TestTree
textshowProperties = testGroup "Properties of TextShow"
    [ QC.testProperty "textshow and show result agree" textshowCoherence
    ]
  where
    textshowCoherence :: BitVector -> Property
    textshowCoherence bv =
        (toString . showb $ bv) === show bv


bitVectorProperties :: TestTree
bitVectorProperties = testGroup
    "BitVector properties"
    [ QC.testProperty "otoList === toBits" otoListTest
    , QC.testProperty "dimension === length . toBits" dimensionAndToBits
    , QC.testProperty "dimension === finiteBitSize" dimensionAndFiniteBitSize
    , QC.testProperty "fromBits . toBits === id" toBitsFromBits
    , testCase "isZeroVector zeroBits" zeroBitsIsZeroVector
    , QC.testProperty "isZeroVector === (0 ==) . popCount" popCountAndZeroVector
    , QC.testProperty "isZeroVector === all not . toBits" zeroVectorAndAllBitsOff
    , QC.testProperty "(0 ==) . toUnsignedNumber -=> isZeroVector" toUnsignedNumImpliesZeroVector
    , QC.testProperty "toSignedNumber . fromNumber === id" bitVectorUnsignedNumIdentity
    , QC.testProperty "isSigned == const False" noSignBitVector
-- For an unknown reason, this test case causes GHC to panic!
    , QC.testProperty "i >  j -=> subRange (i,j) === const zeroBits" badSubRangeEmptyResult
    , QC.testProperty "i <= j -=> dimension . subRange (i,j) === const (j - i + 1)" subRangeFixedDimension
    ]
    where
        otoListTest :: BitVector -> Property
        otoListTest bv = otoList bv === toBits bv

        dimensionAndToBits :: BitVector -> Property
        dimensionAndToBits bv = (fromEnum . dimension) bv === (length . toBits) bv

        dimensionAndFiniteBitSize :: BitVector -> Property
        dimensionAndFiniteBitSize bv = (fromEnum . dimension) bv === finiteBitSize bv

        toBitsFromBits :: BitVector -> Property
        toBitsFromBits bv = (fromBits . toBits) bv === bv

        zeroBitsIsZeroVector :: Assertion
        zeroBitsIsZeroVector = assertBool "zeroBits is not a 'zero vector'" $ isZeroVector zeroBits

        popCountAndZeroVector :: BitVector -> Property
        popCountAndZeroVector bv = isZeroVector bv === ((0 ==) . popCount) bv

        zeroVectorAndAllBitsOff :: BitVector -> Property
        zeroVectorAndAllBitsOff bv = isZeroVector bv === (all not . toBits) bv

        toUnsignedNumImpliesZeroVector :: BitVector -> Property
        toUnsignedNumImpliesZeroVector bv =
            ((0 ==) . (toUnsignedNumber :: BitVector -> Integer)) bv -=> isZeroVector bv

        bitVectorUnsignedNumIdentity :: Integer -> Property
        bitVectorUnsignedNumIdentity num = (toSignedNumber . fromNumber width) num === num
            where width = succ . succ . ceiling . logBase (2.0 :: Double) . fromIntegral $ abs num

        noSignBitVector :: BitVector -> Property
        noSignBitVector bv = isSigned bv === False

        badSubRangeEmptyResult :: (Word, Word) -> BitVector -> Property
        badSubRangeEmptyResult range@(lower, upper) bv = lower > upper -=> subRange range bv === zeroBits

        subRangeFixedDimension :: (NonNegative Int, NonNegative Int) -> BitVector -> Property
        subRangeFixedDimension (NonNegative lowerI, NonNegative upperI) bv =
            lower <= upper -=> dimension (subRange (lower, upper) bv) === upper - lower + 1
            where
                lower = toEnum lowerI
                upper = toEnum upperI


bitVectorRankSelect :: TestTree
bitVectorRankSelect = testGroup
    "BitVector rank/select"
    [ QC.testProperty "select (bit i) 0 === i" selectBitValue
    , QC.testProperty "select (bit x .|. bit y) 0 === min (select (bit x) 0) (select (bit y) 0)" selectBitOr
    , QC.testProperty
        "rank (bit x .|. bit y) (max x y + 1) === rank (bit x) (x+1) + rank (bit y) (y+1)"
        rankBitOr
    , QC.testProperty "rank (bit i) (i+1) === i" rankBitValue
    , QC.testProperty "rank <$> id <*> dimension === popCount" rankPopCount
    , QC.testProperty "rank bv i === length . filter id . take i . toBits bv" rankToBits
    , QC.testProperty "rank bv (select bv i) === i" rankSelectMinDef
    ]
    where
        selectBitValue :: NonNegative Int -> Property
        selectBitValue (NonNegative x) = select (bit x) 0 === Just (toEnum x)

        selectBitOr :: NonNegative Int -> NonNegative Int -> Property
        selectBitOr (NonNegative x) (NonNegative y) =
            select (bit x .|. bit y) 0 === min (select (bit x) 0) (select (bit y) 0)

        rankBitValue :: NonNegative Word -> Property
        rankBitValue (NonNegative x) = rank (bit (fromEnum x)) (x + 1) === 1

        rankBitOr :: NonNegative Int -> NonNegative Int -> Property
        rankBitOr (NonNegative x) (NonNegative y) =
            x /= y -=> rank (bit x .|. bit y) z' === rank (bit x) (x' + 1) + rank (bit y) (y' + 1)
            where
                x' = toEnum x
                y' = toEnum y
                z' = max x' y' + 1

        rankPopCount :: BitVector -> Property
        rankPopCount bv = (rank <$> id <*> dimension) bv === toEnum (popCount bv)

        rankToBits :: BitVector -> NonNegative Word -> Property
        rankToBits bv (NonNegative x) =
            rank bv x === (toEnum . length . filter id . take (fromEnum x) . toBits) bv

        rankSelectMinDef :: BitVector -> NonNegative Word -> Property
        rankSelectMinDef bv (NonNegative x) =
            let idx = select bv x
                k   = fromJust idx
            in  idx === Nothing .||. rank bv k === x


monoFunctorEquivalence :: TestTree
monoFunctorEquivalence = testGroup
    "Equivalence of a MonoFunctor"
    [SC.testProperty "omap f === fromBits . map f . toBits" $ forAll omapOptimizationIsValid]
    where
        omapOptimizationIsValid :: (Bool -> Bool, VisualBitVector) -> Bool
        omapOptimizationIsValid (f, y) = omap f bv == (fromBits . map f . toBits) bv
            where bv = getBitVector y


monoFoldableEquivalence :: TestTree
monoFoldableEquivalence = testGroup
    "Equivalence of a MonoFoldable"
    [ SC.testProperty "oall f === all f . otoList" $ forAll oallOptimizationIsValid
    , SC.testProperty "oany f === any f . otoList" $ forAll oanyOptimizationIsValid
    , SC.testProperty "ofoldr1Ex  f === foldr1 f . otoList" $ forAll ofoldr1ExOptimizationIsValid
    , SC.testProperty "ofoldl1Ex' f === foldl1 f . otoList" $ forAll ofoldl1ExOptimizationIsValid
    , SC.testProperty "headEx === head . otoList" $ forAll headExOptimizationIsValid
    , SC.testProperty "lastEx === last . otoList" $ forAll lastExOptimizationIsValid
    , SC.testProperty "maximumByEx f === maximumBy f . otoList" $ forAll maximumByExOptimizationIsValid
    , SC.testProperty "minimumByEx f === minimumBy f . otoList" $ forAll minimumByExOptimizationIsValid
    , SC.testProperty "oelem e === oelem e . otoList" $ forAll oelemOptimizationIsValid
    , SC.testProperty "onotElem e === onotElem e . otoList" $ forAll onotElemOptimizationIsValid
    ]
    where
        oallOptimizationIsValid :: (UnaryLogicalOperator, VisualBitVector) -> Bool
        oallOptimizationIsValid (y, x) = oall op bv == (all op . otoList) bv
            where
                bv = getBitVector x
                op = getUnaryLogicalOperator y

        oanyOptimizationIsValid :: (UnaryLogicalOperator, VisualBitVector) -> Bool
        oanyOptimizationIsValid (y, x) = oany op bv == (any op . otoList) bv
            where
                bv = getBitVector x
                op = getUnaryLogicalOperator y

        ofoldr1ExOptimizationIsValid :: (BinaryLogicalOperator, VisualBitVector) -> Bool
        ofoldr1ExOptimizationIsValid (y, x) = isZeroVector bv || ofoldr1Ex op bv == (foldr1 op . otoList) bv
            where
                bv = getBitVector x
                op = getBinaryLogicalOperator y

        ofoldl1ExOptimizationIsValid :: (BinaryLogicalOperator, VisualBitVector) -> Bool
        ofoldl1ExOptimizationIsValid (y, x) = isZeroVector bv || ofoldl1Ex' op bv == (foldl1 op . otoList) bv
            where
                bv = getBitVector x
                op = getBinaryLogicalOperator y

        headExOptimizationIsValid :: VisualBitVector -> Bool
        headExOptimizationIsValid x = isZeroVector bv || headEx bv == (head . otoList) bv
            where bv = getBitVector x

        lastExOptimizationIsValid :: VisualBitVector -> Bool
        lastExOptimizationIsValid x = isZeroVector bv || lastEx bv == (last . otoList) bv
            where bv = getBitVector x

        maximumByExOptimizationIsValid :: (VisualBitVector, ComparisonOperator) -> Bool
        maximumByExOptimizationIsValid (x, y) =
            isZeroVector bv || maximumByEx op bv == (maximumBy op . otoList) bv
            where
                bv = getBitVector x
                op = getComparator y

        minimumByExOptimizationIsValid :: (VisualBitVector, ComparisonOperator) -> Bool
        minimumByExOptimizationIsValid (x, y) =
            isZeroVector bv || minimumByEx op bv == (minimumBy op . otoList) bv
            where
                bv = getBitVector x
                op = getComparator y

        oelemOptimizationIsValid :: (VisualBitVector, Bool) -> Bool
        oelemOptimizationIsValid (x, e) = oelem e bv == (oelem e . otoList) bv where bv = getBitVector x

        onotElemOptimizationIsValid :: (VisualBitVector, Bool) -> Bool
        onotElemOptimizationIsValid (x, e) = onotElem e bv == (onotElem e . otoList) bv
            where bv = getBitVector x


monoZipEquivalence :: TestTree
monoZipEquivalence = testGroup
    "Equivalence of a MonoZip"
    [ SC.testProperty "ozipWith f x === fromBits . zipWith f . (toBits x) . toBits"
        $ forAll omapOptimizationIsValid
    ]
    where
        omapOptimizationIsValid
            :: (BinaryLogicalOperator, VisualBitVectorSmall, VisualBitVectorSmall) -> Bool
        omapOptimizationIsValid (f, x, y) = ozipWith op lhs rhs
            == (fromBits . zipWith op (toBits lhs) . toBits) rhs
            where
                op  = getBinaryLogicalOperator f
                lhs = getBitVector x
                rhs = getBitVector y


{-
infixr 0 ===>
(===>) :: QC.Testable prop => Bool -> prop -> Property
False ===> _ = property True
True  ===> p = property p
-}