{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Lorentz.UStore.Migration.Blocks
(
mustoreToOld
, MigrationFinishCheckPosition (..)
, migrateCoerceUnsafe
, migrateGetField
, migrateAddField
, migrateRemoveField
, migrateExtractField
, migrateOverwriteField
, migrateModifyField
, muBlock
, muBlockNamed
, (<-->)
, ($:)
) where
import Data.Vinyl.Derived (Label)
import Lorentz.Base
import Lorentz.Coercions
import Lorentz.Instr (dip)
import Lorentz.UStore.Instr
import Lorentz.UStore.Migration.Base
import Lorentz.UStore.Migration.Diff
import Lorentz.UStore.Types
import Util.Type
import Util.TypeLits
type family RequireBeInitial (touched :: [Symbol]) :: Constraint where
RequireBeInitial '[] = ()
RequireBeInitial _ =
TypeError ('Text "Migration has already been started over this store")
type family RequireUntouched (field :: Symbol) (wasTouched :: Bool)
:: Constraint where
RequireUntouched _ 'False = ()
RequireUntouched field 'True = TypeError
('Text ("Field `" `AppendSymbol` field `AppendSymbol` "` has already been \
\migrated and cannot be read")
)
migrateCoerceUnsafe
:: forall field oldTempl newTempl diff touched newDiff newDiff0 _1 _2 s.
( '(_1, newDiff0) ~ CoverDiff 'DcRemove field diff
, '(_2, newDiff) ~ CoverDiff 'DcAdd field newDiff0
)
=> Label field
-> MUStore oldTempl newTempl diff touched : s
:-> MUStore oldTempl newTempl newDiff touched : s
migrateCoerceUnsafe _ =
forcedCoerce_
migrateGetField
:: forall field oldTempl newTempl diff touched fieldTy s.
( HasUField field fieldTy oldTempl
, RequireUntouched field (field `IsElem` touched)
)
=> Label field
-> MUStore oldTempl newTempl diff touched : s
:-> fieldTy : MUStore oldTempl newTempl diff touched : s
migrateGetField label =
forcedCoerce_ @_ @(UStore oldTempl) # ustoreGetField label # dip forcedCoerce_
migrateAddField
:: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.
( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field diff
, HasUField field fieldTy newTempl
)
=> Label field
-> fieldTy : MUStore oldTempl newTempl diff touched : s
:-> MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateAddField label =
attachMigrationActionName (DAddAction "add") label (Proxy @fieldTy) #
dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_
migrateRemoveField
:: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.
( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff
, HasUField field fieldTy oldTempl
)
=> Label field
-> MUStore oldTempl newTempl diff touched : s
:-> MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateRemoveField label =
attachMigrationActionName DDelAction label (Proxy @fieldTy) #
forcedCoerce_ @_ @(UStore oldTempl) # ustoreRemoveFieldUnsafe label # forcedCoerce_
migrateExtractField
:: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.
( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff
, HasUField field fieldTy oldTempl
, RequireUntouched field (field `IsElem` touched)
)
=> Label field
-> MUStore oldTempl newTempl diff touched : s
:-> fieldTy : MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateExtractField label =
attachMigrationActionName DDelAction label (Proxy @fieldTy) #
migrateGetField label # dip (migrateRemoveField label)
migrateOverwriteField
:: forall field oldTempl newTempl diff touched fieldTy oldFieldTy
marker oldMarker newDiff newDiff0 s.
( '(UStoreFieldExt oldMarker oldFieldTy, newDiff0) ~ CoverDiff 'DcRemove field diff
, '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field newDiff0
, HasUField field fieldTy newTempl
)
=> Label field
-> fieldTy : MUStore oldTempl newTempl diff touched : s
:-> MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateOverwriteField label =
attachMigrationActionName (DAddAction "overwrite") label (Proxy @fieldTy) #
dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_
migrateModifyField
:: forall field oldTempl newTempl diff touched fieldTy s.
( HasUField field fieldTy oldTempl
, HasUField field fieldTy newTempl
)
=> Label field
-> fieldTy : MUStore oldTempl newTempl diff touched : s
:-> MUStore oldTempl newTempl diff touched : s
migrateModifyField label =
attachMigrationActionName (DAddAction "modify") label (Proxy @fieldTy) #
dip (forcedCoerce_ @_ @(UStore oldTempl)) # ustoreSetField label # forcedCoerce_
muBlock
:: ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
-> MigrationBlocks o n d1 t1 d2 t2
muBlock code =
MigrationBlocks . one . formMigrationAtom Nothing $
forcedCoerce_ # code # forcedCoerce_
muBlockNamed
:: Text
-> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
-> MigrationBlocks o n d1 t1 d2 t2
muBlockNamed name code =
MigrationBlocks . one . formMigrationAtom (Just name) $
forcedCoerce_ # code # forcedCoerce_
(<-->)
:: MigrationBlocks o n d1 t1 d2 t2
-> MigrationBlocks o n d2 t2 d3 t3
-> MigrationBlocks o n d1 t1 d3 t3
MigrationBlocks blocks1 <--> MigrationBlocks blocks2 =
MigrationBlocks (blocks1 <> blocks2)
infixl 2 <-->
($:) :: (a -> b) -> a -> b
($:) = ($)
infixr 7 $:
mustoreToOld
:: RequireBeInitial touched
=> MUStore oldTemplate newTemplate remDiff touched : s
:-> UStore oldTemplate : s
mustoreToOld = forcedCoerce_
class MigrationFinishCheckPosition a where
migrationFinish :: a
instance ( i ~ (MUStore oldTempl newTempl diff touched : s)
, o ~ (MUStore oldTempl newTempl '[] touched : s)
, RequireEmptyDiff diff
) =>
MigrationFinishCheckPosition (i :-> o) where
migrationFinish = forcedCoerce_
instance (RequireEmptyDiff d1, t1 ~ t2) =>
MigrationFinishCheckPosition (MigrationBlocks o n d1 t1 '[] t2) where
migrationFinish = MigrationBlocks []