ComplexRefs.hs

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

module Test.Lorentz.StoreClass.ComplexRefs
  ( test_Nested
  , test_Direct
  , test_stToFieldNamed
  ) where

import Prelude hiding (drop, swap)

import Control.Lens (at)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase, (@?=))

import Lorentz.Run.Simple
import Lorentz.StoreClass
import Lorentz.StoreClass.Extra qualified as E
import Lorentz.Value
import Morley.Util.Lens
import Morley.Util.Named
import Test.Cleveland.Instances ()

data Storage = Storage
  { sField1 :: SubStorage
  } deriving stock (Eq, Show, Generic)
    deriving anyclass (IsoValue)

data SubStorage = SubStorage
  { ssField1 :: Group
  } deriving stock (Eq, Show, Generic)
    deriving anyclass (IsoValue)

data Group = Group
  { gField :: Integer
  , gSubmap :: Map MText Natural
  } deriving stock (Eq, Show, Generic)
    deriving anyclass (IsoValue)

makeLensesWith postfixLFields ''Storage
makeLensesWith postfixLFields ''SubStorage
makeLensesWith postfixLFields ''Group

initStorage :: Storage
initStorage = Storage
  { sField1 = SubStorage
    { ssField1 = Group
      { gField = 3
      , gSubmap = one ("a", 5)
      }
    }
  }

test_Nested :: [TestTree]
test_Nested =
  [ testCase "Deep field access" $
      initStorage
        &- stToField (#sField1 :-| #ssField1 :-| #gField)
        @?= 3

  , testCase "Deep map elem access" $
      ("a", initStorage)
        &- stGet (#sField1 :-| #ssField1 :-| #gSubmap)
        @?= Just 5

  , testCase "Deep field update" $
      (99, initStorage)
        &- stSetField (#sField1 :-| #ssField1 :-| #gField)
        @?= (initStorage & sField1L . ssField1L . gFieldL .~ 99)

  , testCase "Deep map elem update" $
      ("b", (Just 50, initStorage))
        &- stUpdate (#sField1 :-| #ssField1 :-| #gSubmap)
        @?= (initStorage & sField1L . ssField1L . gSubmapL . at "b" .~ Just 50)

  , testCase "Intermediate piece access" $
      initStorage
        &- stToField (#sField1 :-| #ssField1)
        @?= (initStorage & sField1 & ssField1)
  ]

test_Direct :: [TestTree]
test_Direct =
  [ testCase "Direct access to field" $
      (5 :: Natural) &- stToField this
      @?= 5

  , testCase "Access using stNested" $
      initStorage
        &- stToField (stNested #sField1 #ssField1 #gField)
        @?= 3

  , testCase "Access using dot operator" $
      initStorage
        &- stToField (#sField1 E.. #ssField1 E.. #gField)
        @?= 3
  ]

test_stToFieldNamed :: [TestTree]
test_stToFieldNamed =
  [ testCase "Symbolic reference" $
      initStorage
        &- stToFieldNamed #sField1
        @?= #sField1 :! sField1 initStorage

  , testCase "Nested field reference" $
      initStorage
        &- stToFieldNamed (#sField1 :-| #ssField1 :-| #gField)
        @?= #gField :! 3
  ]