lorentz 0.6.2 → 0.7.0

raw patch · 22 files changed

+37/−2957 lines, 22 filesdep −QuickCheckdep −pretty-terminal

Dependencies removed: QuickCheck, pretty-terminal

Files

• CHANGES.md +10/−0
• lorentz.cabal +2/−19
• src/Lorentz.hs +0/−1
• src/Lorentz/Annotation.hs +3/−0
• src/Lorentz/Base.hs +13/−4
• src/Lorentz/Coercions.hs +7/−5
• src/Lorentz/Doc.hs +2/−1
• src/Lorentz/TestScenario.hs +0/−57
• src/Lorentz/UStore.hs +0/−107
• src/Lorentz/UStore/Common.hs +0/−17
• src/Lorentz/UStore/Doc.hs +0/−237
• src/Lorentz/UStore/Haskell.hs +0/−312
• src/Lorentz/UStore/Instances.hs +0/−28
• src/Lorentz/UStore/Instr.hs +0/−355
• src/Lorentz/UStore/Lift.hs +0/−113
• src/Lorentz/UStore/Migration.hs +0/−93
• src/Lorentz/UStore/Migration/Base.hs +0/−536
• src/Lorentz/UStore/Migration/Batching.hs +0/−117
• src/Lorentz/UStore/Migration/Blocks.hs +0/−290
• src/Lorentz/UStore/Migration/Diff.hs +0/−200
• src/Lorentz/UStore/Traversal.hs +0/−193
• src/Lorentz/UStore/Types.hs +0/−272

@@ -1,3 +1,13 @@+0.7.0+=====+* [!629](https://gitlab.com/morley-framework/morley/-/merge_requests/629)+  All `UStore` modules has been moved to the [morley-upgradeable](https://gitlab.com/morley-framework/morley-upgradeable/) repository.+  Now you have to include that repository to your build and import `Lorentz.UStore`.+* [!610](https://gitlab.com/morley-framework/morley/-/merge_requests/610)+  Remove `Lorentz.TestScenario`.+* [!585](https://gitlab.com/morley-framework/morley/-/merge_requests/585)+  Add `HasAnnotation` instance for `ChainId`.+ 0.6.2 ===== * [!589](https://gitlab.com/morley-framework/morley/-/merge_requests/589)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           lorentz-version:        0.6.2+version:        0.7.0 synopsis:       EDSL for the Michelson Language description:    Lorentz is a powerful meta-programming tool which allows one to write Michelson contracts directly in Haskell. It has the same instructions as Michelson, but operates on Haskell values and allows one to use Haskell features. category:       Language@@ -64,22 +64,7 @@       Lorentz.Referenced       Lorentz.Run       Lorentz.StoreClass-      Lorentz.TestScenario       Lorentz.UParam-      Lorentz.UStore-      Lorentz.UStore.Common-      Lorentz.UStore.Doc-      Lorentz.UStore.Haskell-      Lorentz.UStore.Instances-      Lorentz.UStore.Instr-      Lorentz.UStore.Lift-      Lorentz.UStore.Migration-      Lorentz.UStore.Migration.Base-      Lorentz.UStore.Migration.Batching-      Lorentz.UStore.Migration.Blocks-      Lorentz.UStore.Migration.Diff-      Lorentz.UStore.Traversal-      Lorentz.UStore.Types       Lorentz.Util.TH       Lorentz.Value       Lorentz.Wrappable@@ -93,8 +78,7 @@   default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude   build-depends:-      QuickCheck-    , aeson-pretty+      aeson-pretty     , base >=4.7 && <5     , bimap     , bytestring@@ -110,7 +94,6 @@     , mtl     , named     , optparse-applicative-    , pretty-terminal     , singletons     , template-haskell     , text

@@ -32,7 +32,6 @@ import Lorentz.Run as Exports import Lorentz.StoreClass as Exports import Lorentz.UParam as Exports-import Lorentz.UStore as Exports import Lorentz.Util.TH as Exports import Lorentz.Value as Exports import Lorentz.Zip as Exports ()

@@ -162,6 +162,9 @@ instance HasAnnotation Signature where   getAnnotation _ = starNotes +instance HasAnnotation ChainId where+  getAnnotation _ = starNotes+ instance (HasAnnotation a) => HasAnnotation (ContractRef a) where   getAnnotation _ = NTContract noAnn (getAnnotation @a NotFollowEntrypoint) 

@@ -127,11 +127,20 @@ infixl 8 #  -- | Version of '#' which performs some optimizations immediately.+--+-- In particular, this avoids glueing @Nop@s. (##) :: (a :-> b) -> (b :-> c) -> (a :-> c)-l ## r = case (l, r) of-  (I Nop, I x) -> I x-  (I x, I Nop) -> I x-  _ -> l # r+l ## r =+  -- We are very verbose about cases to avoid+  -- significant compilation time increase+  case l of+    I Nop -> case r of+      I x -> I x+      _ -> l # r+    I x -> case r of+      I Nop -> I x+      _ -> l # r+    _ -> l # r   type Lambda i o = '[i] :-> '[o]

@@ -41,9 +41,9 @@ import Lorentz.Base import Lorentz.Instr import Lorentz.Value+import Lorentz.Wrappable (Wrappable(..)) import Lorentz.Zip import Michelson.Typed-import Lorentz.Wrappable (Wrappable(..)) ---------------------------------------------------------------------------- -- Unsafe coercions ----------------------------------------------------------------------------@@ -63,10 +63,12 @@  -- | Convert between values of types that have the same representation. ----- This function is not safe in a sense that this allows breaking invariants of--- casted type (example: @UStore@) or may stop compile on code changes (example:--- coercion of pair to a datatype with two fields will break if new field is--- added).+-- This function is not safe in a sense that this allows+-- * breaking invariants of casted type+--   (example: @UStore@ from morley-upgradeable), or+-- * may stop compile on code changes+--   (example: coercion of pair to a datatype with two fields+--    will break if new field is added). -- Still, produced Michelson code will always be valid. -- -- Prefer using one of more specific functions from this module.

@@ -118,7 +118,8 @@ contractGeneralDefault :: s :-> s contractGeneralDefault =   (contractGeneral $ doc DGitRevisionUnknown) #-  doc (DToc "")+  doc (DToc "") #+  doc DConversionInfo  buildLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> ContractDoc buildLorentzDocWithGitRev gitRev (iAnyCode -> code) =

@@ -1,57 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Lorentz.TestScenario-  {-# DEPRECATED "Use cleveland instead" #-}-  ( TestScenario-  , showTestScenario-  ) where--import Fmt (Buildable, Builder, fmt, (+|), (|+))--import Lorentz.Constraints (KnownValue, NicePrintedValue, NoOperation)-import Lorentz.Print (printLorentzValue)-import Michelson.Typed.Haskell.Value (IsoValue)-import Tezos.Address (Address)---- | Type that represents test scenario for Lorentz contract.--- Simply put, it is sequence of pairs (`sender`, `parameter`).--- Using this sequence we can perform transfers to the desired contract.-type TestScenario param = [(Address, param)]---- | Function to get textual representation of @TestScenario@, each Parameter--- is printed as a raw Michelson value.--- This representation can later be used in order to run test scenario--- on real network.------ The format for a single contract call is the following:--- # `printed Lorentz parameter` (actually comment)--- `sender address`--- `printed raw Michelson parameter`-showTestScenario-  :: (Buildable param, NicePrintedValue param)-  => TestScenario param -> Text-showTestScenario = fmt . foldMap formatParam-  where-     formatParam-       :: (Buildable param, KnownValue param, NoOperation param)-       => (Address, param) -> Builder-     formatParam (addr, param) =-       "# " +| param |+ "\n" +|-       addr |+ "\n" +|-       printLorentzValue True param |+ "\n"--data Parameter-  = Param1 Integer Bool-  | Param2-  | Param3 Natural Natural-  deriving stock Generic-  deriving anyclass IsoValue--_mkTestScenarioExample :: Address -> TestScenario Parameter-_mkTestScenarioExample owner =-  [ (owner, Param1 5 False)-  , (owner, Param2)-  , (owner, Param3 2 2)-  ]

@@ -1,107 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{- | This module contains implementation of 'UStore'.--@UStore@ is essentially-  @forall store field type. Lorentz.StoreClass.StoreHasField store field type@-modified for the sake of upgradeability.--In API it differs from @Store@ in the following ways:-1. It keeps both virtual @big_map@s and plain fields;-2. Neat conversion between Michelson and Haskell values-is implemented;-3. Regarding composabililty, one can operate with one @UStore@-and then lift it to a bigger one which includes the former.-This allows for simpler management of stores and clearer error messages.-In spite of this, operations with 'UStore's over deeply nested templates will-still work as before.--We represent 'UStore' as @big_map bytes bytes@.--* Plain fields are stored as-@key = pack fieldName; value = pack originalValue@.--* Virtual @big_map@s are kept as-@key = pack (bigMapName, originalKey); value = pack originalValue@.---}-module Lorentz.UStore-  ( -- * UStore and related type definitions-    UStore-  , type (|~>)(..)-  , UStoreFieldExt (..)-  , UStoreField-  , UStoreMarkerType-  , KnownUStoreMarker (..)--    -- ** Type-lookup-by-name-  , GetUStoreKey-  , GetUStoreValue-  , GetUStoreField-  , GetUStoreFieldMarker--    -- ** Instructions-  , ustoreMem-  , ustoreGet-  , ustoreUpdate-  , ustoreInsert-  , ustoreInsertNew-  , ustoreDelete--  , ustoreToField-  , ustoreGetField-  , ustoreSetField--    -- ** Instruction constraints-  , HasUStore-  , HasUField-  , HasUStoreForAllIn--    -- * UStore composability-  , liftUStore-  , unliftUStore--    -- * Documentation-  , UStoreTemplateHasDoc (..)-  , UStoreMarkerHasDoc (..)--    -- * UStore management from Haskell-  , mkUStore-  , ustoreDecompose-  , ustoreDecomposeFull-  , fillUStore-  , MkUStoreTW-  , DecomposeUStoreTW-  , FillUStoreTW--    -- * Migrations-  , MigrationScript (..)-  , MigrationScript_-  , UStoreMigration-  , migrationToScript-  , migrationToScriptI-  , migrationToLambda-  , mkUStoreMigration-  , mustoreToOld-  , migrateGetField-  , migrateAddField-  , migrateRemoveField-  , migrateExtractField-  , migrateOverwriteField-  , migrateModifyField--    -- * Extras-  , PickMarkedFields-  , UStoreTraversable-  ) where--import Lorentz.UStore.Types-import Lorentz.UStore.Instr-import Lorentz.UStore.Traversal-import Lorentz.UStore.Instances ()-import Lorentz.UStore.Haskell-import Lorentz.UStore.Doc-import Lorentz.UStore.Lift-import Lorentz.UStore.Migration

@@ -1,17 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Lorentz.UStore.Common-  ( fieldNameToMText-  ) where--import GHC.TypeLits (KnownSymbol, symbolVal)--import Michelson.Text--fieldNameToMText :: forall field. KnownSymbol field => MText-fieldNameToMText =-  -- Using 'mkMTextUnsafe' because our coding practices does not allow-  -- weird characters (like unicode) in field names-  mkMTextUnsafe . toText . symbolVal $ Proxy @field

@@ -1,237 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}---- | Autodoc for UStore.-module Lorentz.UStore.Doc-  ( UStoreTemplateHasDoc (..)-  , UStoreMarkerHasDoc (..)-  , DUStoreTemplate (..)-  , dUStoreTemplateRef-  , DocumentTW-  ) where--import Data.Constraint (Dict(..))-import Fmt (build)-import Lorentz.Doc-import Lorentz.UStore.Traversal-import Lorentz.UStore.Types-import Michelson.Typed.Haskell.Doc-import Util.Generic-import Util.Label-import Util.Markdown-import Util.Typeable-import Util.TypeLits---- | Information for UStore template required for documentation.------ You only need to instantiate this for templates used directly in--- UStore, nested subtemplates do not need this instance.-class Typeable template => UStoreTemplateHasDoc template where-  -- | UStore template name as it appears in documentation.-  ---  -- Should be only 1 word.-  ustoreTemplateDocName :: Text-  default ustoreTemplateDocName-    :: (Generic template, KnownSymbol (GenericTypeName template))-    => Text-  ustoreTemplateDocName = symbolValT' @(GenericTypeName template)-    where _needGeneric = Dict @(Generic template)--  -- | Description of template.-  ustoreTemplateDocDescription :: Markdown--  -- | Description of template entries.-  ustoreTemplateDocContents :: Markdown-  default ustoreTemplateDocContents-    :: (UStoreTraversable DocumentTW template) => Markdown-  ustoreTemplateDocContents =-    "\n" <> documentUStore (Proxy @template)--  ustoreTemplateDocDependencies :: [SomeTypeWithDoc]-  default ustoreTemplateDocDependencies-    :: (UStoreTraversable DocumentTW template) => [SomeTypeWithDoc]-  ustoreTemplateDocDependencies =-    gatherUStoreDeps (Proxy @template)---- | Instantiated for documented UStore markers.-class (KnownUStoreMarker marker) =>-      UStoreMarkerHasDoc (marker :: UStoreMarkerType) where--  -- | Specifies key encoding.-  ---  -- You accept description of field name, and should return how is it encoded-  -- as key of @big_map bytes bytes@.-  ustoreMarkerKeyEncoding :: Text -> Text--instance UStoreTemplateHasDoc template =>-         TypeHasDoc (UStore template) where-  typeDocName _ = "Upgradeable storage"-  typeDocMdDescription = [md|-    Storage with not hardcoded structure, which allows upgrading the contract-    in place. UStore is capable of storing simple fields and multiple submaps.-    |]-  typeDocMdReference tp wp =-    applyWithinParens wp $ mconcat-      [ mdLocalRef (mdTicked "UStore") (docItemRef (DType tp))-      , " "-      , dUStoreTemplateRef (DUStoreTemplate (Proxy @template))-      ]-  typeDocHaskellRep = homomorphicTypeDocHaskellRep-  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep-  typeDocDependencies p =-    genericTypeDocDependencies p <>-    [SomeDocDefinitionItem (DUStoreTemplate $ Proxy @template)]--data DUStoreTemplate where-  DUStoreTemplate-    :: UStoreTemplateHasDoc template-    => Proxy template -> DUStoreTemplate--instance Eq DUStoreTemplate where-  DUStoreTemplate p1 == DUStoreTemplate p2 = eqParam1 p1 p2-instance Ord DUStoreTemplate where-  DUStoreTemplate p1 `compare` DUStoreTemplate p2 = compareExt p1 p2--instance DocItem DUStoreTemplate where-  type DocItemPlacement DUStoreTemplate = 'DocItemInDefinitions-  type DocItemReferenced DUStoreTemplate = 'True--  docItemPos = 12700-  docItemSectionName = Just "Used upgradeable storage formats"-  docItemSectionDescription = Just-    "This section describes formats (aka _templates_) of upgradeable storages \-    \mentioned across the given document. \-    \Each format describes set of fields and virtual submaps which the storage \-    \must have."--  docItemToMarkdown lvl (DUStoreTemplate (_ :: Proxy template)) =-    mconcat-    [ mdSeparator-    , mdHeader lvl (mdTicked . build $ ustoreTemplateDocName @template)-    , ustoreTemplateDocDescription @template-    , "\n\n"-    , mdSubsection "Contents" $ ustoreTemplateDocContents @template-    , "\n\n"-    ]--  docItemRef (DUStoreTemplate (_ :: Proxy template)) =-    DocItemRef . DocItemId $-      "ustore-template-" <> ustoreTemplateDocName @template--  docItemDependencies (DUStoreTemplate (_ :: Proxy template)) =-    ustoreTemplateDocDependencies @template <&>-      \(SomeTypeWithDoc t) -> SomeDocDefinitionItem (DType t)---- | Make a reference to given UStore template description.-dUStoreTemplateRef :: DUStoreTemplate -> Markdown-dUStoreTemplateRef (DUStoreTemplate (_ :: Proxy template)) =-  mdLocalRef (mdTicked . build $ ustoreTemplateDocName @template)-             (docItemRef (DUStoreTemplate (Proxy @template)))---- Instances-------------------------------------------------------------------------------instance UStoreTemplateHasDoc () where-  ustoreTemplateDocName = "empty"-  ustoreTemplateDocDescription = ""-  ustoreTemplateDocContents =-    mdItalic "empty"--instance UStoreMarkerHasDoc UMarkerPlainField where-  ustoreMarkerKeyEncoding k = "pack (" <> k <> ")"---- Internals-------------------------------------------------------------------------------documentUStore-  :: forall template.-     (UStoreTraversable DocumentTW template)-  => Proxy template -> Markdown-documentUStore _ =-  let Const collected = traverseUStore @_ @template DocumentTW (Const ())-      entries = appEndo (dcEntries collected) []-  in if null entries-     then mdTicked "<empty>"-     else mconcat $ map (\e -> "* " <> e <> "\n") entries--gatherUStoreDeps-  :: forall template.-     (UStoreTraversable DocumentTW template)-  => Proxy template -> [SomeTypeWithDoc]-gatherUStoreDeps _ =-  let Const collected = traverseUStore @_ @template DocumentTW (Const ())-  in appEndo (dcDependencies collected) []--data DocCollector = DocCollector-  { dcEntries :: Endo [Markdown]-  , dcDependencies :: Endo [SomeTypeWithDoc]-  }--data DocumentTW = DocumentTW--instance Semigroup DocCollector where-  DocCollector e1 d1 <> DocCollector e2 d2 = DocCollector (e1 <> e2) (d1 <> d2)-instance Monoid DocCollector where-  mempty = DocCollector mempty mempty--instance UStoreTraversalWay DocumentTW where-  type UStoreTraversalArgumentWrapper DocumentTW = Const ()-  type UStoreTraversalMonad DocumentTW = Const DocCollector--instance (UStoreMarkerHasDoc marker, TypeHasDoc v) =>-         UStoreTraversalFieldHandler DocumentTW marker v where-  ustoreTraversalFieldHandler DocumentTW fieldName (Const ()) =-    Const DocCollector-    { dcEntries = Endo . (:) $ mconcat-        [ mdBold "Field" <> " "-        , mdTicked (build $ labelToText fieldName)-        , ": "-        , typeDocMdReference (Proxy @v) (WithinParens False)-        , "\n"--        , mdSpoiler "Encoding" $ mconcat-          [ "\n"-          , let key = build $-                  ustoreMarkerKeyEncoding @marker-                  ("\"" <> labelToText fieldName <> "\"")-            in-            "  + " <> mdTicked ("key = " <> key) <> "\n\n"-          , "  + " <> mdTicked "value = pack (<field value>)" <> "\n\n"-          , mdSeparator-          ]-        , "\n"-        ]-    , dcDependencies = Endo . (<>) $-        [ SomeTypeWithDoc (Proxy @v)-        ]-    }--instance (TypeHasDoc k, TypeHasDoc v) =>-         UStoreTraversalSubmapHandler DocumentTW k v where-  ustoreTraversalSubmapHandler DocumentTW fieldName (Const ()) =-    Const DocCollector-    { dcEntries = Endo . (:) $ mconcat-        [ mdBold "Submap" <> " "-        , mdTicked (build $ labelToText fieldName)-        , ": "-        , typeDocMdReference (Proxy @k) (WithinParens False)-        , " -> "-        , typeDocMdReference (Proxy @v) (WithinParens False)-        , "\n"--        , mdSpoiler "Encoding" $ mconcat-          [ "\n"-          , " + " <> mdTicked "key = pack (<submap key>)" <> "\n\n"-          , " + " <> mdTicked "value = pack (<submap value>)" <> "\n\n"-          , mdSeparator-          ]-        , "\n"-        ]-    , dcDependencies = Endo . (<>) $-        [ SomeTypeWithDoc (Proxy @k)-        , SomeTypeWithDoc (Proxy @v)-        ]-    }

@@ -1,312 +0,0 @@--- 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 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 = UStore . BigMap . mkUStoreInternal---- | Decompose 'UStore' into separate @big_map@s and fields.------ Since this function needs to @UNPACK@ content of @UStore@ to actual--- keys and values, you have to provide 'UnpackEnv'.------ 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 = storeDecomposeInternal . Map.toList . unBigMap . 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 = do-  (remained, res) <- ustoreDecompose ustore-  unless (null remained) $-    Left $ "Unrecognized entries in UStore: " +|| remained ||+ ""-  return res---- | Make migration script which initializes 'UStore' from scratch.-fillUStore-  :: (UStoreTraversable FillUStoreTW template)-  => template -> UStoreMigration () template-fillUStore v = UStoreMigration $ fillUStoreInternal 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 v = MigrationBlocks $ fillUStoreInternal 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 v =-  let atoms = fillUStoreInternal v-      script = foldMap (unMigrationScript . maScript) atoms-  in forcedCoerce_ # script # 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 = foldUStore MkUStoreTW---- | Internal helper for 'ustoreDecompose'.-storeDecomposeInternal-  :: forall template.-     (UStoreTraversable DecomposeUStoreTW template)-  => UStoreContent -> Either Text (UStoreContent, template)-storeDecomposeInternal =-  runExcept . fmap swap . runStateT (genUStore DecomposeUStoreTW)---- | Internal helper for 'fillUStore'.-fillUStoreInternal-  :: (UStoreTraversable FillUStoreTW template)-  => template-  -> [MigrationAtom]-fillUStoreInternal a = appEndo (foldUStore FillUStoreTW 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 fieldName (Identity val) =-    Const $-    one ( mkFieldMarkerUKeyL @marker fieldName-        , lPackValue val-        )--instance (NicePackedValue k, NicePackedValue v) =>-         UStoreTraversalSubmapHandler MkUStoreTW k v where-  ustoreTraversalSubmapHandler MkUStoreTW fieldName (Identity m) =-    Const $-    mconcat-      [ one ( lPackValue (labelToMText fieldName, k)-            , lPackValue v-            )-      | (k, v) <- Map.toList 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 fieldName (Const ()) = do-    let expectedKey = mkFieldMarkerUKey @marker (labelToMText fieldName)-    allMatched <- mapMaybesState $ \(key, value) -> do-      unless (key == expectedKey) mzero-      case lUnpackValue value of-        Left err -> throwError $-          "Failed to parse UStore value for field " +|-          demote @(ToT val) |+ ": " +| err |+ ""-        Right valValue ->-          pure valValue-    case allMatched of-        [] -> throwError $-          "Failed to find field in UStore: " +| labelToMText fieldName |+ ""-        [matched] ->-          pure matched-        (_ : _ : _) ->-          error "UStore content contained multiple entries with the same key"--instance (Ord k, NiceUnpackedValue k, NiceUnpackedValue v) =>-         UStoreTraversalSubmapHandler DecomposeUStoreTW k v where-  ustoreTraversalSubmapHandler _ fieldName (Const ()) =-    fmap Map.fromList $-    mapMaybesState $ \(key, value) ->-      case lUnpackValue @(UStoreSubmapKey k) key of-        Left _ -> mzero-        Right (name :: MText, keyValue :: k)-          | name /= labelToMText fieldName ->-              mzero-          | otherwise ->-            case lUnpackValue value of-              Left err -> throwError $-                "Failed to parse UStore value for " +|-                demote @(ToT k) |+ " |~> " +| demote @(ToT v) |+-                ": " +| err |+ ""-              Right valValue ->-                pure (keyValue, 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 fieldName (Identity val) =-    Const $-    Endo . (:) . formMigrationAtom Nothing $-      attachMigrationActionName (DAddAction "init field") fieldName (Proxy @v) #-      -- 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 $ lPackValue val)@-      L.push val # L.pack # L.some #--      L.push (mkFieldMarkerUKeyL @marker fieldName) #-      L.update--instance (NiceConstant k, NiceConstant v) =>-         UStoreTraversalSubmapHandler FillUStoreTW k v where-  ustoreTraversalSubmapHandler _ fieldName (Identity m) =-    Const $-    Endo . (<>) $-    Map.toList m <&> \(k, v) ->-    formMigrationAtom Nothing $-      attachMigrationActionName (DAddAction "init submap") fieldName (Proxy @v) #-      -- @PUSH + PACK@ will be merged by optimizer, but there is still place-      -- for further improvement both or 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-      L.push v # L.pack # L.some #-      L.push k # L.push (labelToMText fieldName) # L.pair #-      L.pack @(UStoreSubmapKey _) #-      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 mapper =-  get >>= \st -> do-    mapped <- mapM (\a -> (a, ) <$> runMaybeT (mapper a)) st-    let-      (passed, failed) =-        bimap (map (Unsafe.fromJust . snd)) (map fst) $-        L.partition @(a, Maybe b) (isJust . snd) $-        mapped-    put failed-    return passed---- Examples-------------------------------------------------------------------------------data MyStoreTemplate = MyStoreTemplate-  { ints :: Integer |~> ()-  , flag :: UStoreField Bool-  }-  deriving stock (Generic)--data MyStoreTemplateBig = MyStoreTemplateBig-  { templ :: MyStoreTemplate-  , bytes :: ByteString |~> ByteString-  }-  deriving stock (Generic)--_storeSample :: UStore MyStoreTemplate-_storeSample = mkUStore-  MyStoreTemplate-  { ints = UStoreSubMap $ one (1, ())-  , flag = UStoreField False-  }--_storeSampleBig :: UStore MyStoreTemplateBig-_storeSampleBig = mkUStore $-  MyStoreTemplateBig-    MyStoreTemplate-      { ints = UStoreSubMap $ one (1, ())-      , flag = UStoreField False-      }-    (UStoreSubMap $ one ("a", "b"))

@@ -1,28 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}--module Lorentz.UStore.Instances () where--import Lorentz.StoreClass-import Lorentz.UStore.Instr-import Lorentz.UStore.Types--instance HasUField fname ftype templ =>-         StoreHasField (UStore templ) fname ftype where-  storeFieldOps = StoreFieldOps-    { sopToField = ustoreToField-    , sopSetField = ustoreSetField-    }--instance HasUStore mname key value templ =>-         StoreHasSubmap (UStore templ) mname key value where-  storeSubmapOps = StoreSubmapOps-    { sopMem = ustoreMem-    , sopGet = ustoreGet-    , sopUpdate = ustoreUpdate-    , sopDelete = Just ustoreDelete-    , sopInsert = Just ustoreInsert-    }

@@ -1,355 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Instructions to work with 'UStore'.-module Lorentz.UStore.Instr-  ( unsafeEmptyUStore-  , ustoreMem-  , ustoreGet-  , ustoreUpdate-  , ustoreInsert-  , ustoreInsertNew-  , ustoreDelete--  , ustoreToField-  , ustoreGetField-  , ustoreSetField-  , ustoreRemoveFieldUnsafe--    -- ** Instruction constraints-  , HasUStore-  , HasUField-  , HasUStoreForAllIn--    -- ** Internals-  , packSubMapUKey-  ) where--import qualified Data.Kind as Kind-import GHC.Generics ((:*:), (:+:))-import qualified GHC.Generics as G-import GHC.TypeLits (KnownSymbol, Symbol)-import Type.Reflection ((:~:)(Refl))--import Lorentz.Base-import Lorentz.Coercions (coerceWrap)-import Lorentz.Errors-import Lorentz.Instr as L-import Lorentz.Macro-import Lorentz.Constraints-import Lorentz.UStore.Types-import Lorentz.UStore.Common-import Michelson.Text-import Michelson.Typed.Haskell.Value-import Util.Label (Label)---- Helpers-------------------------------------------------------------------------------type KeyAccessC store name =-  ( NiceFullPackedValue (GetUStoreKey store name)-  , KnownSymbol name-  )--type ValueAccessC store name =-  ( NiceFullPackedValue (GetUStoreValue store name)-  , KnownSymbol name-  )--type FieldAccessC store name =-  ( NiceFullPackedValue (GetUStoreField store name)-  , KnownUStoreMarker (GetUStoreFieldMarker store name)-  , KnownSymbol name-  )--packSubMapUKey-  :: forall (field :: Symbol) k s.-     (KnownSymbol field, NicePackedValue k)-  => (k : s) :-> (ByteString : s)-packSubMapUKey = push submapName # pair # pack @(UStoreSubmapKey _)-  where-    submapName = fieldNameToMText @field--unpackUValueUnsafe-  :: forall (field :: Symbol) val s.-     (KnownSymbol field, NiceUnpackedValue val)-  => (ByteString : s) :-> (val : s)-unpackUValueUnsafe = unpack @val # ifSome nop (failUsing failErr)-  where-    failErr = mconcat-      [ [mt|UStore: failed to unpack |]-      , fieldNameToMText @field-      ]---- Main instructions--------------------------------------------------------------------------------- | Put an empty 'UStore' onto the stack. This function is generally unsafe:--- if store template contains a 'UStoreField', the resulting 'UStore' is not--- immediately usable.--- If you are sure that 'UStore' contains only submaps, feel free to just use--- the result of this function. Otherwise you must set all fields.-unsafeEmptyUStore :: forall store s. s :-> UStore store ': s-unsafeEmptyUStore = emptyBigMap # coerceWrap--ustoreMem-  :: forall store name s.-     (KeyAccessC store name)-  => Label name-  -> GetUStoreKey store name : UStore store : s :-> Bool : s-ustoreMem _ = packSubMapUKey @name # mem--ustoreGet-  :: forall store name s.-     (KeyAccessC store name, ValueAccessC store name)-  => Label name-  -> GetUStoreKey store name : UStore store : s-       :-> Maybe (GetUStoreValue store name) : s-ustoreGet _ =-  packSubMapUKey @name #-  L.get #-  lmap (unpackUValueUnsafe @name @(GetUStoreValue store name))--ustoreUpdate-  :: forall store name s.-     (KeyAccessC store name, ValueAccessC store name)-  => Label name-  -> GetUStoreKey store name-      : Maybe (GetUStoreValue store name)-      : UStore store-      : s-  :-> UStore store : s-ustoreUpdate _ =-  packSubMapUKey @name #-  dip (lmap pack) #-  update--ustoreInsert-  :: forall store name s.-     (KeyAccessC store name, ValueAccessC store name)-  => Label name-  -> GetUStoreKey store name-      : GetUStoreValue store name-      : UStore store-      : s-  :-> UStore store : s-ustoreInsert _ =-  packSubMapUKey @name #-  dip (pack # L.some) #-  update---- | Insert a key-value pair, but fail if it will overwrite some existing entry.-ustoreInsertNew-  :: forall store name s.-     (KeyAccessC store name, ValueAccessC store name)-  => Label name-  -> (forall s0 any. GetUStoreKey store name : s0 :-> any)-  -> GetUStoreKey store name-      : GetUStoreValue store name-      : UStore store-      : s-  :-> UStore store : s-ustoreInsertNew label doFail =-  duupX @3 # duupX @2 # ustoreMem label #-  if_ doFail (ustoreInsert label)--ustoreDelete-  :: forall store name s.-     (KeyAccessC store name)-  => Label name-  -> GetUStoreKey store name : UStore store : s-     :-> UStore store : s-ustoreDelete _ =-  packSubMapUKey @name #-  dip none #-  update---- | Like 'toField', but for 'UStore'.------ This may fail only if 'UStore' was made up incorrectly during contract--- initialization.-ustoreToField-  :: forall store name s.-     (FieldAccessC store name)-  => Label name-  -> UStore store : s-     :-> GetUStoreField store name : s-ustoreToField l =-  push (mkFieldUKey @store l) #-  L.get #-  ensureFieldIsPresent #-  unpackUValueUnsafe @name @(GetUStoreField store name)-  where-    ensureFieldIsPresent =-      ifSome nop $ failUsing $ mconcat-        [ [mt|UStore: no field |]-        , fieldNameToMText @name-        ]---- | Like 'getField', but for 'UStore'.------ This may fail only if 'UStore' was made up incorrectly during contract--- initialization.-ustoreGetField-  :: forall store name s.-     (FieldAccessC store name)-  => Label name-  -> UStore store : s-     :-> GetUStoreField store name : UStore store : s-ustoreGetField label = dup # ustoreToField label---- | Like 'setField', but for 'UStore'.-ustoreSetField-  :: forall store name s.-     (FieldAccessC store name)-  => Label name-  -> GetUStoreField store name : UStore store : s-     :-> UStore store : s-ustoreSetField l =-  pack # L.some #-  push (mkFieldUKey @store l) #-  L.update---- | Remove a field from 'UStore', for internal purposes only.-ustoreRemoveFieldUnsafe-  :: forall store name s.-     (FieldAccessC store name)-  => Label name-  -> UStore store : s-     :-> UStore store : s-ustoreRemoveFieldUnsafe l =-  L.none #-  push (mkFieldUKey @store l) #-  L.update---- | This constraint can be used if a function needs to work with--- /big/ store, but needs to know only about some submap(s) of it.------ It can use all UStore operations for a particular name, key and--- value without knowing whole template.-type HasUStore name key value store =-   ( KeyAccessC store name, ValueAccessC store name-   , GetUStoreKey store name ~ key-   , GetUStoreValue store name ~ value-   )---- | This constraint can be used if a function needs to work with--- /big/ store, but needs to know only about some field of it.-type HasUField name ty store =-   ( FieldAccessC store name-   , GetUStoreField store name ~ ty-   )---- | Write down all sensisble constraints which given @store@ satisfies--- and apply them to @constrained@.------ This store should have '|~>' and 'UStoreField' fields in its immediate fields,--- no deep inspection is performed.-type HasUStoreForAllIn store constrained =-  (Generic store, GHasStoreForAllIn constrained (G.Rep store))--type family GHasStoreForAllIn (store :: Kind.Type) (x :: Kind.Type -> Kind.Type)-            :: Constraint where-  GHasStoreForAllIn store (G.D1 _ x) = GHasStoreForAllIn store x-  GHasStoreForAllIn store (x :+: y) =-    (GHasStoreForAllIn store x, GHasStoreForAllIn store y)-  GHasStoreForAllIn store (x :*: y) =-    (GHasStoreForAllIn store x, GHasStoreForAllIn store y)-  GHasStoreForAllIn store (G.C1 _ x) = GHasStoreForAllIn store x-  GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _)-                            (G.Rec0 (key |~> value))) =-    HasUStore name key value store-  GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _)-                            (G.Rec0 (UStoreFieldExt _ value))) =-    HasUField name value store-  GHasStoreForAllIn _ G.V1 = ()-  GHasStoreForAllIn _ G.U1 = ()--------------------------------------------------------------------------------- Examples-------------------------------------------------------------------------------data MyStoreTemplate = MyStoreTemplate-  { ints :: Integer |~> ()-  , bytes :: ByteString |~> ByteString-  , flag :: UStoreField Bool-  , entrypoint :: UStoreFieldExt Marker1 Integer-  }-  deriving stock (Generic)--type MyStore = UStore MyStoreTemplate--data Marker1 :: UStoreMarkerType-  deriving anyclass KnownUStoreMarker--_sample1 :: Integer : MyStore : s :-> MyStore : s-_sample1 = ustoreDelete @MyStoreTemplate #ints--_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s-_sample2 = ustoreInsert @MyStoreTemplate #bytes--_sample3 :: MyStore : s :-> Bool : s-_sample3 = ustoreToField @MyStoreTemplate #flag--_sample3'5 :: MyStore : s :-> Integer : s-_sample3'5 = ustoreToField @MyStoreTemplate #entrypoint--data MyStoreTemplate2 = MyStoreTemplate2-  { bools :: Bool |~> Bool-  , ints2 :: Integer |~> Integer-  , ints3 :: Integer |~> Bool-  }-  deriving stock (Generic)--newtype MyNatural = MyNatural Natural-  deriving newtype (IsoValue)--data MyStoreTemplate3 = MyStoreTemplate3 { store3 :: Natural |~> MyNatural }-  deriving stock Generic--data MyStoreTemplateBig = MyStoreTemplateBig-  MyStoreTemplate-  MyStoreTemplate2-  MyStoreTemplate3-  deriving stock Generic--_MyStoreTemplateBigTextsStore ::-  GetUStore "bytes" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString-_MyStoreTemplateBigTextsStore = Refl--_MyStoreTemplateBigBoolsStore ::-  GetUStore "bools" MyStoreTemplateBig :~: 'MapSignature Bool Bool-_MyStoreTemplateBigBoolsStore = Refl--_MyStoreTemplateBigMyStoreTemplate3 ::-  GetUStore "store3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural-_MyStoreTemplateBigMyStoreTemplate3 = Refl--type MyStoreBig = UStore MyStoreTemplateBig--_sample4 :: Integer : MyStoreBig : s :-> MyStoreBig : s-_sample4 = ustoreDelete #ints2--_sample5 :: ByteString : MyStoreBig : s :-> Bool : s-_sample5 = ustoreMem #bytes--_sample6 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s-_sample6 = ustoreInsert #store3---- | When you want to express a constraint like--- "given big store contains all elements present in given small concrete store",--- you can use 'HasUStoreForAllIn'.------ Here @store@ is a big store, and we expect it to contain 'MyStoreTemplate'--- entirely.-_sample7-  :: HasUStoreForAllIn MyStoreTemplate store-  => UStore store : s :-> Bool : Maybe ByteString : s-_sample7 = ustoreGetField #flag # dip (push "x" # ustoreGet #bytes)---- | '_sample7' with @store@ instantiated to 'MyStoreTemplateBig'.-_sample7' :: UStore MyStoreTemplateBig : s :-> Bool : Maybe ByteString : s-_sample7' = _sample7

@@ -1,113 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Composability helper for 'UStore'.-module Lorentz.UStore.Lift-  ( liftUStore-  , unliftUStore--    -- * Internals-  , UStoreFieldsAreUnique-  ) where--import qualified Data.Kind as Kind-import GHC.Generics (type (:+:), type (:*:))-import qualified GHC.Generics as G-import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)--import Lorentz.Base-import Lorentz.Coercions-import Lorentz.Instr-import Lorentz.UStore.Types-import Michelson.Typed.Haskell-import Util.Label (Label)-import Util.Type---- | Get all fields names accessible in given 'UStore' template.-type UStoreFields (template :: Kind.Type) = GUStoreFields (G.Rep template)--type family GUStoreFields (x :: Kind.Type -> Kind.Type) :: [Symbol] where-  -- We are not oblidged to fail in case of bad template - this will be handled-  -- in other operations with 'UStore' anyway.-  GUStoreFields (G.D1 _ x) = GUStoreFields x-  GUStoreFields (_ :+: _) = '[]-  GUStoreFields G.V1 = '[]-  GUStoreFields (G.C1 _ x) = GUStoreFields x-  GUStoreFields (x :*: y) = GUStoreFields x ++ GUStoreFields y-  GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (_ |~> _))) =-    '[fieldName]-  GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt _ _))) =-    '[fieldName]-  GUStoreFields (G.S1 _ (G.Rec0 a)) =-    UStoreFields a--type UStoreFieldsAreUnique template = AllUnique (UStoreFields template)--type family RequireAllUniqueFields (template :: Kind.Type) :: Constraint where-  RequireAllUniqueFields template =-    If (UStoreFieldsAreUnique template)-       (() :: Constraint)-       (TypeError ('Text "Some field in template is duplicated"))-      -- TODO: if this ever fires for you and it's not clear which exact field-      -- is duplicated, please create a ticket to implement the corresponding-      -- logic.---- | Lift an 'UStore' to another 'UStore' which contains all the entries--- of the former under given field.------ This function is not intended for use in migrations, only in normal--- entry points.------ Note that this function ensures that template of resulting store--- does not contain inner nested templates with duplicated fields,--- otherwise 'UStore' invariants could get broken.-liftUStore-  :: (Generic template, RequireAllUniqueFields template)-  => Label name-  -> UStore (GetFieldType template name) : s :-> UStore template : s-liftUStore _ = forcedCoerce_---- | Unlift an 'UStore' to a smaller 'UStore' which is part of the former.------ This function is not intended for use in migrations, only in normal--- entry points.------ Surprisingly, despite smaller 'UStore' may have extra entries,--- this function is safe when used in contract code.--- Truly, all getters and setters are still safe to use.--- Also, there is no way for the resulting small @UStore@ to leak outside--- of the contract since the only place where 'big_map' can appear--- is contract storage, so this small @UStore@ can be either dropped--- or lifted back via 'liftUStore' to appear as part of the new contract's state.------ When this function is run as part of standalone instructions sequence,--- not as part of contract code (e.g. in tests), you may get an @UStore@--- with entries not inherent to it.-unliftUStore-  :: (Generic template)-  => Label name-  -> UStore template : s :-> UStore (GetFieldType template name) : s-unliftUStore _ = forcedCoerce_---- Examples-------------------------------------------------------------------------------data MyStoreTemplate = MyStoreTemplate-  { ints :: Integer |~> Integer-  } deriving stock Generic--data MyStoreTemplateBig = MyStoreTemplateBig-  { bool :: UStoreField Bool-  , substore :: MyStoreTemplate-  } deriving stock Generic---- | This example demostrates a way to run an instruction, operating on small--- 'UStore', so that it works on a larger 'UStore'.-_sampleWithMyStore-  :: ('[param, UStore MyStoreTemplate] :-> '[UStore MyStoreTemplate])-  -> ('[param, UStore MyStoreTemplateBig] :-> '[UStore MyStoreTemplateBig])-_sampleWithMyStore instr =-  dip (unliftUStore #substore) # instr # liftUStore #substore

@@ -1,93 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{- | Type-safe migrations of UStore.--This implements imperative approach to migration when we make user-write a code of migration and track whether all new fields were indeed added-and all unnecessary fields were removed.--You can find migration examples in tests.--== How to write your simple migration--1. Start with migration template:--    @-    migration :: 'UStoreMigration' V1.Storage V2.Storage-    migration = 'mkUStoreMigration' $ do-      -- migration code to be put here-      'migrationFinish'-    @--    You will be prompted with a list of fields which should be added or removed.--2. Add/remove necessary fields using 'migrateAddField', 'migrateExtractField'-and other instructions.-They allow you to operate with 'MUStore' — it is similar to 'UStore'-but used within 'mkUStoreMigration' to track migration progress.--3. Use 'migrationToScript' or 'migrationToTestScript' to turn 'UStoreMigration'-into something useful.--Note that here you will get a solid 'MigrationScript', thus migration has-to fit into single Tezos transaction. If that's an issue, see the next section.--== How to write batched migration--1. Insert migration template.--    It looks like:--    @-    migration :: 'UStoreMigration' V1.Storage V2.Storage-    migration = 'mkUStoreBatchedMigration' $-      -- place for migration blocks-      'migrationFinish'-    @--2. Fill migration code with blocks like--    @-    'mkUStoreBatchedMigration' $-      'muBlock' '$:' do-        -- code for block 1-      '<-->'-      'muBlock' '$:' do-        -- code for block 2-      '<-->'-      'migrationFinish'-    @--    Migration blocks have to be the smallest actions which can safely be mixed-    and splitted across migration stages.--3. Compile migration with 'compileBatchedMigration'.--    Here you have to supply batching implementation. Alternatives include--    * 'mbNoBatching';-    * 'mbBatchesAsIs';-    * Functions from 'Lorentz.UStore.Migration.Batching' module.--4. Get the required information about migration.--    * 'migrationToScripts' picks the migration scripts, each has to be put-      in a separate Tezos transaction.--    * 'buildMigrationPlan' - dump description of each migration stage.--== Manual migrations--If for some reasons you need to define migration manually, you can use-functions from @Manual migrations@ section of "Lorentz.UStore.Migration.Base".---}-module Lorentz.UStore.Migration-  ( module Exports-  ) where--import Lorentz.UStore.Migration.Base as Exports-import Lorentz.UStore.Migration.Batching as Exports-import Lorentz.UStore.Migration.Blocks as Exports

@@ -1,536 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# OPTIONS_GHC -Wno-orphans #-}--{- | Basic migration primitives.--All primitives in one scheme:---                         MigrationBlocks-                   (batched migrations writing)-                    /|          ||-           muBlock //           || mkUStoreBatchedMigration-                  //            ||-                 //             ||-             MUStore            ||         UStore template value-    (simple migration writing)  ||       (storage initialization)-                    \\          ||         //-                     \\         ||        //-    mkUStoreMigration \\        ||       // fillUStore-                       \|       \/      |/-                         UStoreMigration-                        (whole migration)-                              ||    \\-                              ||     \\-            migrationToScript ||      \\ compileMigration-                              ||       \\                    MigrationBatching-                              ||        \\                (way to slice migration)-                              ||         \\                    //-                              ||          \\                  //-                              ||           \|                |/-                              ||         UStoreMigrationCompiled-                              ||           (sliced migration)-                              ||          //                 \\-                              ||    migrationToScripts        \\ buildMigrationPlan-                              ||        //                     \\ migrationStagesNum-                              ||       //                       \\ ...-                              \/      |/                         \|-                        MigrationScript                    Information about migration-                    (part of migration which            (migration plan, stages number...)-                  fits into Tezos transaction)---}-module Lorentz.UStore.Migration.Base-  ( -- * 'UStore' utilities-    SomeUTemplate-  , UStore_--    -- * Basic migration primitives-  , MigrationScript (..)-  , maNameL-  , maScriptL-  , maActionsDescL-  , MigrationScriptFrom-  , MigrationScriptTo-  , MigrationScript_-  , MigrationAtom (..)-  , UStoreMigration (..)-  , MigrationBlocks (..)-  , MUStore (..)-  , migrationToLambda-  , mapMigrationCode--    -- ** Simple migrations-  , mkUStoreMigration-  , migrationToScript-  , migrationToScriptI--    -- ** Batched migrations-  , MigrationBatching (..)-  , mbBatchesAsIs-  , mbNoBatching-  , compileMigration-  , UStoreMigrationCompiled (..)-  , mkUStoreBatchedMigration-  , migrationToScripts-  , migrationToScriptsList-  , migrationToInfo-  , migrationStagesNum-  , buildMigrationPlan--    -- * Manual migrations-  , manualWithOldUStore-  , manualWithNewUStore-  , manualConcatMigrationScripts-  , manualMapMigrationScript--    -- * Extras-  , DMigrationActionType (..)-  , DMigrationActionDesc (..)-  , attachMigrationActionName--    -- * Internals-  , formMigrationAtom-  ) where--import Control.Lens (iso, traversed)-import qualified Data.Foldable as Foldable-import qualified Data.Kind as Kind-import Data.Singletons (SingI(..), demote)-import qualified Data.Typeable as Typeable-import Fmt (Buildable(..), Builder, fmt)--import Lorentz.Annotation (HasAnnotation)-import Lorentz.Base-import Lorentz.Coercions-import Lorentz.Doc-import Lorentz.UStore.Doc-import Lorentz.Instr (nop)-import Lorentz.Run-import Lorentz.UStore.Types-import Lorentz.Value-import Michelson.Typed.Haskell.Doc (applyWithinParens)-import Michelson.Typed (ExtInstr(..), Instr(..), T(..))-import Michelson.Typed.Util-import Util.Label (labelToText)-import Util.Lens-import Util.Markdown-import Util.TypeLits--import Lorentz.UStore.Migration.Diff--------------------------------------------------------------------------------- UStore utilities--------------------------------------------------------------------------------- | Dummy template for 'UStore', use this when you want to forget exact template--- and make type of store homomorphic.-data SomeUTemplate---- | UStore with hidden template.-type UStore_ = UStore SomeUTemplate---- | We allow casting between 'UStore_' and 'UStore' freely.-instance SameUStoreTemplate template1 template2 =>-         UStore template1 `CanCastTo` UStore template2--type family SameUStoreTemplate (template1 :: Kind.Type) (template2 :: Kind.Type)-              :: Constraint where-  SameUStoreTemplate t t = ()  -- case for undeducible but equal types-  SameUStoreTemplate SomeUTemplate _ = ()-  SameUStoreTemplate _ SomeUTemplate = ()-  SameUStoreTemplate t1 t2 = (t1 ~ t2)--instance UStoreTemplateHasDoc SomeUTemplate where-  ustoreTemplateDocName = "Some"-  ustoreTemplateDocDescription =-    "This is a dummy template, usually designates that any format can be used \-    \here."-  ustoreTemplateDocContents = mdItalic "unspecified"-  ustoreTemplateDocDependencies = []--------------------------------------------------------------------------------- Migration primitives--------------------------------------------------------------------------------- | Code of migration for 'UStore'.------ Invariant: preferably should fit into op size / gas limits (quite obvious).--- Often this stands for exactly one stage of migration (one Tezos transaction).-newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) =-  MigrationScript-  { unMigrationScript :: Lambda UStore_ UStore_-  } deriving stock (Show, Generic)-    deriving anyclass (IsoValue, HasAnnotation, Wrappable)--instance (Each [Typeable, UStoreTemplateHasDoc] [oldStore, newStore]) =>-         TypeHasDoc (MigrationScript oldStore newStore) where-  typeDocMdDescription =-    "A code which updates storage in order to make it compliant with the \-    \new version of the contract.\n\-    \It is common to have a group of migration scripts because each of it \-    \is to be used in Tezos transaction and thus should fit into gas and \-    \operation size limits.\-    \"-  typeDocMdReference tp wp =-    applyWithinParens wp $ mconcat-      [ mdLocalRef (mdTicked "MigrationScript") (docItemRef (DType tp))-      , " "-      , dUStoreTemplateRef (DUStoreTemplate (Proxy @oldStore))-      , " "-      , dUStoreTemplateRef (DUStoreTemplate (Proxy @newStore))-      ]-  typeDocDependencies p =-    [ dTypeDep @(UStore oldStore)-    , dTypeDep @(UStore newStore)-    ] <> genericTypeDocDependencies p-  typeDocHaskellRep = homomorphicTypeDocHaskellRep-  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep--instance Lambda (UStore ot1) (UStore nt1) `CanCastTo` Lambda (UStore ot2) (UStore nt2) =>-         MigrationScript ot1 nt1 `CanCastTo` MigrationScript ot2 nt2---- | Corner case of 'MigrationScript' with some type argument unknown.------ You can turn this into 'MigrationScript' using 'checkedCoerce'.-type MigrationScriptFrom oldStore = MigrationScript oldStore SomeUTemplate-type MigrationScriptTo newStore = MigrationScript SomeUTemplate newStore-type MigrationScript_ = MigrationScript SomeUTemplate SomeUTemplate---- | Manually perform a piece of migration.-manualWithUStore-  :: forall ustore template oldStore newStore.-      (ustore ~ UStore template)-  => ('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore-manualWithUStore action = MigrationScript $ checkedCoercing_ action--manualWithOldUStore-  :: ('[UStore oldStore] :-> '[UStore oldStore]) -> MigrationScript oldStore newStore-manualWithOldUStore = manualWithUStore--manualWithNewUStore-  :: ('[UStore newStore] :-> '[UStore newStore]) -> MigrationScript oldStore newStore-manualWithNewUStore = manualWithUStore---- | Modify code under given 'MigrationScript'.------ Avoid using this function when constructing a batched migration because--- batching logic should know size of the code precisely, consider mapping--- 'UStoreMigration' instead.-manualMapMigrationScript-  :: (('[UStore_] :-> '[UStore_]) -> ('[UStore_] :-> '[UStore_]))-  -> MigrationScript oldStore newStore-  -> MigrationScript oldStore newStore-manualMapMigrationScript f = MigrationScript . f . unMigrationScript---- | Merge several migration scripts. Used in manual migrations.------ This function is generally unsafe because resulting migration script can fail--- to fit into operation size limit.-manualConcatMigrationScripts :: [MigrationScript os ns] -> MigrationScript os ns-manualConcatMigrationScripts =-  MigrationScript . foldl' (#) nop . fmap unMigrationScript---- | An action on storage entry.-data DMigrationActionType-  = DAddAction Text-    -- ^ Some sort of addition: "init", "set", "overwrite", e.t.c.-  | DDelAction-    -- ^ Removal.-  deriving stock Show--instance Buildable DMigrationActionType where-  build = \case-    DAddAction a -> build a-    DDelAction -> "remove"---- | Describes single migration action.------ In most cases it is possible to derive reasonable description for migration--- atom automatically, this datatype exactly carries this information.-data DMigrationActionDesc = DMigrationActionDesc-  { manAction :: DMigrationActionType-    -- ^ Action on field, e.g. "set", "remove", "overwrite".-  , manField :: Text-    -- ^ Name of affected field of 'UStore'.-  , manFieldType :: T-    -- ^ Type of affected field of 'UStore' in new storage version.-  } deriving stock Show---- Sad that we need to write this useless documentation instance, probably it's--- worth generalizing @doc_group@ and @doc_item@ instructions so that they--- could serve as multi-purpose markers.-instance DocItem DMigrationActionDesc where-  docItemPos = 105010-  docItemSectionName = Nothing-  docItemToMarkdown _ _ = "Migration action"---- | Add description of action, it will be used in rendering migration plan and--- some batching implementations.-attachMigrationActionName-  :: SingI (ToT fieldTy)-  => DMigrationActionType-  -> Label fieldName-  -> Proxy fieldTy-  -> s :-> s-attachMigrationActionName action label (_ :: Proxy fieldTy) =-  doc $ DMigrationActionDesc-  { manAction = action-  , manField = labelToText label-  , manFieldType = demote @(ToT fieldTy)-  }---- | Minimal possible piece of migration script.------ Different atoms can be arbitrarily reordered and separated across migration--- stages, but each single atom is treated as a whole.------ Splitting migration into atoms is responsibility of migration writer.-data MigrationAtom = MigrationAtom-  { maName :: Text-  , maScript :: MigrationScript_-  , maActionsDesc :: [DMigrationActionDesc]-  } deriving stock (Show)--makeLensesWith postfixLFields ''MigrationAtom---- | Keeps information about migration between 'UStore's with two given--- templates.-data UStoreMigration (oldTempl :: Kind.Type) (newTempl :: Kind.Type) where-  UStoreMigration-    :: [MigrationAtom]-    -> UStoreMigration oldTempl newTempl---- | Turn 'Migration' into a whole piece of code for transforming storage.------ This is not want you'd want to use for contract deployment because of--- gas and operation size limits that Tezos applies to transactions.-migrationToLambda-  :: UStoreMigration oldTemplate newTemplate-  -> Lambda (UStore oldTemplate) (UStore newTemplate)-migrationToLambda (UStoreMigration atoms) =-  checkedCoerce_ # foldMap (unMigrationScript . maScript) atoms # checkedCoerce_--instance MapLorentzInstr (UStoreMigration os ns) where-  mapLorentzInstr f (UStoreMigration atoms) =-    UStoreMigration $-      atoms & traversed . maScriptL . wrapped %~ f-    where-      wrapped = iso unMigrationScript MigrationScript---- | Modify all code in migration.-mapMigrationCode-  :: (forall i o. (i :-> o) -> (i :-> o))-  -> UStoreMigration os ns-  -> UStoreMigration os ns-mapMigrationCode = mapLorentzInstr-{-# DEPRECATED mapMigrationCode "Use 'hoistLorentzInstr' instead" #-}---- | A bunch of migration atoms produced by migration writer.-newtype MigrationBlocks (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)-                        (preRemDiff :: [DiffItem]) (preTouched :: [Symbol])-                        (postRemDiff :: [DiffItem]) (postTouched :: [Symbol]) =-  MigrationBlocks [MigrationAtom]--{- | Wrapper over 'UStore' which is currently being migrated.--In type-level arguments it keeps--* Old and new 'UStore' templates - mostly for convenience of the implementation.--* Remaining diff which yet should be covered. Here we track migration progress.-Once remaining diff is empty, migration is finished.--* Names of fields which have already been touched by migration.-Required to make getters safe.--}-newtype MUStore (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)-                (remDiff :: [DiffItem]) (touched :: [Symbol]) =-  MUStoreUnsafe (UStore oldTemplate)-  deriving stock Generic-  deriving anyclass IsoValue---- | Create migration atom from code.------ This is an internal function, should not be used for writing migrations.-formMigrationAtom-  :: Maybe Text-  -> Lambda UStore_ UStore_-  -> MigrationAtom-formMigrationAtom mname code =-  MigrationAtom-  { maName = name-  , maScript = MigrationScript (checkedCoercing_ code)-  , maActionsDesc = actionsDescs-  }-  where-    name = case mname of-      Just n -> n-      Nothing ->-        fmt . mconcat $ intersperse ", "-          [ build action <> " \"" <> build field <> "\""-          | DMigrationActionDesc action field _type <- actionsDescs-          ]--    actionsDescs =-      let instr = compileLorentz code-          (_, actions) = dfsInstr def (\i -> (i, pickActionDescs i)) instr-      in actions--    pickActionDescs :: Instr i o -> [DMigrationActionDesc]-    pickActionDescs i = case i of-      Ext (DOC_ITEM (SomeDocItem di)) ->-        [ d-        | Just d@DMigrationActionDesc{} <- pure $ Typeable.cast di-        ]-      _ -> []---- | Way of distributing migration atoms among batches.------ This also participates in describing migration plan and should contain--- information which would clarify to a user why migration is splitted--- such a way. Objects of type @batchInfo@ stand for information corresponding to--- a batch and may include e.g. names of taken actions and gas consumption.------ Type argument @structure@ stands for container where batches will be put to--- and is usually a list ('[]').------ When writing an instance of this datatype, you should tend to produce--- as few batches as possible because Tezos transaction execution overhead--- is quite high; though these batches should still preferably fit into gas limit.------ Note that we never fail here because reaching perfect consistency with Tezos--- gas model is beyond dreams for now, even if our model predicts that some--- migration atom cannot be fit into gas limit, Tezos node can think differently--- and accept the migration.--- If your batching function can make predictions about fitting into gas limit,--- consider including this information in @batchInfo@ type.------ See batching implementations in "Lorentz.UStore.Migration.Batching" module.-data MigrationBatching (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =-  MigrationBatching ([MigrationAtom] -> structure (batchInfo, MigrationScript_))---- | Put each migration atom to a separate batch.------ In most cases this is not what you want, but may be useful if e.g. you write--- your migration manually.-mbBatchesAsIs :: MigrationBatching [] Text-mbBatchesAsIs = MigrationBatching $-  map (maName &&& maScript)---- | Put the whole migration into one batch.-mbNoBatching :: MigrationBatching Identity Text-mbNoBatching = MigrationBatching $-  Identity . \atoms ->-    ( mconcat . intersperse ", " $ maName <$> atoms-    , manualConcatMigrationScripts (maScript <$> atoms)-    )---- | Version of 'mkUStoreMigration' which allows splitting migration in batches.------ Here you supply a sequence of migration blocks which then are automatically--- distributed among migration stages.-mkUStoreBatchedMigration-  :: MigrationBlocks oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1-  -> UStoreMigration oldTempl newTempl-mkUStoreBatchedMigration (MigrationBlocks blocks) = UStoreMigration blocks---- | Safe way to create migration scripts for 'UStore'.------ You have to supply a code which would transform 'MUStore',--- coverring required diff step-by-step.--- All basic instructions work, also use @migrate*@ functions--- from this module to operate with 'MUStore'.------ This method produces a whole migration, it cannot be splitted in batches.--- In case if your migration is too big to be applied within a single--- transaction, use 'mkUStoreBatchedMigration'.-mkUStoreMigration-  :: Lambda-       (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])-       (MUStore oldTempl newTempl '[] _1)-  -> UStoreMigration oldTempl newTempl-mkUStoreMigration code =-  mkUStoreBatchedMigration $-    MigrationBlocks . one . formMigrationAtom (Just "Migration") $-      forcedCoerce_ # code # forcedCoerce_---- | Migration script splitted in batches.------ This is an intermediate form of migration content and needed because--- compiling 'UStoreMigration' is a potentially heavyweight operation,--- and after compilation is performed you may need to get various information like--- number of migration steps, migration script, migration plan and other.-newtype UStoreMigrationCompiled-          (oldStore :: Kind.Type) (newStore :: Kind.Type)-          (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =-  UStoreMigrationCompiled-  { compiledMigrationContent-     :: structure (batchInfo, MigrationScript oldStore newStore)-  }---- | Compile migration for use in production.-compileMigration-  :: (Functor t)-  => MigrationBatching t batchInfo-  -> UStoreMigration ot nt-  -> UStoreMigrationCompiled ot nt t batchInfo-compileMigration (MigrationBatching toBatches) (UStoreMigration blks) =-  UStoreMigrationCompiled (second forcedCoerce <$> toBatches blks)---- | Get migration scripts, each to be executed in separate Tezos transaction.-migrationToScripts-  :: Traversable t-  => UStoreMigrationCompiled os ns t batchInfo-  -> t (MigrationScript os ns)-migrationToScripts = map snd . compiledMigrationContent---- | Get migration scripts as list.-migrationToScriptsList-  :: Traversable t-  => UStoreMigrationCompiled os ns t batchInfo-  -> [MigrationScript os ns]-migrationToScriptsList = Foldable.toList . migrationToScripts---- | Get migration script in case of simple (non-batched) migration.-migrationToScriptI-  :: UStoreMigration os ns-  -> Identity (MigrationScript os ns)-migrationToScriptI =-  migrationToScripts . compileMigration mbNoBatching---- | Get migration script in case of simple (non-batched) migration.-migrationToScript-  :: UStoreMigration os ns-  -> MigrationScript os ns-migrationToScript =-  runIdentity . migrationToScriptI---- | Get information about each batch.-migrationToInfo-  :: Traversable t-  => UStoreMigrationCompiled ot nt t batchInfo-  -> t batchInfo-migrationToInfo = map fst . compiledMigrationContent---- | Number of stages in migration.-migrationStagesNum-  :: Traversable t-  => UStoreMigrationCompiled ot nt t batchInfo -> Int-migrationStagesNum = Foldable.length . migrationToScripts---- | Render migration plan.-buildMigrationPlan-  :: (Traversable t, Buildable batchInfo)-  => UStoreMigrationCompiled ot nt t batchInfo -> Builder-buildMigrationPlan content =-  let infos = Foldable.toList $ migrationToInfo content-  in mconcat-     [ "Migration stages:\n"-     , mconcat $ zip [1..] infos <&> \(i :: Int, info) ->-        build i <> ") " <> build info <> "\n"-     ]

@@ -1,117 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Different approaches to batching.------ For now we do not support perfect batching because operation size evaluation--- (as well as gas consumption evaluation) is not implemented yet.--- The only non-trivial batching implementation we provide is--- 'mbSeparateLambdas'.-module Lorentz.UStore.Migration.Batching-  ( -- * Separate-lambdas batching-    SlBatchType (..)-  , SlBatchInfo (..)-  , mbSeparateLambdas-  ) where--import qualified Data.List as L-import Fmt (Buildable(..))-import System.Console.Pretty (Color(..), color)--import Lorentz.UStore.Migration.Base-import Michelson.Typed--------------------------------------------------------------------------------- Separating lambdas--------------------------------------------------------------------------------- | Type of batch.-data SlBatchType-  = SlbtData-    -- ^ Addition of any type of data.-  | SlbtLambda-    -- ^ Addition of code.-  | SlbtCustom-    -- ^ Several joined actions of different types.-  | SlbtUnknown-    -- ^ No information to chooseType about batching.-    -- This means that the given action does not contain 'DMigrationActionDesc'.-  deriving stock (Show, Eq)--slbtIsData :: SlBatchType -> Bool-slbtIsData = \case { SlbtData -> True; _ -> False }--data SlBatchInfo = SlBatchInfo-  { slbiType :: SlBatchType-  , slbiActions :: [Text]-  }--instance Buildable SlBatchInfo where-  build (SlBatchInfo ty actions) = mconcat-    [ build @Text $ case ty of-        SlbtData -> color Blue "[data]"-        SlbtLambda -> color Green "[code]"-        SlbtCustom -> color Yellow "[custom]"-        SlbtUnknown -> color Red "[unknown]"-    , " "-    , case actions of-        [] -> "-"-        [a] -> build a-        as -> foldMap (\a -> "\n  * " <> build a) as-    ]---- | Puts all data updates in one batch, and all lambdas in separate batches,--- one per batch.------ The reason for such behaviour is that in production contracts amount of--- changed data (be it in contract initialization or contract upgrade) is small,--- while stored entrypoints are huge and addition of even one entrypoint often--- barely fits into gas limit.-mbSeparateLambdas :: MigrationBatching [] SlBatchInfo-mbSeparateLambdas = MigrationBatching $ \atoms ->-  let-    atomsWithType = atoms <&> \a -> (atomType a, a)-    (dataAtoms, otherAtoms) = L.partition (slbtIsData . fst) atomsWithType-    dataMigration =-      ( SlBatchInfo SlbtData (nubCounting $ maName . snd <$> dataAtoms)-      , manualConcatMigrationScripts (maScript . snd <$> dataAtoms)-      )-    otherMigrations =-      [ (SlBatchInfo ty [maName atom], maScript atom)-      | (ty, atom) <- otherAtoms-      ]-  in dataMigration : otherMigrations-  where-    atomType :: MigrationAtom -> SlBatchType-    atomType = chooseType . maActionsDesc--    chooseType :: [DMigrationActionDesc] -> SlBatchType-    chooseType = \case-      [] -> SlbtUnknown-      xs | all isLambda xs -> SlbtLambda-      xs | (not . any isAddLambda) xs -> SlbtData-         | otherwise -> SlbtCustom--    isLambda :: DMigrationActionDesc -> Bool-    isLambda = \case { TLambda{} -> True; _ -> False } . manFieldType--    isAddLambda :: DMigrationActionDesc -> Bool-    isAddLambda a = and-      [ isLambda a-      , case manAction a of { DAddAction _ -> True; _ -> False }-      ]---- | Similar to 'nub', counts number of invocations and attaches to text entry.------ >>> nubCounting ["a", "b", "a"]--- ["a (x2)", "b"]-nubCounting :: [Text] -> [Text]-nubCounting = \case-  [] -> []-  x : xs ->-    let ((length -> repetitions), others) = L.partition (== x) xs-        x' = if repetitions == 0-             then x-             else x <> " (x" <> show (repetitions + 1) <> ")"-    in x' : nubCounting others

@@ -1,290 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Elemental building blocks for migrations.-module Lorentz.UStore.Migration.Blocks-  ( -- * General-    mustoreToOld-  , MigrationFinishCheckPosition (..)--    -- * Elemental steps-  , migrateCoerceUnsafe-  , migrateGetField-  , migrateAddField-  , migrateRemoveField-  , migrateExtractField-  , migrateOverwriteField-  , migrateModifyField--    -- * Migration batches-  , muBlock-  , muBlockNamed-  , (<-->)-  , ($:)-  ) where--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.Label (Label)-import Util.Type-import Util.TypeLits---- | Helper for 'mustoreToOld' which ensures that given store hasn't been--- (partially) migrated yet.-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")-    )---- | Cast field or submap pretending that its value fits to the new type.------ Useful when type of field, e.g. lambda or set of lambdas, is polymorphic--- over storage type.-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_---- Migrating fields--------------------------------------------------------------------------------- | Get a field present in old version of 'UStore'.-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_---- | Add a field which was not present before.--- This covers one addition from the diff and any removals of field with given--- name.------ This function cannot overwrite existing field with the same name, if this--- is necessary use 'migrateOverwriteField' which would declare removal--- explicitly.-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_---- | Remove a field which should not be present in new version of storage.--- This covers one removal from the diff.------ In fact, this action could be performed automatically, but since--- removal is a destructive operation, being explicit about it seems--- like a good thing.-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_---- | Get and remove a field from old version of 'UStore'.------ You probably want to use this more often than plain 'migrateRemoveField'.-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)---- | Remove field and write new one in place of it.------ This is semantically equivalent to--- @dip (migrateRemoveField label) >> migrateAddField label@,--- but is cheaper.-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_---- | Modify field which should stay in new version of storage.--- This does not affect remaining diff.-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_---- Migrating virtual submaps (strict migration)-------------------------------------------------------------------------------{- For now we do not support this kind of migration.--"Strict" means that we want to modify maps right here rather than signal to-do modification of each entry on first access to it (which would be simpler-in some sense).--Implementing this is slightly less trivial than migrating individial fields.-1. One needs current value of UStore picked from the contract, because it's-not possible to iterate over big_map from within a contract in the current mainnet.-Even if it was, we can't assume that iteration of the whole submap would fit-into gas limit of single transaction, thus iteration should be performed-from outside of the contract by someone who knows the current storage.--2. We need to split migration in batches smartly. Too big batches would hit-operation size limit, while small ones would cause high overhead of-contract/storage deserialization.-Will be resolved in TM-330.--}--------------------------------------------------------------------------------- Blocks for batched migrations--------------------------------------------------------------------------------- | Define a migration atom.------ It will be named automatically according to the set of actions it performs--- (via 'DMigrationActionDesc's).--- This may be want you want for small sequences of actions, but for complex ones--- consider using 'muBlockNamed'.--- Names are used in rendering migration plan.-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_---- | Define a migration atom with given name.------ Name will be used when rendering migration plan.-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_---- | Composition of migration blocks.-(<-->)-  :: 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 <-->--{- | This is '$' operator with priority higher than '<-->'.--It allows you writing--@-mkUStoreBatchedMigration =-  muBlock $: do-    migrateAddField ...-  <-->-  muBlock $: do-    migrateRemoveField ...-@--Alternatively, @BlockArguments@ extension can be used.--}-($:) :: (a -> b) -> a -> b-($:) = ($)-infixr 7 $:--------------------------------------------------------------------------------- Common--------------------------------------------------------------------------------- | Get the old version of storage.------ This can be applied only in the beginning of migration.------ In fact this function is not very useful, all required operations should--- be available for 'MUStore', but leaving it here just in case.-mustoreToOld-  :: RequireBeInitial touched-  => MUStore oldTemplate newTemplate remDiff touched : s-  :-> UStore oldTemplate : s-mustoreToOld = forcedCoerce_--class MigrationFinishCheckPosition a where-  -- | Put this in the end of migration script to get a human-readable message-  -- about remaining diff which yet should be covered.-  -- Use of this function in migration is fully optional.-  ---  -- This function is not part of 'mkUStoreMigration' for the sake of-  -- proper error messages ordering, during development-  -- you probably want errors in migration script to be located earlier-  -- in code than errors about not fully covered diff (if you used-  -- to fix errors in the same order in which they appear).-  migrationFinish :: a---- | This version can be used in 'mkUStoreMigration'.-instance ( i ~ (MUStore oldTempl newTempl diff touched : s)-         , o ~ (MUStore oldTempl newTempl '[] touched : s)-         , RequireEmptyDiff diff-         ) =>-         MigrationFinishCheckPosition (i :-> o) where-  migrationFinish = forcedCoerce_---- | This version can be used in 'mkUStoreMultiMigration' as the last migration--- block.-instance (RequireEmptyDiff d1, t1 ~ t2) =>-         MigrationFinishCheckPosition (MigrationBlocks o n d1 t1 '[] t2) where-  migrationFinish = MigrationBlocks []

@@ -1,200 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Lorentz.UStore.Migration.Diff-  ( FieldInfo-  , DiffKind (..)-  , DiffItem-  , BuildDiff-  , ShowDiff-  , RequireEmptyDiff--  , LinearizeUStore-  , LinearizeUStoreF-  , AllUStoreFieldsF--  , DiffCoverage (..)-  , CoverDiff-  , CoverDiffMany-  ) where--import qualified Data.Kind as Kind-import Fcf (type (***), type (=<<), Eval, Exp, Fst, Pure)-import qualified Fcf-import Fcf.Data.List (Cons)-import Fcf.Utils (TError)-import GHC.Generics ((:*:), (:+:))-import qualified GHC.Generics as G--import Lorentz.UStore.Types-import Util.Type-import Util.TypeLits---- Diff definition--------------------------------------------------------------------------------- | Information about single field of UStore.-type FieldInfo = (Symbol, Kind.Type)---- | What should happen with a particular 'UStoreItem'.-data DiffKind = ToAdd | ToDel---- | Single piece of a diff.-type DiffItem = (DiffKind, FieldInfo)---- Building diff--------------------------------------------------------------------------------- | Get information about all fields of UStore template in a list.------ In particular, this recursivelly traverses template and retrives--- names and types of fields. Semantic wrappers like 'UStoreField'--- and '|~>' in field types are returned as-is.-type LinearizeUStore a = GLinearizeUStore (G.Rep a)--data LinearizeUStoreF (template :: Kind.Type) :: Exp [FieldInfo]-type instance Eval (LinearizeUStoreF template) = LinearizeUStore template---- | Get only field names of UStore template.-type family AllUStoreFieldsF (template :: Kind.Type) :: Exp [Symbol] where-  AllUStoreFieldsF template = Fcf.Map Fst =<< LinearizeUStoreF template--type family GLinearizeUStore (template :: Kind.Type -> Kind.Type)-    :: [FieldInfo] where-  GLinearizeUStore (G.D1 _ x) = GLinearizeUStore x-  GLinearizeUStore (G.C1 _ x) = GLinearizeUStore x-  GLinearizeUStore (_ :+: _) = TypeError-    ('Text "Unexpected sum type in UStore template")-  GLinearizeUStore G.V1 = TypeError-    ('Text "Unexpected void-like type in UStore template")-  GLinearizeUStore G.U1 = '[]-  GLinearizeUStore (x :*: y) = GLinearizeUStore x ++ GLinearizeUStore y--  GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (k |~> v))) =-    '[ '(RequireFieldName mfield, k |~> v) ]-  GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (UStoreFieldExt m v))) =-    '[ '(RequireFieldName mfield, UStoreFieldExt m v) ]-  GLinearizeUStore (G.S1 _ (G.Rec0 a)) =-    LinearizeUStore a---- | Helper to make sure that datatype field is named and then extract this name.-type family RequireFieldName (mfield :: Maybe Symbol) :: Symbol where-  RequireFieldName ('Just field) = field-  RequireFieldName 'Nothing = TypeError ('Text "Unnamed field in UStore template")---- | Lift a list of 'FieldInfo' to 'DiffItem's via attaching given 'DiffKind'.-type family LiftToDiff (kind :: DiffKind) (items :: [FieldInfo]) :: [DiffItem] where-  LiftToDiff _ '[] = '[]-  LiftToDiff kind (item ': items) = '(kind, item) ': LiftToDiff kind items---- | Make up a migration diff between given old and new 'UStore' templates.-type BuildDiff oldTemplate newTemplate =-  LiftToDiff 'ToAdd (LinearizeUStore newTemplate // LinearizeUStore oldTemplate)-  ++-  LiftToDiff 'ToDel (LinearizeUStore oldTemplate // LinearizeUStore newTemplate)---- Pretty-printing diff--------------------------------------------------------------------------------- | Renders human-readable message describing given diff.-type ShowDiff diff =-  'Text "Migration is incomplete, remaining diff:" ':$$: ShowDiffItems diff--type family ShowDiffItems (diff :: [DiffItem]) :: ErrorMessage where-  ShowDiffItems '[d] = ShowDiffItem d-  ShowDiffItems (d : ds) = ShowDiffItem d ':$$: ShowDiffItems ds--type family ShowDiffKind (kind :: DiffKind) :: Symbol where-  ShowDiffKind 'ToAdd = "+"-  ShowDiffKind 'ToDel = "-"--type family ShowUStoreElement (ty :: Kind.Type) :: ErrorMessage where-  ShowUStoreElement (UStoreFieldExt m f) =-    ShowUStoreField m f-  ShowUStoreElement (k |~> v) =-    'Text "submap " ':<>: 'ShowType k ':<>: 'Text " -> " ':<>: 'ShowType v--type family ShowDiffItem (diff :: DiffItem) :: ErrorMessage where-  ShowDiffItem '(kind, '(field, ty)) =-    'Text (ShowDiffKind kind `AppendSymbol`-           " `" `AppendSymbol`-           field `AppendSymbol`-           "`") ':<>:-    'Text ": " ':<>: ShowUStoreElement ty---- | Helper type family which dumps error message about remaining diff--- if such is present.-type family RequireEmptyDiff (diff :: [DiffItem]) :: Constraint where-  RequireEmptyDiff '[] = ()-  RequireEmptyDiff diff = TypeError (ShowDiff diff)---- Diff coverage--------------------------------------------------------------------------------- | Cover the respective part of diff.--- Maybe fail if such action is not required.------ This type is very similar to 'DiffKind', but we still use another type as--- 1. Their kinds will differ - no chance to mix up anything.--- 2. One day there might appear more complex actions.-data DiffCoverage-  = DcAdd-  | DcRemove--type family PrefixSecond (a :: k2) (r :: (k1, [k2])) :: (k1, [k2]) where-  PrefixSecond a '(t, l) = '(t, (a ': l))---- | Apply given diff coverage, returning type of affected field and modified--- diff.-type family CoverDiff (cover :: DiffCoverage) (field :: Symbol) (diff :: [DiffItem])-            :: (Kind.Type, [DiffItem]) where-  CoverDiff cover field diff = Eval (CoverDiffF '(cover, field) diff)--type family CoverDiffF (arg :: (DiffCoverage, Symbol)) (diff :: [DiffItem])-            :: Exp (Kind.Type, [DiffItem]) where-  CoverDiffF '( 'DcAdd, field) diff = RemoveDiffF 'ToAdd field diff-  CoverDiffF '( 'DcRemove, field) diff = RemoveDiffF 'ToDel field diff--type family RemoveDiffF (kind :: DiffKind) (field :: Symbol) (diff :: [DiffItem])-            :: Exp (Kind.Type, [DiffItem]) where-  RemoveDiffF kind field ('(kind, '(field, ty)) ': diff) = Pure '(ty, diff)-  RemoveDiffF kind field (d ': diff) = (Pure *** Cons d) =<< RemoveDiffF kind field diff-  RemoveDiffF kind field '[] =-    TError ('Text (ShowDiffKindWord kind) ':<>: 'Text " field " ':<>:-            'ShowType field ':<>: 'Text " is not required")--type family ShowDiffKindWord (kind :: DiffKind) :: Symbol where-  ShowDiffKindWord 'ToAdd = "Adding"-  ShowDiffKindWord 'ToDel = "Removing"---- | Single piece of a coverage.-type DiffCoverageItem = (DiffCoverage, FieldInfo)---- | Apply multiple coverage steps.-type family CoverDiffMany (diff :: [DiffItem]) (covers :: [DiffCoverageItem])-            :: [DiffItem] where-  CoverDiffMany diff '[] = diff-  CoverDiffMany diff ('(dc, '(field, ty)) ': cs) =-    CoverDiffMany (HandleCoverRes field ty (CoverDiff dc field diff)) cs--type family HandleCoverRes (field :: Symbol) (ty :: Kind.Type) (res :: (Kind.Type, [DiffItem]))-            :: [DiffItem] where-  HandleCoverRes _ ty '(ty, diff) = diff-  HandleCoverRes field tyCover '(tyDiff, _) = TypeError-    ('Text "Type mismatch when covering diff for field " ':<>: 'ShowType field-     ':$$:-     'Text "Expected type `" ':<>: 'ShowType tyDiff ':<>: 'Text "` (in requested diff)"-     ':$$:-     'Text "but covered with value of type `" ':<>: 'ShowType tyCover ':<>: 'Text "`"-    )--type family EnsureDiffHasNoRemovalF (field :: Symbol) (diff :: [DiffItem])-             :: Exp [DiffItem] where-  EnsureDiffHasNoRemovalF _ '[] = Pure '[]-  EnsureDiffHasNoRemovalF field ('( 'ToDel, '(field, _)) ': _) =-    TError ('Text "Field with name " ':<>: 'ShowType field ':<>:-            'Text " is present in old version of storage"-           )-  EnsureDiffHasNoRemovalF field (d ': diff) =-    Cons d =<< EnsureDiffHasNoRemovalF field diff

@@ -1,193 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | UStore templates generic traversals.------ Normally you work with functionality of this module as follows:--- 1. Pick the function fitting most for your traversal, one of---    'traverseUStore', 'foldUStore' e.t.c.--- 2. Create a custom datatype value of which will be put to that function.--- 3. Implement a respective 'UStoreTemplateTraversable' instance for this---    datatype.-module Lorentz.UStore.Traversal-  ( UStoreTraversalWay (..)-  , UStoreTraversalFieldHandler (..)-  , UStoreTraversalSubmapHandler (..)-  , UStoreTraversable-  , traverseUStore-  , modifyUStore-  , foldUStore-  , genUStore-  ) where--import qualified Data.Kind as Kind-import GHC.Generics ((:*:)(..), (:+:))-import qualified GHC.Generics as G--import Lorentz.UStore.Types-import Util.Label-import Util.TypeLits--------------------------------------------------------------------------------- Interface--------------------------------------------------------------------------------- | Defines general parameters of UStore template traversal.--- You need a separate @way@ datatype with an instance of this typeclass for each--- type of traversal.-class ( Applicative (UStoreTraversalArgumentWrapper way)-      , Applicative (UStoreTraversalMonad way)-      ) =>-      UStoreTraversalWay (way :: Kind.Type) where--  -- | Wrapper which will accompany the existing value of traversed template,-  -- aka argument.-  -- This is usually @'Identity'@ or @'Const' a@.-  type UStoreTraversalArgumentWrapper way :: Kind.Type -> Kind.Type--  -- | Additional constraints on monadic action used in traversal.-  -- Common ones include 'Identity', @'Const'@, @(,) a@-  type UStoreTraversalMonad way :: Kind.Type -> Kind.Type---- | Declares a handler for UStore fields when given traversal way is applied.-class (UStoreTraversalWay way) =>-      UStoreTraversalFieldHandler-        (way :: Kind.Type) (marker :: UStoreMarkerType) (v :: Kind.Type) where-  -- | How to process each of UStore fields.-  ustoreTraversalFieldHandler-    :: (KnownUStoreMarker marker)-    => way-    -> Label name-    -> UStoreTraversalArgumentWrapper way v-    -> UStoreTraversalMonad way v---- | Declares a handler for UStore submaps when given traversal way is applied.-class (UStoreTraversalWay way) =>-      UStoreTraversalSubmapHandler-        (way :: Kind.Type) (k :: Kind.Type) (v :: Kind.Type) where-  -- | How to process each of UStore submaps.-  ustoreTraversalSubmapHandler-    :: way-    -> Label name-    -> UStoreTraversalArgumentWrapper way (Map k v)-    -> UStoreTraversalMonad way (Map k v)---- | Constraint for UStore traversal.-type UStoreTraversable way a =-  (Generic a, GUStoreTraversable way (G.Rep a), UStoreTraversalWay way)---- | Perform UStore traversal. The most general way to perform a traversal.-traverseUStore-  :: forall way template.-     (UStoreTraversable way template)-  => way-  -> UStoreTraversalArgumentWrapper way template-  -> UStoreTraversalMonad way template-traverseUStore way =-  fmap G.to . gTraverseUStore way . fmap G.from---- | Modify each UStore entry.-modifyUStore-  :: ( UStoreTraversable way template-     , UStoreTraversalArgumentWrapper way ~ Identity-     , UStoreTraversalMonad way ~ Identity-     )-  => way-  -> template-  -> template-modifyUStore way a =-  runIdentity $ traverseUStore way (Identity a)---- | Collect information about UStore entries into monoid.-foldUStore-  :: ( UStoreTraversable way template-     , UStoreTraversalArgumentWrapper way ~ Identity-     , UStoreTraversalMonad way ~ Const res-     )-  => way-  -> template-  -> res-foldUStore way a =-  getConst $ traverseUStore way (Identity a)---- | Fill UStore template with entries.-genUStore-  :: ( UStoreTraversable way template-     , UStoreTraversalArgumentWrapper way ~ Const ()-     )-  => way -> UStoreTraversalMonad way template-genUStore way =-  traverseUStore way (Const ())---- Implementation--------------------------------------------------------------------------------- | Generic traversal of UStore template.-class GUStoreTraversable (way :: Kind.Type) (x :: Kind.Type -> Kind.Type) where-  gTraverseUStore-    :: (UStoreTraversalWay way)-    => way-    -> UStoreTraversalArgumentWrapper way (x p)-    -> UStoreTraversalMonad way (x p)--instance GUStoreTraversable way x =>-         GUStoreTraversable way (G.D1 i x) where-  gTraverseUStore way x =-    G.M1 <$> gTraverseUStore way (G.unM1 <$> x)--instance GUStoreTraversable way x =>-         GUStoreTraversable way (G.C1 i x) where-  gTraverseUStore way x =-    G.M1 <$> gTraverseUStore way (G.unM1 <$> x)--instance TypeError ('Text "Unexpected sum type in UStore template") =>-         GUStoreTraversable way (x :+: y) where-  gTraverseUStore _ = error "imposible"--instance TypeError ('Text "Unexpected void-like type in UStore template") =>-         GUStoreTraversable way G.V1 where-  gTraverseUStore _ = error "impossible"--instance ( GUStoreTraversable way x-         , GUStoreTraversable way y-         ) =>-         GUStoreTraversable way (x :*: y) where-  gTraverseUStore way a =-    (:*:) <$> gTraverseUStore way (a <&> \(x :*: _) -> x)-          <*> gTraverseUStore way (a <&> \(_ :*: y) -> y)--instance GUStoreTraversable way G.U1 where-  gTraverseUStore _ _ = pure G.U1--instance {-# OVERLAPPABLE #-}-         UStoreTraversable way template =>-         GUStoreTraversable way (G.S1 i (G.Rec0 template)) where-  gTraverseUStore way sub =-    G.M1 . G.K1 <$> traverseUStore way (G.unK1 . G.unM1 <$> sub)--instance ( UStoreTraversalFieldHandler way marker v, KnownUStoreMarker marker-         , KnownSymbol ctor-         ) =>-         GUStoreTraversable-           way-           (G.S1 ('G.MetaSel ('Just ctor) _1 _2 _3) (G.Rec0 (UStoreFieldExt marker v))) where-  gTraverseUStore way entry =-    G.M1 . G.K1 . UStoreField <$>-      ustoreTraversalFieldHandler-        @_-        @marker-        way-        (Label @ctor)-        (entry <&> \(G.M1 (G.K1 (UStoreField v))) -> v)--instance (UStoreTraversalSubmapHandler way k v, KnownSymbol ctor) =>-         GUStoreTraversable-           way-           (G.S1 ('G.MetaSel ('Just ctor) _1 _2 _3) (G.Rec0 (k |~> v))) where-  gTraverseUStore way entry =-    G.M1 . G.K1 . UStoreSubMap <$>-      ustoreTraversalSubmapHandler-        way-        (Label @ctor)-        (entry <&> \(G.M1 (G.K1 (UStoreSubMap m))) -> m)

@@ -1,272 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | 'UStore' definition and common type-level stuff.-module Lorentz.UStore.Types-  ( -- * UStore and related type definitions-    UStore (..)-  , type (|~>)(..)-  , UStoreFieldExt (..)-  , UStoreField-  , UStoreMarkerType-  , UMarkerPlainField--    -- ** Extras-  , KnownUStoreMarker (..)-  , mkFieldMarkerUKeyL-  , mkFieldUKey-  , UStoreSubmapKey-  , UStoreSubmapKeyT--    -- ** Type-lookup-by-name-  , GetUStoreKey-  , GetUStoreValue-  , GetUStoreField-  , GetUStoreFieldMarker--    -- ** Marked fields-  , PickMarkedFields--   -- * Internals-  , ElemSignature (..)-  , GetUStore-  , MSKey-  , MSValue-  , FSValue-  , FSMarker-  ) where--import qualified Data.Kind as Kind-import GHC.Generics ((:*:)(..), (:+:)(..))-import qualified GHC.Generics as G-import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)-import Test.QuickCheck (Arbitrary)--import Lorentz.Annotation (HasAnnotation)-import Lorentz.Coercions (Wrappable)-import Lorentz.Pack-import Lorentz.Polymorphic-import Lorentz.Value-import Michelson.Text (labelToMText)-import Michelson.Typed.T-import Util.Type---- | Gathers multple fields and 'BigMap's under one object.------ Type argument of this datatype stands for a "store template" ---- a datatype with one constructor and multiple fields, each containing--- an object of type 'UStoreField' or '|~>' and corresponding to single--- virtual field or 'BigMap' respectively.--- It's also possible to parameterize it with a larger type which is--- a product of types satisfying the above property.-newtype UStore (a :: Kind.Type) = UStore-  { unUStore :: BigMap ByteString ByteString-  } deriving stock (Eq, Show, Generic)-    deriving newtype (Default, Semigroup, Monoid, IsoValue,-                      MemOpHs, GetOpHs, UpdOpHs)-    deriving anyclass (HasAnnotation, Wrappable)---- | Describes one virtual big map in the storage.-newtype k |~> v = UStoreSubMap { unUStoreSubMap :: Map k v }-  deriving stock (Show, Eq)-  deriving newtype (Default, Arbitrary)---- | Describes plain field in the storage.-newtype UStoreFieldExt (m :: UStoreMarkerType) (v :: Kind.Type) = UStoreField { unUStoreField :: v }-  deriving stock (Show, Eq)-  deriving newtype Arbitrary---- | Just a servant type.-data UStoreMarker---- | Specific kind used to designate markers for 'UStoreFieldExt'.------ We suggest that fields may serve different purposes and so annotated with--- special markers accordingly, which influences translation to Michelson.--- See example below.------ This Haskell kind is implemented like that because we want markers to differ from all--- other types in kind; herewith 'UStoreMarkerType' is still an open kind--- (has potentially infinite number of inhabitants).-type UStoreMarkerType = UStoreMarker -> Kind.Type---- | Just a plain field used as data.-type UStoreField = UStoreFieldExt UMarkerPlainField-data UMarkerPlainField :: UStoreMarkerType---- | What do we serialize when constructing big_map key for accessing--- an UStore submap.-type UStoreSubmapKey k = (MText, k)-type UStoreSubmapKeyT k = 'TPair (ToT MText) k---- Extra attributes of fields--------------------------------------------------------------------------------- | Allows to specify format of key under which fields of this type are stored.--- Useful to avoid collisions.-class KnownUStoreMarker (marker :: UStoreMarkerType) where-  -- | By field name derive key under which field should be stored.-  mkFieldMarkerUKey :: MText -> ByteString-  default mkFieldMarkerUKey :: MText -> ByteString-  mkFieldMarkerUKey = lPackValue--  -- | Display type-level information about UStore field with given marker and-  -- field value type.-  -- Used for error messages.-  type ShowUStoreField marker v :: ErrorMessage-  type ShowUStoreField marker v = 'Text "field of type " ':<>: 'ShowType v---- | Version of 'mkFieldMarkerUKey' which accepts label.-mkFieldMarkerUKeyL-  :: forall marker field.-     KnownUStoreMarker marker-  => Label field -> ByteString-mkFieldMarkerUKeyL label =-  mkFieldMarkerUKey @marker (labelToMText label)---- | Shortcut for 'mkFieldMarkerUKey' which accepts not marker but store template--- and name of entry.-mkFieldUKey-  :: forall (store :: Kind.Type) field.-     KnownUStoreMarker (GetUStoreFieldMarker store field)-  => Label field -> ByteString-mkFieldUKey = mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field)--instance KnownUStoreMarker UMarkerPlainField where--------------------------------------------------------------------------------- Type-safe lookup magic-------------------------------------------------------------------------------{- Again we use generic magic to implement methods for 'Store'-(and thus 'Store' type constructor accepts a datatype, not a type-level list).--There are two reasons for this:--1. This gives us expected balanced tree of 'Or's for free.--2. This allows us selecting a map by field name, not by-e.g. type of map value. This is subjective, but looks like a good thing-for me (@martoon). On the other hand, it prevents us from sharing the-same interface between maps and 'Store'.---}---- | What was found on lookup by constructor name.------ This keeps either type arguments of '|~>' or 'UStoreField'.-data ElemSignature-  = MapSignature Kind.Type Kind.Type-  | FieldSignature UStoreMarkerType Kind.Type---- Again, we will use these getters instead of binding types within--- 'MapSignature' using type equality because getters does not produce extra--- compile errors on "field not found" cases.-type family MSKey (ms :: ElemSignature) :: Kind.Type where-  MSKey ('MapSignature k _) = k-  MSKey ('FieldSignature _ _) =-    TypeError ('Text "Expected UStore submap, but field was referred")-type family MSValue (ms :: ElemSignature) :: Kind.Type where-  MSValue ('MapSignature _ v) = v-  MSValue ('FieldSignature _ _) =-    TypeError ('Text "Expected UStore submap, but field was referred")-type family FSValue (ms :: ElemSignature) :: Kind.Type where-  FSValue ('FieldSignature _ v) = v-  FSValue ('MapSignature _ _) =-    TypeError ('Text "Expected UStore field, but submap was referred")-type family FSMarker (ms :: ElemSignature) :: UStoreMarkerType where-  FSMarker ('FieldSignature m _) = m-  FSMarker ('MapSignature _ _) =-    TypeError ('Text "Expected UStore field, but submap was referred")---- | Get map signature from the constructor with a given name.-type GetUStore name a = MERequireFound name a (GLookupStore name (G.Rep a))--type family MERequireFound-  (name :: Symbol)-  (a :: Kind.Type)-  (mlr :: Maybe ElemSignature)-    :: ElemSignature where-  MERequireFound _ _ ('Just ms) = ms-  MERequireFound name a 'Nothing = TypeError-    ('Text "Failed to find plain field or submap in store template: datatype `"-     ':<>: 'ShowType a ':<>: 'Text "` has no field " ':<>: 'ShowType name)--type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)-              :: Maybe ElemSignature where-  GLookupStore name (G.D1 _ x) = GLookupStore name x-  GLookupStore _ (_ :+: _) =-    TypeError ('Text "Templates used in UStore should have only one constructor")-  GLookupStore _ G.V1 =-    TypeError ('Text "No constructors in UStore template")--  GLookupStore name (G.C1 _ x) = GLookupStore name x--  GLookupStore name (x :*: y) = LSMergeFound name (GLookupStore name x)-                                                  (GLookupStore name y)--  -- When we encounter a field there are three cases we are interested in:-  -- 1. This field has type '|~>'. Then we check its name and return 'Just'-  -- with all required info on match, and 'Nothing' otherwise.-  -- 2. This field has type 'UStoreField'. We act in the same way-  -- as for '|~>', attaching 'ThePlainFieldKey' as key.-  -- 3. This field type is a different one. Then we expect this field to store-  -- '|~>' or 'UStoreField' somewhere deeper and try to find it there.-  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (k |~> v))) =-    Guard ('Just name == mFieldName) ('MapSignature k v)-  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (UStoreFieldExt m v))) =-    Guard ('Just name == mFieldName) ('FieldSignature m v)--  GLookupStore name (G.S1 _ (G.Rec0 a)) =-    GLookupStore name (G.Rep a)--  GLookupStore _ G.U1 = 'Nothing--type family LSMergeFound (name :: Symbol)-  (f1 :: Maybe ElemSignature) (f2 :: Maybe ElemSignature)-  :: Maybe ElemSignature where-  LSMergeFound _ 'Nothing 'Nothing = 'Nothing-  LSMergeFound _ ('Just ms) 'Nothing = 'Just ms-  LSMergeFound _ 'Nothing ('Just ms) = 'Just ms-  -- It's possible that there are two constructors with the same name,-  -- because main template pattern may be a sum of smaller template-  -- patterns with same constructor names.-  LSMergeFound ctor ('Just _) ('Just _) = TypeError-    ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)----- | Get type of submap key.-type GetUStoreKey store name = MSKey (GetUStore name store)---- | Get type of submap value.-type GetUStoreValue store name = MSValue (GetUStore name store)---- | Get type of plain field.--- This ignores marker with field type.-type GetUStoreField store name = FSValue (GetUStore name store)---- | Get kind of field.-type GetUStoreFieldMarker store name = FSMarker (GetUStore name store)---- One more magic--------------------------------------------------------------------------------- | Collect all fields with the given marker.-type PickMarkedFields marker template = GPickMarkedFields marker (G.Rep template)--type family GPickMarkedFields (marker :: UStoreMarkerType) (x :: Kind.Type -> Kind.Type)-             :: [(Symbol, Kind.Type)] where-  GPickMarkedFields m (G.D1 _ x) = GPickMarkedFields m x-  GPickMarkedFields m (G.C1 _ x) = GPickMarkedFields m x-  GPickMarkedFields m (x :*: y) = GPickMarkedFields m x ++ GPickMarkedFields m y-  GPickMarkedFields _ G.U1 = '[]--  GPickMarkedFields m (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt m v))) =-    '[ '(fieldName, v) ]-  GPickMarkedFields _ (G.S1 _ (G.Rec0 (UStoreFieldExt _ _))) =-    '[]-  GPickMarkedFields _ (G.S1 _ (G.Rec0 (_ |~> _))) =-    '[]-  GPickMarkedFields m (G.S1 _ (G.Rec0 a)) =-    PickMarkedFields m a