{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Flat.Spec (test_flat) where

import Codec.Serialise (serialise)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Char (ord)
import Data.Word
import PlutusCore.Data (Data)
import PlutusCore.DeBruijn
import PlutusCore.Default (DefaultFun (..), DefaultUni (..))
import PlutusCore.Flat
import PlutusCore.Flat.Bits (asBytes, bits)
import PlutusCore.Generators.QuickCheck.Builtin ()
import PlutusCore.Name.Unique (Name (..), TyName (..), Unique (..))
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Universe (Some (..), ValueOf (..))
import UntypedPlutusCore.Core.Type

-- Also brings the Flat (Strict.Vector a) orphan instance into scope:
import UntypedPlutusCore (UnrestrictedProgram (..))

test_deBruijnIso :: TestTree
test_deBruijnIso :: TestTree
test_deBruijnIso = TestName -> (DeBruijn -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"deBruijnIso" ((DeBruijn -> Property) -> TestTree)
-> (DeBruijn -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \DeBruijn
d ->
  DeBruijn
d DeBruijn -> DeBruijn -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== FakeNamedDeBruijn -> DeBruijn
fromFake (DeBruijn -> FakeNamedDeBruijn
toFake DeBruijn
d)

test_fakeIso :: TestTree
test_fakeIso :: TestTree
test_fakeIso = TestName -> (FakeNamedDeBruijn -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"fakeIso" ((FakeNamedDeBruijn -> Property) -> TestTree)
-> (FakeNamedDeBruijn -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \FakeNamedDeBruijn
fnd ->
  FakeNamedDeBruijn
fnd FakeNamedDeBruijn -> FakeNamedDeBruijn -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== DeBruijn -> FakeNamedDeBruijn
toFake (FakeNamedDeBruijn -> DeBruijn
fromFake FakeNamedDeBruijn
fnd)

test_deBruijnTripping :: TestTree
test_deBruijnTripping :: TestTree
test_deBruijnTripping = TestName -> (DeBruijn -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"debruijnTripping" ((DeBruijn -> Property) -> TestTree)
-> (DeBruijn -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \DeBruijn
d ->
  DeBruijn -> Either DecodeException DeBruijn
forall a b. b -> Either a b
Right DeBruijn
d Either DecodeException DeBruijn
-> Either DecodeException DeBruijn -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString -> Either DecodeException DeBruijn
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (forall a. Flat a => a -> ByteString
flat @DeBruijn DeBruijn
d)

test_fakeTripping :: TestTree
test_fakeTripping :: TestTree
test_fakeTripping = TestName -> (FakeNamedDeBruijn -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"fakeTripping" ((FakeNamedDeBruijn -> Property) -> TestTree)
-> (FakeNamedDeBruijn -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \FakeNamedDeBruijn
fnd ->
  FakeNamedDeBruijn -> Either DecodeException FakeNamedDeBruijn
forall a b. b -> Either a b
Right FakeNamedDeBruijn
fnd Either DecodeException FakeNamedDeBruijn
-> Either DecodeException FakeNamedDeBruijn -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString -> Either DecodeException FakeNamedDeBruijn
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (forall a. Flat a => a -> ByteString
flat @FakeNamedDeBruijn FakeNamedDeBruijn
fnd)

test_binderDeBruijn :: TestTree
test_binderDeBruijn :: TestTree
test_binderDeBruijn = TestName -> (Binder DeBruijn -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"binderDeBruijn" ((Binder DeBruijn -> Property) -> TestTree)
-> (Binder DeBruijn -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \Binder DeBruijn
b ->
  -- binders should always decode as init binder
  Binder DeBruijn -> Either DecodeException (Binder DeBruijn)
forall a b. b -> Either a b
Right Binder DeBruijn
initB Either DecodeException (Binder DeBruijn)
-> Either DecodeException (Binder DeBruijn) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString -> Either DecodeException (Binder DeBruijn)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (forall a. Flat a => a -> ByteString
flat @(Binder DeBruijn) Binder DeBruijn
b)

test_binderFake :: TestTree
test_binderFake :: TestTree
test_binderFake = TestName -> (Binder FakeNamedDeBruijn -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"binderFake" ((Binder FakeNamedDeBruijn -> Property) -> TestTree)
-> (Binder FakeNamedDeBruijn -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \Binder FakeNamedDeBruijn
bf ->
  -- binders should always decode as init binder
  Binder FakeNamedDeBruijn
-> Either DecodeException (Binder FakeNamedDeBruijn)
forall a b. b -> Either a b
Right (DeBruijn -> FakeNamedDeBruijn
toFake (DeBruijn -> FakeNamedDeBruijn)
-> Binder DeBruijn -> Binder FakeNamedDeBruijn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Binder DeBruijn
initB) Either DecodeException (Binder FakeNamedDeBruijn)
-> Either DecodeException (Binder FakeNamedDeBruijn) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString -> Either DecodeException (Binder FakeNamedDeBruijn)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (forall a. Flat a => a -> ByteString
flat @(Binder FakeNamedDeBruijn) Binder FakeNamedDeBruijn
bf)

{- Check that a bytestring is the canonical flat encoding of another bytestring.
A bytestring is encoded as sequence of chunks where each chunk is preceded by a
single byte giving its length and the end of the bytestring is marked by a
zero-length chunk.  The encoding is canonical if it consists of a (possibly
empty) sequence of 255-byte chunks followed by an optional smaller block
followed by an empty block.  See Note [Flat serialisation for strict and lazy
bytestrings].  See Appendix C of the Plutus Core specification for details of
the `flat` encoding, in particular Section C.2.5. -}
isCanonicalFlatEncodedByteString :: BS.ByteString -> Bool
isCanonicalFlatEncodedByteString :: ByteString -> Bool
isCanonicalFlatEncodedByteString ByteString
bs =
  case ByteString -> [Word8]
BS.unpack ByteString
bs of
    [] -> Bool
False -- Should never happen.
    Word8
0x01 : [Word8]
r -> [Word8] -> Bool
forall {a}. Integral a => [a] -> Bool
go [Word8]
r -- 0x01 is the tag for an encoded bytestring
    --  (Plutus Core specification, Table C.2)
    [Word8]
_ -> Bool
False -- Not the encoding of a bytestring.
  where
    go :: [a] -> Bool
go [] = Bool
False -- We've fallen off the end, possibly due to having dropped too many bytes.
    go l :: [a]
l@(a
w : [a]
ws) =
      -- w is the purported size of the next chunk.
      if a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0xFF
        then [a] -> Bool
go (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
255 [a]
ws) -- Throw away any initial 255-byte chunks.
        else [a]
l [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
end Bool -> Bool -> Bool
|| Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w) [a]
ws [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
end
      where
        -- Either we've arrived exactly at the end or we have a single short chunk before the end.
        end :: [a]
end = [a
0x00, a
0x01] -- An empty chunk followed by a padding byte.

test_canonicalEncoding :: forall a. (Arbitrary a, Flat a, Show a) => String -> Int -> TestTree
test_canonicalEncoding :: forall a.
(Arbitrary a, Flat a, Show a) =>
TestName -> Int -> TestTree
test_canonicalEncoding TestName
s Int
n =
  TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
s (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
    Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
n (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Gen a -> (a -> Bool) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall a. Arbitrary a => Gen a
arbitrary @a) (ByteString -> Bool
isCanonicalFlatEncodedByteString (ByteString -> Bool) -> (a -> ByteString) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Flat a => a -> ByteString
flat @a)

-- Data objects are encoded by first being converted to a bytestring using CBOR.
-- This is the case that we're really interested in, since we get a lazy
-- bytestring from CBOR and it has to converted into a strict one to ensure that
-- the encoding's canonical.
test_canonicalData :: TestTree
test_canonicalData :: TestTree
test_canonicalData =
  forall a.
(Arbitrary a, Flat a, Show a) =>
TestName -> Int -> TestTree
test_canonicalEncoding @Data TestName
"flat encodes Data canonically" Int
5000

-- We may as well check that it does the right thing for strict bytestrings
-- while we're here.
test_canonicalByteString :: TestTree
test_canonicalByteString :: TestTree
test_canonicalByteString =
  forall a.
(Arbitrary a, Flat a, Show a) =>
TestName -> Int -> TestTree
test_canonicalEncoding @BS.ByteString TestName
"flat encodes ByteStrings canonically" Int
1000

{- Some tests that non-canonically encoded bytestrings decode correctly to strict
bytestrings.  One strategy is to encode lazy bytestrings and decode the results
to get strict bytestrings and then check that the result is the same as
converting the original input into a strict bytestring, and we do this with
arbitrary lazy bytestrings and also ones obtained by CBOR-serialising `Data`
objects. However this will only test what we want when the lazy bytestring is
encoded non-canonically, which in fact happens quite rarely. To make sure that
we really do test some non-canonical inputs there are a few handwritten examples
as well. -}
test_nonCanonicalByteStringDecoding :: TestTree
test_nonCanonicalByteStringDecoding :: TestTree
test_nonCanonicalByteStringDecoding =
  let target :: ByteString
target = ByteString
"This is a test." :: BS.ByteString

      ch :: Char -> Word8
      ch :: Char -> Word8
ch = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

      input1 :: ByteString
input1 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01 -- 0x01 is the tag for an encoded bytestring.
          , Word8
0x01
          , Char -> Word8
ch Char
'T'
          , Word8
0x01
          , Char -> Word8
ch Char
'h'
          , Word8
0x01
          , Char -> Word8
ch Char
'i'
          , Word8
0x01
          , Char -> Word8
ch Char
's'
          , Word8
0x01
          , Char -> Word8
ch Char
' '
          , Word8
0x01
          , Char -> Word8
ch Char
'i'
          , Word8
0x01
          , Char -> Word8
ch Char
's'
          , Word8
0x01
          , Char -> Word8
ch Char
' '
          , Word8
0x01
          , Char -> Word8
ch Char
'a'
          , Word8
0x01
          , Char -> Word8
ch Char
' '
          , Word8
0x01
          , Char -> Word8
ch Char
't'
          , Word8
0x01
          , Char -> Word8
ch Char
'e'
          , Word8
0x01
          , Char -> Word8
ch Char
's'
          , Word8
0x01
          , Char -> Word8
ch Char
't'
          , Word8
0x01
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      input2 :: ByteString
input2 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01
          , Word8
0x03
          , Char -> Word8
ch Char
'T'
          , Char -> Word8
ch Char
'h'
          , Char -> Word8
ch Char
'i'
          , Word8
0x03
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'i'
          , Word8
0x03
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'a'
          , Word8
0x03
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'e'
          , Word8
0x03
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      input3 :: ByteString
input3 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01
          , Word8
0x01
          , Char -> Word8
ch Char
'T'
          , Word8
0x02
          , Char -> Word8
ch Char
'h'
          , Char -> Word8
ch Char
'i'
          , Word8
0x03
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'i'
          , Word8
0x04
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'a'
          , Char -> Word8
ch Char
' '
          , Word8
0x05
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'e'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      input4 :: ByteString
input4 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01
          , Word8
0x05
          , Char -> Word8
ch Char
'T'
          , Char -> Word8
ch Char
'h'
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Word8
0x05
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'a'
          , Char -> Word8
ch Char
' '
          , Word8
0x05
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'e'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      input5 :: ByteString
input5 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01
          , Word8
0x05
          , Char -> Word8
ch Char
'T'
          , Char -> Word8
ch Char
'h'
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Word8
0x04
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'a'
          , Word8
0x03
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'e'
          , Word8
0x02
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
't'
          , Word8
0x01
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      input6 :: ByteString
input6 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01
          , Word8
0x01
          , Char -> Word8
ch Char
'T'
          , Word8
0x0e
          , Char -> Word8
ch Char
'h'
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'a'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'e'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      input7 :: ByteString
input7 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01
          , Word8
0x01
          , Char -> Word8
ch Char
'T'
          , Word8
0x0d
          , Char -> Word8
ch Char
'h'
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'a'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'e'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
't'
          , Word8
0x01
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      input8 :: ByteString
input8 =
        [Word8] -> ByteString
BS.pack
          [ Word8
0x01
          , Word8
0x03
          , Char -> Word8
ch Char
'T'
          , Char -> Word8
ch Char
'h'
          , Char -> Word8
ch Char
'i'
          , Word8
0x01
          , Char -> Word8
ch Char
's'
          , Word8
0x05
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'i'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
'a'
          , Word8
0x02
          , Char -> Word8
ch Char
' '
          , Char -> Word8
ch Char
't'
          , Word8
0x04
          , Char -> Word8
ch Char
'e'
          , Char -> Word8
ch Char
's'
          , Char -> Word8
ch Char
't'
          , Char -> Word8
ch Char
'.'
          , Word8
0x00
          , Word8
0x01
          ]

      mkTest :: b -> Assertion
mkTest b
input =
        HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"Input failed to decode successfully" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
          (ByteString -> Either DecodeException ByteString
forall a b. b -> Either a b
Right ByteString
target Either DecodeException ByteString
-> Either DecodeException ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== b -> Either DecodeException ByteString
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat b
input)
   in TestName -> [TestTree] -> TestTree
testGroup
        TestName
"Non-canonical bytestring encodings decode succesfully"
        [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"Data via lazy bytestrings" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
            Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
5000 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Gen Data -> (Data -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall a. Arbitrary a => Gen a
arbitrary @Data) \Data
d ->
              Data -> Either DecodeException Data
forall a b. b -> Either a b
Right Data
d Either DecodeException Data
-> Either DecodeException Data -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString -> Either DecodeException Data
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (ByteString -> ByteString
forall a. Flat a => a -> ByteString
flat (Data -> ByteString
forall a. Serialise a => a -> ByteString
serialise Data
d :: BSL.ByteString))
        , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"Arbitrary lazy bytestrings" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
            Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
10000 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
              Gen ByteString -> (ByteString -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall a. Arbitrary a => Gen a
arbitrary @BSL.ByteString) \ByteString
bs ->
                ByteString -> Either DecodeException ByteString
forall a b. b -> Either a b
Right (ByteString -> ByteString
BSL.toStrict ByteString
bs) Either DecodeException ByteString
-> Either DecodeException ByteString -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString -> Either DecodeException ByteString
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (ByteString -> ByteString
forall a. Flat a => a -> ByteString
flat ByteString
bs)
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 1" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input1
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 2" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input2
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 3" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input3
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 4" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input4
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 5" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input5
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 6" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input6
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 7" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input7
        , TestName -> Assertion -> TestTree
testCase TestName
"Explicit input 8" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ByteString -> Assertion
forall {b}. AsByteString b => b -> Assertion
mkTest ByteString
input8
        ]

{-| Stable byte encoding tests for Binder types.
These pin the exact byte representation to detect encoding changes. -}
test_binderStaticEncoding :: TestTree
test_binderStaticEncoding :: TestTree
test_binderStaticEncoding =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Binder stable encoding"
    [ TestName -> Assertion -> TestTree
testCase TestName
"Binder DeBruijn encodes as empty (zero-cost)" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        Binder DeBruijn -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (DeBruijn -> Binder DeBruijn
forall name. name -> Binder name
Binder (Index -> DeBruijn
DeBruijn Index
deBruijnInitIndex) :: Binder DeBruijn) [Word8] -> [Word8] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= []
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder FakeNamedDeBruijn encodes as empty (zero-cost)" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        Binder FakeNamedDeBruijn -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (FakeNamedDeBruijn -> Binder FakeNamedDeBruijn
forall name. name -> Binder name
Binder (DeBruijn -> FakeNamedDeBruijn
toFake (Index -> DeBruijn
DeBruijn Index
deBruijnInitIndex)) :: Binder FakeNamedDeBruijn) [Word8] -> [Word8] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= []
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder Name encodes same as Name" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        Binder Name -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (Name -> Binder Name
forall name. name -> Binder name
Binder (Text -> Unique -> Name
Name Text
"x" (Int -> Unique
Unique Int
0)) :: Binder Name)
          [Word8] -> [Word8] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Name -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (Text -> Unique -> Name
Name Text
"x" (Int -> Unique
Unique Int
0))
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder TyName encodes same as TyName" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        Binder TyName -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (TyName -> Binder TyName
forall name. name -> Binder name
Binder (Name -> TyName
TyName (Text -> Unique -> Name
Name Text
"x" (Int -> Unique
Unique Int
0))) :: Binder TyName)
          [Word8] -> [Word8] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= TyName -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (Name -> TyName
TyName (Text -> Unique -> Name
Name Text
"x" (Int -> Unique
Unique Int
0)))
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder NamedDeBruijn encodes same as NamedDeBruijn" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        Binder NamedDeBruijn -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (NamedDeBruijn -> Binder NamedDeBruijn
forall name. name -> Binder name
Binder (Text -> Index -> NamedDeBruijn
NamedDeBruijn Text
"x" (Word64 -> Index
Index Word64
42)) :: Binder NamedDeBruijn)
          [Word8] -> [Word8] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= NamedDeBruijn -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (Text -> Index -> NamedDeBruijn
NamedDeBruijn Text
"x" (Word64 -> Index
Index Word64
42))
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder NamedTyDeBruijn encodes same as NamedTyDeBruijn" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        Binder NamedTyDeBruijn -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (NamedTyDeBruijn -> Binder NamedTyDeBruijn
forall name. name -> Binder name
Binder (NamedDeBruijn -> NamedTyDeBruijn
NamedTyDeBruijn (Text -> Index -> NamedDeBruijn
NamedDeBruijn Text
"x" (Word64 -> Index
Index Word64
42))) :: Binder NamedTyDeBruijn)
          [Word8] -> [Word8] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= NamedTyDeBruijn -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (NamedDeBruijn -> NamedTyDeBruijn
NamedTyDeBruijn (Text -> Index -> NamedDeBruijn
NamedDeBruijn Text
"x" (Word64 -> Index
Index Word64
42)))
    ]

-- | Roundtrip tests for newtype Binder wrappers (Name, TyName, NamedDeBruijn, NamedTyDeBruijn).
test_binderNewtypeRoundtrip :: TestTree
test_binderNewtypeRoundtrip :: TestTree
test_binderNewtypeRoundtrip =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Binder newtype roundtrip"
    [ TestName -> Assertion -> TestTree
testCase TestName
"Binder Name" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        let v :: Binder Name
v = Name -> Binder Name
forall name. name -> Binder name
Binder (Text -> Unique -> Name
Name Text
"x" (Int -> Unique
Unique Int
0)) :: Binder Name
         in ByteString -> Decoded (Binder Name)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (Binder Name -> ByteString
forall a. Flat a => a -> ByteString
flat Binder Name
v) Decoded (Binder Name) -> Decoded (Binder Name) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Binder Name -> Decoded (Binder Name)
forall a b. b -> Either a b
Right Binder Name
v
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder TyName" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        let v :: Binder TyName
v = TyName -> Binder TyName
forall name. name -> Binder name
Binder (Name -> TyName
TyName (Text -> Unique -> Name
Name Text
"x" (Int -> Unique
Unique Int
0))) :: Binder TyName
         in ByteString -> Decoded (Binder TyName)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (Binder TyName -> ByteString
forall a. Flat a => a -> ByteString
flat Binder TyName
v) Decoded (Binder TyName) -> Decoded (Binder TyName) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Binder TyName -> Decoded (Binder TyName)
forall a b. b -> Either a b
Right Binder TyName
v
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder NamedDeBruijn" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        let v :: Binder NamedDeBruijn
v = NamedDeBruijn -> Binder NamedDeBruijn
forall name. name -> Binder name
Binder (Text -> Index -> NamedDeBruijn
NamedDeBruijn Text
"x" (Word64 -> Index
Index Word64
42)) :: Binder NamedDeBruijn
         in ByteString -> Decoded (Binder NamedDeBruijn)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (Binder NamedDeBruijn -> ByteString
forall a. Flat a => a -> ByteString
flat Binder NamedDeBruijn
v) Decoded (Binder NamedDeBruijn)
-> Decoded (Binder NamedDeBruijn) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Binder NamedDeBruijn -> Decoded (Binder NamedDeBruijn)
forall a b. b -> Either a b
Right Binder NamedDeBruijn
v
    , TestName -> Assertion -> TestTree
testCase TestName
"Binder NamedTyDeBruijn" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        let v :: Binder NamedTyDeBruijn
v = NamedTyDeBruijn -> Binder NamedTyDeBruijn
forall name. name -> Binder name
Binder (NamedDeBruijn -> NamedTyDeBruijn
NamedTyDeBruijn (Text -> Index -> NamedDeBruijn
NamedDeBruijn Text
"x" (Word64 -> Index
Index Word64
42))) :: Binder NamedTyDeBruijn
         in ByteString -> Decoded (Binder NamedTyDeBruijn)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (Binder NamedTyDeBruijn -> ByteString
forall a. Flat a => a -> ByteString
flat Binder NamedTyDeBruijn
v) Decoded (Binder NamedTyDeBruijn)
-> Decoded (Binder NamedTyDeBruijn) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Binder NamedTyDeBruijn -> Decoded (Binder NamedTyDeBruijn)
forall a b. b -> Either a b
Right Binder NamedTyDeBruijn
v
    ]

{-| Roundtrip and stable byte test for a minimal UPLC program:
  (program 1.1.0 (con integer 0)) -}
test_uplcProgramFlat :: TestTree
test_uplcProgramFlat :: TestTree
test_uplcProgramFlat =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"UPLC Program"
    [ TestName -> Assertion -> TestTree
testCase TestName
"minimal program roundtrip" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        let encoded :: ByteString
encoded = UnrestrictedProgram DeBruijn DefaultUni DefaultFun () -> ByteString
forall a. Flat a => a -> ByteString
flat (Program DeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UnrestrictedProgram Program DeBruijn DefaultUni DefaultFun ()
prog)
         in (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
 -> Program DeBruijn DefaultUni DefaultFun ())
-> Either
     DecodeException
     (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
-> Either
     DecodeException (Program DeBruijn DefaultUni DefaultFun ())
forall a b.
(a -> b) -> Either DecodeException a -> Either DecodeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
UnrestrictedProgram name uni fun ann -> Program name uni fun ann
unUnrestrictedProgram (ByteString
-> Either
     DecodeException
     (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat ByteString
encoded) Either DecodeException (Program DeBruijn DefaultUni DefaultFun ())
-> Either
     DecodeException (Program DeBruijn DefaultUni DefaultFun ())
-> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Program DeBruijn DefaultUni DefaultFun ()
-> Either
     DecodeException (Program DeBruijn DefaultUni DefaultFun ())
forall a b. b -> Either a b
Right Program DeBruijn DefaultUni DefaultFun ()
prog
    , TestName -> Assertion -> TestTree
testCase TestName
"minimal program stable encoding" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        UnrestrictedProgram DeBruijn DefaultUni DefaultFun () -> [Word8]
forall a. Flat a => a -> [Word8]
flatBytes (Program DeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UnrestrictedProgram Program DeBruijn DefaultUni DefaultFun ()
prog) [Word8] -> [Word8] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Word8
1, Word8
1, Word8
0, Word8
72, Word8
0, Word8
0]
    ]
  where
    Program DeBruijn DefaultUni DefaultFun ()
prog :: Program DeBruijn DefaultUni DefaultFun () =
      ()
-> Version
-> Term DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
Program
        ()
        (Natural -> Natural -> Natural -> Version
Version Natural
1 Natural
1 Natural
0)
        (()
-> Some (ValueOf DefaultUni)
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Some (ValueOf uni) -> Term name uni fun ann
Constant () (ValueOf DefaultUni Integer -> Some (ValueOf DefaultUni)
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some (DefaultUni (Esc Integer) -> Integer -> ValueOf DefaultUni Integer
forall (uni :: * -> *) a. uni (Esc a) -> a -> ValueOf uni a
ValueOf DefaultUni (Esc Integer)
DefaultUniInteger (Integer
0 :: Integer))))

test_flat :: TestTree
test_flat :: TestTree
test_flat =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"FlatProp"
    [ TestTree
test_deBruijnIso
    , TestTree
test_fakeIso
    , TestTree
test_deBruijnTripping
    , TestTree
test_fakeTripping
    , TestTree
test_binderDeBruijn
    , TestTree
test_binderFake
    , TestTree
test_binderStaticEncoding
    , TestTree
test_binderNewtypeRoundtrip
    , TestTree
test_uplcProgramFlat
    , TestTree
test_canonicalData
    , TestTree
test_canonicalByteString
    , TestTree
test_nonCanonicalByteStringDecoding
    ]

-- Helpers

flatBytes :: Flat a => a -> [Word8]
flatBytes :: forall a. Flat a => a -> [Word8]
flatBytes = Bits -> [Word8]
asBytes (Bits -> [Word8]) -> (a -> Bits) -> a -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bits
forall a. Flat a => a -> Bits
bits

initB :: Binder DeBruijn
initB :: Binder DeBruijn
initB = DeBruijn -> Binder DeBruijn
forall name. name -> Binder name
Binder (DeBruijn -> Binder DeBruijn) -> DeBruijn -> Binder DeBruijn
forall a b. (a -> b) -> a -> b
$ Index -> DeBruijn
DeBruijn Index
deBruijnInitIndex

-- orphans for QuickCheck generation
deriving via Word64 instance Arbitrary DeBruijn
instance Arbitrary FakeNamedDeBruijn where
  arbitrary :: Gen FakeNamedDeBruijn
arbitrary = DeBruijn -> FakeNamedDeBruijn
toFake (DeBruijn -> FakeNamedDeBruijn)
-> Gen DeBruijn -> Gen FakeNamedDeBruijn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DeBruijn
forall a. Arbitrary a => Gen a
arbitrary -- via debruijn
deriving newtype instance Arbitrary (Binder DeBruijn)
deriving newtype instance Arbitrary (Binder FakeNamedDeBruijn)