lorentz-0.1.0: test/Test/Lorentz/UStore/Migration/Batched.hs

module Test.Lorentz.UStore.Migration.Batched
  ( test_Separated_lambdas
  ) where

import qualified Data.Map as M
import Test.HUnit ((@?=))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import qualified Lorentz as L
import Lorentz.UStore
import Lorentz.UStore.Migration

import qualified Test.Lorentz.UStore.Migration.Batched.V1 as V1
import qualified Test.Lorentz.UStore.Migration.Batched.V2 as V2

initMigration :: UStoreMigration () V1.MyTemplate
initMigration = fillUStore V1.MyTemplate
  { bytes = UStoreSubMap $ M.fromList [(1, "a"), (2, "b")]
  , int1 = UStoreField 1
  , int2 = UStoreField 2
  , code1 = UStoreField L.nop
  , code2 = UStoreField L.int
  , code3 = UStoreField L.nop
  }

v2migration :: UStoreMigration V1.MyTemplate V2.MyTemplate
v2migration = mkUStoreBatchedMigration $
  muBlock $:
    L.push @Natural 1 L.#
    migrateOverwriteField #int1
  <-->
  muBlock $:
    migrateRemoveField #int2
  <-->
  muBlock $:
    -- Normally such joined blocks should not be present, but we
    -- want to test different scenarios
    L.push L.nop L.#
    migrateModifyField #code1 L.#

    migrateRemoveField #code2
  <-->
  muBlock $:
    migrateRemoveField #code3
  <-->
  migrationFinish

test_Separated_lambdas :: [TestTree]
test_Separated_lambdas =
  [ testGroup "V0 -> V1" $
      let cmigration = compileMigration mbSeparateLambdas initMigration
      in
    [ testCase "Split is correct" $
        (slbiType <$> migrationToInfo cmigration)
        @?=
        [ SlbtData
        , SlbtLambda
        , SlbtLambda
        , SlbtLambda
        ]
    ]

  , testGroup "V1 -> V2" $
      let cmigration = compileMigration mbSeparateLambdas v2migration
      in
    [ testCase "Split is correct" $
        (slbiType <$> migrationToInfo cmigration)
        @?=
        [ SlbtData
        , SlbtLambda
        , SlbtLambda
          -- Lambda removals should not be put separatelly, so one lambda is gone
        ]
    ]
  ]