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

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Conversion between 'UStore' in Haskell and Michelson representation.
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

-- | 'UStore' content represented as key-value pairs.
type UStoreContent = [(ByteString, ByteString)]

-- | Make 'UStore' from separate @big_map@s and fields.
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

-- | Decompose 'UStore' into separate @big_map@s and fields.
--
-- Along with resulting value, you get a list of @UStore@ entries which
-- were not recognized as belonging to any submap or field according to
-- @UStore@'s template - this should be empty unless @UStore@ invariants
-- were violated.
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

-- | Like 'ustoreDecompose', but requires all entries from @UStore@ to be
-- recognized.
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

-- | Make migration script which initializes 'UStore' from scratch.
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

-- | Version of 'migrateFillUStore' for batched migrations.
--
-- Each field write will be placed to a separate batch.
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

-- | Fill 'UStore' with entries from the given template as part of simple
-- migration.
--
-- Sometimes you already have some fields initialized and 'fillUStore' does not
-- suit, then in case if your UStore template is a nested structure you can use
-- sub-templates to initialize the corresponding parts of UStore.
--
-- For batched migrations see 'fillUStoreMigrationBlock'.
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

-- Implementation
----------------------------------------------------------------------------

-- | Internal helper for 'mkUStore'.
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

-- | Internal helper for 'ustoreDecompose'.
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)

-- | Internal helper for 'fillUStore'.
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) []

-- | Declares handlers for UStore creation from template.
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
      ]

-- | Declares handlers for UStore conversion to template.
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)

-- | Declares handlers for UStore filling via lambda.
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
#
      -- Not pushing already packed value (which would be more efficient) because
      -- analyzers cannot work with packed values.
      -- TODO: make optimizer compress this to @push (Just $ lPackValueRaw val)@
      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
#
      -- @PUSH + PACK@ will be merged by optimizer, but there is still place
      -- for further improvement both for value and key pushing.
      -- We cannot push already packed value because that would break code
      -- analyzers and transformers, consider adding necessary rules to
      -- optimizer.
      -- TODO [TM-379]: consider improving this case
      -- or
      -- TODO: add necessary rules to optimizer
      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

-- | Tries to map all items in the state and returns those which were mapped
-- successfully; others are retained in the state.
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

-- Examples
----------------------------------------------------------------------------

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