DupableScan.hs

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

-- | Tests on 'Lorentz.Test.DupableScan' module.
module Test.Lorentz.DupableScan
  ( test_checkDupablesDistribution
  , test_testDupablesDistribution
  ) where

import Data.Constraint (Dict(..))
import Data.Typeable (typeRep)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase, (@?=))

import Lorentz.Layouts
import Lorentz.Test.DupableScan
import Lorentz.Value

data ProperSample = ProperSample
  { _s1a :: Integer
  , _s1b :: MText
  , _s1c :: Ticket ()
  , _s1d :: Ticket Natural
  } deriving stock (Generic)

data MisplacedDupableSample = MisplacedDupableSample
  { _s2a :: Integer
  , _s2b :: MText
  , _s2c :: Natural
  , _s2d :: Ticket Natural
  } deriving stock (Generic)

data MisplacedNonDupableSample = MisplacedNonDupableSample
  { _s3a :: Ticket ByteString
  , _s3b :: MText
  , _s3c :: Ticket ()
  , _s3d :: Ticket Natural
  } deriving stock (Generic)

data CombGenericSample = CombGenericSample
  { _s4a :: Integer
  , _s4b :: Ticket ()
  , _s4c :: Ticket Integer
  , _s4d :: Ticket Natural
  }

customGeneric "CombGenericSample" rightComb

test_checkDupablesDistribution :: [TestTree]
test_checkDupablesDistribution =
  [ testCase "Good type" $
      checkDupablesDistribution @ProperSample @?= Right ()

  , testCase "Misplaced dupable" $
      checkDupablesDistribution @MisplacedDupableSample @?= Left BadElement
        { beExpectedDupability = False
        , beRecName = Just "_s2c"
        , beRecType = typeRep (Proxy @Natural)
        }

  , testCase "Misplaced non-dupable" $
      checkDupablesDistribution @MisplacedNonDupableSample @?= Left BadElement
        { beExpectedDupability = True
        , beRecName = Just "_s3a"
        , beRecType = typeRep (Proxy @(Ticket ByteString))
        }

  , testCase "Comb generic" $
      checkDupablesDistribution @CombGenericSample @?= Right ()

  ]

-- Two ways to test product type layout

test_testDupablesDistribution :: TestTree
test_testDupablesDistribution = testDupablesDistribution @ProperSample

_test_typeVerifyDupablesDistribution :: Dict (VerifyDupablesDistribution ProperSample)
_test_typeVerifyDupablesDistribution = Dict

-- Checking that deriveSemiDupableGeneric matches with our test utilities
----------------------------------------------------------------------------

data MegaType = MegaType
  { _mt1 :: Integer
  , _mt2 :: Natural
  , _mt3 :: ()
  , _mt4 :: MText
  , _mt5 :: ByteString
  , _mt6 :: Ticket Natural
  , _mt7 :: Ticket Integer
  }

deriveSemiDupableGeneric "MegaType" 2

_test_MegaType_layout :: Dict (VerifyDupablesDistribution MegaType)
_test_MegaType_layout = Dict