finitary-2.2.0.1: 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
-- base
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 Data.Word (Word16, Word32, Word64, Word8)
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
import GHC.TypeNats (type (<=))
-- vector-sized
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
-- hedgehog
import Hedgehog ((===), Gen, PropertyT, forAll)
import qualified Hedgehog.Gen as Gen
import Hedgehog.Range (constantBounded)
-- hspec
import Test.Hspec (SpecWith, describe, hspec, it, parallel, shouldBe)
-- hspec-hedgehod
import Test.Hspec.Hedgehog (hedgehog)
--------------------------------------------------------------------------------
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)
checkBijection "Word16"
$ Gen.enumBounded @_ @Word16
checkBijection "Word32"
$ Gen.enumBounded @_ @Word32
checkBijection "Word64"
$ Gen.word64 constantBounded
checkBijection "Int8" (Gen.enumBounded @_ @Int8)
checkBijection "Int16"
$ Gen.enumBounded @_ @Int16
checkBijection "Int32"
$ Gen.enumBounded @_ @Int32
checkBijection "Int64"
$ Gen.int64 constantBounded
checkBijection "Int"
$ Gen.int constantBounded
checkBijection "Word"
$ Gen.word constantBounded
describe "Down" $ do
checkMonotonic "Bool" Gen.bool
checkMonotonic "Int"
$ (Gen.enumBounded @_ @Int)
checkMonotonic "(Either Int32 Bool)"
$ Gen.choice
[ Left <$> Gen.enumBounded @_ @Int32,
Right <$> Gen.enumBounded @_ @Bool
]
checkMonotonic "(Int32, Bool)"
$ ( (,)
<$> Gen.enumBounded @_ @Int32
<*> Gen.enumBounded @_ @Bool
)
checkMonotonic "of a user-defined type"
$ genFoo
describe "Fixed-length vectors" $ do
checkStorable "Int8"
. genStorable
$ Gen.enumBounded @_ @Int8
checkUnboxed "Int8"
. genUnboxed
$ Gen.enumBounded @_ @Int8
checkRegular "Int8"
. genRegular
$ Gen.enumBounded @_ @Int8
checkUnboxed "(Int8, Int8)"
. genUnboxed
$ ( (,) <$> Gen.enumBounded @_ @Int8
<*> Gen.enumBounded @_ @Int8
)
checkRegular "(Int8, Int8)"
. genRegular
$ ( (,) <$> Gen.enumBounded @_ @Int8
<*> Gen.enumBounded @_ @Int8
)
checkRegular "Either Int8 Bool"
. genRegular
. Gen.choice
$ [ Left <$> Gen.enumBounded @_ @Int8,
Right <$> Gen.bool
]
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