finitary-1.2.0.0: test/Main.hs
{-
- Copyright (C) 2019 Koz Ross <koz.ross@retro-freedom.nz>
-
- This program is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Main where
import Data.List (sort, sortOn)
import Data.Ord (Down)
import Data.Maybe (isNothing, isJust)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.TypeNats
import GHC.Generics
import Data.Kind (Type)
import Data.Finite (Finite, finites)
import Data.Proxy (Proxy(..))
import Control.Monad.Loops (andM)
import Data.Typeable (Typeable, typeRep)
import Data.String (fromString)
import Hedgehog
import qualified Hedgehog.Gen as G
import qualified Hedgehog.Range as R
import qualified Data.Vector.Sized as VS
import qualified Data.Vector.Unboxed.Sized as VUS
import qualified Data.Vector.Storable.Sized as VSS
import qualified Data.Bit as B
import qualified Data.Bit.ThreadSafe as BTS
import Data.Finitary
-- A representation of types
data SomeFinitaryRep where
SomeFinitaryRep :: forall (a :: Type) . (Finitary a, Ord a, Show a, Typeable a, 1 <= (Cardinality a)) => Proxy a -> SomeFinitaryRep
-- A representation of test functions
data SomeTestFunction where
SomeTestFunction :: (forall (a :: Type) . (Finitary a, Ord a, Show a, 1 <= (Cardinality a)) => Proxy a -> Property) -> SomeTestFunction
-- Some weird generic
data Foo = Bar | Baz (VS.Vector 4 Bool) | Quux Word8
deriving (Eq, Show, Typeable, Generic, Finitary, Ord)
-- Something I will need for further tests
iterateMN :: forall (m :: Type -> Type) (a :: Type) (b :: Type) . (Eq a, Bounded a, Enum a, Monad m) => a -> (b -> m b) -> b -> m b
iterateMN i f x = if i == minBound
then f x
else iterateMN (pred i) f x >>= f
-- How much testing do I want to do for random inputs?
testLimit :: forall (a :: Type) (b :: Type) . (Finitary a, Num b) => b
testLimit = fromIntegral . (* 2) . min 32767 . natVal $ Proxy @(Cardinality a)
-- Generators
choose :: forall (a :: Type) m . (MonadGen m, Finitary a) => m a
choose = fromFinite <$> chooseFinite
chooseFinite :: forall (n :: Nat) m . (KnownNat n, MonadGen m) => m (Finite n)
chooseFinite = fromIntegral <$> G.integral (R.linear 0 limit)
where limit = subtract @Integer 1 . fromIntegral . natVal @n $ Proxy
-- Data
allTheTypes :: [SomeFinitaryRep]
allTheTypes = [
SomeFinitaryRep @(Proxy Int) Proxy,
SomeFinitaryRep @Bool Proxy,
SomeFinitaryRep @B.Bit Proxy,
SomeFinitaryRep @BTS.Bit Proxy,
SomeFinitaryRep @Ordering Proxy,
SomeFinitaryRep @Char Proxy,
SomeFinitaryRep @Word8 Proxy,
SomeFinitaryRep @Word16 Proxy,
SomeFinitaryRep @Word32 Proxy,
SomeFinitaryRep @Word64 Proxy,
SomeFinitaryRep @Int16 Proxy,
SomeFinitaryRep @Int8 Proxy,
SomeFinitaryRep @Int32 Proxy,
SomeFinitaryRep @Int64 Proxy,
SomeFinitaryRep @Int Proxy,
SomeFinitaryRep @Word Proxy,
SomeFinitaryRep @(Down Int) Proxy,
SomeFinitaryRep @(Maybe Word8) Proxy,
SomeFinitaryRep @(Either Word8 Int8) Proxy,
SomeFinitaryRep @(Word8, Int8) Proxy,
SomeFinitaryRep @(VS.Vector 4 Bool) Proxy,
SomeFinitaryRep @(VUS.Vector 4 Bool) Proxy,
SomeFinitaryRep @(VSS.Vector 4 Bool) Proxy
]
constructTest :: SomeTestFunction -> GroupName -> IO Bool
constructTest (SomeTestFunction testFunc) name = checkParallel . Group name $ fmap go allTheTypes
where go (SomeFinitaryRep p) = (fromString . show . typeRep $ p, testFunc p)
-- Properties
isBijection :: forall (a :: Type) . (Finitary a, Show a) => Proxy a -> Property
isBijection _ = withTests (testLimit @a) (property $ do x <- forAll $ choose @a
x === (fromFinite . toFinite $ x))
isOrderPreserving :: forall (a :: Type) . (Finitary a, Ord a) => Proxy a -> Property
isOrderPreserving _ = withTests (testLimit @a) (property $ do i <- forAll $ chooseFinite @(Cardinality a)
j <- forAll $ chooseFinite @(Cardinality a)
assert (fromFinite @a i > fromFinite @a j || i <= j))
startIsCorrect :: forall (a :: Type) . (Finitary a, Show a, 1 <= (Cardinality a)) => Proxy a -> Property
startIsCorrect _ = property $ start @a === fromFinite minBound
previousStartNothing :: forall (a :: Type) . (Finitary a, 1 <= (Cardinality a)) => Proxy a -> Property
previousStartNothing _ = property $ assert (isNothing . previous $ start @a)
endNextNothing :: forall (a :: Type) . (Finitary a, 1 <= (Cardinality a)) => Proxy a -> Property
endNextNothing _ = property $ assert (isNothing . next $ end @a)
endIsCorrect :: forall (a :: Type) . (Finitary a, Show a, 1 <= (Cardinality a)) => Proxy a -> Property
endIsCorrect _ = property $ end @a === fromFinite maxBound
previousIsCorrect :: forall (a :: Type) . (Finitary a, 1 <= Cardinality a, Show a) => Proxy a -> Property
previousIsCorrect _ = withTests (testLimit @a) (property $ do x <- forAll $ choose @a
if x == start
then success
else assert . isJust . previous $ x)
nextIsCorrect :: forall (a :: Type) . (Finitary a, 1 <= Cardinality a, Show a) => Proxy a -> Property
nextIsCorrect _ = withTests (testLimit @a) (property $ do x <- forAll $ choose @a
if x == end
then success
else assert . isJust . next $ x)
-- Check the behaviour of the tuple generic so that we don't violate
-- order-preservation
agreesWithOrd :: Property
agreesWithOrd = property $ do let xs = (,) <$> [LT ..] <*> [False ..]
sort xs === sortOn toFinite xs
-- Check that we can enumerate properly and that our type, in order, is
-- isomorphic to 'finites'
enumeratesProperly :: Property
enumeratesProperly = property $ do let xs = (,) <$> [LT ..] <*> [False ..]
(toFinite <$> sort xs) === finites
-- All the tests I want to use
allTests :: [(SomeTestFunction, GroupName)]
allTests = [
(SomeTestFunction isBijection, "bijectivity"),
(SomeTestFunction isOrderPreserving, "order preservation"),
(SomeTestFunction startIsCorrect, "start"),
(SomeTestFunction endIsCorrect, "end"),
(SomeTestFunction previousStartNothing, "previous + start"),
(SomeTestFunction endNextNothing, "next + end"),
(SomeTestFunction previousIsCorrect, "previous"),
(SomeTestFunction nextIsCorrect, "next")
]
main :: IO Bool
main = andM . (:) (checkSequential . Group "Ord agreement" $ [("ordering", agreesWithOrd), ("totality", enumeratesProperly)]) . fmap (uncurry constructTest) $ allTests