{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Evaluation.Builtins.BLS12_381.TestClasses
where

import Evaluation.Builtins.Common (PlcTerm, mkApp1, mkApp2)

import PlutusCore.Crypto.BLS12_381.G1 qualified as G1
import PlutusCore.Crypto.BLS12_381.G2 qualified as G2
import PlutusCore.Default
import PlutusCore.Generators.QuickCheck.Builtin (ArbitraryBuiltin)
import PlutusCore.MkPlc (mkConstant)

import Data.ByteString as BS (ByteString, empty)
import Test.QuickCheck (Arbitrary (..), Gen, frequency, suchThat)

---------------- Typeclasses for groups ----------------

{- | The code for the property tests for G1 and G2 is essentially identical, so
 it's worth abstracting over the common features.  The blst Haskell FFI uses a
 phantom type to do this but unfortunately we have to hide that to stop the
 builtin machinery spotting it and then we have to re-abstract here. -}

-- We could re-use the AbelianGroup class here, but that uses <> and `mempty`
-- and that's confusing.
class (Eq a, Show a, Arbitrary a, ArbitraryBuiltin a, DefaultUni `Contains` a) => TestableAbelianGroup a
    where
      groupName          :: String
      zero               :: a
      addTerm            :: PlcTerm -> PlcTerm -> PlcTerm
      negTerm            :: PlcTerm -> PlcTerm
      scalarMulTerm      :: PlcTerm -> PlcTerm -> PlcTerm
      multiScalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm
      eqTerm             :: PlcTerm -> PlcTerm -> PlcTerm

zeroTerm :: forall g. TestableAbelianGroup g => PlcTerm
zeroTerm :: forall g. TestableAbelianGroup g => PlcTerm
zeroTerm = () -> g -> PlcTerm
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
mkConstant () (g -> PlcTerm) -> g -> PlcTerm
forall a b. (a -> b) -> a -> b
$ forall a. TestableAbelianGroup a => a
zero @g

-- An arbitrary nonzero group element.  For the BLS12-381 groups it's highly
-- unlikely that we'll get the zero element, but let's make sure.
arbitraryNonZero :: forall g. TestableAbelianGroup g => Gen g
arbitraryNonZero :: forall g. TestableAbelianGroup g => Gen g
arbitraryNonZero = (forall a. Arbitrary a => Gen a
arbitrary @g) Gen g -> (g -> Bool) -> Gen g
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (g -> g -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (forall a. TestableAbelianGroup a => a
zero @g))

class TestableAbelianGroup a => HashAndCompress a
    where
      compressedSize  :: Int
      compress        :: a -> ByteString
      compressTerm    :: PlcTerm -> PlcTerm
      uncompressTerm  :: PlcTerm -> PlcTerm
      hashToGroupTerm :: PlcTerm -> PlcTerm -> PlcTerm

---------- Instances for G1 ----------

{- | Generate an arbitrary element of G1.  It's tricky to construct such an
 element directly without using quite low-level operations on the curve
 because a random point on the curve is highly unlikely to be in the subgroup
 G1, but fortunately `hashToGroup` always produces an element of the subgroup,
 so we can produce random elements of G1 by hashing random bytestrings. -}
instance Arbitrary G1.Element
    where
      arbitrary :: Gen Element
arbitrary = [(Int, Gen Element)] -> Gen Element
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
9, Gen Element
arbitraryElement)
                            , (Int
1, Element -> Gen Element
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> Gen Element) -> Element -> Gen Element
forall a b. (a -> b) -> a -> b
$ Element
G1.offchain_zero)
                            ]
        where arbitraryElement :: Gen Element
arbitraryElement =
                ByteString -> ByteString -> Either BLS12_381_Error Element
G1.hashToGroup (ByteString -> ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString
-> Gen (ByteString -> Either BLS12_381_Error Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary Gen (ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString -> Gen (Either BLS12_381_Error Element)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Gen ByteString
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BS.empty Gen (Either BLS12_381_Error Element)
-> (Either BLS12_381_Error Element -> Gen Element) -> Gen Element
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left BLS12_381_Error
err -> [Char] -> Gen Element
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen Element) -> [Char] -> Gen Element
forall a b. (a -> b) -> a -> b
$ [Char]
"Arbitrary instance for G1.Element:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BLS12_381_Error -> [Char]
forall a. Show a => a -> [Char]
show BLS12_381_Error
err
                Right Element
p  -> Element -> Gen Element
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
p

instance TestableAbelianGroup G1.Element
    where
      groupName :: [Char]
groupName          = [Char]
"G1"
      zero :: Element
zero               = Element
G1.offchain_zero
      addTerm :: PlcTerm -> PlcTerm -> PlcTerm
addTerm            = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G1_add
      negTerm :: PlcTerm -> PlcTerm
negTerm            = DefaultFun -> PlcTerm -> PlcTerm
mkApp1 DefaultFun
Bls12_381_G1_neg
      scalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm
scalarMulTerm      = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G1_scalarMul
      multiScalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm
multiScalarMulTerm = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G1_multiScalarMul
      eqTerm :: PlcTerm -> PlcTerm -> PlcTerm
eqTerm             = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G1_equal

instance HashAndCompress G1.Element
    where
      compressedSize :: Int
compressedSize  = Int
48
      compress :: Element -> ByteString
compress        = Element -> ByteString
G1.compress
      compressTerm :: PlcTerm -> PlcTerm
compressTerm    = DefaultFun -> PlcTerm -> PlcTerm
mkApp1 DefaultFun
Bls12_381_G1_compress
      uncompressTerm :: PlcTerm -> PlcTerm
uncompressTerm  = DefaultFun -> PlcTerm -> PlcTerm
mkApp1 DefaultFun
Bls12_381_G1_uncompress
      hashToGroupTerm :: PlcTerm -> PlcTerm -> PlcTerm
hashToGroupTerm = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G1_hashToGroup

---------- Instances for G2 ----------

-- | See the comment for the Arbitrary instance for G1.
instance Arbitrary G2.Element
    where
      arbitrary :: Gen Element
arbitrary = [(Int, Gen Element)] -> Gen Element
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
9, Gen Element
arbitraryElement)
                            , (Int
1, Element -> Gen Element
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> Gen Element) -> Element -> Gen Element
forall a b. (a -> b) -> a -> b
$ Element
G2.offchain_zero)
                            ]
        where arbitraryElement :: Gen Element
arbitraryElement =
                ByteString -> ByteString -> Either BLS12_381_Error Element
G2.hashToGroup (ByteString -> ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString
-> Gen (ByteString -> Either BLS12_381_Error Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary Gen (ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString -> Gen (Either BLS12_381_Error Element)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Gen ByteString
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BS.empty Gen (Either BLS12_381_Error Element)
-> (Either BLS12_381_Error Element -> Gen Element) -> Gen Element
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left BLS12_381_Error
err -> [Char] -> Gen Element
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen Element) -> [Char] -> Gen Element
forall a b. (a -> b) -> a -> b
$ [Char]
"Arbitrary instance for G2.Element:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BLS12_381_Error -> [Char]
forall a. Show a => a -> [Char]
show BLS12_381_Error
err
                Right Element
p  -> Element -> Gen Element
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
p

instance TestableAbelianGroup G2.Element
    where
      groupName :: [Char]
groupName          = [Char]
"G2"
      zero :: Element
zero               = Element
G2.offchain_zero
      addTerm :: PlcTerm -> PlcTerm -> PlcTerm
addTerm            = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G2_add
      negTerm :: PlcTerm -> PlcTerm
negTerm            = DefaultFun -> PlcTerm -> PlcTerm
mkApp1 DefaultFun
Bls12_381_G2_neg
      scalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm
scalarMulTerm      = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G2_scalarMul
      multiScalarMulTerm :: PlcTerm -> PlcTerm -> PlcTerm
multiScalarMulTerm = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G2_multiScalarMul
      eqTerm :: PlcTerm -> PlcTerm -> PlcTerm
eqTerm             = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G2_equal

instance HashAndCompress G2.Element
    where
      compressedSize :: Int
compressedSize  = Int
96
      compress :: Element -> ByteString
compress        = Element -> ByteString
G2.compress
      compressTerm :: PlcTerm -> PlcTerm
compressTerm    = DefaultFun -> PlcTerm -> PlcTerm
mkApp1 DefaultFun
Bls12_381_G2_compress
      uncompressTerm :: PlcTerm -> PlcTerm
uncompressTerm  = DefaultFun -> PlcTerm -> PlcTerm
mkApp1 DefaultFun
Bls12_381_G2_uncompress
      hashToGroupTerm :: PlcTerm -> PlcTerm -> PlcTerm
hashToGroupTerm = DefaultFun -> PlcTerm -> PlcTerm -> PlcTerm
mkApp2 DefaultFun
Bls12_381_G2_hashToGroup