SetSubmap.hs

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

module Test.Lorentz.StoreClass.SetSubmap
  ( test_Simple_set
  ) where

import Prelude hiding (drop, swap)

import qualified Data.Set as S
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, testCase, (@?=))

import qualified Lorentz as L
import Lorentz.Annotation (HasAnnotation)
import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Run.Simple
import Lorentz.StoreClass
import Lorentz.Value
import Test.Cleveland.Instances ()

----------------------------------------------------------------------------
-- Types
----------------------------------------------------------------------------

data Storage = Storage
  { x :: Set MText
  } deriving stock (Eq, Show, Generic)
    deriving anyclass (IsoValue, HasAnnotation)

emptyStorage :: Storage
emptyStorage = Storage mempty

mkStorage :: [MText] -> Storage
mkStorage = Storage . S.fromList

----------------------------------------------------------------------------
-- Tests
----------------------------------------------------------------------------

type DeleteInstr =
  forall mname key value store s.
     (StoreHasSubmap store mname key value, KnownValue value)
  => FieldSymRef mname -> key : store : s :-> store : s

testCaseDelete :: (DeleteInstr -> Assertion) -> TestTree
testCaseDelete mkSuite =
  testGroup "delete"
  [ testCase "setDelete" $ mkSuite stDelete
  ]

type InsertInstr =
  forall mname key value store s.
     (StoreHasSubmap store mname key value)
  => FieldSymRef mname -> key : value : store : s :-> store : s

testCaseInsert :: (InsertInstr -> Assertion) -> TestTree
testCaseInsert mkSuite =
  testGroup "insert"
  [ testCase "setInsert" $ mkSuite stInsert
  ]

key1, key2 :: MText
key1 = "a"
key2 = "b"

test_Simple_set :: [TestTree]
test_Simple_set =
  let l = #x in
  [ testGroup "Empty storage"

    [ testCase "mem" $
        emptyStorage
          &- L.push key1 # stMem l
          @?= False

    , testCase "get" $
        emptyStorage
          &- L.push key1 # stGet l
          @?= Nothing

    , testCaseDelete $ \delete ->
        emptyStorage
          &- L.push key1 # delete l
          @?= emptyStorage

    , testCaseInsert $ \insert ->
        emptyStorage
          &- L.push () # L.push key1 # insert l
          @?= mkStorage [key1]
    ]

  , testGroup "Storage with some values - checking them"

    [ testCase "mem" $
        mkStorage [key1]
          &- L.push key1 # stMem l
          @?= True

    , testCase "get" $
        mkStorage [key1]
          &- L.push key1 # stGet l
          @?= Just ()

    , testCaseDelete $ \delete ->
        mkStorage [key1]
          &- L.push key1 # delete l
          @?= emptyStorage

    , testCaseInsert $ \insert ->
        mkStorage [key1]
          &- L.push () # L.push key1 # insert l
          @?= mkStorage [key1]

    ]

  , testGroup "Storage with some values - checking others"

    [ testCase "mem" $
        mkStorage [key1]
          &- L.push key2 # stMem l
          @?= False

    , testCase "get" $
        mkStorage [key1]
          &- L.push key2 # stGet l
          @?= Nothing

    , testCaseDelete $ \delete ->
        mkStorage [key1]
          &- L.push key2 # delete l
          @?= mkStorage [key1]

    , testCaseInsert $ \insert ->
        mkStorage [key1]
          &- L.push () # L.push key2 # insert l
          @?= mkStorage [key1, key2]

    ]

  ]