-- 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)]))]
      ]

    ]
  ]