Pack.hs

-- | Tests for Lorentz packing/unpacking

module Test.Lorentz.Pack
  ( test_lambda_roundtrip
  ) where

import Prelude hiding (drop, swap)
import Test.HUnit (Assertion, assertFailure, (@?=))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Lorentz
import Michelson.Typed.Instr (Instr(..))
import Michelson.Typed.Util (DfsSettings(..), dfsFoldInstr)

test_lambda_roundtrip :: [TestTree]
test_lambda_roundtrip =
  [ testCase "Packing and then unpacking a Lambda does not add empty annotations" $
      lambdaRoundtripWithoutNotes lam
  ]
  where
    lam :: Lambda () ()
    lam = push @Natural 5 # drop

-- | Checks that packing and unpacking a lambda made of instructions without
-- Annotations will produce the same lambda, still without annotations.
lambdaRoundtripWithoutNotes
  :: forall i o. NiceUnpackedValue (Lambda i o)
  => Lambda i o
  -> Assertion
lambdaRoundtripWithoutNotes l = case lUnpackValue @(Lambda i o) $ lPackValue l of
  Left err -> assertFailure $ "Unpacking error: " <> show err
  Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of
    [] -> ul @?= l
    notes -> assertFailure $ "Lambda has annotations: " <> show notes
  where
    dfsSettings :: DfsSettings [Text]
    dfsSettings = def { dsGoToValues = True}

    instrNotes :: Instr inp out -> [Text]
    instrNotes = \case
      InstrWithNotes n _ -> [show n]
      _ -> []