cleveland-0.1.1: lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
module Test.Lorentz.StoreClass.SubmapZoom
( test_Simple_part_of_value
, test_Part_of_value_with_nested_map
, test_Different_parts_of_value_interaction
) where
import Prelude hiding (drop, swap)
import Data.Map qualified as M
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, testCase, (@?=))
import Lorentz qualified as L
import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Iso
import Lorentz.Run.Simple
import Lorentz.StoreClass
import Lorentz.Value
import Morley.Util.Named
import Test.Cleveland.Instances ()
----------------------------------------------------------------------------
-- Types
----------------------------------------------------------------------------
type MapValue = ("x" :! Natural, "y" :! Map MText Integer)
data Storage = Storage
{ all :: BigMap MText MapValue
} deriving stock (Eq, Show, Generic)
deriving anyclass (IsoValue)
instance StoreHasSubmap Storage (FieldNickname "x") MText Natural where
storeSubmapOps =
storeSubmapOpsReferTo #x $
zoomStoreSubmapOps #all nonDefIso nonDefIso storeSubmapOps storeFieldOpsADT
instance StoreHasSubmap Storage (FieldNickname "y") (MText, MText) Integer where
storeSubmapOps =
storeSubmapOpsReferTo #y $
sequenceStoreSubmapOps #all nonDefIso storeSubmapOps storeSubmapOps
emptyStorage :: Storage
emptyStorage = Storage mempty
mkStorage :: [(MText, (Natural, [(MText, Integer)]))] -> Storage
mkStorage entries =
Storage $ mkBigMap
[ (k, (#x :! v1, #y :! M.fromList v2))
| (k, (v1, v2)) <- entries
]
----------------------------------------------------------------------------
-- Tests
----------------------------------------------------------------------------
type DeleteInstr =
forall mname key value store s.
(StoreHasSubmap store (FieldNickname mname) key value, KnownValue value)
=> FieldRef (FieldNickname mname) -> key : store : s :-> store : s
testCaseDelete :: (DeleteInstr -> Assertion) -> TestTree
testCaseDelete mkSuite =
testGroup "delete"
[ testCase "normal" $ mkSuite stDelete
, testCase "via update" $ mkSuite (\l -> L.dip L.none # stUpdate l)
]
type InsertInstr =
forall mname key value store s.
(StoreHasSubmap store (FieldNickname mname) key value)
=> FieldRef (FieldNickname mname) -> key : value : store : s :-> store : s
testCaseInsert :: (InsertInstr -> Assertion) -> TestTree
testCaseInsert mkSuite =
testGroup "insert"
[ testCase "normal" $ mkSuite stInsert
, testCase "via update" $ mkSuite (\l -> L.dip L.some # stUpdate l)
]
key1, key2 :: MText
key1 = "a"
key2 = "b"
dkey1 :: (MText, MText)
dkey1 = (key1, key1)
test_Simple_part_of_value :: [TestTree]
test_Simple_part_of_value =
let l = stNickname #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 1 # L.push key1 # insert l
@?= mkStorage [(key1, (1, []))]
]
, testGroup "Storage with some values - checking them"
[ testCase "mem" $
mkStorage [(key1, (1, []))]
&- L.push key1 # stMem l
@?= True
, testCase "mem for def value" $
mkStorage [(key1, (0, []))]
&- L.push key1 # stMem l
@?= False
, testCase "get" $
mkStorage [(key1, (1, []))]
&- L.push key1 # stGet l
@?= Just 1
, testCase "get for def value" $
mkStorage [(key1, (0, []))]
&- L.push key1 # stGet l
@?= Nothing
, testCaseDelete $ \delete ->
mkStorage [(key1, (1, []))]
&- L.push key1 # delete l
@?= emptyStorage
, testCaseInsert $ \insert ->
mkStorage [(key1, (1, []))]
&- L.push 2 # L.push key1 # insert l
@?= mkStorage [(key1, (2, []))]
]
, testGroup "Storage with some values - checking others"
[ testCase "mem" $
mkStorage [(key1, (1, []))]
&- L.push key2 # stMem l
@?= False
, testCase "get" $
mkStorage [(key1, (1, []))]
&- L.push key2 # stGet l
@?= Nothing
, testCaseDelete $ \delete ->
mkStorage [(key1, (1, []))]
&- L.push key2 # delete l
@?= mkStorage [(key1, (1, []))]
, testCaseInsert $ \insert ->
mkStorage [(key1, (1, []))]
&- L.push 2 # L.push key2 # insert l
@?= mkStorage [(key1, (1, [])), (key2, (2, []))]
]
]
test_Part_of_value_with_nested_map :: [TestTree]
test_Part_of_value_with_nested_map =
let l = stNickname #y in
[ testGroup "Empty storage"
[ testCase "mem" $
emptyStorage
&- L.push dkey1 # stMem l
@?= False
, testCase "get" $
emptyStorage
&- L.push dkey1 # stGet l
@?= Nothing
, testCaseDelete $ \delete ->
emptyStorage
&- L.push dkey1 # delete l
@?= emptyStorage
, testCaseInsert $ \insert ->
emptyStorage
&- L.push 1 # L.push dkey1 # insert l
@?= mkStorage [(key1, (0, [(key1, 1)]))]
]
, testGroup "Storage with some values - checking them"
[ testCase "mem" $
mkStorage [(key1, (0, [(key1, 1)]))]
&- L.push dkey1 # stMem l
@?= True
, testCase "mem for def value" $
mkStorage [(key1, (0, [(key1, 0)]))]
&- L.push dkey1 # stMem l
@?= True
, testCase "get" $
mkStorage [(key1, (0, [(key1, 1)]))]
&- L.push dkey1 # stGet l
@?= Just 1
, testCase "get for def value" $
mkStorage [(key1, (0, [(key1, 0)]))]
&- L.push dkey1 # stGet l
@?= Just 0
, testCaseDelete $ \delete ->
mkStorage [(key1, (0, [(key1, 1)]))]
&- L.push dkey1 # delete l
@?= emptyStorage
, testCaseInsert $ \insert ->
mkStorage [(key1, (0, [(key1, 1)]))]
&- L.push 2 # L.push dkey1 # insert l
@?= mkStorage [(key1, (0, [(key1, 2)]))]
]
]
test_Different_parts_of_value_interaction :: [TestTree]
test_Different_parts_of_value_interaction =
[ testGroup "Deleting the last value"
[ testGroup "Working with simple subvalue"
[ testCaseDelete $ \delete ->
mkStorage [(key1, (1, [(key1, 1)]))]
&- L.push key1 # delete (stNickname #x)
@?= mkStorage [(key1, (0, [(key1, 1)]))]
]
, testGroup "Working with nested map"
[ testCaseDelete $ \delete ->
mkStorage [(key1, (1, [(key1, 1)]))]
&- L.push dkey1 # delete (stNickname #y)
@?= mkStorage [(key1, (1, []))]
]
]
, testGroup "Deleting not the last value"
[ testGroup "Working with simple subvalue 1"
[ testCaseDelete $ \delete ->
mkStorage [(key1, (1, [(key1, 1)])), (key2, (1, []))]
&- L.push key1 # delete (stNickname #x)
@?= mkStorage [(key1, (0, [(key1, 1)])), (key2, (1, []))]
]
, testGroup "Working with simple subvalue 2"
[ testCaseDelete $ \delete ->
mkStorage [(key1, (1, [(key1, 1)])), (key2, (1, []))]
&- L.push key2 # delete (stNickname #x)
@?= mkStorage [(key1, (1, [(key1, 1)]))]
]
, testGroup "Working with nested map 1"
[ testCaseDelete $ \delete ->
mkStorage [(key1, (1, [(key1, 1)])), (key2, (1, []))]
&- L.push dkey1 # delete (stNickname #y)
@?= mkStorage [(key1, (1, [])), (key2, (1, []))]
]
, testGroup "Working with nested map 2"
[ testCaseDelete $ \delete ->
mkStorage [(key1, (1, [(key1, 1), (key2, 1)]))]
&- L.push dkey1 # delete (stNickname #y)
@?= mkStorage [(key1, (1, [(key2, 1)]))]
]
]
]