Pack.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Tests for Lorentz packing/unpacking

module Test.Lorentz.Pack
  ( test_lambda_roundtrip
  ) where

import Debug qualified (show)
import Lorentz
import Prelude hiding (drop, swap)

import Fmt (pretty)
import Test.HUnit (Assertion, assertFailure, (@?=))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Morley.Michelson.Typed.Instr (Instr(..))
import Morley.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 lUnpackValueRaw @(Lambda i o) $ lPackValueRaw l of
  Left err -> assertFailure $ "Unpacking error: " <> pretty err
  Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of
    [] -> ul @?= l
    notes -> assertFailure $ "Lambda has annotations: " <> pretty notes
  where
    dfsSettings = def { dsGoToValues = True}

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