FillInParts.hs

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

module Test.Lorentz.UStore.Migration.FillInParts
  ( test_Migration_works
  ) where

import Fmt (pretty)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)
import Test.HUnit ((@?=), assertFailure)

import qualified Lorentz as L
import Lorentz.UStore
import Lorentz.UStore.Migration
import Lorentz.UStore.Haskell
import Michelson.Text
import Michelson.Test.Dummy
import Lorentz.Run

data MyTemplateWrapper substore = MyTemplateWrapper
  { commonField :: UStoreField MText
  , custom :: substore
  } deriving stock (Eq, Show, Generic)

data MySubTemplatePart1 = MySubTemplatePart1
  { int :: UStoreField Integer
  , nat :: UStoreField Natural
  } deriving stock (Eq, Show, Generic)

part1Val :: MySubTemplatePart1
part1Val = MySubTemplatePart1{ int = UStoreField -1, nat = UStoreField 1 }

data MySubTemplatePart2 = MySubTemplatePart2
  { string :: UStoreField MText
  } deriving stock (Eq, Show, Generic)

part2Val :: MySubTemplatePart2
part2Val = MySubTemplatePart2{ string = UStoreField [mt|bb|] }

type MyTemplateV0 = MyTemplateWrapper ()

type MyTemplateV1 = MyTemplateWrapper (MySubTemplatePart1, MySubTemplatePart2)

migrationBatched :: UStoreMigration MyTemplateV0 MyTemplateV1
migrationBatched = mkUStoreBatchedMigration $
  muBlock $:
    L.push [mt|bb|] L.#
    migrateModifyField #commonField
  <-->
  fillUStoreMigrationBlock part1Val
  <-->
  fillUStoreMigrationBlock part2Val
  <-->
  migrationFinish

migrationSimple :: UStoreMigration MyTemplateV0 MyTemplateV1
migrationSimple = mkUStoreMigration $
  L.push [mt|bb|] L.# migrateModifyField #commonField L.#
  migrateFillUStore part1Val L.#
  migrateFillUStore part2Val L.#
  migrationFinish

test_Migration_works :: [TestTree]
test_Migration_works =
  [ ("simple migration", migrationSimple)
  , ("batched migration", migrationBatched)
  ] <&> \(desc, migration) ->
    testCase desc $ migratesToWith migration
      MyTemplateWrapper
      { commonField = UStoreField [mt|aa|]
      , custom = ()
      }
      MyTemplateWrapper
      { commonField = UStoreField [mt|bb|]
      , custom = (part1Val, part2Val)
      }
  where
    migratesToWith migration storeV1 expectedStoreV2 =
      either (assertFailure . toString) (@?= expectedStoreV2) $ do
        storeV2 <-
          first pretty $
          interpretLorentzLambda
            dummyContractEnv
            (migrationToLambda migration)
            (mkUStore storeV1)
        ustoreDecomposeFull storeV2