content: module Tests.PreEncoded (
      testTree
    ) where
  
  import           Codec.CBOR.Term     (Term, encodeTerm)
  import           Codec.CBOR.FlatTerm (FlatTerm, toFlatTerm, TermToken(..))
  import           Codec.CBOR.Write    (toStrictByteString, toLazyByteString)
  import           Codec.CBOR.Encoding (Encoding, encodePreEncoded)
  
  import           Test.Tasty (TestTree, testGroup)
  import           Test.Tasty.QuickCheck (testProperty)
  
  import           Tests.Term () -- instance Arbitrary Term
  import           Tests.Reference.Generators
                     (canonicalNaN, floatToWord, doubleToWord)
  
  
  -- | Use 'encodePreEncoded' but with a serialised term as the bytes.
  --
  encodePreEncoded' :: Term -> Encoding
  encodePreEncoded' = encodePreEncoded . toStrictByteString . encodeTerm
  
  
  prop_preEncodedTerm_sameBytes :: Term -> Bool
  prop_preEncodedTerm_sameBytes t =
      sameBytes
        (encodeTerm t)
        (encodePreEncoded' t)
  
  
  prop_preEncodedTerm_sameTokens :: Term -> Bool
  prop_preEncodedTerm_sameTokens t =
      sameTokens
        (encodeTerm t)
        (encodePreEncoded' t)
  
  
  prop_preEncodedTerms_sameBytes :: [(Term, Bool)] -> Bool
  prop_preEncodedTerms_sameBytes ts  =
      sameBytes
        (mconcat [ encodeTerm t | (t, _) <- ts ])
        (mconcat [ if pre then encodePreEncoded' t
                          else encodeTerm t
                 | (t, pre) <- ts ])
  
  prop_preEncodedTerms_sameTokens :: [(Term, Bool)] -> Bool
  prop_preEncodedTerms_sameTokens ts  =
      sameTokens
        (mconcat [ encodeTerm t | (t, _) <- ts ])
        (mconcat [ if pre then encodePreEncoded' t
                          else encodeTerm t
                 | (t, pre) <- ts ])
  
  
  sameBytes :: Encoding -> Encoding -> Bool
  sameBytes e1 e2 = toLazyByteString e1 == toLazyByteString e2
  
  sameTokens :: Encoding -> Encoding -> Bool
  sameTokens e1 e2 = canonicaliseFlatTerm (toFlatTerm e1)
        `eqFlatTerm` canonicaliseFlatTerm (toFlatTerm e2)
  
  canonicaliseFlatTerm :: FlatTerm -> FlatTerm
  canonicaliseFlatTerm = map canonicaliseTermToken
  
  canonicaliseTermToken :: TermToken -> TermToken
  canonicaliseTermToken (TkFloat16 f) | isNaN f = TkFloat16 canonicalNaN
  canonicaliseTermToken (TkFloat32 f) | isNaN f = TkFloat16 canonicalNaN
  canonicaliseTermToken (TkFloat64 f) | isNaN f = TkFloat16 canonicalNaN
  canonicaliseTermToken x = x
  
  eqFlatTerm :: FlatTerm -> FlatTerm -> Bool
  eqFlatTerm x y = and (zipWith eqTermToken x y)
  
  -- NaNs strike again!
  eqTermToken :: TermToken -> TermToken -> Bool
  eqTermToken (TkFloat16 x) (TkFloat16 y) = floatToWord  x == floatToWord  y
  eqTermToken (TkFloat32 x) (TkFloat32 y) = floatToWord  x == floatToWord  y
  eqTermToken (TkFloat64 x) (TkFloat64 y) = doubleToWord x == doubleToWord y
  eqTermToken x y = x == y
  
  
  --------------------------------------------------------------------------------
  -- TestTree API
  
  testTree :: TestTree
  testTree =
    testGroup "pre-encoded"
    [ testProperty "single term, same bytes"   prop_preEncodedTerm_sameBytes
    , testProperty "single term, same tokens"  prop_preEncodedTerm_sameTokens
    , testProperty "list terms, same bytes"    prop_preEncodedTerms_sameBytes
    , testProperty "list terms, same tokens"   prop_preEncodedTerms_sameTokens
    ]
  
  