morley-upgradeable-0.3: test/Test/Lorentz/UStore/StoreClass.hs

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

-- | Tests for Lorentz 'UStore'.
module Test.Lorentz.UStore.StoreClass
  ( test_Fields
  , test_Submaps
  ) where

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

import Lorentz.ADT
import Lorentz.Run.Simple
import Lorentz.StoreClass
import Lorentz.UStore
import Lorentz.Value

data MyTemplate = MyTemplate
  { ints :: Integer |~> ()
  , flag :: UStoreField Bool
  } deriving stock (Eq, Show, Generic)

initTemplate :: MyTemplate
initTemplate = MyTemplate
  { ints = UStoreSubMap mempty
  , flag = UStoreField False
  }

data Storage = Storage
  { dummy :: ()
  , upgradeable :: UStore MyTemplate
  } deriving stock (Generic)
    deriving anyclass (IsoValue)

instance HasFieldOfType Storage name ty =>
         StoreHasField Storage name ty where
  storeFieldOps = storeFieldOpsADT

initStorage :: Storage
initStorage = Storage () (mkUStore initTemplate)

test_Fields :: [TestTree]
test_Fields =
  [ testCase "Get field" $
      mkUStore initTemplate
      &- stToField #flag
      @?= False

  , testCase "Set field" $
      (True, mkUStore initTemplate)
      &- stSetField #flag
      @?= mkUStore initTemplate{ flag = UStoreField True }

  , testCase "Nested access" $
      initStorage
      &- stToField (#upgradeable :-| #flag)
      @?= False
  ]

test_Submaps :: [TestTree]
test_Submaps =
  [ testCase "Get submap entry" $
      (5, mkUStore initTemplate)
      &- stMem #ints
      @?= False

  , testCase "Update submap entry" $
      (5, ((), mkUStore initTemplate))
      &- stInsert #ints
      @?= mkUStore initTemplate{ ints = UStoreSubMap $ one (5, ()) }
  ]