{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoStarIsType #-}

-- | Internal module defining the 'SmallKey' utiliy class for 'TestSuite'
-- construction. Exposed through 'Test.Consensus.Genesis.TestSuite' re-exports.
module Test.Consensus.Genesis.TestSuite.SmallKey
  ( SmallKey -- class method is not exported to prevent bespoke instances
  , getAllKeys
  ) where

import Data.Int
import Data.Kind
import Data.Proxy
import Data.Text (Text)
import Data.Word
import GHC.Generics
import GHC.TypeError
import Type.Reflection

-- | This class is meant to be derived 'Generically' for the construction of
-- 'TestSuite's only. Which is done in basically two settings:
--
-- 1. For enumeration types matching the 'ConformanceTest's in a module one-to-one.
-- 2. For sums of other 'SmallKey' types for the composition of 'TestSuite's.
--
-- In essence, deriving an instance of this class is a declaration that the
-- type has a /small/ finite number of values and that 'allKeys' ('getAllKeys')
-- constains them all. \"Small\" here is a performance requirement, meaning that
-- it is feasible to drive an exhaustive construction from its values.
--
-- /Laws:/
--
-- Any inhabitant of a 'SmallKey' type must have a finite index in 'allKeys',
-- which must contain no duplicates. That is, whenever we have an 'Eq'
-- instance for the type, the following should hold:
--
-- @
-- 'elem' x 'allKeys' ==> 'length' ('filter' (== x) 'allKeys') == 1
-- @
class SmallKey a where
  allKeys :: [a]

getAllKeys :: SmallKey k => [k]
getAllKeys :: forall k. SmallKey k => [k]
getAllKeys = [k]
forall k. SmallKey k => [k]
allKeys

instance
  ( Generic a
  , AssertNotRecursive a (Rep a)
  , GSmallKey (Rep a)
  ) =>
  SmallKey (Generically a)
  where
  allKeys :: [Generically a]
allKeys = (Rep a (ZonkAny 0) -> Generically a)
-> [Rep a (ZonkAny 0)] -> [Generically a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Generically a
forall a. a -> Generically a
Generically (a -> Generically a)
-> (Rep a (ZonkAny 0) -> a) -> Rep a (ZonkAny 0) -> Generically a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a (ZonkAny 0) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to) ([Rep a (ZonkAny 0)] -> [Generically a])
-> [Rep a (ZonkAny 0)] -> [Generically a]
forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. GSmallKey f => [f a]
gAllKeys @(Rep a)

{-------------------------------------------------------------------------------
  TODO [Blacklist]

  If @base ^>=4.19.0.0@, then `GHC.TypeError.Unsatisfiable` +
  `GHC.TypeError.unsatisfiable` can be used to black-list types instead of
  'TypeError' + 'error', allowing finer triggering of the error that
  could be used to improve the 'SmallKey.Tests' (at least in principle).

  See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst
-------------------------------------------------------------------------------}

type family AssertNotRecursive (a :: Type) (f :: Type -> Type) :: Constraint where
  -- Throw type error if a direct recursive occurrence of the data type is found
  -- in its generic representation.
  AssertNotRecursive a (Rec0 a) =
    TypeError
      ( 'Text "Recursive data types are not allowed "
          ':<>: 'Text "to have a SmallKey instance: "
          ':<>: 'ShowType a
      )
  AssertNotRecursive _ (Rec0 _) = ()
  AssertNotRecursive a (l :+: r) =
    (AssertNotRecursive a l, AssertNotRecursive a r)
  AssertNotRecursive a (l :*: r) =
    (AssertNotRecursive a l, AssertNotRecursive a r)
  AssertNotRecursive a (M1 _ _ f) =
    AssertNotRecursive a f
  AssertNotRecursive _ _ = ()

{-------------------------------------------------------------------------------
  SmallKey generic instance
-------------------------------------------------------------------------------}

class GSmallKey f where
  gAllKeys :: [f a]

instance GSmallKey V1 where
  gAllKeys :: forall a. [V1 a]
gAllKeys = []

instance GSmallKey U1 where
  gAllKeys :: forall a. [U1 a]
gAllKeys = [U1 a
forall k (p :: k). U1 p
U1]

instance (GSmallKey f, GSmallKey g) => GSmallKey (f :+: g) where
  gAllKeys :: forall a. [(:+:) f g a]
gAllKeys = (f a -> (:+:) f g a) -> [f a] -> [(:+:) f g a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> (:+:) f g a
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> (:+:) f g p
L1 [f a]
forall a. [f a]
forall (f :: Type -> Type) a. GSmallKey f => [f a]
gAllKeys [(:+:) f g a] -> [(:+:) f g a] -> [(:+:) f g a]
forall a. Semigroup a => a -> a -> a
<> (g a -> (:+:) f g a) -> [g a] -> [(:+:) f g a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap g a -> (:+:) f g a
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
g p -> (:+:) f g p
R1 [g a]
forall a. [g a]
forall (f :: Type -> Type) a. GSmallKey f => [f a]
gAllKeys

instance
  TypeError
    ( 'Text "Product types are not allowed "
        ':<>: 'Text "to have a SmallKey instance"
    ) =>
  GSmallKey (f :*: g)
  where
  gAllKeys :: forall a. [(:*:) f g a]
gAllKeys = [Char] -> [(:*:) f g a]
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable: product type"

instance GSmallKey f => GSmallKey (M1 i c f) where
  gAllKeys :: forall a. [M1 i c f a]
gAllKeys = (f a -> M1 i c f a) -> [f a] -> [M1 i c f a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 [f a]
forall a. [f a]
forall (f :: Type -> Type) a. GSmallKey f => [f a]
gAllKeys

instance SmallKey a => GSmallKey (K1 r a) where
  gAllKeys :: forall a. [K1 r a a]
gAllKeys = (a -> K1 r a a) -> [a] -> [K1 r a a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 r a a
forall k i c (p :: k). c -> K1 i c p
K1 [a]
forall k. SmallKey k => [k]
allKeys

{-------------------------------------------------------------------------------
  Bundled instances

  These are the instances of 'SmallKey' for common types deemed small enough
  to be used exhaustively for 'TestSuite' construction, and that we expect
  could be used in 'TestKey' types.
-------------------------------------------------------------------------------}

instance SmallKey () where
  allKeys :: [()]
allKeys = [()]

instance SmallKey Bool where
  allKeys :: [Bool]
allKeys = [Bool
False, Bool
True]

{-------------------------------------------------------------------------------
  Black-listed instances
-------------------------------------------------------------------------------}

-- | A constraint for black-listed 'SmallKey' instances of large types.
--
-- We explicitly forbid instances for types deemed too large for exhaustive
-- construction. The 'TypeError' in this type family will be triggered if an
-- attempt is made to use 'allKeys', for any type having it in its instance
-- context.
type family NoSmallKey ty :: Constraint where
  NoSmallKey ty =
    TypeError
      ( 'ShowType ty ':<>: 'Text " doesn't have a SmallKey instance"
          ':$$: 'Text "because it is too large for exhaustive construction"
      )

unreachableSK :: forall a. Typeable a => Proxy a -> String
unreachableSK :: forall a. Typeable a => Proxy a -> [Char]
unreachableSK Proxy a
_ = [Char]
"unreachable: NoSmallKey " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TypeRep a -> [Char]
forall a. Show a => a -> [Char]
show (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a)

instance NoSmallKey Integer => SmallKey Integer where
  allKeys :: [Integer]
allKeys = [Char] -> [Integer]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Integer]) -> [Char] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Proxy Integer -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Integer
forall {k} (t :: k). Proxy t
Proxy :: Proxy Integer)

instance NoSmallKey Int => SmallKey Int where
  allKeys :: [Int]
allKeys = [Char] -> [Int]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Int]) -> [Char] -> [Int]
forall a b. (a -> b) -> a -> b
$ Proxy Int -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Int
forall {k} (t :: k). Proxy t
Proxy :: Proxy Int)

instance NoSmallKey Int8 => SmallKey Int8 where
  allKeys :: [Int8]
allKeys = [Char] -> [Int8]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Int8]) -> [Char] -> [Int8]
forall a b. (a -> b) -> a -> b
$ Proxy Int8 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Int8
forall {k} (t :: k). Proxy t
Proxy :: Proxy Int8)

instance NoSmallKey Int16 => SmallKey Int16 where
  allKeys :: [Int16]
allKeys = [Char] -> [Int16]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Int16]) -> [Char] -> [Int16]
forall a b. (a -> b) -> a -> b
$ Proxy Int16 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Int16
forall {k} (t :: k). Proxy t
Proxy :: Proxy Int16)

instance NoSmallKey Int32 => SmallKey Int32 where
  allKeys :: [Int32]
allKeys = [Char] -> [Int32]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Int32]) -> [Char] -> [Int32]
forall a b. (a -> b) -> a -> b
$ Proxy Int32 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Int32
forall {k} (t :: k). Proxy t
Proxy :: Proxy Int32)

instance NoSmallKey Int64 => SmallKey Int64 where
  allKeys :: [Int64]
allKeys = [Char] -> [Int64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Int64]) -> [Char] -> [Int64]
forall a b. (a -> b) -> a -> b
$ Proxy Int64 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Int64
forall {k} (t :: k). Proxy t
Proxy :: Proxy Int64)

instance NoSmallKey Word => SmallKey Word where
  allKeys :: [Word]
allKeys = [Char] -> [Word]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word]) -> [Char] -> [Word]
forall a b. (a -> b) -> a -> b
$ Proxy Word -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Word
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word)

instance NoSmallKey Word8 => SmallKey Word8 where
  allKeys :: [Word8]
allKeys = [Char] -> [Word8]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word8]) -> [Char] -> [Word8]
forall a b. (a -> b) -> a -> b
$ Proxy Word8 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Word8
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word8)

instance NoSmallKey Word16 => SmallKey Word16 where
  allKeys :: [Word16]
allKeys = [Char] -> [Word16]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word16]) -> [Char] -> [Word16]
forall a b. (a -> b) -> a -> b
$ Proxy Word16 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Word16
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word16)

instance NoSmallKey Word32 => SmallKey Word32 where
  allKeys :: [Word32]
allKeys = [Char] -> [Word32]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word32]) -> [Char] -> [Word32]
forall a b. (a -> b) -> a -> b
$ Proxy Word32 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Word32
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word32)

instance NoSmallKey Word64 => SmallKey Word64 where
  allKeys :: [Word64]
allKeys = [Char] -> [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word64]) -> [Char] -> [Word64]
forall a b. (a -> b) -> a -> b
$ Proxy Word64 -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Word64
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word64)

instance NoSmallKey Char => SmallKey Char where
  allKeys :: [Char]
allKeys = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy Char -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Char
forall {k} (t :: k). Proxy t
Proxy :: Proxy Char)

instance NoSmallKey Text => SmallKey Text where
  allKeys :: [Text]
allKeys = [Char] -> [Text]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Text]) -> [Char] -> [Text]
forall a b. (a -> b) -> a -> b
$ Proxy Text -> [Char]
forall a. Typeable a => Proxy a -> [Char]
unreachableSK (Proxy Text
forall {k} (t :: k). Proxy t
Proxy :: Proxy Text)