Product.hs

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

-- | Tests on product type utilities.
module Test.Lorentz.Product
  ( test_getField_and_dupables
  ) where

import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))

import Lorentz
import Morley.Michelson.Typed.Instr
import Morley.Util.Instances ()

-- | A dupable type
type D = ()

-- | A non-dupable type
type ND = Ticket ()

data SmallDupable = SmallDupable
  { _sd1 :: D
  , _sd2 :: D
  , _sd3 :: D
  , _sd4 :: D
  } deriving stock (Generic)
    deriving anyclass (IsoValue)

data BigDupable = BigDupable
  { _bd1 :: SmallDupable
  , _bd2 :: D
  , _bd3 :: D
  , _bd4 :: D
  } deriving stock (Generic)
    deriving anyclass (IsoValue, HasDupableGetters)

data SmallHalfDupable = SmallHalfDupable
  { _shd1 :: D
  , _shd2 :: D
  , _shd3 :: D
  , _shd4 :: ND
  } deriving stock (Generic)
    deriving anyclass (IsoValue, HasDupableGetters)

data BigHalfDupable1 = BigHalfDupable1
  { _bhd1 :: SmallDupable
  , _bhd2 :: D
  , _bhd3 :: D
  , _bhd4 :: SmallHalfDupable
  } deriving stock (Generic)
    deriving anyclass (IsoValue, HasDupableGetters)

-- | Here we primarily want to test that getters are optimal
-- (taking the existance of non-dupable types into account):
-- if halfway we can apply 'DUP' and end with a sequence of 'CAR' and 'CDR',
-- we should do so.
test_getField_and_dupables :: [TestTree]
test_getField_and_dupables =
  [ testGroup "Direct field access"

    [ testCase "Picking from dupable" $
        getField @SmallDupable #_sd1 @?= I do
          DUP :# CAR :# CAR

    , testCase "Picking from product becoming dupable half-way" $
        getField @SmallHalfDupable #_shd1 @?= I do
          UNPAIR :# DUP :# CAR :# DIP PAIR

    , testCase "Picking from product that is non-dupable all the way along" $
        getField @SmallHalfDupable #_shd3 @?= I do
          UNPAIR :# SWAP :# (UNPAIR :# DUP :# DIP PAIR) :# DIP (SWAP :# PAIR)

    ]

  , testGroup "Nested field access"

    [ testCase "Picking from dupable" $
        stGetField @BigDupable (#_bd1 :-| #_sd1) @?= I do
          DUP :# CAR :# CAR :# CAR :# CAR

    , testCase "Deep picking from dupable nested type" $
        stGetField @BigHalfDupable1 (#_bhd1 :-| #_sd1) @?= I do
          UNPAIR :# DUP :# CAR :# CAR :# CAR :# DIP PAIR

    , testCase "Deep picking from non-dupable nested type" $
        stGetField @BigHalfDupable1 (#_bhd4 :-| #_shd1) @?= I do
          UNPAIR :# SWAP :# UNPAIR :# SWAP
            :# (UNPAIR :# DUP :# CAR :# DIP PAIR)
            :# DIP (SWAP :# PAIR) :# DIP (SWAP :# PAIR)

    ]

  ]