{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Lorentz.UStore.Haskell
( mkUStore
, MkUStoreTW
, ustoreDecompose
, ustoreDecomposeFull
, DecomposeUStoreTW
, fillUStore
, migrateFillUStore
, fillUStoreMigrationBlock
, FillUStoreTW
) where
import Prelude
import qualified Unsafe
import Control.Monad.Except (runExcept, throwError)
import qualified Data.List as L
import qualified Data.Map as Map
import Data.Singletons (demote)
import Fcf (type (=<<), Eval, Pure2)
import qualified Fcf
import Fmt ((+|), (+||), (|+), (||+))
import Lorentz.Base
import Lorentz.Coercions
import Lorentz.Constraints
import qualified Lorentz.Instr as L
import Lorentz.Pack
import Lorentz.UStore.Migration
import Lorentz.UStore.Migration.Diff
import Lorentz.UStore.Traversal
import Lorentz.UStore.Types
import Michelson.Text
import Michelson.Typed.Haskell.Value
import Util.Type
type UStoreContent = [(ByteString, ByteString)]
mkUStore
:: (UStoreTraversable MkUStoreTW template)
=> template -> UStore template
mkUStore :: template -> UStore template
mkUStore = BigMap ByteString ByteString -> UStore template
forall a. BigMap ByteString ByteString -> UStore a
UStore (BigMap ByteString ByteString -> UStore template)
-> (template -> BigMap ByteString ByteString)
-> template
-> UStore template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString ByteString -> BigMap ByteString ByteString
forall k v. Map k v -> BigMap k v
BigMap (Map ByteString ByteString -> BigMap ByteString ByteString)
-> (template -> Map ByteString ByteString)
-> template
-> BigMap ByteString ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. template -> Map ByteString ByteString
forall template.
UStoreTraversable MkUStoreTW template =>
template -> Map ByteString ByteString
mkUStoreInternal
ustoreDecompose
:: forall template.
(UStoreTraversable DecomposeUStoreTW template)
=> UStore template -> Either Text (UStoreContent, template)
ustoreDecompose :: UStore template -> Either Text (UStoreContent, template)
ustoreDecompose = UStoreContent -> Either Text (UStoreContent, template)
forall template.
UStoreTraversable DecomposeUStoreTW template =>
UStoreContent -> Either Text (UStoreContent, template)
storeDecomposeInternal (UStoreContent -> Either Text (UStoreContent, template))
-> (UStore template -> UStoreContent)
-> UStore template
-> Either Text (UStoreContent, template)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString ByteString -> UStoreContent
forall k a. Map k a -> [(k, a)]
Map.toList (Map ByteString ByteString -> UStoreContent)
-> (UStore template -> Map ByteString ByteString)
-> UStore template
-> UStoreContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BigMap ByteString ByteString -> Map ByteString ByteString
forall k v. BigMap k v -> Map k v
unBigMap (BigMap ByteString ByteString -> Map ByteString ByteString)
-> (UStore template -> BigMap ByteString ByteString)
-> UStore template
-> Map ByteString ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UStore template -> BigMap ByteString ByteString
forall a. UStore a -> BigMap ByteString ByteString
unUStore
ustoreDecomposeFull
:: forall template.
(UStoreTraversable DecomposeUStoreTW template)
=> UStore template -> Either Text template
ustoreDecomposeFull :: UStore template -> Either Text template
ustoreDecomposeFull UStore template
ustore = do
(UStoreContent
remained, template
res) <- UStore template -> Either Text (UStoreContent, template)
forall template.
UStoreTraversable DecomposeUStoreTW template =>
UStore template -> Either Text (UStoreContent, template)
ustoreDecompose UStore template
ustore
Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UStoreContent -> Bool
forall t. Container t => t -> Bool
null UStoreContent
remained) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Builder
"Unrecognized entries in UStore: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| UStoreContent
remained UStoreContent -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
template -> Either Text template
forall (m :: * -> *) a. Monad m => a -> m a
return template
res
fillUStore
:: (UStoreTraversable FillUStoreTW template)
=> template -> UStoreMigration () template
fillUStore :: template -> UStoreMigration () template
fillUStore template
v = [MigrationAtom] -> UStoreMigration () template
forall oldTempl newTempl.
[MigrationAtom] -> UStoreMigration oldTempl newTempl
UStoreMigration ([MigrationAtom] -> UStoreMigration () template)
-> [MigrationAtom] -> UStoreMigration () template
forall a b. (a -> b) -> a -> b
$ template -> [MigrationAtom]
forall template.
UStoreTraversable FillUStoreTW template =>
template -> [MigrationAtom]
fillUStoreInternal template
v
fillUStoreMigrationBlock
:: ( UStoreTraversable FillUStoreTW template
, allFieldsExp ~ AllUStoreFieldsF template
, newDiff ~ FillingNewDiff template diff
, newTouched ~ FillingNewTouched template touched
, PatternMatchL newDiff, PatternMatchL newTouched
)
=> template
-> MigrationBlocks oldTempl newTempl diff touched newDiff newTouched
fillUStoreMigrationBlock :: template
-> MigrationBlocks
oldTempl newTempl diff touched newDiff newTouched
fillUStoreMigrationBlock template
v = [MigrationAtom]
-> MigrationBlocks
oldTempl newTempl diff touched newDiff newTouched
forall oldTemplate newTemplate (preRemDiff :: [DiffItem])
(preTouched :: [Symbol]) (postRemDiff :: [DiffItem])
(postTouched :: [Symbol]).
[MigrationAtom]
-> MigrationBlocks
oldTemplate
newTemplate
preRemDiff
preTouched
postRemDiff
postTouched
MigrationBlocks ([MigrationAtom]
-> MigrationBlocks
oldTempl newTempl diff touched newDiff newTouched)
-> [MigrationAtom]
-> MigrationBlocks
oldTempl newTempl diff touched newDiff newTouched
forall a b. (a -> b) -> a -> b
$ template -> [MigrationAtom]
forall template.
UStoreTraversable FillUStoreTW template =>
template -> [MigrationAtom]
fillUStoreInternal template
v
migrateFillUStore
:: ( UStoreTraversable FillUStoreTW template
, allFieldsExp ~ AllUStoreFieldsF template
, newDiff ~ FillingNewDiff template diff
, newTouched ~ FillingNewTouched template touched
, PatternMatchL newDiff, PatternMatchL newTouched
)
=> template
-> Lambda
(MUStore oldTempl newTempl diff touched)
(MUStore oldTempl newTempl newDiff newTouched)
migrateFillUStore :: template
-> Lambda
(MUStore oldTempl newTempl diff touched)
(MUStore oldTempl newTempl newDiff newTouched)
migrateFillUStore template
v =
let atoms :: [MigrationAtom]
atoms = template -> [MigrationAtom]
forall template.
UStoreTraversable FillUStoreTW template =>
template -> [MigrationAtom]
fillUStoreInternal template
v
script :: Lambda UStore_ UStore_
script = (Element [MigrationAtom] -> Lambda UStore_ UStore_)
-> [MigrationAtom] -> Lambda UStore_ UStore_
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (MigrationScript SomeUTemplate SomeUTemplate
-> Lambda UStore_ UStore_
forall oldStore newStore.
MigrationScript oldStore newStore -> Lambda UStore_ UStore_
unMigrationScript (MigrationScript SomeUTemplate SomeUTemplate
-> Lambda UStore_ UStore_)
-> (MigrationAtom -> MigrationScript SomeUTemplate SomeUTemplate)
-> MigrationAtom
-> Lambda UStore_ UStore_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationAtom -> MigrationScript SomeUTemplate SomeUTemplate
maScript) [MigrationAtom]
atoms
in '[MUStore oldTempl newTempl diff touched] :-> '[UStore_]
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a : s) :-> (b : s)
forcedCoerce_ ('[MUStore oldTempl newTempl diff touched] :-> '[UStore_])
-> Lambda UStore_ UStore_
-> '[MUStore oldTempl newTempl diff touched] :-> '[UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Lambda UStore_ UStore_
script ('[MUStore oldTempl newTempl diff touched] :-> '[UStore_])
-> ('[UStore_] :-> '[MUStore oldTempl newTempl newDiff newTouched])
-> Lambda
(MUStore oldTempl newTempl diff touched)
(MUStore oldTempl newTempl newDiff newTouched)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[UStore_] :-> '[MUStore oldTempl newTempl newDiff newTouched]
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a : s) :-> (b : s)
forcedCoerce_
type FillingNewDiff template diff =
CoverDiffMany diff
(Eval (Fcf.Map (Pure2 '(,) 'DcAdd) =<< LinearizeUStoreF template))
type FillingNewTouched template touched =
Eval (AllUStoreFieldsF template) ++ touched
mkUStoreInternal
:: (UStoreTraversable MkUStoreTW template)
=> template -> Map ByteString ByteString
mkUStoreInternal :: template -> Map ByteString ByteString
mkUStoreInternal = MkUStoreTW -> template -> Map ByteString ByteString
forall way template res.
(UStoreTraversable way template,
UStoreTraversalArgumentWrapper way ~ Identity,
UStoreTraversalMonad way ~ Const res) =>
way -> template -> res
foldUStore MkUStoreTW
MkUStoreTW
storeDecomposeInternal
:: forall template.
(UStoreTraversable DecomposeUStoreTW template)
=> UStoreContent -> Either Text (UStoreContent, template)
storeDecomposeInternal :: UStoreContent -> Either Text (UStoreContent, template)
storeDecomposeInternal =
Except Text (UStoreContent, template)
-> Either Text (UStoreContent, template)
forall e a. Except e a -> Either e a
runExcept (Except Text (UStoreContent, template)
-> Either Text (UStoreContent, template))
-> (UStoreContent -> Except Text (UStoreContent, template))
-> UStoreContent
-> Either Text (UStoreContent, template)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((template, UStoreContent) -> (UStoreContent, template))
-> ExceptT Text Identity (template, UStoreContent)
-> Except Text (UStoreContent, template)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (template, UStoreContent) -> (UStoreContent, template)
forall a b. (a, b) -> (b, a)
swap (ExceptT Text Identity (template, UStoreContent)
-> Except Text (UStoreContent, template))
-> (UStoreContent
-> ExceptT Text Identity (template, UStoreContent))
-> UStoreContent
-> Except Text (UStoreContent, template)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT UStoreContent (ExceptT Text Identity) template
-> UStoreContent -> ExceptT Text Identity (template, UStoreContent)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (DecomposeUStoreTW
-> UStoreTraversalMonad DecomposeUStoreTW template
forall way template.
(UStoreTraversable way template,
UStoreTraversalArgumentWrapper way ~ Const ()) =>
way -> UStoreTraversalMonad way template
genUStore DecomposeUStoreTW
DecomposeUStoreTW)
fillUStoreInternal
:: (UStoreTraversable FillUStoreTW template)
=> template
-> [MigrationAtom]
fillUStoreInternal :: template -> [MigrationAtom]
fillUStoreInternal template
a = Endo [MigrationAtom] -> [MigrationAtom] -> [MigrationAtom]
forall a. Endo a -> a -> a
appEndo (FillUStoreTW -> template -> Endo [MigrationAtom]
forall way template res.
(UStoreTraversable way template,
UStoreTraversalArgumentWrapper way ~ Identity,
UStoreTraversalMonad way ~ Const res) =>
way -> template -> res
foldUStore FillUStoreTW
FillUStoreTW template
a) []
data MkUStoreTW = MkUStoreTW
instance UStoreTraversalWay MkUStoreTW where
type UStoreTraversalArgumentWrapper MkUStoreTW = Identity
type UStoreTraversalMonad MkUStoreTW = Const (Map ByteString ByteString)
instance (NicePackedValue val) =>
UStoreTraversalFieldHandler MkUStoreTW marker val where
ustoreTraversalFieldHandler :: MkUStoreTW
-> Label name
-> UStoreTraversalArgumentWrapper MkUStoreTW val
-> UStoreTraversalMonad MkUStoreTW val
ustoreTraversalFieldHandler MkUStoreTW
MkUStoreTW Label name
fieldName (Identity val) =
Map ByteString ByteString -> Const (Map ByteString ByteString) val
forall k a (b :: k). a -> Const a b
Const (Map ByteString ByteString
-> Const (Map ByteString ByteString) val)
-> Map ByteString ByteString
-> Const (Map ByteString ByteString) val
forall a b. (a -> b) -> a -> b
$
OneItem (Map ByteString ByteString) -> Map ByteString ByteString
forall x. One x => OneItem x -> x
one ( Label name -> ByteString
forall (marker :: UStoreMarkerType) (field :: Symbol).
KnownUStoreMarker marker =>
Label field -> ByteString
mkFieldMarkerUKeyL @marker Label name
fieldName
, val -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw val
val
)
instance (NicePackedValue k, NicePackedValue v) =>
UStoreTraversalSubmapHandler MkUStoreTW k v where
ustoreTraversalSubmapHandler :: MkUStoreTW
-> Label name
-> UStoreTraversalArgumentWrapper MkUStoreTW (Map k v)
-> UStoreTraversalMonad MkUStoreTW (Map k v)
ustoreTraversalSubmapHandler MkUStoreTW
MkUStoreTW Label name
fieldName (Identity m) =
Map ByteString ByteString
-> Const (Map ByteString ByteString) (Map k v)
forall k a (b :: k). a -> Const a b
Const (Map ByteString ByteString
-> Const (Map ByteString ByteString) (Map k v))
-> Map ByteString ByteString
-> Const (Map ByteString ByteString) (Map k v)
forall a b. (a -> b) -> a -> b
$
[Map ByteString ByteString] -> Map ByteString ByteString
forall a. Monoid a => [a] -> a
mconcat
[ OneItem (Map ByteString ByteString) -> Map ByteString ByteString
forall x. One x => OneItem x -> x
one ( (MText, k) -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw (Label name -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label name
fieldName, k
k)
, v -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw v
v
)
| (k
k, v
v) <- Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m
]
data DecomposeUStoreTW = DecomposeUStoreTW
instance UStoreTraversalWay DecomposeUStoreTW where
type UStoreTraversalArgumentWrapper DecomposeUStoreTW = Const ()
type UStoreTraversalMonad DecomposeUStoreTW =
StateT UStoreContent (ExceptT Text Identity)
instance (NiceUnpackedValue val) =>
UStoreTraversalFieldHandler DecomposeUStoreTW marker val where
ustoreTraversalFieldHandler :: DecomposeUStoreTW
-> Label name
-> UStoreTraversalArgumentWrapper DecomposeUStoreTW val
-> UStoreTraversalMonad DecomposeUStoreTW val
ustoreTraversalFieldHandler DecomposeUStoreTW
DecomposeUStoreTW Label name
fieldName (Const ()) = do
let expectedKey :: ByteString
expectedKey = MText -> ByteString
forall (marker :: UStoreMarkerType).
KnownUStoreMarker marker =>
MText -> ByteString
mkFieldMarkerUKey @marker (Label name -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label name
fieldName)
[val]
allMatched <- ((ByteString, ByteString)
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) val)
-> StateT UStoreContent (ExceptT Text Identity) [val]
forall a b (m :: * -> *).
MonadState [a] m =>
(a -> MaybeT m b) -> m [b]
mapMaybesState (((ByteString, ByteString)
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) val)
-> StateT UStoreContent (ExceptT Text Identity) [val])
-> ((ByteString, ByteString)
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) val)
-> StateT UStoreContent (ExceptT Text Identity) [val]
forall a b. (a -> b) -> a -> b
$ \(ByteString
key, ByteString
value) -> do
Bool
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) ()
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
key ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expectedKey) MaybeT (StateT UStoreContent (ExceptT Text Identity)) ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
case ByteString -> Either UnpackError val
forall a. NiceUnpackedValue a => ByteString -> Either UnpackError a
lUnpackValueRaw ByteString
value of
Left UnpackError
err -> Text -> MaybeT (StateT UStoreContent (ExceptT Text Identity)) val
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> MaybeT (StateT UStoreContent (ExceptT Text Identity)) val)
-> Text
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) val
forall a b. (a -> b) -> a -> b
$
Builder
"Failed to parse UStore value for field " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|
(SingKind T, SingI (ToT val)) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @(ToT val) T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
": " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| UnpackError
err UnpackError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
Right val
valValue ->
val -> MaybeT (StateT UStoreContent (ExceptT Text Identity)) val
forall (f :: * -> *) a. Applicative f => a -> f a
pure val
valValue
case [val]
allMatched of
[] -> Text -> StateT UStoreContent (ExceptT Text Identity) val
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> StateT UStoreContent (ExceptT Text Identity) val)
-> Text -> StateT UStoreContent (ExceptT Text Identity) val
forall a b. (a -> b) -> a -> b
$
Builder
"Failed to find field in UStore: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Label name -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label name
fieldName MText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
[val
matched] ->
val -> StateT UStoreContent (ExceptT Text Identity) val
forall (f :: * -> *) a. Applicative f => a -> f a
pure val
matched
(val
_ : val
_ : [val]
_) ->
Text -> StateT UStoreContent (ExceptT Text Identity) val
forall a. HasCallStack => Text -> a
error Text
"UStore content contained multiple entries with the same key"
instance (Ord k, NiceUnpackedValue k, NiceUnpackedValue v) =>
UStoreTraversalSubmapHandler DecomposeUStoreTW k v where
ustoreTraversalSubmapHandler :: DecomposeUStoreTW
-> Label name
-> UStoreTraversalArgumentWrapper DecomposeUStoreTW (Map k v)
-> UStoreTraversalMonad DecomposeUStoreTW (Map k v)
ustoreTraversalSubmapHandler DecomposeUStoreTW
_ Label name
fieldName (Const ()) =
([(k, v)] -> Map k v)
-> StateT UStoreContent (ExceptT Text Identity) [(k, v)]
-> StateT UStoreContent (ExceptT Text Identity) (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (StateT UStoreContent (ExceptT Text Identity) [(k, v)]
-> StateT UStoreContent (ExceptT Text Identity) (Map k v))
-> StateT UStoreContent (ExceptT Text Identity) [(k, v)]
-> StateT UStoreContent (ExceptT Text Identity) (Map k v)
forall a b. (a -> b) -> a -> b
$
((ByteString, ByteString)
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v))
-> StateT UStoreContent (ExceptT Text Identity) [(k, v)]
forall a b (m :: * -> *).
MonadState [a] m =>
(a -> MaybeT m b) -> m [b]
mapMaybesState (((ByteString, ByteString)
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v))
-> StateT UStoreContent (ExceptT Text Identity) [(k, v)])
-> ((ByteString, ByteString)
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v))
-> StateT UStoreContent (ExceptT Text Identity) [(k, v)]
forall a b. (a -> b) -> a -> b
$ \(ByteString
key, ByteString
value) ->
case ByteString -> Either UnpackError (UStoreSubmapKey k)
forall a. NiceUnpackedValue a => ByteString -> Either UnpackError a
lUnpackValueRaw @(UStoreSubmapKey k) ByteString
key of
Left UnpackError
_ -> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
Right (MText
name :: MText, k
keyValue :: k)
| MText
name MText -> MText -> Bool
forall a. Eq a => a -> a -> Bool
/= Label name -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label name
fieldName ->
MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Bool
otherwise ->
case ByteString -> Either UnpackError v
forall a. NiceUnpackedValue a => ByteString -> Either UnpackError a
lUnpackValueRaw ByteString
value of
Left UnpackError
err -> Text
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v))
-> Text
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v)
forall a b. (a -> b) -> a -> b
$
Builder
"Failed to parse UStore value for " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|
(SingKind T, SingI (ToT k)) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @(ToT k) T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" |~> " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| (SingKind T, SingI (ToT v)) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @(ToT v) T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
Builder
": " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| UnpackError
err UnpackError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
Right v
valValue ->
(k, v)
-> MaybeT (StateT UStoreContent (ExceptT Text Identity)) (k, v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (k
keyValue, v
valValue)
data FillUStoreTW = FillUStoreTW
instance UStoreTraversalWay FillUStoreTW where
type UStoreTraversalArgumentWrapper FillUStoreTW = Identity
type UStoreTraversalMonad FillUStoreTW = Const (Endo [MigrationAtom])
instance (NiceConstant v) =>
UStoreTraversalFieldHandler FillUStoreTW marker v where
ustoreTraversalFieldHandler :: FillUStoreTW
-> Label name
-> UStoreTraversalArgumentWrapper FillUStoreTW v
-> UStoreTraversalMonad FillUStoreTW v
ustoreTraversalFieldHandler FillUStoreTW
FillUStoreTW Label name
fieldName (Identity val) =
Endo [MigrationAtom] -> Const (Endo [MigrationAtom]) v
forall k a (b :: k). a -> Const a b
Const (Endo [MigrationAtom] -> Const (Endo [MigrationAtom]) v)
-> Endo [MigrationAtom] -> Const (Endo [MigrationAtom]) v
forall a b. (a -> b) -> a -> b
$
([MigrationAtom] -> [MigrationAtom]) -> Endo [MigrationAtom]
forall a. (a -> a) -> Endo a
Endo (([MigrationAtom] -> [MigrationAtom]) -> Endo [MigrationAtom])
-> (Lambda UStore_ UStore_ -> [MigrationAtom] -> [MigrationAtom])
-> Lambda UStore_ UStore_
-> Endo [MigrationAtom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (MigrationAtom -> [MigrationAtom] -> [MigrationAtom])
-> (Lambda UStore_ UStore_ -> MigrationAtom)
-> Lambda UStore_ UStore_
-> [MigrationAtom]
-> [MigrationAtom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Lambda UStore_ UStore_ -> MigrationAtom
formMigrationAtom Maybe Text
forall a. Maybe a
Nothing (Lambda UStore_ UStore_ -> Endo [MigrationAtom])
-> Lambda UStore_ UStore_ -> Endo [MigrationAtom]
forall a b. (a -> b) -> a -> b
$
DMigrationActionType
-> Label name -> Proxy v -> Lambda UStore_ UStore_
forall fieldTy (fieldName :: Symbol) (s :: [*]).
SingI (ToT fieldTy) =>
DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName (Text -> DMigrationActionType
DAddAction Text
"init field") Label name
fieldName (Proxy v
forall k (t :: k). Proxy t
Proxy @v) Lambda UStore_ UStore_
-> ('[UStore_] :-> '[v, UStore_]) -> '[UStore_] :-> '[v, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
v -> '[UStore_] :-> '[v, UStore_]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push v
val ('[UStore_] :-> '[v, UStore_])
-> ('[v, UStore_] :-> '[ByteString, UStore_])
-> '[UStore_] :-> '[ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[v, UStore_] :-> '[ByteString, UStore_]
forall a (s :: [*]).
NicePackedValue a =>
(a : s) :-> (ByteString : s)
L.packRaw ('[UStore_] :-> '[ByteString, UStore_])
-> ('[ByteString, UStore_] :-> '[Maybe ByteString, UStore_])
-> '[UStore_] :-> '[Maybe ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[ByteString, UStore_] :-> '[Maybe ByteString, UStore_]
forall a (s :: [*]). (a : s) :-> (Maybe a : s)
L.some ('[UStore_] :-> '[Maybe ByteString, UStore_])
-> ('[Maybe ByteString, UStore_]
:-> '[ByteString, Maybe ByteString, UStore_])
-> '[UStore_] :-> '[ByteString, Maybe ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
ByteString
-> '[Maybe ByteString, UStore_]
:-> '[ByteString, Maybe ByteString, UStore_]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push (Label name -> ByteString
forall (marker :: UStoreMarkerType) (field :: Symbol).
KnownUStoreMarker marker =>
Label field -> ByteString
mkFieldMarkerUKeyL @marker Label name
fieldName) ('[UStore_] :-> '[ByteString, Maybe ByteString, UStore_])
-> ('[ByteString, Maybe ByteString, UStore_] :-> '[UStore_])
-> Lambda UStore_ UStore_
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
'[ByteString, Maybe ByteString, UStore_] :-> '[UStore_]
forall c (s :: [*]).
UpdOpHs c =>
(UpdOpKeyHs c : UpdOpParamsHs c : c : s) :-> (c : s)
L.update
instance (NiceConstant k, NiceConstant v) =>
UStoreTraversalSubmapHandler FillUStoreTW k v where
ustoreTraversalSubmapHandler :: FillUStoreTW
-> Label name
-> UStoreTraversalArgumentWrapper FillUStoreTW (Map k v)
-> UStoreTraversalMonad FillUStoreTW (Map k v)
ustoreTraversalSubmapHandler FillUStoreTW
_ Label name
fieldName (Identity m) =
Endo [MigrationAtom] -> Const (Endo [MigrationAtom]) (Map k v)
forall k a (b :: k). a -> Const a b
Const (Endo [MigrationAtom] -> Const (Endo [MigrationAtom]) (Map k v))
-> Endo [MigrationAtom] -> Const (Endo [MigrationAtom]) (Map k v)
forall a b. (a -> b) -> a -> b
$
([MigrationAtom] -> [MigrationAtom]) -> Endo [MigrationAtom]
forall a. (a -> a) -> Endo a
Endo (([MigrationAtom] -> [MigrationAtom]) -> Endo [MigrationAtom])
-> ([MigrationAtom] -> [MigrationAtom] -> [MigrationAtom])
-> [MigrationAtom]
-> Endo [MigrationAtom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MigrationAtom] -> [MigrationAtom] -> [MigrationAtom]
forall a. Semigroup a => a -> a -> a
(<>) ([MigrationAtom] -> Endo [MigrationAtom])
-> [MigrationAtom] -> Endo [MigrationAtom]
forall a b. (a -> b) -> a -> b
$
Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m [(k, v)] -> ((k, v) -> MigrationAtom) -> [MigrationAtom]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(k
k, v
v) ->
Maybe Text -> Lambda UStore_ UStore_ -> MigrationAtom
formMigrationAtom Maybe Text
forall a. Maybe a
Nothing (Lambda UStore_ UStore_ -> MigrationAtom)
-> Lambda UStore_ UStore_ -> MigrationAtom
forall a b. (a -> b) -> a -> b
$
DMigrationActionType
-> Label name -> Proxy v -> Lambda UStore_ UStore_
forall fieldTy (fieldName :: Symbol) (s :: [*]).
SingI (ToT fieldTy) =>
DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName (Text -> DMigrationActionType
DAddAction Text
"init submap") Label name
fieldName (Proxy v
forall k (t :: k). Proxy t
Proxy @v) Lambda UStore_ UStore_
-> ('[UStore_] :-> '[v, UStore_]) -> '[UStore_] :-> '[v, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
v -> '[UStore_] :-> '[v, UStore_]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push v
v ('[UStore_] :-> '[v, UStore_])
-> ('[v, UStore_] :-> '[ByteString, UStore_])
-> '[UStore_] :-> '[ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[v, UStore_] :-> '[ByteString, UStore_]
forall a (s :: [*]).
NicePackedValue a =>
(a : s) :-> (ByteString : s)
L.packRaw ('[UStore_] :-> '[ByteString, UStore_])
-> ('[ByteString, UStore_] :-> '[Maybe ByteString, UStore_])
-> '[UStore_] :-> '[Maybe ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[ByteString, UStore_] :-> '[Maybe ByteString, UStore_]
forall a (s :: [*]). (a : s) :-> (Maybe a : s)
L.some ('[UStore_] :-> '[Maybe ByteString, UStore_])
-> ('[Maybe ByteString, UStore_]
:-> '[k, Maybe ByteString, UStore_])
-> '[UStore_] :-> '[k, Maybe ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
k
-> '[Maybe ByteString, UStore_] :-> '[k, Maybe ByteString, UStore_]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push k
k ('[UStore_] :-> '[k, Maybe ByteString, UStore_])
-> ('[k, Maybe ByteString, UStore_]
:-> '[MText, k, Maybe ByteString, UStore_])
-> '[UStore_] :-> '[MText, k, Maybe ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# MText
-> '[k, Maybe ByteString, UStore_]
:-> '[MText, k, Maybe ByteString, UStore_]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push (Label name -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label name
fieldName) ('[UStore_] :-> '[MText, k, Maybe ByteString, UStore_])
-> ('[MText, k, Maybe ByteString, UStore_]
:-> '[(MText, k), Maybe ByteString, UStore_])
-> '[UStore_] :-> '[(MText, k), Maybe ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[MText, k, Maybe ByteString, UStore_]
:-> '[(MText, k), Maybe ByteString, UStore_]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
L.pair ('[UStore_] :-> '[(MText, k), Maybe ByteString, UStore_])
-> ('[(MText, k), Maybe ByteString, UStore_]
:-> '[ByteString, Maybe ByteString, UStore_])
-> '[UStore_] :-> '[ByteString, Maybe ByteString, UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
forall (s :: [*]).
NicePackedValue (MText, k) =>
((MText, k) : s) :-> (ByteString : s)
forall a (s :: [*]).
NicePackedValue a =>
(a : s) :-> (ByteString : s)
L.packRaw @(UStoreSubmapKey _) ('[UStore_] :-> '[ByteString, Maybe ByteString, UStore_])
-> ('[ByteString, Maybe ByteString, UStore_] :-> '[UStore_])
-> Lambda UStore_ UStore_
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
'[ByteString, Maybe ByteString, UStore_] :-> '[UStore_]
forall c (s :: [*]).
UpdOpHs c =>
(UpdOpKeyHs c : UpdOpParamsHs c : c : s) :-> (c : s)
L.update
mapMaybesState :: forall a b m. MonadState [a] m => (a -> MaybeT m b) -> m [b]
mapMaybesState :: (a -> MaybeT m b) -> m [b]
mapMaybesState a -> MaybeT m b
mapper =
m [a]
forall s (m :: * -> *). MonadState s m => m s
get m [a] -> ([a] -> m [b]) -> m [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[a]
st -> do
[(a, Maybe b)]
mapped <- (a -> m (a, Maybe b)) -> [a] -> m [(a, Maybe b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\a
a -> (a
a, ) (Maybe b -> (a, Maybe b)) -> m (Maybe b) -> m (a, Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> MaybeT m b
mapper a
a)) [a]
st
let
([b]
passed, [a]
failed) =
([(a, Maybe b)] -> [b])
-> ([(a, Maybe b)] -> [a])
-> ([(a, Maybe b)], [(a, Maybe b)])
-> ([b], [a])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (((a, Maybe b) -> b) -> [(a, Maybe b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Maybe b -> b
forall a. HasCallStack => Maybe a -> a
Unsafe.fromJust (Maybe b -> b) -> ((a, Maybe b) -> Maybe b) -> (a, Maybe b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Maybe b) -> Maybe b
forall a b. (a, b) -> b
snd)) (((a, Maybe b) -> a) -> [(a, Maybe b)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (a, Maybe b) -> a
forall a b. (a, b) -> a
fst) (([(a, Maybe b)], [(a, Maybe b)]) -> ([b], [a]))
-> ([(a, Maybe b)], [(a, Maybe b)]) -> ([b], [a])
forall a b. (a -> b) -> a -> b
$
((a, Maybe b) -> Bool)
-> [(a, Maybe b)] -> ([(a, Maybe b)], [(a, Maybe b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition @(a, Maybe b) (Maybe b -> Bool
forall a. Maybe a -> Bool
isJust (Maybe b -> Bool)
-> ((a, Maybe b) -> Maybe b) -> (a, Maybe b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Maybe b) -> Maybe b
forall a b. (a, b) -> b
snd) ([(a, Maybe b)] -> ([(a, Maybe b)], [(a, Maybe b)]))
-> [(a, Maybe b)] -> ([(a, Maybe b)], [(a, Maybe b)])
forall a b. (a -> b) -> a -> b
$
[(a, Maybe b)]
mapped
[a] -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [a]
failed
[b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b]
passed
data MyStoreTemplate = MyStoreTemplate
{ MyStoreTemplate -> Integer |~> ()
ints :: Integer |~> ()
, MyStoreTemplate -> UStoreField Bool
flag :: UStoreField Bool
}
deriving stock ((forall x. MyStoreTemplate -> Rep MyStoreTemplate x)
-> (forall x. Rep MyStoreTemplate x -> MyStoreTemplate)
-> Generic MyStoreTemplate
forall x. Rep MyStoreTemplate x -> MyStoreTemplate
forall x. MyStoreTemplate -> Rep MyStoreTemplate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MyStoreTemplate x -> MyStoreTemplate
$cfrom :: forall x. MyStoreTemplate -> Rep MyStoreTemplate x
Generic)
data MyStoreTemplateBig = MyStoreTemplateBig
{ MyStoreTemplateBig -> MyStoreTemplate
templ :: MyStoreTemplate
, MyStoreTemplateBig -> ByteString |~> ByteString
bytes :: ByteString |~> ByteString
}
deriving stock ((forall x. MyStoreTemplateBig -> Rep MyStoreTemplateBig x)
-> (forall x. Rep MyStoreTemplateBig x -> MyStoreTemplateBig)
-> Generic MyStoreTemplateBig
forall x. Rep MyStoreTemplateBig x -> MyStoreTemplateBig
forall x. MyStoreTemplateBig -> Rep MyStoreTemplateBig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MyStoreTemplateBig x -> MyStoreTemplateBig
$cfrom :: forall x. MyStoreTemplateBig -> Rep MyStoreTemplateBig x
Generic)
_storeSample :: UStore MyStoreTemplate
_storeSample :: UStore MyStoreTemplate
_storeSample = MyStoreTemplate -> UStore MyStoreTemplate
forall template.
UStoreTraversable MkUStoreTW template =>
template -> UStore template
mkUStore
MyStoreTemplate :: (Integer |~> ()) -> UStoreField Bool -> MyStoreTemplate
MyStoreTemplate
{ ints :: Integer |~> ()
ints = Map Integer () -> Integer |~> ()
forall k v. Map k v -> k |~> v
UStoreSubMap (Map Integer () -> Integer |~> ())
-> Map Integer () -> Integer |~> ()
forall a b. (a -> b) -> a -> b
$ OneItem (Map Integer ()) -> Map Integer ()
forall x. One x => OneItem x -> x
one (Integer
1, ())
, flag :: UStoreField Bool
flag = Bool -> UStoreField Bool
forall (m :: UStoreMarkerType) v. v -> UStoreFieldExt m v
UStoreField Bool
False
}
_storeSampleBig :: UStore MyStoreTemplateBig
_storeSampleBig :: UStore MyStoreTemplateBig
_storeSampleBig = MyStoreTemplateBig -> UStore MyStoreTemplateBig
forall template.
UStoreTraversable MkUStoreTW template =>
template -> UStore template
mkUStore (MyStoreTemplateBig -> UStore MyStoreTemplateBig)
-> MyStoreTemplateBig -> UStore MyStoreTemplateBig
forall a b. (a -> b) -> a -> b
$
MyStoreTemplate
-> (ByteString |~> ByteString) -> MyStoreTemplateBig
MyStoreTemplateBig
MyStoreTemplate :: (Integer |~> ()) -> UStoreField Bool -> MyStoreTemplate
MyStoreTemplate
{ ints :: Integer |~> ()
ints = Map Integer () -> Integer |~> ()
forall k v. Map k v -> k |~> v
UStoreSubMap (Map Integer () -> Integer |~> ())
-> Map Integer () -> Integer |~> ()
forall a b. (a -> b) -> a -> b
$ OneItem (Map Integer ()) -> Map Integer ()
forall x. One x => OneItem x -> x
one (Integer
1, ())
, flag :: UStoreField Bool
flag = Bool -> UStoreField Bool
forall (m :: UStoreMarkerType) v. v -> UStoreFieldExt m v
UStoreField Bool
False
}
(Map ByteString ByteString -> ByteString |~> ByteString
forall k v. Map k v -> k |~> v
UStoreSubMap (Map ByteString ByteString -> ByteString |~> ByteString)
-> Map ByteString ByteString -> ByteString |~> ByteString
forall a b. (a -> b) -> a -> b
$ OneItem (Map ByteString ByteString) -> Map ByteString ByteString
forall x. One x => OneItem x -> x
one (ByteString
"a", ByteString
"b"))