finitary-2.2.0.0: test/Main.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-
- 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/>.
-}
module Main where
import Data.Bit (Bit)
import Data.Finitary (Finitary (..))
import Data.Finite (Finite)
import Data.Functor.Const (Const)
import Data.Functor.Identity (Identity)
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Ord (Down (..))
import Data.Proxy (Proxy (..))
import Data.Semigroup (All, Any, Dual, First, Last, Max, Min, Product, Sum)
import qualified Data.Vector.Sized as V
import qualified Data.Vector.Storable.Sized as VS
import Data.Vector.Unboxed.Sized (Unbox)
import qualified Data.Vector.Unboxed.Sized as VU
import Data.Word (Word16, Word32, Word64, Word8)
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
import GHC.TypeNats (type (<=))
import Hedgehog ((===), Gen, PropertyT, forAll)
import qualified Hedgehog.Gen as Gen
import Hedgehog.Range (constantBounded)
import Test.Hspec (SpecWith, describe, hspec, it, parallel, shouldBe)
import Test.Hspec.Hedgehog (hedgehog, modifyMaxSize)
main :: IO ()
main = hspec . parallel $ do
describe "Previous and next values for bounds" $ do
checkBoundsPrevNext (Proxy @All) "All"
checkBoundsPrevNext (Proxy @Any) "Any"
checkBoundsPrevNext (Proxy @Int16) "Int16"
checkBoundsPrevNext (Proxy @Int32) "Int32"
checkBoundsPrevNext (Proxy @Int64) "Int64"
checkBoundsPrevNext (Proxy @Int8) "Int8"
checkBoundsPrevNext (Proxy @Word16) "Word16"
checkBoundsPrevNext (Proxy @Word32) "Word32"
checkBoundsPrevNext (Proxy @Word64) "Word64"
checkBoundsPrevNext (Proxy @Word8) "Word8"
checkBoundsPrevNext (Proxy @Bit) "Bit"
checkBoundsPrevNext (Proxy @Ordering) "Ordering"
checkBoundsPrevNext (Proxy @()) "()"
checkBoundsPrevNext (Proxy @Bool) "Bool"
checkBoundsPrevNext (Proxy @Char) "Char"
checkBoundsPrevNext (Proxy @Int) "Int"
checkBoundsPrevNext (Proxy @Word) "Word"
checkBoundsPrevNext (Proxy @(Identity Int32)) "Identity a"
checkBoundsPrevNext (Proxy @(Down Int32)) "Down a"
checkBoundsPrevNext (Proxy @(First Int32)) "First a"
checkBoundsPrevNext (Proxy @(Last Int32)) "Last a"
checkBoundsPrevNext (Proxy @(Max Int32)) "Max a"
checkBoundsPrevNext (Proxy @(Min Int32)) "Min a"
checkBoundsPrevNext (Proxy @(Dual Int32)) "Dual a"
checkBoundsPrevNext (Proxy @(Product Int32)) "Product a"
checkBoundsPrevNext (Proxy @(Sum Int32)) "Sum a"
checkBoundsPrevNext (Proxy @(Finite 10000)) "Finite n"
checkBoundsPrevNext (Proxy @(Maybe Int32)) "Maybe a"
checkBoundsPrevNext (Proxy @(Either Bool Int32)) "Either a b"
checkBoundsPrevNext (Proxy @(Proxy Int32)) "Proxy a"
checkBoundsPrevNext (Proxy @(V.Vector 10 Int32)) "V.Vector a"
checkBoundsPrevNext (Proxy @(VS.Vector 10 Int32)) "VS.Vector a"
checkBoundsPrevNext (Proxy @(VU.Vector 10 Int32)) "VU.Vector a"
checkBoundsPrevNext (Proxy @(Bool, Int32)) "(a, b)"
checkBoundsPrevNext (Proxy @(Const Int32 Bool)) "Const a b"
checkBoundsPrevNext (Proxy @(Bool, Bool, Int32)) "(a, b, c)"
checkBoundsPrevNext (Proxy @(Bool, Int8, Bool, Int32)) "(a, b, c, d)"
checkBoundsPrevNext (Proxy @(Bool, Int8, Bool, Int8, Int32)) "(a, b, c, d, e)"
checkBoundsPrevNext (Proxy @(Bool, Int8, Bool, Int8, Bool, Int32)) "(a, b, c, d, e, f)"
checkBoundsPrevNext (Proxy @Foo) "Foo"
describe "Bijectivity and order preservation" $ do
checkBijection "Char" Gen.unicode
checkBijection "Word8" (Gen.enumBounded @_ @Word8)
modifyMaxSize (const 10000)
. checkBijection "Word16"
$ Gen.enumBounded @_ @Word16
modifyMaxSize (const 10000)
. checkBijection "Word32"
$ Gen.enumBounded @_ @Word32
modifyMaxSize (const 10000)
. checkBijection "Word64"
$ Gen.word64 constantBounded
checkBijection "Int8" (Gen.enumBounded @_ @Int8)
modifyMaxSize (const 10000)
. checkBijection "Int16"
$ Gen.enumBounded @_ @Int16
modifyMaxSize (const 10000)
. checkBijection "Int32"
$ Gen.enumBounded @_ @Int32
modifyMaxSize (const 10000)
. checkBijection "Int64"
$ Gen.int64 constantBounded
modifyMaxSize (const 10000)
. checkBijection "Int"
$ Gen.int constantBounded
modifyMaxSize (const 10000)
. checkBijection "Word"
$ Gen.word constantBounded
describe "Down" $ do
checkMonotonic "Bool" Gen.bool
modifyMaxSize (const 10000)
. checkMonotonic "Int"
$ (Gen.enumBounded @_ @Int)
modifyMaxSize (const 10000)
. checkMonotonic "(Either Int32 Bool)"
$ Gen.choice
[ Left <$> Gen.enumBounded @_ @Int32,
Right <$> Gen.enumBounded @_ @Bool
]
modifyMaxSize (const 10000)
. checkMonotonic "(Int32, Bool)"
$ ( (,)
<$> Gen.enumBounded @_ @Int32
<*> Gen.enumBounded @_ @Bool
)
modifyMaxSize (const 10000)
. checkMonotonic "of a user-defined type"
$ genFoo
describe "Fixed-length vectors" $ do
modifyMaxSize (const 10000)
. checkStorable "Int8"
. genStorable
$ Gen.enumBounded @_ @Int8
modifyMaxSize (const 10000)
. checkUnboxed "Int8"
. genUnboxed
$ Gen.enumBounded @_ @Int8
modifyMaxSize (const 10000)
. checkRegular "Int8"
. genRegular
$ Gen.enumBounded @_ @Int8
modifyMaxSize (const 10000)
. checkUnboxed "(Int8, Int8)"
. genUnboxed
$ ( (,) <$> Gen.enumBounded @_ @Int8
<*> Gen.enumBounded @_ @Int8
)
modifyMaxSize (const 10000)
. checkRegular "(Int8, Int8)"
. genRegular
$ ( (,) <$> Gen.enumBounded @_ @Int8
<*> Gen.enumBounded @_ @Int8
)
modifyMaxSize (const 10000)
. checkRegular "Either Int8 Bool"
. genRegular
. Gen.choice
$ [ Left <$> Gen.enumBounded @_ @Int8,
Right <$> Gen.bool
]
modifyMaxSize (const 10000)
. checkRegular "a user defined type"
. genRegular
$ genFoo
-- Helpers
data Foo
= Bar
| Baz Int8
| Quux (Int8, Int8)
deriving stock (Eq, Ord, Generic, Show)
deriving anyclass (Finitary)
checkStorable ::
forall a.
(Storable a, Finitary a, Show a, Ord a) =>
String ->
Gen (VS.Vector 10 a) ->
SpecWith ()
checkStorable name =
it ("should biject a Storable Vector of " <> name)
. hedgehog
. bicheck @(VS.Vector 10 a)
checkRegular ::
forall a.
(Finitary a, Show a, Ord a) =>
String ->
Gen (V.Vector 10 a) ->
SpecWith ()
checkRegular name =
it ("should biject a Vector of " <> name)
. hedgehog
. bicheck @(V.Vector 10 a)
checkUnboxed ::
forall a.
(Unbox a, Finitary a, Show a, Ord a) =>
String ->
Gen (VU.Vector 10 a) ->
SpecWith ()
checkUnboxed name =
it ("should biject an Unboxed Vector of " <> name)
. hedgehog
. bicheck @(VU.Vector 10 a)
bicheck :: forall a. (Show a, Finitary a, Ord a) => Gen a -> PropertyT IO ()
bicheck gen = do
v <- forAll gen
let iv = toFinite v
v === (fromFinite . toFinite $ v)
iv === (toFinite @a . fromFinite $ iv)
v' <- forAll gen
let iv' = toFinite v'
compare v v' === compare iv iv'
genStorable :: (Storable a) => Gen a -> Gen (VS.Vector 10 a)
genStorable = VS.replicateM
genUnboxed :: (Unbox a) => Gen a -> Gen (VU.Vector 10 a)
genUnboxed = VU.replicateM
genRegular :: Gen a -> Gen (V.Vector 10 a)
genRegular = V.replicateM
genFoo :: Gen Foo
genFoo =
Gen.choice
[ pure Bar,
Baz <$> Gen.enumBounded,
Quux <$> ((,) <$> Gen.enumBounded <*> Gen.enumBounded)
]
checkBijection :: forall a. (Show a, Ord a, Finitary a) => String -> Gen a -> SpecWith ()
checkBijection name gen =
it ("should biject " <> name <> " with fromFinite and toFinite preserving order")
. hedgehog
$ go
where
go = do
x <- forAll gen
let ix = toFinite x
x === (fromFinite . toFinite $ x)
ix === (toFinite @a . fromFinite $ ix)
y <- forAll gen
let iy = toFinite y
compare x y === compare ix iy
checkMonotonic :: (Show a, Finitary a) => String -> Gen a -> SpecWith ()
checkMonotonic name gen =
it ("should be Ord-monotonic on Down " <> name)
. hedgehog
$ go
where
go = do
x <- forAll gen
y <- forAll gen
let dx = toFinite . Down $ x
let dy = toFinite . Down $ y
let ix = toFinite x
let iy = toFinite y
case compare ix iy of
LT -> compare dx dy === GT
EQ -> compare dx dy === EQ
GT -> compare dx dy === LT
checkBoundsPrevNext :: forall a. (1 <= Cardinality a, Show a, Finitary a) => Proxy a -> String -> SpecWith ()
checkBoundsPrevNext _ name = do
it ("(start :: " <> name <> ") should have no predecessor") $
previous (start @a) `shouldBe` Nothing
it ("(end :: " <> name <> ") should have no successor") $
next (end @a) `shouldBe` Nothing