Util.hs

-- SPDX-FileCopyrightText: 2021 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# LANGUAGE OverloadedLists #-}


module Test.Serialization.Util
  ( Example(..)
  , TestMethod(..)
  , deserializeNegSpecImpl
  , examples
  , fromBinaryTestMethodImpl
  , fromJsonTestMethodImpl
  , serializeSpecManualImpl
  , toBinaryTestMethodImpl
  , toJsonTestMethodImpl
  , (~:)
  ) where

import qualified Data.Aeson as J
import Data.Aeson.Encode.Pretty (Indent(Spaces), confCompare, confIndent, defConfig, encodePretty')
import Fmt (pretty)
import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy)
import Test.Hspec.Expectations (expectationFailure)
import Text.Hex (encodeHex)

import Morley.Micheline.Class (FromExpression(..), ToExpression(..))
import Morley.Micheline.Expression (Expression)
import Morley.Michelson.Interpret.Unpack
import Test.Cleveland.Util

-- | Helper for defining tests cases for 'serializeSpec'.
(~:) :: a -> b -> (a, b)
(~:) = (,)
infixr 0 ~:

-- | Dummy wrapper for the data needed to test an example scenario + its name.
data Example a = Example
  { _eTestName :: String
  , _eTestData :: a
  }

-- | Creates a list of example scenarios and labels them using their index.
-- examples :: [a] -> [Example a]
examples :: [a] -> [Example a]
examples xs =
  xs `zip` [1..] <&>
    \(testData, index) -> Example ("Example #" <> show @String @Int index) testData

-- | Dummy wrapper for what do we test - serialize/deserialize from/to binary/json.
data TestMethod t = TestMethod
  { _tmName :: String
  , _tmApply :: t -> Text -> J.Value -> Expectation
  }

toBinaryTestMethodImpl :: HasCallStack => (t -> ByteString) -> [TestMethod t]
toBinaryTestMethodImpl doPack = one $
  TestMethod "To binary" $
    \val encodedHex _ ->
      encodeHex (doPack val) `shouldBe` stripOptional0x encodedHex

fromBinaryTestMethodImpl :: (HasCallStack, Show t, Eq t) => (ByteString -> Either UnpackError t) -> [TestMethod t]
fromBinaryTestMethodImpl doUnpack = one $
  TestMethod "From binary" $
    \val encodedHex _ ->
      doUnpack (unsafeFromHex encodedHex) `shouldBe` Right val

toJsonTestMethodImpl :: (ToExpression t) => HasCallStack => [TestMethod t]
toJsonTestMethodImpl = one $
  TestMethod "To json" $
    \val _ expectedJson -> do
      let actualJson = J.toJSON (toExpression val)
      ShowWith prettify actualJson `shouldBe` ShowWith prettify expectedJson
  where
    prettify :: J.Value -> String
    prettify =
      decodeUtf8 . encodePretty'
        -- we use `confCompare` to reverse the order of the json keys, so that `prim` appears before `args`.
        (defConfig { confCompare = \x y -> compare y x, confIndent = Spaces 2 })

fromJsonTestMethodImpl :: forall t. (FromExpression t, Show t, Eq t) => HasCallStack => [TestMethod t]
fromJsonTestMethodImpl = one $
  TestMethod "From json" $
    \expectedVal _ json -> do
      case J.eitherDecode' @Expression (J.encode json) of
        Left err -> expectationFailure $ pretty err
        Right expr -> do
          case fromExpression @t expr of
            Left err -> expectationFailure $ pretty err
            Right val ->
              val `shouldBe` expectedVal

serializeSpecManualImpl
  :: forall y x. (HasCallStack)
  => (y -> x) -> String -> [TestMethod x] -> [Example (y, (Text, J.Value))] -> Spec
serializeSpecManualImpl toVal' name testMethods suites =
  forM_ @[_] testMethods $ \(TestMethod mname method) ->
    describe mname $
      describe name $ forM_ suites $ \(Example exampleName (x, (hex, json))) ->
        it exampleName $ method (toVal' x) hex json

deserializeNegSpecImpl
  :: forall t. (FromExpression t, Show t)
  => (ByteString -> Either UnpackError t)
  -> String
  -> Text
  -> J.Value
  -> Spec
deserializeNegSpecImpl doUnpack name encodedHex json =
  describe name $ do
    it "From binary" $
      let encoded = unsafeFromHex (stripOptional0x encodedHex)
      in doUnpack encoded `shouldSatisfy` isLeft
    it "From json" $
      case J.eitherDecode' @Expression (J.encode json) of
        Left _ -> pass
        Right expr -> do
          fromExpression @t expr `shouldSatisfy` isLeft