{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
-- NOTE: These tests depend on deferring the type errors that would otherwise
-- prevent some of the instances in this module from being derived.
{-# OPTIONS_GHC -fdefer-type-errors #-}

module Test.Consensus.Genesis.TestSuite.SmallKey.Tests (tests) where

import Control.Exception
import Data.List
  ( isInfixOf
  , permutations
  )
import GHC.Generics
import Test.Consensus.Genesis.TestSuite.SmallKey
import Test.Tasty
import Test.Tasty.HUnit

{-------------------------------------------------------------------------------
  Types for testing SmallKey instances
-------------------------------------------------------------------------------}

data Empty
  deriving stock (forall x. Empty -> Rep Empty x)
-> (forall x. Rep Empty x -> Empty) -> Generic Empty
forall x. Rep Empty x -> Empty
forall x. Empty -> Rep Empty x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Empty -> Rep Empty x
from :: forall x. Empty -> Rep Empty x
$cto :: forall x. Rep Empty x -> Empty
to :: forall x. Rep Empty x -> Empty
Generic
  deriving [Empty]
[Empty] -> SmallKey Empty
forall a. [a] -> SmallKey a
$callKeys :: [Empty]
allKeys :: [Empty]
SmallKey via Generically Empty

data Unit = Unit
  deriving stock (Unit -> Unit -> Bool
(Unit -> Unit -> Bool) -> (Unit -> Unit -> Bool) -> Eq Unit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Unit -> Unit -> Bool
== :: Unit -> Unit -> Bool
$c/= :: Unit -> Unit -> Bool
/= :: Unit -> Unit -> Bool
Eq, (forall x. Unit -> Rep Unit x)
-> (forall x. Rep Unit x -> Unit) -> Generic Unit
forall x. Rep Unit x -> Unit
forall x. Unit -> Rep Unit x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Unit -> Rep Unit x
from :: forall x. Unit -> Rep Unit x
$cto :: forall x. Rep Unit x -> Unit
to :: forall x. Rep Unit x -> Unit
Generic)
  deriving [Unit]
[Unit] -> SmallKey Unit
forall a. [a] -> SmallKey a
$callKeys :: [Unit]
allKeys :: [Unit]
SmallKey via Generically Unit

data Single x = S x
  deriving stock (Single x -> Single x -> Bool
(Single x -> Single x -> Bool)
-> (Single x -> Single x -> Bool) -> Eq (Single x)
forall x. Eq x => Single x -> Single x -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall x. Eq x => Single x -> Single x -> Bool
== :: Single x -> Single x -> Bool
$c/= :: forall x. Eq x => Single x -> Single x -> Bool
/= :: Single x -> Single x -> Bool
Eq, (forall x. Single x -> Rep (Single x) x)
-> (forall x. Rep (Single x) x -> Single x) -> Generic (Single x)
forall x. Rep (Single x) x -> Single x
forall x. Single x -> Rep (Single x) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x x. Rep (Single x) x -> Single x
forall x x. Single x -> Rep (Single x) x
$cfrom :: forall x x. Single x -> Rep (Single x) x
from :: forall x. Single x -> Rep (Single x) x
$cto :: forall x x. Rep (Single x) x -> Single x
to :: forall x. Rep (Single x) x -> Single x
Generic)
  deriving [Single x]
[Single x] -> SmallKey (Single x)
forall a. [a] -> SmallKey a
forall x. SmallKey x => [Single x]
$callKeys :: forall x. SmallKey x => [Single x]
allKeys :: [Single x]
SmallKey via Generically (Single x)

data Enumeration = A | B | C
  deriving stock (Enumeration -> Enumeration -> Bool
(Enumeration -> Enumeration -> Bool)
-> (Enumeration -> Enumeration -> Bool) -> Eq Enumeration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Enumeration -> Enumeration -> Bool
== :: Enumeration -> Enumeration -> Bool
$c/= :: Enumeration -> Enumeration -> Bool
/= :: Enumeration -> Enumeration -> Bool
Eq, Enumeration
Enumeration -> Enumeration -> Bounded Enumeration
forall a. a -> a -> Bounded a
$cminBound :: Enumeration
minBound :: Enumeration
$cmaxBound :: Enumeration
maxBound :: Enumeration
Bounded, Int -> Enumeration
Enumeration -> Int
Enumeration -> [Enumeration]
Enumeration -> Enumeration
Enumeration -> Enumeration -> [Enumeration]
Enumeration -> Enumeration -> Enumeration -> [Enumeration]
(Enumeration -> Enumeration)
-> (Enumeration -> Enumeration)
-> (Int -> Enumeration)
-> (Enumeration -> Int)
-> (Enumeration -> [Enumeration])
-> (Enumeration -> Enumeration -> [Enumeration])
-> (Enumeration -> Enumeration -> [Enumeration])
-> (Enumeration -> Enumeration -> Enumeration -> [Enumeration])
-> Enum Enumeration
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Enumeration -> Enumeration
succ :: Enumeration -> Enumeration
$cpred :: Enumeration -> Enumeration
pred :: Enumeration -> Enumeration
$ctoEnum :: Int -> Enumeration
toEnum :: Int -> Enumeration
$cfromEnum :: Enumeration -> Int
fromEnum :: Enumeration -> Int
$cenumFrom :: Enumeration -> [Enumeration]
enumFrom :: Enumeration -> [Enumeration]
$cenumFromThen :: Enumeration -> Enumeration -> [Enumeration]
enumFromThen :: Enumeration -> Enumeration -> [Enumeration]
$cenumFromTo :: Enumeration -> Enumeration -> [Enumeration]
enumFromTo :: Enumeration -> Enumeration -> [Enumeration]
$cenumFromThenTo :: Enumeration -> Enumeration -> Enumeration -> [Enumeration]
enumFromThenTo :: Enumeration -> Enumeration -> Enumeration -> [Enumeration]
Enum, (forall x. Enumeration -> Rep Enumeration x)
-> (forall x. Rep Enumeration x -> Enumeration)
-> Generic Enumeration
forall x. Rep Enumeration x -> Enumeration
forall x. Enumeration -> Rep Enumeration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Enumeration -> Rep Enumeration x
from :: forall x. Enumeration -> Rep Enumeration x
$cto :: forall x. Rep Enumeration x -> Enumeration
to :: forall x. Rep Enumeration x -> Enumeration
Generic)
  deriving [Enumeration]
[Enumeration] -> SmallKey Enumeration
forall a. [a] -> SmallKey a
$callKeys :: [Enumeration]
allKeys :: [Enumeration]
SmallKey via Generically Enumeration

data Sum x y = L x | R y
  deriving stock (Sum x y -> Sum x y -> Bool
(Sum x y -> Sum x y -> Bool)
-> (Sum x y -> Sum x y -> Bool) -> Eq (Sum x y)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x y. (Eq x, Eq y) => Sum x y -> Sum x y -> Bool
$c== :: forall x y. (Eq x, Eq y) => Sum x y -> Sum x y -> Bool
== :: Sum x y -> Sum x y -> Bool
$c/= :: forall x y. (Eq x, Eq y) => Sum x y -> Sum x y -> Bool
/= :: Sum x y -> Sum x y -> Bool
Eq, (forall x. Sum x y -> Rep (Sum x y) x)
-> (forall x. Rep (Sum x y) x -> Sum x y) -> Generic (Sum x y)
forall x. Rep (Sum x y) x -> Sum x y
forall x. Sum x y -> Rep (Sum x y) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x y x. Rep (Sum x y) x -> Sum x y
forall x y x. Sum x y -> Rep (Sum x y) x
$cfrom :: forall x y x. Sum x y -> Rep (Sum x y) x
from :: forall x. Sum x y -> Rep (Sum x y) x
$cto :: forall x y x. Rep (Sum x y) x -> Sum x y
to :: forall x. Rep (Sum x y) x -> Sum x y
Generic)
  deriving [Sum x y]
[Sum x y] -> SmallKey (Sum x y)
forall a. [a] -> SmallKey a
forall x y. (SmallKey x, SmallKey y) => [Sum x y]
$callKeys :: forall x y. (SmallKey x, SmallKey y) => [Sum x y]
allKeys :: [Sum x y]
SmallKey via Generically (Sum x y)

data Product x y = P x y
  deriving stock (Product x y -> Product x y -> Bool
(Product x y -> Product x y -> Bool)
-> (Product x y -> Product x y -> Bool) -> Eq (Product x y)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x y. (Eq x, Eq y) => Product x y -> Product x y -> Bool
$c== :: forall x y. (Eq x, Eq y) => Product x y -> Product x y -> Bool
== :: Product x y -> Product x y -> Bool
$c/= :: forall x y. (Eq x, Eq y) => Product x y -> Product x y -> Bool
/= :: Product x y -> Product x y -> Bool
Eq, (forall x. Product x y -> Rep (Product x y) x)
-> (forall x. Rep (Product x y) x -> Product x y)
-> Generic (Product x y)
forall x. Rep (Product x y) x -> Product x y
forall x. Product x y -> Rep (Product x y) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x y x. Rep (Product x y) x -> Product x y
forall x y x. Product x y -> Rep (Product x y) x
$cfrom :: forall x y x. Product x y -> Rep (Product x y) x
from :: forall x. Product x y -> Rep (Product x y) x
$cto :: forall x y x. Rep (Product x y) x -> Product x y
to :: forall x. Rep (Product x y) x -> Product x y
Generic)
  deriving [Product x y]
[Product x y] -> SmallKey (Product x y)
forall a. [a] -> SmallKey a
forall x y. [Product x y]
$callKeys :: forall x y. [Product x y]
allKeys :: [Product x y]
SmallKey via Generically (Product x y)

data Outer = Inner Bool
  deriving stock (Outer -> Outer -> Bool
(Outer -> Outer -> Bool) -> (Outer -> Outer -> Bool) -> Eq Outer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Outer -> Outer -> Bool
== :: Outer -> Outer -> Bool
$c/= :: Outer -> Outer -> Bool
/= :: Outer -> Outer -> Bool
Eq, (forall x. Outer -> Rep Outer x)
-> (forall x. Rep Outer x -> Outer) -> Generic Outer
forall x. Rep Outer x -> Outer
forall x. Outer -> Rep Outer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Outer -> Rep Outer x
from :: forall x. Outer -> Rep Outer x
$cto :: forall x. Rep Outer x -> Outer
to :: forall x. Rep Outer x -> Outer
Generic)
  deriving [Outer]
[Outer] -> SmallKey Outer
forall a. [a] -> SmallKey a
$callKeys :: [Outer]
allKeys :: [Outer]
SmallKey via Generically Outer

{-------------------------------------------------------------------------------
  Tests
-------------------------------------------------------------------------------}

-- | Unit tests for the correct derivation of some simple ADT 'SmallKey'
-- instances and a test asserting failure for each black-listing strategy:
--
-- 1. A type with a product on its generic representation.
-- 2. A type with a explicitly black-listed field.
--
-- NOTE: These tests depend on @-fdefer-type-errors@ to run.
--
-- TODO: Once the use of 'TypeError' is replaced with 'Unsatisfiable' in
-- 'SmallKey' it should be possible to 'assertError' the /actual/ type error
-- instead of the /unreacheable/ runtime error from 'getAllKeys', and write a
-- test case for the forbidden directly recursive types, e.g.
--
-- @
-- data DirectlyRecursive = Nil | More DirectlyRecursive
--   deriving stock (Eq, Ord, Generic)
--   deriving SmallKey via Generically DirectlyRecursive
-- @
--
-- for which the corresponding test would not terminate trying to evaluate
-- 'getAllKeys' otherwise.
-- See TODO [BlackList].
tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"SmallKey"
    [ TestName -> [TestTree] -> TestTree
testGroup
        TestName
"generic instantiation of allowed types"
        [ TestName -> Assertion -> TestTree
testCase TestName
"Empty" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"must return the empty list" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
              forall k. SmallKey k => [k]
getAllKeys @Empty [Empty] -> [Empty] -> Bool
forall a. Eq a => a -> a -> Bool
== []
        , TestName -> Assertion -> TestTree
testCase TestName
"Unit" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"must return a list with its only constructor" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
              forall k. SmallKey k => [k]
getAllKeys @Unit [Unit] -> [Unit] -> Bool
forall a. Eq a => a -> a -> Bool
== [Unit
Unit]
        , TestName -> Assertion -> TestTree
testCase TestName
"Single constructor" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"must return a list with its only constructor" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
              forall k. SmallKey k => [k]
getAllKeys @(Single ()) [Single ()] -> [Single ()] -> Bool
forall a. Eq a => a -> a -> Bool
== [() -> Single ()
forall x. x -> Single x
S ()]
        , TestName -> Assertion -> TestTree
testCase TestName
"Enumeration" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"allKeys must be a permutation of the list of all values" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
              [Enumeration] -> [[Enumeration]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall k. SmallKey k => [k]
getAllKeys @Enumeration) ([[Enumeration]] -> Bool) -> [[Enumeration]] -> Bool
forall a b. (a -> b) -> a -> b
$
                [Enumeration] -> [[Enumeration]]
forall a. [a] -> [[a]]
permutations [Enumeration
forall a. Bounded a => a
minBound .. Enumeration
forall a. Bounded a => a
maxBound]
        , TestName -> Assertion -> TestTree
testCase TestName
"Sum" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"allKeys must be a permutation of the list of all values" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
              [Sum () Bool] -> [[Sum () Bool]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall k. SmallKey k => [k]
getAllKeys @(Sum () Bool)) ([[Sum () Bool]] -> Bool) -> [[Sum () Bool]] -> Bool
forall a b. (a -> b) -> a -> b
$
                [Sum () Bool] -> [[Sum () Bool]]
forall a. [a] -> [[a]]
permutations [() -> Sum () Bool
forall x y. x -> Sum x y
L (), Bool -> Sum () Bool
forall x y. y -> Sum x y
R Bool
False, Bool -> Sum () Bool
forall x y. y -> Sum x y
R Bool
True]
        , TestName -> Assertion -> TestTree
testCase TestName
"Nested key" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"allKeys must be a permutation of the list of all values" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
              [Outer] -> [[Outer]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall k. SmallKey k => [k]
getAllKeys @Outer) ([[Outer]] -> Bool) -> [[Outer]] -> Bool
forall a b. (a -> b) -> a -> b
$
                [Outer] -> [[Outer]]
forall a. [a] -> [[a]]
permutations [Bool -> Outer
Inner Bool
False, Bool -> Outer
Inner Bool
True]
        ]
    , TestName -> [TestTree] -> TestTree
testGroup
        TestName
"black-listed types"
        [ TestName -> Assertion -> TestTree
testCase TestName
"Product" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            TestName -> [Product () ()] -> Assertion
forall a. TestName -> a -> Assertion
assertError TestName
"unreachable: product type" ([Product () ()] -> Assertion) -> [Product () ()] -> Assertion
forall a b. (a -> b) -> a -> b
$
              forall k. SmallKey k => [k]
getAllKeys @(Product () ())
        , TestName -> Assertion -> TestTree
testCase TestName
"Unary type with black-listed argument (Int)" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            TestName -> [Single Int] -> Assertion
forall a. TestName -> a -> Assertion
assertError TestName
"unreachable: NoSmallKey Int" ([Single Int] -> Assertion) -> [Single Int] -> Assertion
forall a b. (a -> b) -> a -> b
$
              forall k. SmallKey k => [k]
getAllKeys @(Single Int)
        ]
    ]

assertError :: String -> a -> Assertion
assertError :: forall a. TestName -> a -> Assertion
assertError TestName
expected a
val = do
  result <- forall e a. Exception e => IO a -> IO (Either e a)
try @ErrorCall (a -> IO a
forall a. a -> IO a
evaluate a
val)
  case result of
    Left (ErrorCall TestName
msg)
      | TestName
expected TestName -> TestName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` TestName
msg -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise -> TestName -> Assertion
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName -> Assertion) -> TestName -> Assertion
forall a b. (a -> b) -> a -> b
$ TestName
"Unexpected error message:\n" TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
msg
    Right a
_ ->
      TestName -> Assertion
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"Expected an error, but computation succeeded"