lorentz 0.3.0 → 0.4.0
raw patch · 32 files changed
+1281/−358 lines, 32 filesdep +basedep +hedgehogdep +tasty-hedgehogdep −base-nopreludedep −tasty-quickcheckdep −tezos-bake-monitor-lib
Dependencies added: base, hedgehog, tasty-hedgehog
Dependencies removed: base-noprelude, tasty-quickcheck, tezos-bake-monitor-lib
Files
- CHANGES.md +23/−6
- README.md +0/−6
- lorentz.cabal +17/−11
- src/Lorentz/Base.hs +2/−3
- src/Lorentz/Constraints/Scopes.hs +2/−2
- src/Lorentz/ContractRegistry.hs +0/−1
- src/Lorentz/Doc.hs +6/−5
- src/Lorentz/EntryPoints/Core.hs +1/−2
- src/Lorentz/EntryPoints/Impl.hs +1/−1
- src/Lorentz/Errors.hs +5/−4
- src/Lorentz/Errors/Numeric/Contract.hs +1/−1
- src/Lorentz/Extensible.hs +3/−2
- src/Lorentz/Instr.hs +11/−8
- src/Lorentz/Macro.hs +8/−4
- src/Lorentz/StoreClass.hs +280/−11
- src/Lorentz/Test.hs +28/−12
- src/Lorentz/Test/Integrational.hs +46/−44
- src/Lorentz/TypeAnns.hs +3/−3
- src/Lorentz/UStore.hs +10/−1
- src/Lorentz/UStore/Doc.hs +236/−0
- src/Lorentz/UStore/Haskell.hs +145/−172
- src/Lorentz/UStore/Migration.hs +1/−1
- src/Lorentz/UStore/Migration/Base.hs +30/−4
- src/Lorentz/UStore/Traversal.hs +193/−0
- src/Lorentz/UStore/Types.hs +22/−16
- src/Lorentz/Zip.hs +2/−2
- test/Test/Doc.hs +10/−9
- test/Test/Lorentz/EntryPoints.hs +3/−6
- test/Test/Lorentz/Errors.hs +1/−2
- test/Test/Lorentz/Interpreter.hs +6/−8
- test/Test/Lorentz/StoreClass.hs +143/−0
- test/Test/Lorentz/UStore/Behaviour.hs +42/−11
CHANGES.md view
@@ -1,12 +1,29 @@-<!---SPDX-FileCopyrightText: 2020 Tocqueville Group--SPDX-License-Identifier: LicenseRef-MIT-TQ--->- Unreleased ========== <!-- Append new entries here -->++0.4.0+=====+* [!449](https://gitlab.com/morley-framework/morley/-/merge_requests/449)+ + Improve `Lorentz.Test.Integrational` interface.+ + Remove `IntegrationalValidator`, `SuccessValidator`, `validate`,+ `composeValidators`, `composeValidatorsList`, `expectAnySuccess`.+ + Add `unexpectedInterpreterError`, `attempt`, `catchExpectedError`.+ + Change type of `expect*`/`tExpect*`/`lExpect*` functions.+ They now return `IntegrationalScenario` instead of `SuccessValidator` / `Bool`.+ + Rename `ValidationError` to `TestError`+ + Replace `TestError`'s `UnexpectedExecutorError` constructor with+ `InterpreterError` and `UnexpectedInterpreterError`.+* [!432](https://gitlab.com/morley-framework/morley/-/merge_requests/432)+ Add `whenNone` to Lorentz.+* [!398](https://gitlab.com/morley-framework/morley/-/merge_requests/398)+ Add `StoreHasEntrypoint` class to conveniently use entrypoints as lambdas+ stored into `big_map`(s) to make use of lazy evaluation.+* [!409](https://gitlab.com/morley-framework/morley/-/merge_requests/409)+ + Add hedgehog support+* [!303](https://gitlab.com/morley-framework/morley/merge_requests/303)+ + Functions for working with `UStore` from Haskell world (e.g. `fillUStore`) now have a different constraint.+ + `UStore` templates are now documented and thus may require instance of the respective typeclass. 0.3.0 =====
README.md view
@@ -1,9 +1,3 @@-<!---SPDX-FileCopyrightText: 2020 Tocqueville Group--SPDX-License-Identifier: LicenseRef-MIT-TQ--->- # Morley Lorentz EDSL ## Table of contents
lorentz.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 7df6ecd69cd3e2cb79e6545e9f1715fce5b2d92b302c7ed0bcfb82a4090245fa+-- hash: fccef8190cb6d01163ff5cfe694606e9d553421a90846ae212d8c5e6a2c4a133 name: lorentz-version: 0.3.0+version: 0.4.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@@ -76,6 +76,7 @@ Lorentz.UParam Lorentz.UStore Lorentz.UStore.Common+ Lorentz.UStore.Doc Lorentz.UStore.Haskell Lorentz.UStore.Instances Lorentz.UStore.Instr@@ -85,6 +86,7 @@ Lorentz.UStore.Migration.Batching Lorentz.UStore.Migration.Blocks Lorentz.UStore.Migration.Diff+ Lorentz.UStore.Traversal Lorentz.UStore.Types Lorentz.Value Lorentz.Zip@@ -94,13 +96,13 @@ Paths_lorentz hs-source-dirs: src- default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies 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+ 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: HUnit , QuickCheck , aeson-pretty- , base-noprelude >=4.7 && <5+ , base >=4.7 && <5 , bimap , bytestring , constraints >=0.11@@ -110,6 +112,7 @@ , fmt , formatting , ghc-prim+ , hedgehog , interpolate , lens , morley@@ -121,9 +124,10 @@ , singletons , template-haskell , text- , tezos-bake-monitor-lib , unordered-containers , vinyl+ mixins:+ base hiding (Prelude) default-language: Haskell2010 test-suite lorentz-test@@ -145,6 +149,7 @@ Test.Lorentz.Macro Test.Lorentz.Pack Test.Lorentz.Print+ Test.Lorentz.StoreClass Test.Lorentz.UParam Test.Lorentz.UStore.Behaviour Test.Lorentz.UStore.Migration.Batched@@ -162,33 +167,34 @@ Paths_lorentz hs-source-dirs: test- default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies 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 DerivingStrategies- 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 -threaded -with-rtsopts=-N+ 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 DerivingStrategies+ 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 -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m" build-tool-depends: tasty-discover:tasty-discover build-depends: HUnit- , QuickCheck- , base-noprelude >=4.7 && <5+ , base >=4.7 && <5 , bimap , bytestring , constraints , containers- , data-default , filepath , first-class-families , fmt , formatting+ , hedgehog , lorentz , morley , morley-prelude , singletons , spoon , tasty+ , tasty-hedgehog , tasty-hunit-compat- , tasty-quickcheck , text , type-spec , unordered-containers , vinyl+ mixins:+ base hiding (Prelude) default-language: Haskell2010
src/Lorentz/Base.hs view
@@ -36,7 +36,6 @@ import Data.Default (def) import qualified Data.Kind as Kind import qualified Data.List.NonEmpty as NE (fromList)-import Data.Singletons (SingI(..)) import Fmt (Buildable(..)) import Lorentz.Constraints@@ -157,8 +156,8 @@ -- contract's type. Obviously it can not work, because we don't have -- any information about a contract to which this value belongs (there -- is no such contract at all).-parseLorentzValue ::- forall v. (IsoValue v, SingI (ToT v), Typeable (ToT v))+parseLorentzValue+ :: forall v. KnownValue v => Text -> Either ParseLorentzError v parseLorentzValue =
src/Lorentz/Constraints/Scopes.hs view
@@ -45,8 +45,8 @@ -- type aliases, in order to allow their partial application. -- | Gathers constraints, commonly required for values.-class (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a-instance (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a+class (IsoValue a, Typeable a) => KnownValue a+instance (IsoValue a, Typeable a) => KnownValue a -- | Ensure given type does not contain "operation". class (IsoValue a, ForbidOp (ToT a)) => NoOperation a
src/Lorentz/ContractRegistry.hs view
@@ -28,7 +28,6 @@ import Data.Text.Lazy.Builder (toLazyText) import Fmt (Buildable(..), blockListF, nameF, pretty, (+|), (|+)) import qualified Options.Applicative as Opt-import Tezos.V005.Micheline (Expression) import Lorentz.Constraints import Lorentz.Doc
src/Lorentz/Doc.hs view
@@ -37,6 +37,7 @@ , DComment (..) , DAnchor (..) , DType (..)+ , dTypeDep , docDefinitionRef , contractDocToMarkdown , subDocToMarkdown@@ -149,11 +150,11 @@ \and `unpair` instructions until fits into mentioned restriction.\ \" typeDocDependencies _ = mconcat- [ reifyList @_ @TypeHasDoc @i SomeTypeWithDoc- , reifyList @_ @TypeHasDoc @o SomeTypeWithDoc- , [ SomeTypeWithDoc (Proxy @Integer)- , SomeTypeWithDoc (Proxy @Natural)- , SomeTypeWithDoc (Proxy @MText)+ [ reifyList @_ @TypeHasDoc @i dTypeDepP+ , reifyList @_ @TypeHasDoc @o dTypeDepP+ , [ dTypeDep @Integer+ , dTypeDep @Natural+ , dTypeDep @MText ] ] typeDocHaskellRep _ _ = Nothing
src/Lorentz/EntryPoints/Core.hs view
@@ -255,8 +255,7 @@ -- | Derive annotations for given parameter. parameterEntryPointsToNotes- :: forall cp.- (Typeable cp, ParameterDeclaresEntryPoints cp)+ :: forall cp. ParameterDeclaresEntryPoints cp => ParamNotes (ToT cp) parameterEntryPointsToNotes = let notes = pepNotes @cp
src/Lorentz/EntryPoints/Impl.hs view
@@ -332,7 +332,7 @@ gMkEpLiftSequence _ = EpConstructionFailed gMkDescs = RNil -instance Each [Typeable, SingI] [GValueType x, GValueType y] =>+instance Each '[KnownT] [GValueType x, GValueType y] => GEntryPointsNotes mode 'EPLeaf (x G.:*: y) where type GAllEntryPoints mode 'EPLeaf (x G.:*: y) = '[] type GLookupEntryPoint mode 'EPLeaf (x G.:*: y) = Fcf.ConstFn 'Nothing
src/Lorentz/Errors.hs view
@@ -59,6 +59,7 @@ import qualified Text.Show import Lorentz.Base+import Lorentz.Constraints (KnownValue) import Lorentz.Doc import Lorentz.Instr hiding (cast) import Lorentz.Value@@ -95,7 +96,7 @@ errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r -- | Converts a @Value@ into Haskell error.- errorFromVal :: (Typeable t, SingI t) => Value t -> Either Text e+ errorFromVal :: (KnownT t) => Value t -> Either Text e -- | Implementation of 'errorToVal' via 'IsoValue'. isoErrorToVal@@ -205,7 +206,7 @@ errorDocName = "Unspecified error" errorDocMdCause = "Some error occured." errorDocHaskellRep = typeDocMdReference (Proxy @()) (WithinParens False) <> "."- errorDocDependencies = typeDocDependencies' (Proxy @())+ errorDocDependencies = typeDocDependencies (Proxy @()) -- | Type wrapper for an @IsError@. data SomeError = forall e. (IsError e, Eq e) => SomeError e@@ -711,8 +712,8 @@ -- | Signature of 'userFailWith'. type FailUsingArg e name fieldTy s s' = ( KnownSymbol name, IsError e- , IsoValue fieldTy- , CtorHasOnlyField name e fieldTy, Each [Typeable, SingI] '[ToT fieldTy]+ , KnownValue fieldTy+ , CtorHasOnlyField name e fieldTy , HasCallStack ) => Label name -> fieldTy : s :-> s'
src/Lorentz/Errors/Numeric/Contract.hs view
@@ -162,7 +162,7 @@ -- map, we conservatively preserve that number (because this whole -- approach is rather a heuristic). errorFromValNumeric ::- (Typeable t, SingI t, IsError e) => ErrorTagMap -> Value t -> Either Text e+ (KnownT t, IsError e) => ErrorTagMap -> Value t -> Either Text e errorFromValNumeric errorTagMap v = case v of VNat tag
src/Lorentz/Extensible.hs view
@@ -67,6 +67,7 @@ import Lorentz.Base import Lorentz.Coercions import Lorentz.Constraints+import Lorentz.Doc import Lorentz.Instr import Lorentz.Pack import Lorentz.TypeAnns@@ -224,10 +225,10 @@ extensibleDocName :: Proxy x -> Text -- | Implementation for 'typeDocDependencies' of the corresponding @Extensible@.- extensibleDocDependencies :: Proxy x -> [SomeTypeWithDoc]+ extensibleDocDependencies :: Proxy x -> [SomeDocDefinitionItem] default extensibleDocDependencies :: (Generic x, GTypeHasDoc (G.Rep x))- => Proxy x -> [SomeTypeWithDoc]+ => Proxy x -> [SomeDocDefinitionItem] extensibleDocDependencies = genericTypeDocDependencies -- | Overall description of this type.
src/Lorentz/Instr.hs view
@@ -102,7 +102,7 @@ , chainId , framed , LorentzFunctor (..)- , nonZero+ , NonZero (..) ) where import Prelude hiding@@ -289,7 +289,7 @@ emptyBigMap = I EMPTY_BIG_MAP map- :: (MapOpHs c, IsoMapOpRes c b, HasCallStack)+ :: (MapOpHs c, IsoMapOpRes c b, KnownValue b, HasCallStack) => (MapOpInpHs c & s :-> b & s) -> (c & s :-> MapOpResHs c b & s) map (iNonFailingCode -> action) = I (MAP action) @@ -301,7 +301,9 @@ mem :: MemOpHs c => MemOpKeyHs c & c & s :-> Bool & s mem = I MEM -get :: GetOpHs c => GetOpKeyHs c & c & s :-> Maybe (GetOpValHs c) & s+get+ :: (GetOpHs c, KnownValue (GetOpValHs c))+ => GetOpKeyHs c & c & s :-> Maybe (GetOpValHs c) & s get = I GET update :: UpdOpHs c => UpdOpKeyHs c & UpdOpParamsHs c & c & s :-> c & s@@ -318,7 +320,7 @@ loopLeft (iAnyCode -> b) = I (LOOP_LEFT b) lambda- :: (ZipInstrs [i, o], KnownValue (ZippedStack i), KnownValue (ZippedStack o))+ :: ZipInstrs [i, o] => (i :-> o) -> (s :-> (i :-> o) & s) lambda instr = case zippingStack instr of I l -> I (LAMBDA . VLam $ RfNormal l)@@ -345,8 +347,7 @@ _example = execute apply- :: forall a b c s.- (NiceConstant a)+ :: forall a b c s. (NiceConstant a, KnownValue b) => a & Lambda (a, b) c & s :-> Lambda b c & s apply = I $ APPLY \\ niceConstantEvi @a @@ -385,7 +386,7 @@ _example :: '[ Integer, Integer, Integer ] :-> '[ Integer, Integer, Integer, () ] _example = dipN @3 unit -failWith :: (KnownValue a) => a & s :-> t+failWith :: KnownValue a => a & s :-> t failWith = FI FAILWITH cast :: KnownValue a => (a & s :-> a & s)@@ -407,7 +408,9 @@ concat' :: ConcatOpHs c => List c & s :-> c & s concat' = I CONCAT' -slice :: SliceOpHs c => Natural & Natural & c & s :-> Maybe c & s+slice+ :: (SliceOpHs c, KnownValue c)+ => Natural & Natural & c & s :-> Maybe c & s slice = I SLICE isNat :: Integer & s :-> Maybe Natural & s
src/Lorentz/Macro.hs view
@@ -77,6 +77,7 @@ , when_ , unless_ , whenSome+ , whenNone , mapCar , mapCdr , papair@@ -137,7 +138,7 @@ import Lorentz.Instr import Lorentz.TypeAnns import Lorentz.Value-import Michelson.Typed (ConstraintDIG', ConstraintDIPN', ConstraintDUG', T, typeDocDependencies')+import Michelson.Typed (ConstraintDIG', ConstraintDIPN', ConstraintDUG', T) import Michelson.Typed.Arith import Michelson.Typed.Haskell.Value import Util.Markdown@@ -466,6 +467,9 @@ whenSome :: (a : s :-> s) -> (Maybe a : s :-> s) whenSome i = ifSome i nop +whenNone :: (s :-> a : s) -> (Maybe a : s :-> a : s)+whenNone i = ifNone i nop+ -- | Various convenient instructions on maps. class MapInstrs map where -- | Specialized version of 'update'.@@ -647,7 +651,7 @@ typeDocMdReference = poly2TypeDocMdReference typeDocDependencies p = genericTypeDocDependencies p <>- [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]+ [dTypeDep @(), dTypeDep @Integer] typeDocHaskellRep = haskellRepNoFields $ concreteTypeDocHaskellRep @(View () Integer) typeDocMichelsonRep =@@ -722,7 +726,7 @@ ] typeDocDependencies p = genericTypeDocDependencies p <>- [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]+ [dTypeDep @(), dTypeDep @Integer] typeDocHaskellRep p descr = do (_, rhs) <- haskellRepNoFields (concreteTypeDocHaskellRep @(Void_ () Integer)) p descr return (Just "Void () Integer", rhs)@@ -777,7 +781,7 @@ errorDocHaskellRep = mdTicked ("(\"" <> pretty voidResultTag <> "\", " <> "<return value>" <> ")") errorDocDependencies =- typeDocDependencies' (Proxy @MText) <> typeDocDependencies' (Proxy @r)+ [dTypeDep @MText, dTypeDep @r] instance (WellTypedIsoValue (VoidResult r), CustomErrorNoIsoValue (VoidResult r)) => IsoValue (VoidResult r) where type ToT (VoidResult r) = CustomErrorNoIsoValue (VoidResult r)
src/Lorentz/StoreClass.hs view
@@ -11,9 +11,16 @@ , StoreFieldOps (..) , StoreHasSubmap (..) , StoreSubmapOps (..)+ , StoreHasEntrypoint (..)+ , StoreEntrypointOps (..) + -- * Useful type synonyms+ , EntrypointLambda+ , EntrypointsField+ -- * Expressing constraints on storage , type (~>)+ , type (::->) , StorageContains -- * Methods to work with storage@@ -26,23 +33,43 @@ , stDelete , stInsert , stInsertNew+ , stEntrypoint+ , stToEpLambda+ , stGetEpLambda+ , stSetEpLambda+ , stToEpStore+ , stGetEpStore+ , stSetEpStore -- * Implementations , storeFieldOpsADT+ , storeEntrypointOpsADT+ , storeEntrypointOpsFields+ , storeEntrypointOpsSubmapField , storeFieldOpsDeeper , storeSubmapOpsDeeper+ , storeEntrypointOpsDeeper , storeFieldOpsReferTo , storeSubmapOpsReferTo+ , storeEntrypointOpsReferTo , composeStoreFieldOps , composeStoreSubmapOps+ , composeStoreEntrypointOps++ -- * Storage generation+ , mkStoreEp ) where +import Data.Map (singleton)+ import Lorentz.ADT import Lorentz.Base+import Lorentz.Errors (failUnexpected) import Lorentz.Constraints import qualified Lorentz.Instr as L import qualified Lorentz.Macro as L import Lorentz.Value+import Michelson.Text (labelToMText) ---------------------------------------------------------------------------- -- Fields@@ -50,10 +77,10 @@ -- | Datatype containing the full implementation of 'StoreHasField' typeclass. ----- We use this grouping because in most cases implementation will be chosen+-- We use this grouping because in most cases the implementation will be chosen -- among the default ones, and initializing all methods at once is simpler -- and more consistent.--- (One can say that we are trying to emulate benefits of @DerivingVia@ extension.)+-- (One can say that we are trying to emulate the @DerivingVia@ extension.) data StoreFieldOps store fname ftype = StoreFieldOps { sopToField :: forall s.@@ -91,19 +118,20 @@ -- Virtual big maps ---------------------------------------------------------------------------- --- | Datatype containing the full implementation of 'StoreHasField' typeclass.+-- | Datatype containing the full implementation of 'StoreHasSubmap' typeclass. ----- We use this grouping because in most cases implementation will be chosen+-- We use this grouping because in most cases the implementation will be chosen -- among the default ones, and initializing all methods at once is simpler -- and more consistent.--- (One can say that we are trying to emulate @DerivingVia@ extension.)+-- (One can say that we are trying to emulate the @DerivingVia@ extension.) data StoreSubmapOps store mname key value = StoreSubmapOps { sopMem :: forall s. Label mname -> key : store : s :-> Bool : s , sopGet :: forall s.- Label mname -> key : store : s :-> Maybe value : s+ (KnownValue value)+ => Label mname -> key : store : s :-> Maybe value : s , sopUpdate :: forall s. Label mname -> key : Maybe value : store : s :-> store : s@@ -119,7 +147,7 @@ Maybe (Label mname -> key : value : store : s :-> store : s) } --- | Provides operations on fields for storage.+-- | Provides operations on submaps of storage. class StoreHasSubmap store mname key value | store mname -> key value where storeSubmapOps :: StoreSubmapOps store mname key value @@ -131,7 +159,7 @@ -- | Get value in storage. stGet- :: StoreHasSubmap store mname key value+ :: (StoreHasSubmap store mname key value, KnownValue value) => Label mname -> key : store : s :-> Maybe value : s stGet = sopGet storeSubmapOps @@ -195,7 +223,101 @@ , sopInsert = Nothing } +----------------------------------------------------------------------------+-- Stored Entrypoints+---------------------------------------------------------------------------- +-- | Type synonym for a 'Lambda' that can be used as an entrypoint+type EntrypointLambda param store = Lambda (param, store) ([Operation], store)++-- | Type synonym of a 'BigMap' mapping 'MText' (entrypoint names) to+-- 'EntrypointLambda'.+--+-- This is useful when defining instances of 'StoreHasEntrypoint' as a storage+-- field containing one or more entrypoints (lambdas) of the same type.+type EntrypointsField param store = BigMap MText (EntrypointLambda param store)++-- | Datatype containing the full implementation of 'StoreHasEntrypoint' typeclass.+--+-- We use this grouping because in most cases the implementation will be chosen+-- among the default ones, and initializing all methods at once is simpler+-- and more consistent.+-- (One can say that we are trying to emulate the @DerivingVia@ extension.)+data StoreEntrypointOps store epName epParam epStore = StoreEntrypointOps+ { sopToEpLambda+ :: forall s.+ Label epName+ -> store : s :-> (EntrypointLambda epParam epStore) : s+ , sopSetEpLambda+ :: forall s.+ Label epName+ -> (EntrypointLambda epParam epStore) : store : s :-> store : s+ , sopToEpStore+ :: forall s.+ Label epName+ -> store : s :-> epStore : s+ , sopSetEpStore+ :: forall s.+ Label epName+ -> epStore : store : s :-> store : s+ }++-- | Provides operations on stored entrypoints.+--+-- @store@ is the storage containing both the entrypoint @epName@ (note: it has+-- to be in a 'BigMap' to take advantage of lazy evaluation) and the @epStore@+-- field this operates on.+class StoreHasEntrypoint store epName epParam epStore | store epName -> epParam epStore where+ storeEpOps :: StoreEntrypointOps store epName epParam epStore++-- | Extracts and executes the @epName@ entrypoint lambda from storage, returing+-- the updated full storage (@store@) and the produced 'Operation's.+stEntrypoint+ :: StoreHasEntrypoint store epName epParam epStore+ => Label epName -> epParam : store : s :-> ([Operation], store) : s+stEntrypoint l =+ L.dip (L.dup # stGetEpLambda l # L.swap # stToEpStore l) #+ L.pair # L.exec # L.unpair #+ L.dip (stSetEpStore l) # L.pair++-- | Pick stored entrypoint lambda.+stToEpLambda+ :: StoreHasEntrypoint store epName epParam epStore+ => Label epName -> store : s :-> (EntrypointLambda epParam epStore) : s+stToEpLambda = sopToEpLambda storeEpOps++-- | Get stored entrypoint lambda, preserving the storage itself on the stack.+stGetEpLambda+ :: StoreHasEntrypoint store epName epParam epStore+ => Label epName -> store : s :-> (EntrypointLambda epParam epStore) : store : s+stGetEpLambda l = L.dup # stToEpLambda l++-- | Stores the entrypoint lambda in the storage. Fails if already set.+stSetEpLambda+ :: StoreHasEntrypoint store epName epParam epStore+ => Label epName -> (EntrypointLambda epParam epStore) : store : s :-> store : s+stSetEpLambda = sopSetEpLambda storeEpOps++-- | Pick the sub-storage that the entrypoint operates on.+stToEpStore+ :: StoreHasEntrypoint store epName epParam epStore+ => Label epName -> store : s :-> epStore : s+stToEpStore = sopToEpStore storeEpOps++-- | Get the sub-storage that the entrypoint operates on, preserving the storage+-- itself on the stack.+stGetEpStore+ :: StoreHasEntrypoint store epName epParam epStore+ => Label epName -> store : s :-> epStore : store : s+stGetEpStore l = L.dup # stToEpStore l++-- | Update the sub-storage that the entrypoint operates on.+stSetEpStore+ :: StoreHasEntrypoint store epName epParam epStore+ => Label epName -> epStore : store : s :-> store : s+stSetEpStore = sopSetEpStore storeEpOps++---------------------------------------------------------------------------- -- Implementations ---------------------------------------------------------------------------- @@ -209,6 +331,57 @@ , sopSetField = setField } +-- | Implementation of 'StoreHasEntrypoint' for a datatype keeping a pack of+-- fields, among which one has contains the entrypoint and another is what such+-- entrypoint operates on.+storeEntrypointOpsADT+ :: ( HasFieldOfType store epmName (EntrypointsField epParam epStore)+ , HasFieldOfType store epsName epStore+ , KnownValue epParam, KnownValue epStore+ )+ => Label epmName -> Label epsName+ -> StoreEntrypointOps store epName epParam epStore+storeEntrypointOpsADT mapLabel fieldLabel = StoreEntrypointOps+ { sopToEpLambda = \l -> toField mapLabel # pushStEp l # L.get # someStEp l+ , sopSetEpLambda = \l -> L.dip (getField mapLabel) # setStEp mapLabel l # setField mapLabel+ , sopToEpStore = \_l -> toField fieldLabel+ , sopSetEpStore = \_l -> setField fieldLabel+ }++-- | Implementation of 'StoreHasEntrypoint' for a datatype that has a 'StoreHasField'+-- for an 'EntrypointsField' that contains the entrypoint and a 'StoreHasField'+-- for the field such entrypoint operates on.+storeEntrypointOpsFields+ :: ( StoreHasField store epmName (EntrypointsField epParam epStore)+ , StoreHasField store epsName epStore+ , KnownValue epParam, KnownValue epStore+ )+ => Label epmName -> Label epsName+ -> StoreEntrypointOps store epName epParam epStore+storeEntrypointOpsFields mapLabel fieldLabel = StoreEntrypointOps+ { sopToEpLambda = \l -> stToField mapLabel # pushStEp l # L.get # someStEp l+ , sopSetEpLambda = \l -> L.dip (stGetField mapLabel) # setStEp mapLabel l # stSetField mapLabel+ , sopToEpStore = \_l -> stToField fieldLabel+ , sopSetEpStore = \_l -> stSetField fieldLabel+ }++-- | Implementation of 'StoreHasEntrypoint' for a datatype that has a 'StoreHasSubmap'+-- that contains the entrypoint and a 'StoreHasField' for the field such+-- entrypoint operates on.+storeEntrypointOpsSubmapField+ :: ( StoreHasSubmap store epmName MText (EntrypointLambda epParam epStore)+ , StoreHasField store epsName epStore+ , KnownValue epParam, KnownValue epStore+ )+ => Label epmName -> Label epsName+ -> StoreEntrypointOps store epName epParam epStore+storeEntrypointOpsSubmapField mapLabel fieldLabel = StoreEntrypointOps+ { sopToEpLambda = \l -> pushStEp l # stGet mapLabel # someStEp l+ , sopSetEpLambda = \l -> setStEp mapLabel l+ , sopToEpStore = \_l -> stToField fieldLabel+ , sopSetEpStore = \_l -> stSetField fieldLabel+ }+ -- | Implementation of 'StoreHasField' for a data type which has an -- instance of 'StoreHasField' inside. -- For instance, it can be used for top-level storage.@@ -233,6 +406,18 @@ storeSubmapOpsDeeper submapLabel = composeStoreSubmapOps submapLabel storeFieldOpsADT storeSubmapOps +-- | Implementation of 'StoreHasEntrypoint' for a data type which has an+-- instance of 'StoreHasEntrypoint' inside.+-- For instance, it can be used for top-level storage.+storeEntrypointOpsDeeper+ :: ( HasFieldOfType store nameInStore substore+ , StoreHasEntrypoint substore epName epParam epStore+ )+ => Label nameInStore+ -> StoreEntrypointOps store epName epParam epStore+storeEntrypointOpsDeeper fieldsLabel =+ composeStoreEntrypointOps fieldsLabel storeFieldOpsADT storeEpOps+ {- | Pretend that given 'StoreSubmapOps' implementation is made up for submap with name @desiredName@, not its actual name. Logic of the implementation remains the same.@@ -259,8 +444,8 @@ , sopInsert = (\op _l -> op l) <$> sopInsert } --- | Pretend that given 'StoreSubmapOps' implementation is made up--- for submap with name @desiredName@, not its actual name.+-- | Pretend that given 'StoreFieldOps' implementation is made up+-- for field with name @desiredName@, not its actual name. -- Logic of the implementation remains the same. -- -- See also 'storeSubmapOpsReferTo'.@@ -274,6 +459,22 @@ , sopSetField = \_l -> sopSetField l } +-- | Pretend that given 'StoreEntrypointOps' implementation is made up+-- for entrypoint with name @desiredName@, not its actual name.+-- Logic of the implementation remains the same.+--+-- See also 'storeSubmapOpsReferTo'.+storeEntrypointOpsReferTo+ :: Label epName+ -> StoreEntrypointOps store epName epParam epStore+ -> StoreEntrypointOps store desiredName epParam epStore+storeEntrypointOpsReferTo l StoreEntrypointOps{..} = StoreEntrypointOps+ { sopToEpLambda = \_l -> sopToEpLambda l+ , sopSetEpLambda = \_l -> sopSetEpLambda l+ , sopToEpStore = \_l -> sopToEpStore l+ , sopSetEpStore = \_l -> sopSetEpStore l+ }+ -- | Chain two implementations of field operations. -- -- Suits for a case when your store does not contain its fields directly@@ -323,7 +524,68 @@ sopSetField ops1 l1 } +composeStoreEntrypointOps+ :: Label nameInStore+ -> StoreFieldOps store nameInStore substore+ -> StoreEntrypointOps substore epName epParam epStore+ -> StoreEntrypointOps store epName epParam epStore+composeStoreEntrypointOps l1 ops1 ops2 = StoreEntrypointOps+ { sopToEpLambda = \l2 ->+ sopToField ops1 l1 # sopToEpLambda ops2 l2+ , sopSetEpLambda = \l2 ->+ L.dip (L.dup # sopToField ops1 l1) #+ sopSetEpLambda ops2 l2 #+ sopSetField ops1 l1+ , sopToEpStore = \l2 ->+ sopToField ops1 l1 # sopToEpStore ops2 l2+ , sopSetEpStore = \l2 ->+ L.dip (L.dup # sopToField ops1 l1) #+ sopSetEpStore ops2 l2 #+ sopSetField ops1 l1+ }++-- | Utility to 'push' the 'MText' name of and entrypoint from its 'Label'+pushStEp :: Label name -> s :-> MText : s+pushStEp = L.push . labelToMText++-- | Utility to extract an 'EntrypointLambda' from a 'Maybe', fails in case of+-- 'Nothing'.+someStEp+ :: Label epName+ -> Maybe (EntrypointLambda epParam epStore) : s :-> (EntrypointLambda epParam epStore) : s+someStEp l = L.ifSome L.nop $+ failUnexpected ([mt|unknown storage entrypoint: |] <> labelToMText l)++-- | Utility to set an 'EntrypointLambda' into a store.+-- Fails in case the entrypoint is already set.+setStEp+ :: StoreHasSubmap store epmName MText (EntrypointLambda epParam epStore)+ => Label epmName -> Label epsName+ -> (EntrypointLambda epParam epStore) : store : s :-> store : s+setStEp ml l = pushStEp l # stInsertNew ml failAlreadySetEp+ where+ failAlreadySetEp :: MText : s :-> any+ failAlreadySetEp =+ L.push [mt|Storage entrypoint already set: |] # L.concat # L.failWith+ ----------------------------------------------------------------------------+-- Storage generation+----------------------------------------------------------------------------++-- Note: we could make this safer with a 'StoreHasEntrypoint' constraint, but GHC+-- would flag it as redundant and we'd also need to annotate the @store@+--+-- | Utility to create 'EntrypointsField's from an entrypoint name (@epName@) and+-- an 'EntrypointLambda' implementation. Note that you need to merge multiple of+-- these (with '<>') if your field contains more than one entrypoint lambda.+mkStoreEp+ :: Label epName+ -> EntrypointLambda epParam epStore+ -> EntrypointsField epParam epStore+mkStoreEp l = BigMap . singleton (labelToMText l)+++---------------------------------------------------------------------------- -- Utilities ---------------------------------------------------------------------------- @@ -331,14 +593,19 @@ data k ~> v infix 9 ~> +-- | Indicates a stored entrypoint with the given @param@ and @store@ types.+data param ::-> store+infix 9 ::->+ {- | Concise way to write down constraints with expected content of a storage. Use it like follows: @-type StorageConstraint = StorageContains+type StorageConstraint store = StorageContains store [ "fieldInt" := Int , "fieldNat" := Nat+ , "epsToNat" := Int ::-> Nat , "balances" := Address ~> Int ] @@@ -348,5 +615,7 @@ StorageContains _ '[] = () StorageContains store ((n := k ~> v) ': ct) = (StoreHasSubmap store n k v, StorageContains store ct)+ StorageContains store ((n := ep ::-> es) ': ct) =+ (StoreHasEntrypoint store n ep es, StorageContains store ct) StorageContains store ((n := ty) ': ct) = (StoreHasField store n ty, StorageContains store ct)
src/Lorentz/Test.hs view
@@ -17,13 +17,11 @@ -- * Integrational testing -- ** Testing engine- , IntegrationalValidator- , SuccessValidator , IntegrationalScenario , IntegrationalScenarioM- , ValidationError (..)+ , TestError (..) , integrationalTestExpectation- , integrationalTestProperty+ , integrationalTestProp , lOriginate , lOriginateEmpty , lTransfer@@ -31,8 +29,8 @@ , lCallEP , EntryPointRef (..) , lCallDef- , validate , integrationalFail+ , unexpectedInterpreterError , setMaxSteps , setNow , rewindTime@@ -43,15 +41,17 @@ , offshoot -- ** Validators- , composeValidators- , composeValidatorsList- , expectAnySuccess , expectNoUpdates , expectNoStorageUpdates , lExpectStorageUpdate , lExpectBalance , lExpectStorage , lExpectStorageConst++ -- ** Errors+ , attempt+ , expectError+ , catchExpectedError , lExpectMichelsonFailed , lExpectFailWith , lExpectError@@ -80,11 +80,20 @@ , excludeDocTests -- * General utilities- , failedProp- , succeededProp- , qcIsLeft- , qcIsRight+ , failedTest+ , succeededTest+ , eitherIsLeft+ , eitherIsRight+ , total+ , meanTimeUpperBoundProp+ , meanTimeUpperBoundPropNF + -- * Re-exports+ --+ -- | These functions from "Time" are re-exported here to make it convenient to call+ -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'.+ , mcs, ms, sec, minute+ -- * Dummy values , dummyContractEnv @@ -95,6 +104,13 @@ -- * Special contracts for testing , contractConsumer++ -- * Deprecated+ , integrationalTestProperty+ , failedProp+ , succeededProp+ , qcIsLeft+ , qcIsRight ) where import Michelson.Doc.Test
src/Lorentz/Test/Integrational.hs view
@@ -23,13 +23,11 @@ , I.tExpectStorageConst -- * Testing engine- , I.IntegrationalValidator- , SuccessValidator , IntegrationalScenarioM , I.IntegrationalScenario- , I.ValidationError (..)+ , I.TestError (..) , I.integrationalTestExpectation- , I.integrationalTestProperty+ , I.integrationalTestProp , lOriginate , lOriginateEmpty , lTransfer@@ -37,8 +35,8 @@ , lCallEP , EntryPointRef (..) , lCallDef- , I.validate , I.integrationalFail+ , I.unexpectedInterpreterError , I.setMaxSteps , I.setNow , I.rewindTime@@ -49,16 +47,17 @@ , I.offshoot -- * Validators- , I.composeValidators- , I.composeValidatorsList- , I.expectAnySuccess , I.expectNoUpdates , I.expectNoStorageUpdates , lExpectStorageUpdate , lExpectBalance , lExpectStorage , lExpectStorageConst+ -- * Errors+ , I.attempt+ , I.expectError+ , I.catchExpectedError , lExpectMichelsonFailed , lExpectFailWith , lExpectError@@ -71,10 +70,12 @@ -- ** Consumer , lExpectConsumerStorage , lExpectViewConsumerStorage++ -- * Deprecated+ , I.integrationalTestProperty ) where import Data.Constraint (Dict(..))-import Data.Singletons (SingI) import Data.Typeable (gcast) import Fmt (Buildable, listF, (+|), (|+)) import Named ((:!), arg)@@ -192,8 +193,8 @@ validateStorageCb :: forall st addr. (NiceStorage st, ToAddress addr, HasCallStack)- => (Address -> (U.Value -> Either ValidationError ()) -> SuccessValidator)- -> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+ => (Address -> (U.Value -> Either TestError ()) -> IntegrationalScenario)+ -> addr -> (st -> Either I.TestError ()) -> IntegrationalScenario validateStorageCb validator (toAddress -> addr) predicate = validator addr $ \got -> do val <- first I.UnexpectedTypeCheckError $ typeCheck got@@ -209,25 +210,25 @@ lExpectStorage :: forall st addr. (NiceStorage st, ToAddress addr, HasCallStack)- => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+ => addr -> (st -> Either I.TestError ()) -> IntegrationalScenario lExpectStorage = validateStorageCb I.expectStorage -- | Similar to 'expectStorageUpdate', but for Lorentz values. lExpectStorageUpdate :: forall st addr. (NiceStorage st, ToAddress addr, HasCallStack)- => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+ => addr -> (st -> Either I.TestError ()) -> IntegrationalScenario lExpectStorageUpdate = validateStorageCb I.expectStorageUpdate -- | Like 'expectBalance', for Lorentz values.-lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator+lExpectBalance :: ToAddress addr => addr -> Mutez -> IntegrationalScenario lExpectBalance (toAddress -> addr) money = I.expectBalance addr money -- | Similar to 'expectStorageConst', for Lorentz values. lExpectStorageConst :: forall st addr. (NiceStorage st, ToAddress addr)- => addr -> st -> SuccessValidator+ => addr -> st -> IntegrationalScenario lExpectStorageConst (toAddress -> addr) expected = withDict (niceStorageEvi @st) $ I.tExpectStorageConst addr (T.toVal expected)@@ -238,7 +239,7 @@ -- with [FAILED]. lExpectMichelsonFailed :: forall addr. (ToAddress addr)- => (MichelsonFailed -> Bool) -> addr -> ExecutorError -> Bool+ => (MichelsonFailed -> Bool) -> addr -> ExecutorError -> IntegrationalScenario lExpectMichelsonFailed predicate (toAddress -> addr) = I.expectMichelsonFailed predicate addr @@ -246,21 +247,22 @@ -- to match against the given predicate. lExpectFailWith :: forall e.- (Typeable (T.ToT e), T.IsoValue e)- => (e -> Bool) -> ExecutorError -> Bool-lExpectFailWith predicate =- \case- EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->- case gcast err of- Just errT -> predicate $ T.fromVal @e errT- Nothing -> False- _ -> False+ (T.IsoValue e)+ => (e -> Bool) -> ExecutorError -> IntegrationalScenario+lExpectFailWith predicate err =+ case err of+ EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith errVal, _)) ->+ case gcast errVal of+ Just errT | predicate $ T.fromVal @e errT -> pass+ | otherwise -> unexpectedInterpreterError err "predicate failed"+ Nothing -> unexpectedInterpreterError err "failed to cast error"+ _ -> unexpectedInterpreterError err "expected runtime failure with `FAILWITH`" -- | Expect contract to fail with given error. lExpectError :: forall e. (L.IsError e)- => (e -> Bool) -> ExecutorError -> Bool+ => (e -> Bool) -> ExecutorError -> IntegrationalScenario lExpectError = lExpectError' L.errorFromVal -- | Version of 'lExpectError' for the case when numeric@@ -268,30 +270,30 @@ lExpectErrorNumeric :: forall e. (L.IsError e)- => L.ErrorTagMap -> (e -> Bool) -> ExecutorError -> Bool+ => L.ErrorTagMap -> (e -> Bool) -> ExecutorError -> IntegrationalScenario lExpectErrorNumeric errorTagMap = lExpectError' (L.errorFromValNumeric errorTagMap) lExpectError' :: forall e.- (forall t. (Typeable t, SingI t) =>- Value t -> Either Text e)+ (forall t. T.KnownT t => Value t -> Either Text e) -> (e -> Bool) -> ExecutorError- -> Bool-lExpectError' errorFromValImpl predicate =- \case- EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->- case errorFromValImpl err of- Right err' -> predicate err'- Left _ -> False- _ -> False+ -> IntegrationalScenario+lExpectError' errorFromValImpl predicate err =+ case err of+ EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith errVal, _)) ->+ case errorFromValImpl errVal of+ Right err' | predicate err' -> pass+ | otherwise -> unexpectedInterpreterError err "predicate failed"+ Left reason -> unexpectedInterpreterError err reason+ _ -> unexpectedInterpreterError err "expected runtime failure with `FAILWITH`" -- | Expect contract to fail with given 'CustomError'. lExpectCustomError :: forall tag arg. (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)- => Label tag -> arg -> ExecutorError -> Bool+ => Label tag -> arg -> ExecutorError -> IntegrationalScenario lExpectCustomError l a = lExpectError (== L.CustomError l a) @@ -300,7 +302,7 @@ lExpectCustomErrorNumeric :: forall tag arg. (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)- => L.ErrorTagMap -> Label tag -> arg -> ExecutorError -> Bool+ => L.ErrorTagMap -> Label tag -> arg -> ExecutorError -> IntegrationalScenario lExpectCustomErrorNumeric errorTagMap l a = lExpectErrorNumeric errorTagMap (== L.CustomError l a) @@ -308,7 +310,7 @@ lExpectCustomError_ :: forall tag. (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())- => Label tag -> ExecutorError -> Bool+ => Label tag -> ExecutorError -> IntegrationalScenario lExpectCustomError_ l = lExpectCustomError l () @@ -317,7 +319,7 @@ lExpectCustomErrorNumeric_ :: forall tag. (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())- => L.ErrorTagMap -> Label tag -> ExecutorError -> Bool+ => L.ErrorTagMap -> Label tag -> ExecutorError -> IntegrationalScenario lExpectCustomErrorNumeric_ errorTagMap l = lExpectCustomErrorNumeric errorTagMap l () @@ -328,7 +330,7 @@ lExpectConsumerStorage :: forall cp st addr. (st ~ [cp], NiceStorage st, ToTAddress cp addr)- => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+ => addr -> (st -> Either I.TestError ()) -> IntegrationalScenario lExpectConsumerStorage addr = lExpectStorageUpdate (toTAddress @cp addr) -- | Assuming that "consumer" contract receives a value from 'View', expect@@ -343,11 +345,11 @@ , NiceStorage st , ToTAddress cp addr )- => addr -> [cp] -> SuccessValidator+ => addr -> [cp] -> IntegrationalScenario lExpectViewConsumerStorage addr expected = lExpectConsumerStorage addr (matchExpected . reverse) where- mkError = Left . I.CustomValidationError+ mkError = Left . I.CustomTestError matchExpected got | got == expected = pass | otherwise = mkError $ "Expected " +| listF expected |+
src/Lorentz/TypeAnns.hs view
@@ -11,13 +11,13 @@ , insertTypeAnn ) where -import Data.Singletons (SingI) import qualified GHC.Generics as G import Named (NamedF) import Michelson.Text import Michelson.Typed- (BigMap, ContractRef(..), EpAddress, Notes(..), Operation, ToT, insertTypeAnn, starNotes)+ (BigMap, ContractRef(..), EpAddress, KnownIsoT, Notes(..), Operation, ToT, insertTypeAnn,+ starNotes) import Michelson.Typed.Haskell.Value (GValueType) import Michelson.Untyped (TypeAnn, ann, noAnn) import Tezos.Address@@ -101,7 +101,7 @@ instance (HasTypeAnn k, HasTypeAnn v) => HasTypeAnn (BigMap k v) where getTypeAnn = NTBigMap noAnn (getTypeAnn @k) (getTypeAnn @v) -instance (SingI (ToT v), Typeable (ToT v)) => HasTypeAnn (Set v) where+instance (KnownIsoT v) => HasTypeAnn (Set v) where getTypeAnn = starNotes instance (HasTypeAnn a) => HasTypeAnn [a] where
src/Lorentz/UStore.hs view
@@ -62,12 +62,18 @@ , liftUStore , unliftUStore + -- * Documentation+ , UStoreTemplateHasDoc (..)+ , UStoreMarkerHasDoc (..)+ -- * UStore management from Haskell- , UStoreConversible , mkUStore , ustoreDecompose , ustoreDecomposeFull , fillUStore+ , MkUStoreTW+ , DecomposeUStoreTW+ , FillUStoreTW -- * Migrations , MigrationScript (..)@@ -87,11 +93,14 @@ -- * 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
+ src/Lorentz/UStore/Doc.hs view
@@ -0,0 +1,236 @@+-- 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 DocItemPosition DUStoreTemplate = 12700+ type DocItemPlacement DUStoreTemplate = 'DocItemInDefinitions++ 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)+ ]+ }
src/Lorentz/UStore/Haskell.hs view
@@ -6,37 +6,36 @@ -- | Conversion between 'UStore' in Haskell and Michelson representation. module Lorentz.UStore.Haskell- ( UStoreContent- , UStoreConversible- , mkUStore+ ( mkUStore+ , MkUStoreTW , ustoreDecompose , ustoreDecomposeFull+ , DecomposeUStoreTW , fillUStore , migrateFillUStore , fillUStoreMigrationBlock+ , FillUStoreTW ) where -import qualified Data.Kind as Kind+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 GHC.Generics ((:*:)(..), (:+:)(..))-import qualified GHC.Generics as G-import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal) import Lorentz.Base import Lorentz.Coercions import Lorentz.Constraints import qualified Lorentz.Instr as L import Lorentz.Pack-import Lorentz.UStore.Common import Lorentz.UStore.Migration import Lorentz.UStore.Migration.Diff+import Lorentz.UStore.Traversal import Lorentz.UStore.Types-import Michelson.Interpret.Pack import Michelson.Text import Michelson.Typed.Haskell.Value import Util.Type@@ -46,9 +45,9 @@ -- | Make 'UStore' from separate @big_map@s and fields. mkUStore- :: (UStoreConversible template)+ :: (UStoreTraversable MkUStoreTW template) => template -> UStore template-mkUStore = UStore . BigMap . mkUStoreRec+mkUStore = UStore . BigMap . mkUStoreInternal -- | Decompose 'UStore' into separate @big_map@s and fields. --@@ -61,21 +60,33 @@ -- were violated. ustoreDecompose :: forall template.- (UStoreConversible template)+ (UStoreTraversable DecomposeUStoreTW template) => UStore template -> Either Text (UStoreContent, template)-ustoreDecompose = storeDecomposeRec . Map.toList . unBigMap . unUStore+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- :: (UStoreConversible template)+ :: (UStoreTraversable FillUStoreTW template) => template -> UStoreMigration () template-fillUStore v = UStoreMigration $ appEndo (fillUStoreRec v) []+fillUStore v = UStoreMigration $ fillUStoreInternal v -- | Version of 'migrateFillUStore' for batched migrations. -- -- Each field write will be placed to a separate batch. fillUStoreMigrationBlock- :: ( UStoreConversible template+ :: ( UStoreTraversable FillUStoreTW template , allFieldsExp ~ AllUStoreFieldsF template , newDiff ~ FillingNewDiff template diff , newTouched ~ FillingNewTouched template touched@@ -83,7 +94,7 @@ ) => template -> MigrationBlocks oldTempl newTempl diff touched newDiff newTouched-fillUStoreMigrationBlock v = MigrationBlocks $ appEndo (fillUStoreRec v) []+fillUStoreMigrationBlock v = MigrationBlocks $ fillUStoreInternal v -- | Fill 'UStore' with entries from the given template as part of simple -- migration.@@ -94,7 +105,7 @@ -- -- For batched migrations see 'fillUStoreMigrationBlock'. migrateFillUStore- :: ( UStoreConversible template+ :: ( UStoreTraversable FillUStoreTW template , allFieldsExp ~ AllUStoreFieldsF template , newDiff ~ FillingNewDiff template diff , newTouched ~ FillingNewTouched template touched@@ -105,7 +116,7 @@ (MUStore oldTempl newTempl diff touched) (MUStore oldTempl newTempl newDiff newTouched) migrateFillUStore v =- let atoms = appEndo (fillUStoreRec v) []+ let atoms = fillUStoreInternal v script = foldMap (unMigrationScript . maScript) atoms in forcedCoerce_ # script # forcedCoerce_ @@ -119,145 +130,129 @@ -- Implementation ---------------------------------------------------------------------------- --- | Like 'ustoreDecompose', but requires all entries from @UStore@ to be--- recognized.-ustoreDecomposeFull- :: forall template.- (UStoreConversible template)- => UStore template -> Either Text template-ustoreDecomposeFull ustore = do- (remained, res) <- ustoreDecompose ustore- unless (null remained) $- Left $ "Unrecognized entries in UStore: " +|| remained ||+ ""- return res---- | Recursive template traversal for 'mkUStore'.-mkUStoreRec- :: (UStoreConversible template)+-- | Internal helper for 'mkUStore'.+mkUStoreInternal+ :: (UStoreTraversable MkUStoreTW template) => template -> Map ByteString ByteString-mkUStoreRec = gUstoreToVal . G.from+mkUStoreInternal = foldUStore MkUStoreTW --- | Recursive template traversal for 'ustoreDecompose'.-storeDecomposeRec+-- | Internal helper for 'ustoreDecompose'.+storeDecomposeInternal :: forall template.- (UStoreConversible template)+ (UStoreTraversable DecomposeUStoreTW template) => UStoreContent -> Either Text (UStoreContent, template)-storeDecomposeRec = fmap (second G.to) ... gUstoreFromVal+storeDecomposeInternal =+ runExcept . fmap swap . runStateT (genUStore DecomposeUStoreTW) --- | Recursive template traversal for 'fillUStore'.-fillUStoreRec- :: (UStoreConversible template)+-- | Internal helper for 'fillUStore'.+fillUStoreInternal+ :: (UStoreTraversable FillUStoreTW template) => template- -> Endo [MigrationAtom]-fillUStoreRec = gUstoreToScript . G.from---- | Given template can be converted to 'UStore' value.-class (Generic template, GUStoreConversible (G.Rep template)) =>- UStoreConversible template-instance (Generic template, GUStoreConversible (G.Rep template)) =>- UStoreConversible template---- | Generic traversal for 'mkUStore' and 'ustoreDecompose'.-class GUStoreConversible (template :: Kind.Type -> Kind.Type) where- -- | Convert generic value to internal 'UStore' representation.- gUstoreToVal :: template p -> Map ByteString ByteString-- -- | Parse internal 'UStore' representation into generic Haskell value of- -- 'UStore', also returning unparsed entries.- gUstoreFromVal- :: UStoreContent- -> Either Text (UStoreContent, template p)-- -- | Convert generic value to a script filling the corresponding 'UStore'.- gUstoreToScript- :: template p- -> Endo [MigrationAtom]--instance GUStoreConversible x => GUStoreConversible (G.D1 i x) where- gUstoreToVal = gUstoreToVal . G.unM1- gUstoreFromVal = fmap (second G.M1) ... gUstoreFromVal- gUstoreToScript = gUstoreToScript . G.unM1--instance GUStoreConversible x => GUStoreConversible (G.C1 i x) where- gUstoreToVal = gUstoreToVal . G.unM1- gUstoreFromVal = fmap (second G.M1) ... gUstoreFromVal- gUstoreToScript = gUstoreToScript . G.unM1--instance TypeError ('Text "Unexpected sum type in UStore template") =>- GUStoreConversible (x :+: y) where- gUstoreToVal = error "impossible"- gUstoreFromVal = error "impossible"- gUstoreToScript = error "impossible"--instance TypeError ('Text "UStore template should have one constructor") =>- GUStoreConversible G.V1 where- gUstoreToVal = error "impossible"- gUstoreFromVal = error "impossible"- gUstoreToScript = error "impossible"+ -> [MigrationAtom]+fillUStoreInternal a = appEndo (foldUStore FillUStoreTW a) [] -instance (GUStoreConversible x, GUStoreConversible y) =>- GUStoreConversible (x :*: y) where- gUstoreToVal (x :*: y) = gUstoreToVal x <> gUstoreToVal y- gUstoreFromVal entries = do- (entries', res1) <- gUstoreFromVal entries- (entries'', res2) <- gUstoreFromVal entries'- return (entries'', res1 :*: res2)- gUstoreToScript (x :*: y) = gUstoreToScript x <> gUstoreToScript y+-- | Declares handlers for UStore creation from template.+data MkUStoreTW = MkUStoreTW -instance GUStoreConversible G.U1 where- gUstoreToVal G.U1 = mempty- gUstoreFromVal entries = pure (entries, G.U1)- gUstoreToScript G.U1 = mempty+instance UStoreTraversalWay MkUStoreTW where+ type UStoreTraversalArgumentWrapper MkUStoreTW = Identity+ type UStoreTraversalMonad MkUStoreTW = Const (Map ByteString ByteString) --- | Case of nested template.-instance {-# OVERLAPPABLE #-}- (UStoreConversible template) =>- GUStoreConversible (G.S1 i (G.Rec0 template)) where- gUstoreToVal = mkUStoreRec . G.unK1 . G.unM1- gUstoreFromVal = fmap (second $ G.M1 . G.K1) ... storeDecomposeRec- gUstoreToScript = fillUStoreRec . G.unK1 . G.unM1+instance (NicePackedValue val) =>+ UStoreTraversalFieldHandler MkUStoreTW marker val where+ ustoreTraversalFieldHandler MkUStoreTW fieldName (Identity val) =+ Const $+ one ( mkFieldMarkerUKeyL @marker fieldName+ , lPackValue val+ ) --- | Case of '|~>'.-instance ( NiceFullPackedValue k, NiceFullPackedValue v- , KnownSymbol fieldName, Ord k- ) =>- GUStoreConversible (G.S1 ('G.MetaSel ('Just fieldName) _1 _2 _3)- (G.Rec0 (k |~> v))) where- gUstoreToVal (G.M1 (G.K1 (UStoreSubMap m))) =+instance (NicePackedValue k, NicePackedValue v) =>+ UStoreTraversalSubmapHandler MkUStoreTW k v where+ ustoreTraversalSubmapHandler MkUStoreTW fieldName (Identity m) =+ Const $ mconcat- [ one ( lPackValue (fieldNameToMText @fieldName, k)+ [ one ( lPackValue (labelToMText fieldName, k) , lPackValue v ) | (k, v) <- Map.toList m ] - gUstoreFromVal allEntries = do- (unrecognized, res) <- foldM parseEntry (mempty, mempty) allEntries- return (unrecognized, G.M1 . G.K1 $ UStoreSubMap res)- where- parseEntry- :: (UStoreContent, Map k v)- -> (ByteString, ByteString)- -> Either Text (UStoreContent, Map k v)- parseEntry (entries, !acc) entry@(key, val) =- case lUnpackValue @(UStoreSubmapKey _) key of- Left _ -> Right (entry : entries, acc)+-- | 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)- | toText name /= toText (symbolVal $ Proxy @fieldName) ->- Right (entry : entries, acc)+ | name /= labelToMText fieldName ->+ mzero | otherwise ->- case lUnpackValue val of- Left err ->- Left $ "Failed to parse UStore value for " +|- demote @(ToT k) |+ " |~> " +| demote @(ToT v) |+- ": " +| err |+ ""+ case lUnpackValue value of+ Left err -> throwError $+ "Failed to parse UStore value for " +|+ demote @(ToT k) |+ " |~> " +| demote @(ToT v) |++ ": " +| err |+ "" Right valValue ->- Right (entries, Map.insert keyValue valValue acc)+ pure (keyValue, valValue) - gUstoreToScript (G.M1 (G.K1 (UStoreSubMap m))) = Endo . (<>) $+-- | 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") (fromLabel @fieldName) (Proxy @v) #+ 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@@ -267,45 +262,23 @@ -- or -- TODO: add necessary rules to optimizer L.push v # L.pack # L.some #- L.push k # L.push (fieldNameToMText @fieldName) # L.pair #+ L.push k # L.push (labelToMText fieldName) # L.pair # L.pack @(UStoreSubmapKey _) # L.update --- | Case of 'UStoreField'.-instance (NiceFullPackedValue v, KnownUStoreMarker m, KnownSymbol fieldName) =>- GUStoreConversible (G.S1 ('G.MetaSel ('Just fieldName) _1 _2 _3)- (G.Rec0 (UStoreFieldExt m v))) where- gUstoreToVal (G.M1 (G.K1 (UStoreField val))) =- one ( mkFieldMarkerUKeyL @m (fromLabel @fieldName)- , lPackValue val- )-- gUstoreFromVal entries =- let key = packValue' $ toVal (fieldNameToMText @fieldName)- in case L.partition ((== key) . fst) entries of- ([], _) ->- Left $ "Failed to find field in UStore: " +|- fieldNameToMText @fieldName |+ ""- ([(_, val)], otherEntries) ->- case lUnpackValue val of- Left err ->- Left $ "Failed to parse UStore value for field " +|- demote @(ToT v) |+ ": " +| err |+ ""- Right valValue ->- Right (otherEntries, G.M1 . G.K1 $ UStoreField valValue)- (_ : _ : _, _) ->- error "UStore content contained multiple entries with the same key"-- gUstoreToScript (G.M1 (G.K1 (UStoreField val))) =- Endo . (:) . formMigrationAtom Nothing $- attachMigrationActionName (DAddAction "init field") (fromLabel @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 @m (fromLabel @fieldName)) #- 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 ----------------------------------------------------------------------------
src/Lorentz/UStore/Migration.hs view
@@ -61,7 +61,7 @@ @ Migration blocks have to be the smallest actions which can safely be mixed- and splitted accross migration stages.+ and splitted across migration stages. 3. Compile migration with 'compileBatchedMigration'.
src/Lorentz/UStore/Migration/Base.hs view
@@ -107,15 +107,18 @@ import Lorentz.Base import Lorentz.Coercions import Lorentz.Doc+import Lorentz.UStore.Doc+import Lorentz.TypeAnns (HasTypeAnn) import Lorentz.Instr (nop) import Lorentz.Run-import Lorentz.TypeAnns (HasTypeAnn) 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@@ -142,6 +145,14 @@ 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 ----------------------------------------------------------------------------@@ -158,12 +169,27 @@ instance Wrapped (MigrationScript oldStore newStore) -instance (Typeable oldStore, Typeable newStore) =>+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."- typeDocMdReference tp = customTypeDocMdReference ("MigrationScript", DType tp) []+ \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
+ src/Lorentz/UStore/Traversal.hs view
@@ -0,0 +1,193 @@+-- 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)
src/Lorentz/UStore/Types.hs view
@@ -35,6 +35,10 @@ , MSValue , FSValue , FSMarker++ -- * Generators+ , genUStoreSubMap+ , genUStoreFieldExt ) where import Control.Lens (Wrapped)@@ -42,13 +46,16 @@ import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)+import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range import Test.QuickCheck (Arbitrary) -import Lorentz.Doc import Lorentz.Pack-import Lorentz.Polymorphic import Lorentz.TypeAnns (HasTypeAnn)+import Lorentz.Polymorphic import Lorentz.Value+import Michelson.Test.Util (genTuple2) import Michelson.Text (labelToMText) import Michelson.Typed.T import Util.Type@@ -86,9 +93,10 @@ -- | Specific kind used to designate markers for 'UStoreFieldExt'. -- -- We suggest that fields may serve different purposes and so annotated with--- special markers accordingly. See example below.+-- special markers accordingly, which influences translation to Michelson.+-- See example below. ----- This kind is implemented like that because we want markers to differ from all+-- 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@@ -97,18 +105,6 @@ type UStoreField = UStoreFieldExt UMarkerPlainField data UMarkerPlainField :: UStoreMarkerType -instance Typeable template => TypeHasDoc (UStore template) where- typeDocName _ = "Upgradeable storage"- typeDocMdDescription =- "Storage with not hardcoded structure, which allows upgrading the contract \- \in place. UStore is capable of storing simple fields and multiple submaps. \- \For simple fields key is serialized field name. For submap element big_map \- \key is serialized `(submapName, keyValue)`."- typeDocMdReference tp =- customTypeDocMdReference ("UStore", DType tp) []- typeDocHaskellRep = homomorphicTypeDocHaskellRep- typeDocMichelsonRep = homomorphicTypeDocMichelsonRep- -- | What do we serialize when constructing big_map key for accessing -- an UStore submap. type UStoreSubmapKey k = (MText, k)@@ -284,3 +280,13 @@ '[] GPickMarkedFields m (G.S1 _ (G.Rec0 a)) = PickMarkedFields m a++----------------------------------------------------------------------------+-- Generators+----------------------------------------------------------------------------++genUStoreSubMap :: (MonadGen m, Ord k) => m k -> m v -> m (k |~> v)+genUStoreSubMap genK genV = UStoreSubMap <$> Gen.map (Range.linear 0 100) (genTuple2 genK genV)++genUStoreFieldExt :: MonadGen m => m v -> m (UStoreFieldExt marker v)+genUStoreFieldExt genV = UStoreField <$> genV
src/Lorentz/Zip.hs view
@@ -27,7 +27,7 @@ import Michelson.Untyped (noAnn) -- | Zipping stack into tuple and back.-class ZipInstr (s :: [Kind.Type]) where+class (KnownIsoT (ZippedStack s)) => ZipInstr (s :: [Kind.Type]) where -- | A type which contains the whole stack zipped. type ZippedStack s :: Kind.Type @@ -46,7 +46,7 @@ zipInstr = I UNIT unzipInstr = I DROP -instance ZipInstr '[a] where+instance (KnownIsoT a) => ZipInstr '[a] where type ZippedStack '[a] = a zipInstr = I Nop unzipInstr = I Nop
test/Test/Doc.hs view
@@ -13,15 +13,16 @@ import qualified Data.Set as Set import Fmt (build)+import Hedgehog (property) import Test.HUnit (assertBool, assertFailure, (@?=))-import Test.QuickCheck (total) import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase)-import Test.Tasty.QuickCheck (testProperty) import Lorentz (( # )) import qualified Lorentz as L import Michelson.Doc+import Michelson.Test (total) import Michelson.Typed import Util.Named @@ -91,7 +92,7 @@ deriving anyclass (IsoValue) instance TypeHasDoc MyLoopedType where- typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyLoopedType)]+ typeDocDependencies _ = [dTypeDep @MyLoopedType] typeDocMdDescription = "" newtype MyMutuallyDependentType1 = MyMutuallyDependentType1 Integer@@ -103,21 +104,21 @@ deriving anyclass (IsoValue) instance TypeHasDoc MyMutuallyDependentType1 where- typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType2)]+ typeDocDependencies _ = [dTypeDep @MyMutuallyDependentType2] typeDocMdDescription = "" instance TypeHasDoc MyMutuallyDependentType2 where- typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType1)]+ typeDocDependencies _ = [dTypeDep @MyMutuallyDependentType1] typeDocMdDescription = "" test_Dependencies_loops :: [TestTree] test_Dependencies_loops =- [ testProperty "Type depending on itself" $+ [ testProperty "Type depending on itself" $ property $ let contract = L.doc $ DType (Proxy @MyLoopedType)- in total . contractDocToMarkdown $ L.buildLorentzDoc contract- , testProperty "Mutually dependent types" $+ in void . total . contractDocToMarkdown $ L.buildLorentzDoc contract+ , testProperty "Mutually dependent types" $ property $ let contract = L.doc $ DType (Proxy @MyMutuallyDependentType1)- in total . contractDocToMarkdown $ L.buildLorentzDoc contract+ in void . total . contractDocToMarkdown $ L.buildLorentzDoc contract ] -- Functions semantics
test/Test/Lorentz/EntryPoints.hs view
@@ -454,8 +454,7 @@ caller <- lOriginate myCallerContract "Caller" () (toMutez 10) target <- lOriginateEmpty myTargetContract "Call target" lCallDef caller target- validate . Right $- lExpectStorageConst target (5 :: Natural)+ lExpectStorageConst target (5 :: Natural) , testCase "Calling default entrypoint" $ integrationalTestExpectation $ do@@ -468,8 +467,7 @@ caller <- lOriginate myCallerContract "Caller" () (toMutez 10) target <- lOriginateEmpty myTargetContract "Call target" lCallDef caller target- validate . Right $- lExpectStorageConst target (3 :: Natural)+ lExpectStorageConst target (3 :: Natural) ] test_Self_call :: [TestTree]@@ -486,6 +484,5 @@ contractRef <- lOriginate myContract "Contract" 0 (toMutez 10) lCallDef contractRef Do10- validate . Right $- lExpectStorageConst contractRef (15 :: Natural)+ lExpectStorageConst contractRef (15 :: Natural) ]
test/Test/Lorentz/Errors.hs view
@@ -135,8 +135,7 @@ let (voidSample', errorTagMap) = useNumericErrors voidSample ref <- lOriginate (defaultContract voidSample') "voidSample" () minBound- lCall ref (mkVoid True)- validate . Left $+ lCall ref (mkVoid True) `catchExpectedError` lExpectErrorNumeric errorTagMap (== VoidResult False) voidSample :: ContractCode (Void_ Bool Bool) ()
test/Test/Lorentz/Interpreter.hs view
@@ -78,11 +78,11 @@ contractWithDefTy = U.Type (U.TOr (U.ann "a") (U.ann "default") (U.Type U.TNat U.noAnn) (U.Type U.TString U.noAnn)) U.noAnn- addr = mkContractAddressRaw+ addr = ContractAddress . mkContractHashHack env =- [ (mkContractHashRaw "simple", U.ParameterType contractSimpleTy U.noAnn)- , (mkContractHashRaw "complex", U.ParameterType contractComplexTy U.noAnn)- , (mkContractHashRaw "def", U.ParameterType contractWithDefTy U.noAnn)+ [ (mkContractHashHack "simple", U.ParameterType contractSimpleTy U.noAnn)+ , (mkContractHashHack "complex", U.ParameterType contractComplexTy U.noAnn)+ , (mkContractHashHack "def", U.ParameterType contractWithDefTy U.noAnn) ] test_Entry_points_calling :: IO [TestTree]@@ -102,8 +102,7 @@ tTransfer (#from .! genesisAddress) (#to .! callerRef) (toMutez 1) T.DefEpName (toVal targetRef) - validate . Right $- tExpectStorageConst targetRef (toVal @Integer 5)+ tExpectStorageConst targetRef (toVal @Integer 5) , testCase "Calling some entrypoint in SELF" $ integrationalTestExpectation $ do@@ -112,8 +111,7 @@ tTransfer (#from .! genesisAddress) (#to .! contractRef) (toMutez 1) T.DefEpName (toVal $ Right @Integer ()) - validate . Right $- tExpectStorageConst contractRef (toVal @Integer 5)+ tExpectStorageConst contractRef (toVal @Integer 5) ] where dir = entrypointsDir
+ test/Test/Lorentz/StoreClass.hs view
@@ -0,0 +1,143 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.StoreClass+ ( test_Storage_entrypoints+ ) where++import Prelude hiding (swap)++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz.Address+import Lorentz.ADT+import Lorentz.Base+import Lorentz.EntryPoints+import Lorentz.EntryPoints.Doc+import Lorentz.Instr+import Lorentz.Macro+import Lorentz.Run+import Lorentz.StoreClass+import Lorentz.Test+import Lorentz.TypeAnns (HasTypeAnn)+import Michelson.Text (mt)+import Michelson.Typed (IsoValue)+import Tezos.Core (toMutez)++----------------------------------------------------------------------------+-- Storage Entrypoints - Types+----------------------------------------------------------------------------++data ParameterEpTest+ = AddNat Natural+ | SubNat Natural+ | GetValue (View () Natural)+ | SetSubNat (EntrypointLambda Natural Natural)+ deriving stock Generic+ deriving anyclass (IsoValue, HasTypeAnn)++instance ParameterHasEntryPoints ParameterEpTest where+ type ParameterEntryPointsDerivation ParameterEpTest = EpdPlain++data StorageEpTest = StorageEpTest+ { epNats :: EntrypointsField Natural Natural+ , storeNat :: Natural+ } deriving stock Generic+ deriving anyclass IsoValue++instance StoreHasEntrypoint StorageEpTest "addNat" Natural Natural where+ storeEpOps = storeEntrypointOpsADT #epNats #storeNat++instance StoreHasEntrypoint StorageEpTest "subNat" Natural Natural where+ storeEpOps = storeEntrypointOpsADT #epNats #storeNat++instance StoreHasField StorageEpTest "storeNat" Natural where+ storeFieldOps = storeFieldOpsADT++type StorageIsEpTest store = StorageContains store+ [ "addNat" := Natural ::-> Natural+ , "subNat" := Natural ::-> Natural+ , "storeNat" := Natural+ ]++----------------------------------------------------------------------------+-- Storage Entrypoints - Impl+----------------------------------------------------------------------------++addNat :: EntrypointLambda Natural Natural+addNat = unpair # add # nil # pair++subNat :: EntrypointLambda Natural Natural+subNat = unpair # swap # sub # isNat # ifSome nop (push 0) # nil # pair++mkStorageEpTestFull :: Natural -> StorageEpTest+mkStorageEpTestFull n = StorageEpTest+ { epNats = mkStoreEp #addNat addNat <> mkStoreEp #subNat subNat+ , storeNat = n+ }++mkStorageEpTestPart :: Natural -> StorageEpTest+mkStorageEpTestPart n = StorageEpTest+ { epNats = mkStoreEp #addNat addNat+ , storeNat = n+ }++contractEpTest :: StorageIsEpTest store => ContractCode ParameterEpTest store+contractEpTest = unpair # entryCaseSimple @ParameterEpTest+ ( #cAddNat /-> stEntrypoint #addNat+ , #cSubNat /-> stEntrypoint #subNat+ , #cGetValue /-> view_ (cdr # stToField #storeNat)+ , #cSetSubNat /-> stSetEpLambda #subNat # nil # pair+ )++----------------------------------------------------------------------------+-- Storage Entrypoints - Tests+----------------------------------------------------------------------------++lOriginateEpContract :: StorageEpTest -> IntegrationalScenarioM (TAddress ParameterEpTest)+lOriginateEpContract st = lOriginate (defaultContract contractEpTest) "StEps" st (toMutez 0)++test_Storage_entrypoints :: [TestTree]+test_Storage_entrypoints =+ [ testCase "Executes both entrypoints correctly when set at origination" $+ integrationalTestExpectation $ do+ testCon <- lOriginateEpContract $ mkStorageEpTestFull 10+ consumer <- lOriginateEmpty @Natural contractConsumer "consumer"++ lCallDef testCon $ GetValue (mkView () consumer)+ lCallDef testCon $ AddNat 10+ lCallDef testCon $ GetValue (mkView () consumer)+ lCallDef testCon $ SubNat 5+ lCallDef testCon $ GetValue (mkView () consumer)++ lExpectViewConsumerStorage consumer [10, 20, 15]+ , testCase "Cannot set entrypoint that was set at origination" $+ integrationalTestExpectation $ do+ testCon <- lOriginateEpContract $ mkStorageEpTestFull 10++ lCallDef testCon (SetSubNat subNat) `catchExpectedError`+ lExpectFailWith (== [mt|Storage entrypoint already set: subNat|])+ , testCase "Cannot set entrypoint twice" $+ integrationalTestExpectation $ do+ testCon <- lOriginateEpContract $ mkStorageEpTestPart 10++ lCallDef testCon $ SetSubNat subNat+ lCallDef testCon (SetSubNat subNat) `catchExpectedError`+ lExpectFailWith (== [mt|Storage entrypoint already set: subNat|])+ , testCase "Executes correctly entrypoint set after origination" $+ integrationalTestExpectation $ do+ testCon <- lOriginateEpContract $ mkStorageEpTestPart 10+ consumer <- lOriginateEmpty @Natural contractConsumer "consumer"++ lCallDef testCon $ GetValue (mkView () consumer)+ lCallDef testCon $ AddNat 5+ lCallDef testCon $ GetValue (mkView () consumer)++ lCallDef testCon $ SetSubNat subNat+ lCallDef testCon $ SubNat 20+ lCallDef testCon $ GetValue (mkView () consumer)++ lExpectViewConsumerStorage consumer [10, 15, 0]+ ]
test/Test/Lorentz/UStore/Behaviour.hs view
@@ -9,28 +9,33 @@ , test_Script ) where -import Data.Default (def) import qualified Data.Map as M+import Hedgehog (Gen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range import Test.HUnit (Assertion, assertFailure, (@?=))-import Test.QuickCheck (Arbitrary(..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Lorentz.Base import Lorentz.Instr as L+import Lorentz.Pack import Lorentz.Run import Lorentz.UStore+import Lorentz.Value+import Lorentz.UStore.Types (genUStoreFieldExt, genUStoreSubMap) import Michelson.Test.Dummy import Michelson.Test.Util-import Util.Test.Arbitrary () data MyTemplate = MyTemplate { ints :: Integer |~> () , bool :: UStoreField Bool } deriving stock (Eq, Show, Generic) -instance Arbitrary MyTemplate where- arbitrary = MyTemplate <$> arbitrary <*> arbitrary+genMyTemplate :: Gen MyTemplate+genMyTemplate = MyTemplate+ <$> genUStoreSubMap (Gen.integral (Range.linearFrom 0 -1000 1000)) (pure ())+ <*> genUStoreFieldExt Gen.bool data MyTemplateBig = MyTemplateBig { small :: MyTemplate@@ -38,13 +43,31 @@ , total :: UStoreField Integer } deriving stock (Eq, Show, Generic) -instance Arbitrary MyTemplateBig where- arbitrary = MyTemplateBig <$> arbitrary <*> arbitrary <*> arbitrary+genMyTemplateBig :: Gen MyTemplateBig+genMyTemplateBig = MyTemplateBig+ <$> genMyTemplate+ <*> genUStoreSubMap (Gen.bytes (Range.linear 0 100)) (Gen.integral (Range.linear 0 1000))+ <*> genUStoreFieldExt (Gen.integral (Range.linearFrom 0 -1000 1000)) +data MyMarker :: UStoreMarkerType+instance KnownUStoreMarker MyMarker where+ mkFieldMarkerUKey name = lPackValue ([mt|X|] <> name)++data MyTemplateWithMarker = MyTemplateWithMarker+ { mint :: UStoreField Integer+ , mbool :: UStoreFieldExt MyMarker Bool+ } deriving stock (Eq, Show, Generic)++genMyTemplateWithMarker :: Gen MyTemplateWithMarker+genMyTemplateWithMarker = MyTemplateWithMarker+ <$> genUStoreFieldExt (Gen.integral (Range.linearFrom 0 -1000 1000))+ <*> genUStoreFieldExt Gen.bool+ test_Roundtrip :: [TestTree] test_Roundtrip =- [ roundtripTest (mkUStore @MyTemplate) ustoreDecomposeFull- , roundtripTest (mkUStore @MyTemplateBig) ustoreDecomposeFull+ [ roundtripTree genMyTemplate (mkUStore @MyTemplate) ustoreDecomposeFull+ , roundtripTree genMyTemplateBig (mkUStore @MyTemplateBig) ustoreDecomposeFull+ , roundtripTree genMyTemplateWithMarker (mkUStore @MyTemplateWithMarker) ustoreDecomposeFull ] test_Conversions :: [TestTree]@@ -123,7 +146,11 @@ where -- We accept a tuple as argument to avoid many parentheses ustoreChangeTest- :: (Each [Eq, Show, Generic, UStoreConversible] '[template], HasCallStack)+ :: ( Each [Eq, Show, Generic] '[template]+ , UStoreTraversable MkUStoreTW template+ , UStoreTraversable DecomposeUStoreTW template+ , HasCallStack+ ) => ( '[UStore template] :-> '[UStore template] , template , template@@ -162,7 +189,11 @@ ] where ustoreScriptTest- :: (Each [Eq, Show, Generic, UStoreConversible] '[template], HasCallStack)+ :: ( Each [Eq, Show, Generic] '[template]+ , UStoreTraversable FillUStoreTW template+ , UStoreTraversable DecomposeUStoreTW template+ , HasCallStack+ ) => template -> Assertion ustoreScriptTest store =