lorentz 0.4.0 → 0.5.0

raw patch · 77 files changed

+1979/−6162 lines, 77 filesdep −HUnitdep −filepathdep −formattingdep ~constraintsdep ~first-class-familiesdep ~morley-preludePVP ok

version bump matches the API change (PVP)

Dependencies removed: HUnit, filepath, formatting, ghc-prim, hedgehog, lorentz, spoon, tasty, tasty-hedgehog, tasty-hunit-compat, template-haskell, type-spec

Dependency ranges changed: constraints, first-class-families, morley-prelude

API changes (from Hackage documentation)

Files

• CHANGES.md +13/−3
• README.md +10/−6
• lorentz.cabal +11/−90
• src/Lorentz.hs +3/−3
• src/Lorentz/Address.hs +14/−14
• src/Lorentz/Annotation.hs +187/−0
• src/Lorentz/Coercions.hs +6/−9
• src/Lorentz/Constraints/Derivative.hs +2/−2
• src/Lorentz/Constraints/Scopes.hs +5/−3
• src/Lorentz/ContractRegistry.hs +8/−6
• src/Lorentz/Doc.hs +1/−0
• src/Lorentz/Empty.hs +2/−2
• src/Lorentz/EntryPoints.hs +0/−52
• src/Lorentz/EntryPoints/Core.hs +0/−499
• src/Lorentz/EntryPoints/Doc.hs +0/−563
• src/Lorentz/EntryPoints/Helpers.hs +0/−59
• src/Lorentz/EntryPoints/Impl.hs +0/−364
• src/Lorentz/EntryPoints/Manual.hs +0/−43
• src/Lorentz/Entrypoints.hs +52/−0
• src/Lorentz/Entrypoints/Core.hs +499/−0
• src/Lorentz/Entrypoints/Doc.hs +563/−0
• src/Lorentz/Entrypoints/Helpers.hs +59/−0
• src/Lorentz/Entrypoints/Impl.hs +364/−0
• src/Lorentz/Entrypoints/Manual.hs +41/−0
• src/Lorentz/Errors.hs +3/−131
• src/Lorentz/Errors/Numeric/Doc.hs +1/−1
• src/Lorentz/Extensible.hs +2/−4
• src/Lorentz/Instr.hs +13/−13
• src/Lorentz/Macro.hs +12/−7
• src/Lorentz/Run.hs +7/−5
• src/Lorentz/Store.hs +0/−706
• src/Lorentz/Test.hs +0/−126
• src/Lorentz/Test/Consumer.hs +0/−20
• src/Lorentz/Test/Doc.hs +0/−160
• src/Lorentz/Test/Integrational.hs +0/−356
• src/Lorentz/Test/Unit.hs +0/−32
• src/Lorentz/TestScenario.hs +1/−1
• src/Lorentz/TypeAnns.hs +0/−158
• src/Lorentz/UParam.hs +36/−38
• src/Lorentz/UStore.hs +3/−2
• src/Lorentz/UStore/Doc.hs +1/−1
• src/Lorentz/UStore/Migration/Base.hs +7/−7
• src/Lorentz/UStore/Types.hs +3/−23
• src/Lorentz/Value.hs +11/−4
• src/Lorentz/Wrappable.hs +32/−0
• src/Lorentz/Zip.hs +7/−7
• test/Main.hs +0/−16
• test/Test/Doc.hs +0/−161
• test/Test/DocTest.hs +0/−77
• test/Test/Lorentz/Base.hs +0/−31
• test/Test/Lorentz/Conditionals.hs +0/−32
• test/Test/Lorentz/DeadCode.hs +0/−50
• test/Test/Lorentz/Doc/Positions.hs +0/−42
• test/Test/Lorentz/EntryPoints.hs +0/−488
• test/Test/Lorentz/EntryPoints/Doc.hs +0/−235
• test/Test/Lorentz/Errors.hs +0/−142
• test/Test/Lorentz/Errors/Numeric.hs +0/−71
• test/Test/Lorentz/Extensible.hs +0/−75
• test/Test/Lorentz/Interpreter.hs +0/−120
• test/Test/Lorentz/Macro.hs +0/−78
• test/Test/Lorentz/Pack.hs +0/−47
• test/Test/Lorentz/Print.hs +0/−80
• test/Test/Lorentz/StoreClass.hs +0/−143
• test/Test/Lorentz/UParam.hs +0/−100
• test/Test/Lorentz/UStore/Behaviour.hs +0/−207
• test/Test/Lorentz/UStore/Migration/Batched.hs +0/−80
• test/Test/Lorentz/UStore/Migration/Batched/V1.hs +0/−19
• test/Test/Lorentz/UStore/Migration/Batched/V2.hs +0/−16
• test/Test/Lorentz/UStore/Migration/FillInParts.hs +0/−88
• test/Test/Lorentz/UStore/Migration/Simple.hs +0/−86
• test/Test/Lorentz/UStore/Migration/Simple/V1.hs +0/−17
• test/Test/Lorentz/UStore/Migration/Simple/V2.hs +0/−17
• test/Test/Lorentz/UStore/SafeLift.hs +0/−46
• test/Test/Lorentz/UStore/SafeLift/Helpers.hs +0/−18
• test/Test/Tasty/TypeSpec.hs +0/−31
• test/Test/Util/TypeSpec.hs +0/−24
• test/Tree.hs +0/−5

@@ -1,6 +1,16 @@-Unreleased-==========-<!-- Append new entries here -->+0.5.0+=====+* [!371](https://gitlab.com/morley-framework/morley/-/merge_requests/371)+  Make `view_` argument accept 2 arguments rather than a pair.+* [!486](https://gitlab.com/morley-framework/morley/-/merge_requests/486)+  Add `customGeneric` to derive `Generic` instances with a custom tree structure+  and, consequently, `IsoValue` instances with such a structure.+* [!483](https://gitlab.com/morley-framework/morley/-/merge_requests/483)+  Add a way to generate field annotations for entrypoint parameter.+* [!470](https://gitlab.com/morley-framework/morley/-/merge_requests/470)+  Move `Lorentz.Test` and  Hedgehog generators to a new package: `cleveland`.+* [!357](https://gitlab.com/morley-framework/morley/-/merge_requests/357)+  Remove deprecated `Lorentz.Store` module and deprecated custom error functionality.  0.4.0 =====

@@ -1,5 +1,7 @@ # Morley Lorentz EDSL +[![Hackage](https://img.shields.io/hackage/v/lorentz.svg)](https://hackage.haskell.org/package/lorentz)+ ## Table of contents  * [Overview](#overview)@@ -116,16 +118,18 @@ <a name="lorentz-example"></a> ## Sample smart contract written in Lorentz -Example contract with autodoc:+Example contract with autodoc and custom data-type tree: ```haskell data MeasurementMethod   = ParrotStep   | MonkeyStep   | ElephantStep-  deriving stock Generic-  deriving anyclass (IsoValue, HasTypeAnn) +$(customGeneric "MeasurementMethod" rightBalanced) +deriving anyclass instance IsoValue MeasurementMethod+deriving anyclass instance HasAnnotation MeasurementMethod+ instance TypeHasDoc MeasurementMethod where   typeDocName _ = "MeasurmentMethod"   typeDocMdDescription =@@ -139,8 +143,8 @@   deriving stock Generic   deriving anyclass IsoValue -instance ParameterHasEntryPoints Parameter where-  type ParameterEntryPointsDerivation Parameter = EpdPlain+instance ParameterHasEntrypoints Parameter where+  type ParameterEntrypointsDerivation Parameter = EpdPlain  type Storage = Natural @@ -149,7 +153,7 @@   doc $ DDescription "This contract measures boa constrictor."   unpair   dip drop-  entryCase @Parameter (Proxy @PlainEntryPointsKind)+  entryCase @Parameter (Proxy @PlainEntrypointsKind)     ( #cMeasureBoaConstrictor /-> do         doc $ DDescription "Measure the boa constrictor with given method."         fromNamed #method

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: fccef8190cb6d01163ff5cfe694606e9d553421a90846ae212d8c5e6a2c4a133+-- hash: 16b347727d4e62a2940ac95ec51994350b8b857bcd82d1803c5f7684b86a81f3  name:           lorentz-version:        0.4.0+version:        0.5.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@@ -32,6 +32,7 @@       Lorentz       Lorentz.Address       Lorentz.ADT+      Lorentz.Annotation       Lorentz.Arith       Lorentz.Base       Lorentz.Coercions@@ -42,12 +43,12 @@       Lorentz.ContractRegistry       Lorentz.Doc       Lorentz.Empty-      Lorentz.EntryPoints-      Lorentz.EntryPoints.Core-      Lorentz.EntryPoints.Doc-      Lorentz.EntryPoints.Helpers-      Lorentz.EntryPoints.Impl-      Lorentz.EntryPoints.Manual+      Lorentz.Entrypoints+      Lorentz.Entrypoints.Core+      Lorentz.Entrypoints.Doc+      Lorentz.Entrypoints.Helpers+      Lorentz.Entrypoints.Impl+      Lorentz.Entrypoints.Manual       Lorentz.Errors       Lorentz.Errors.Common       Lorentz.Errors.Numeric@@ -64,15 +65,8 @@       Lorentz.Rebinded       Lorentz.Referenced       Lorentz.Run-      Lorentz.Store       Lorentz.StoreClass-      Lorentz.Test-      Lorentz.Test.Consumer-      Lorentz.Test.Doc-      Lorentz.Test.Integrational-      Lorentz.Test.Unit       Lorentz.TestScenario-      Lorentz.TypeAnns       Lorentz.UParam       Lorentz.UStore       Lorentz.UStore.Common@@ -89,6 +83,7 @@       Lorentz.UStore.Traversal       Lorentz.UStore.Types       Lorentz.Value+      Lorentz.Wrappable       Lorentz.Zip   other-modules:       Paths_lorentz@@ -99,8 +94,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:-      HUnit-    , QuickCheck+      QuickCheck     , aeson-pretty     , base >=4.7 && <5     , bimap@@ -110,9 +104,6 @@     , data-default     , first-class-families >=0.5.0.0     , fmt-    , formatting-    , ghc-prim-    , hedgehog     , interpolate     , lens     , morley@@ -122,77 +113,7 @@     , optparse-applicative     , pretty-terminal     , singletons-    , template-haskell     , text-    , unordered-containers-    , vinyl-  mixins:-      base hiding (Prelude)-  default-language: Haskell2010--test-suite lorentz-test-  type: exitcode-stdio-1.0-  main-is: Main.hs-  other-modules:-      Test.Doc-      Test.DocTest-      Test.Lorentz.Base-      Test.Lorentz.Conditionals-      Test.Lorentz.DeadCode-      Test.Lorentz.Doc.Positions-      Test.Lorentz.EntryPoints-      Test.Lorentz.EntryPoints.Doc-      Test.Lorentz.Errors-      Test.Lorentz.Errors.Numeric-      Test.Lorentz.Extensible-      Test.Lorentz.Interpreter-      Test.Lorentz.Macro-      Test.Lorentz.Pack-      Test.Lorentz.Print-      Test.Lorentz.StoreClass-      Test.Lorentz.UParam-      Test.Lorentz.UStore.Behaviour-      Test.Lorentz.UStore.Migration.Batched-      Test.Lorentz.UStore.Migration.Batched.V1-      Test.Lorentz.UStore.Migration.Batched.V2-      Test.Lorentz.UStore.Migration.FillInParts-      Test.Lorentz.UStore.Migration.Simple-      Test.Lorentz.UStore.Migration.Simple.V1-      Test.Lorentz.UStore.Migration.Simple.V2-      Test.Lorentz.UStore.SafeLift-      Test.Lorentz.UStore.SafeLift.Helpers-      Test.Tasty.TypeSpec-      Test.Util.TypeSpec-      Tree-      Paths_lorentz-  hs-source-dirs:-      test-  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-    , base >=4.7 && <5-    , bimap-    , bytestring-    , constraints-    , containers-    , filepath-    , first-class-families-    , fmt-    , formatting-    , hedgehog-    , lorentz-    , morley-    , morley-prelude-    , singletons-    , spoon-    , tasty-    , tasty-hedgehog-    , tasty-hunit-compat-    , text-    , type-spec     , unordered-containers     , vinyl   mixins:

@@ -7,6 +7,7 @@   ) where  import Lorentz.ADT as Exports+import Lorentz.Annotation as Exports import Lorentz.Arith as Exports import Lorentz.Base as Exports import Lorentz.Coercions as Exports@@ -14,8 +15,8 @@ import Lorentz.Constraints as Exports import Lorentz.Doc as Exports import Lorentz.Empty as Exports-import Lorentz.EntryPoints as Exports-import Lorentz.EntryPoints.Doc as Exports+import Lorentz.Entrypoints as Exports+import Lorentz.Entrypoints.Doc as Exports import Lorentz.Errors as Exports import Lorentz.Errors.Common as Exports () import Lorentz.Errors.Numeric as Exports@@ -30,7 +31,6 @@ import Lorentz.Referenced as Exports import Lorentz.Run as Exports import Lorentz.StoreClass as Exports-import Lorentz.TypeAnns as Exports import Lorentz.UParam as Exports import Lorentz.UStore as Exports import Lorentz.Value as Exports

@@ -53,13 +53,13 @@ import Data.Kind as Kind import Data.Type.Bool (type (&&), Not) +import Lorentz.Annotation import Lorentz.Base import Lorentz.Constraints-import qualified Lorentz.EntryPoints.Core as Ep-import Lorentz.TypeAnns+import qualified Lorentz.Entrypoints.Core as Ep import Michelson.Typed (ContractRef(..), IsoValue(..)) import qualified Michelson.Typed as M-import Michelson.Typed.EntryPoints (EpAddress(..))+import Michelson.Typed.Entrypoints (EpAddress(..)) import Tezos.Address (Address) import Util.Type import Util.TypeLits@@ -71,7 +71,7 @@ -- contract has explicit default entrypoint. newtype TAddress p = TAddress { unTAddress :: Address }   deriving stock Generic-  deriving anyclass (IsoValue, HasTypeAnn)+  deriving anyclass (IsoValue, HasAnnotation)  -- | Turn 'TAddress' to 'ContractRef' in /Haskell/ world. --@@ -81,19 +81,19 @@   :: forall cp mname.      (NiceParameterFull cp)   => TAddress cp-  -> Ep.EntryPointRef mname-  -> ContractRef (Ep.GetEntryPointArgCustom cp mname)+  -> Ep.EntrypointRef mname+  -> ContractRef (Ep.GetEntrypointArgCustom cp mname) callingTAddress (TAddress addr) epRef =   withDict (niceParameterEvi @cp) $-  case Ep.parameterEntryPointCallCustom @cp epRef of-    epc@M.EntryPointCall{} -> ContractRef addr (M.SomeEpc epc)+  case Ep.parameterEntrypointCallCustom @cp epRef of+    epc@M.EntrypointCall{} -> ContractRef addr (M.SomeEpc epc)  -- | Specification of 'callTAddress' to call the default entrypoint. callingDefTAddress   :: forall cp.      (NiceParameterFull cp)   => TAddress cp-  -> ContractRef (Ep.GetDefaultEntryPointArg cp)+  -> ContractRef (Ep.GetDefaultEntrypointArg cp) callingDefTAddress taddr = callingTAddress taddr Ep.CallDefault  -- | Something coercible to 'TAddress cp'.@@ -126,8 +126,8 @@   toVal (FutureContract contract) = toVal $ M.contractRefToAddr contract   fromVal = error "Fetching 'FutureContract' back from Michelson is impossible" -instance HasTypeAnn (FutureContract a) where-  getTypeAnn = M.starNotes+instance HasAnnotation (FutureContract a) where+  getAnnotation = M.starNotes  -- | Convert something to 'Address' in /Haskell/ world. --@@ -174,8 +174,8 @@  instance ( FailWhen cond msg          , cond ~-            ( Ep.CanHaveEntryPoints cp &&-              Not (Ep.ParameterEntryPointsDerivation cp == Ep.EpdNone)+            ( Ep.CanHaveEntrypoints cp &&+              Not (Ep.ParameterEntrypointsDerivation cp == Ep.EpdNone)             )          , msg ~             ( 'Text "Cannot apply `ToContractRef` to `TAddress`" ':$$:@@ -187,7 +187,7 @@          , cp ~ arg, NiceParameter arg            -- These constraints should naturally derive from ones above,            -- but proving that is not worth the effort-         , NiceParameterFull cp, Ep.GetDefaultEntryPointArg cp ~ cp+         , NiceParameterFull cp, Ep.GetDefaultEntrypointArg cp ~ cp          ) =>          ToContractRef arg (TAddress cp) where   toContractRef = callingDefTAddress

@@ -0,0 +1,187 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE UndecidableSuperClasses #-}++-- | Type and field annotations for Lorentz types.+module Lorentz.Annotation+  ( HasAnnotation (..)+  , GHasAnnotation (..)+  , gGetAnnotationNoField+  , insertTypeAnn+  ) where++import qualified GHC.Generics as G+import Named (NamedF)++import Lorentz.Entrypoints.Helpers (ctorNameToAnn)+import Michelson.Text+import Michelson.Typed+  (BigMap, ContractRef(..), EpAddress, KnownIsoT, Notes(..), Operation, ToT, insertTypeAnn,+  starNotes)+import Michelson.Typed.Haskell.Value (GValueType)+import Michelson.Untyped (FieldAnn, TypeAnn, ann, noAnn)+import Tezos.Address+import Tezos.Core+import Tezos.Crypto+import Util.TypeLits++-- | Use this in the instance of @HasAnnotation@ when field annotations+-- should not be generated.+gGetAnnotationNoField+    :: forall a. (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) => Notes (ToT a)+gGetAnnotationNoField = fst $ gGetAnnotation @(G.Rep a) False++-- | This class defines the type and field annotations for a given type. Right now+-- the type annotations come from names in a named field, and field annotations are+-- generated from the record fields.+class HasAnnotation a where+  getAnnotation :: Notes (ToT a)+  default getAnnotation+    :: (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) => Notes (ToT a)+  getAnnotation = fst $ gGetAnnotation @(G.Rep a) True++instance (HasAnnotation a, KnownSymbol name)+  => HasAnnotation (NamedF Identity a name) where+  getAnnotation = insertTypeAnn (symbolAnn @name) $ getAnnotation @a+    where+      symbolAnn :: forall s. KnownSymbol s => TypeAnn+      symbolAnn = ann $ symbolValT' @s++instance (HasAnnotation (Maybe a), KnownSymbol name)+  => HasAnnotation (NamedF Maybe a name) where+  getAnnotation = getAnnotation @(NamedF Identity (Maybe a) name)++-- Primitive instances+instance (HasAnnotation a) => HasAnnotation (Maybe a) where+  getAnnotation = NTOption noAnn (getAnnotation @a)++instance HasAnnotation ()++instance HasAnnotation Integer where+  getAnnotation = starNotes++instance HasAnnotation Natural where+  getAnnotation = starNotes++instance HasAnnotation MText where+  getAnnotation = starNotes++instance HasAnnotation Bool where+  getAnnotation = starNotes++instance HasAnnotation ByteString where+  getAnnotation = starNotes++instance HasAnnotation Mutez where+  getAnnotation = starNotes++instance HasAnnotation Address where+  getAnnotation = starNotes++instance HasAnnotation EpAddress where+  getAnnotation = starNotes++instance HasAnnotation KeyHash where+  getAnnotation = starNotes++instance HasAnnotation Timestamp where+  getAnnotation = starNotes++instance HasAnnotation PublicKey where+  getAnnotation = starNotes++instance HasAnnotation Signature where+  getAnnotation = starNotes++instance (HasAnnotation a) => HasAnnotation (ContractRef a) where+  getAnnotation = NTContract noAnn (getAnnotation @a)++instance (HasAnnotation k, HasAnnotation v) => HasAnnotation (Map k v) where+  getAnnotation = NTMap noAnn (getAnnotation @k) (getAnnotation @v)++instance (HasAnnotation k, HasAnnotation v) => HasAnnotation (BigMap k v) where+  getAnnotation = NTBigMap noAnn (getAnnotation @k) (getAnnotation @v)++instance (KnownIsoT v) => HasAnnotation (Set v) where+  getAnnotation = starNotes++instance (HasAnnotation a) => HasAnnotation [a] where+  getAnnotation = NTList noAnn (getAnnotation @a)++instance HasAnnotation Operation where+  getAnnotation = starNotes++instance (HasAnnotation a, HasAnnotation b) => HasAnnotation (a, b)+instance (HasAnnotation a, HasAnnotation b, HasAnnotation c) => HasAnnotation (a, b, c)+instance (HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d) => HasAnnotation (a, b, c, d)+instance (HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d, HasAnnotation e)+  => HasAnnotation (a, b, c, d, e)+instance (HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d, HasAnnotation e, HasAnnotation f)+  => HasAnnotation (a, b, c, d, e, f)+instance+  ( HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d, HasAnnotation e+  , HasAnnotation f, HasAnnotation g)+  => HasAnnotation (a, b, c, d, e, f, g)++-- | A Generic @HasAnnotation@ implementation+class GHasAnnotation a where+  -- | @Bool@ acts as a flag to determine whether or not field annotations+  -- should be set.+  gGetAnnotation :: Bool -> (Notes (GValueType a), FieldAnn)++instance GHasAnnotation G.U1 where+  gGetAnnotation _ = (starNotes, noAnn)++instance (GHasAnnotation x)+  => GHasAnnotation (G.M1 G.S ('G.MetaSel 'Nothing b c d) x)+  where+  gGetAnnotation b = gGetAnnotation @x b++instance (GHasAnnotation x, KnownSymbol a)+  => GHasAnnotation (G.M1 G.S ('G.MetaSel ('Just a) b c d) x)+  where+  gGetAnnotation b = case b of+    True -> (fst $ gGetAnnotation @x b, ctorNameToAnn @a)+    False -> (fst $ gGetAnnotation @x b, noAnn)++instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.C i1 x) where+  gGetAnnotation b = gGetAnnotation @x b++instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.D i1 x) where+  gGetAnnotation b = gGetAnnotation @x b++instance+    ( GHasAnnotation x+    , GHasAnnotation y+    )+  =>+    GHasAnnotation (x G.:+: y)+  where+  gGetAnnotation b =+    ( NTOr noAnn noAnn noAnn+        (fst $ gGetAnnotation @x b)+        (fst $ gGetAnnotation @y b )+    , noAnn+    )++instance+    ( GHasAnnotation x+    , GHasAnnotation y+    )+  =>+    GHasAnnotation (x G.:*: y)+  where+  gGetAnnotation b =+    let  (xTypeAnn, xFieldAnn) = gGetAnnotation @x b+         (yTypeAnn, yFieldAnn) = gGetAnnotation @y b+    in+      ( NTPair noAnn+          xFieldAnn yFieldAnn+          xTypeAnn yTypeAnn+      , noAnn+      )++instance (HasAnnotation x) => GHasAnnotation (G.Rec0 x) where+  gGetAnnotation _ = (getAnnotation @x, noAnn)

@@ -27,10 +27,9 @@   , fakeCoercing      -- * Re-exports-  , Wrapped (..)+  , Wrappable (..)   ) where -import Control.Lens (Wrapped(..)) import qualified Data.Coerce as Coerce import Data.Constraint ((\\)) import qualified GHC.Generics as G@@ -43,7 +42,7 @@ import Lorentz.Value import Lorentz.Zip import Michelson.Typed-+import Lorentz.Wrappable (Wrappable(..)) ---------------------------------------------------------------------------- -- Unsafe coercions ----------------------------------------------------------------------------@@ -89,16 +88,14 @@  -- | Specialized version of 'coerce_' to wrap into a haskell newtype. coerceWrap-  :: forall newtyp inner s.-     (inner ~ Unwrapped newtyp, MichelsonCoercible newtyp (Unwrapped newtyp))-  => inner : s :-> newtyp : s+  :: forall a s. Wrappable a+  => Unwrappable a : s :-> a : s coerceWrap = forcedCoerce_  -- | Specialized version of 'coerce_' to unwrap a haskell newtype. coerceUnwrap-  :: forall newtyp inner s.-     (inner ~ Unwrapped newtyp, MichelsonCoercible newtyp (Unwrapped newtyp))-  => newtyp : s :-> inner : s+  :: forall a s. Wrappable a+  => a : s :-> Unwrappable a : s coerceUnwrap = forcedCoerce_  -- | Lift given value to a named value.

@@ -10,7 +10,7 @@   ( NiceParameterFull   ) where -import Lorentz.EntryPoints.Core+import Lorentz.Entrypoints.Core  -- | Constraint applied to a whole parameter type.-type NiceParameterFull cp = (Typeable cp, ParameterDeclaresEntryPoints cp)+type NiceParameterFull cp = (Typeable cp, ParameterDeclaresEntrypoints cp)

@@ -37,8 +37,9 @@     withDict   ) where -import Data.Constraint (trans, weaken2)+import Data.Constraint (evidence, trans, weaken2) +import Lorentz.Annotation (HasAnnotation) import Michelson.Typed  -- We write these constraints as class + instance, rather than@@ -70,7 +71,8 @@ -- you usually supply an entrypoint argument, not the whole parameter. type NiceParameter a = (KnownValue a, ProperParameterBetterErrors (ToT a)) -type NiceStorage a = (KnownValue a, ProperStorageBetterErrors (ToT a))+type NiceStorage a =+  (HasAnnotation a, KnownValue a, ProperStorageBetterErrors (ToT a))  type NiceConstant a = (KnownValue a, ProperConstantBetterErrors (ToT a)) @@ -90,7 +92,7 @@  niceStorageEvi :: forall a. NiceStorage a :- StorageScope (ToT a) niceStorageEvi =-  properStorageEvi @(ToT a) `trans` weaken2+  Sub (evidence $ properStorageEvi @(ToT a))  niceConstantEvi :: forall a. NiceConstant a :- ConstantScope (ToT a) niceConstantEvi =

@@ -54,9 +54,10 @@   --   -- If storage is simple and can be easilly constructed manually, you   -- can use 'Nothing'.-  , ciStorageNotes :: Notes (ToT st)-  -- ^ A temporary approach to add annotations to storage.-  -- TODO [#20]: invent something better.+  , ciStorageNotes :: Maybe (Notes (ToT st))+  -- ^ Rewrite annotations in storage.+  -- We don't won't to uncoditionally override storage notes since+  -- after #20 we require notes to be non-empty, so we wrap them into `Maybe`.   }  (?::) :: Text -> a -> (Text, a)@@ -170,9 +171,10 @@   List -> pretty registry   Print name mOutput forceOneLine useMicheline -> do     ContractInfo{..} <- getContract name registry-    let compiledContract  =-          (compileLorentzContract ciContract)-            {M.cStoreNotes = ciStorageNotes}+    let+      compiledContract = case ciStorageNotes of+        Just notes -> (compileLorentzContract ciContract) { M.cStoreNotes = notes }+        Nothing -> compileLorentzContract ciContract     writeFunc (toString name <> ".tz") mOutput $       if useMicheline       then toLazyText $ encodePrettyToTextBuilder $ toExpression compiledContract

@@ -55,6 +55,7 @@   , homomorphicTypeDocHaskellRep   , concreteTypeDocHaskellRep   , concreteTypeDocHaskellRepUnsafe+  , haskellAddNewtypeField   , haskellRepNoFields   , haskellRepStripFieldPrefix   , homomorphicTypeDocMichelsonRep

@@ -18,17 +18,17 @@  import Fmt (Buildable(..)) +import Lorentz.Annotation (HasAnnotation) import Lorentz.Base import Lorentz.Doc import Lorentz.Errors-import Lorentz.TypeAnns (HasTypeAnn) import Lorentz.Value import Michelson.Typed.Haskell.Doc  -- | Replacement for uninhabited type. newtype Empty = Empty ()   deriving stock Generic-  deriving anyclass (IsoValue, HasTypeAnn)+  deriving anyclass (IsoValue, HasAnnotation)  instance TypeHasDoc Empty where   typeDocMdDescription =

@@ -1,52 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE UndecidableSuperClasses #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Entrypoints utilities for Lorentz-module Lorentz.EntryPoints-  ( -- * Typeclasses-    EntryPointsDerivation (..)-  , ParameterHasEntryPoints (..)-  , ParameterDeclaresEntryPoints--    -- * Entrypoints API-  , AllParameterEntryPoints-  , LookupParameterEntryPoint-  , parameterEntryPointsToNotes-  , GetEntryPointArg-  , parameterEntryPointCall-  , GetDefaultEntryPointArg-  , parameterEntryPointCallDefault-  , ForbidExplicitDefaultEntryPoint-  , NoExplicitDefaultEntryPoint-  , sepcCallRootChecked-  , EntryPointRef (..)-  , eprName-  , GetEntryPointArgCustom-  , HasEntryPointArg (..)-  , HasDefEntryPointArg-  , HasEntryPointOfType-  , ParameterContainsEntryPoints-  , TrustEpName (..)-  , parameterEntryPointCallCustom-  , RequireAllUniqueEntryPoints-  , (:>)--    -- * Implementations-  , EpdNone-  , EpdPlain-  , EpdRecursive-  , EpdDelegate--    -- * Behaviour modifiers-  , ParameterWrapper (..)-  , ShouldHaveEntryPoints (..)-  ) where--import Lorentz.EntryPoints.Core-import Lorentz.EntryPoints.Helpers-import Lorentz.EntryPoints.Impl-import Lorentz.EntryPoints.Manual

@@ -1,499 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE UndecidableSuperClasses #-}---- | Primitives supplying entrypoints declarations and lookup.-module Lorentz.EntryPoints.Core-  ( CanHaveEntryPoints-  , EntryPointsDerivation (..)-  , EpConstructionRes (..)-  , EpCallingDesc (..)-  , EpCallingStep (..)-  , RequireAllUniqueEntryPoints-  , ParameterHasEntryPoints (..)-  , ParameterDeclaresEntryPoints-  , GetParameterEpDerivation-  , pepNotes-  , pepCall-  , pepDescs-  , pepDescsWithDef-  , AllParameterEntryPoints-  , LookupParameterEntryPoint-  , parameterEntryPointsToNotes-  , GetEntryPointArg-  , parameterEntryPointCall-  , GetDefaultEntryPointArg-  , parameterEntryPointCallDefault-  , ForbidExplicitDefaultEntryPoint-  , NoExplicitDefaultEntryPoint-  , sepcCallRootChecked-  , EntryPointRef (..)-  , NiceEntryPointName-  , eprName-  , GetEntryPointArgCustom-  , TrustEpName (..)-  , HasEntryPointArg (..)-  , HasDefEntryPointArg-  , HasEntryPointOfType-  , ParameterContainsEntryPoints-  , parameterEntryPointCallCustom-  , EpdNone-  , (:>)--    -- * Internals-  , RequireAllUniqueEntryPoints'-  ) where--import Data.Constraint ((\\))-import qualified Data.Kind as Kind-import Data.Typeable (typeRep)-import Data.Vinyl (Rec(..))-import Fcf (Eval, Exp)-import qualified Fcf-import qualified Fcf.Utils as Fcf-import Fmt (pretty)--import Michelson.Typed-import qualified Michelson.Untyped as U-import Util.Label-import Util.Type-import Util.TypeLits--import Lorentz.Constraints.Scopes-import Lorentz.EntryPoints.Helpers-import Lorentz.TypeAnns (HasTypeAnn, getTypeAnn)---- | Defines a generalized way to declare entrypoints for various parameter types.------ When defining instances of this typeclass, set concrete @deriv@ argument--- and leave variable @cp@ argument.--- Also keep in mind, that in presence of explicit default entrypoint, all other--- 'Or' arms should be callable, though you can put this burden on user if very--- necessary.------ Methods of this typeclass aim to better type-safety when making up an--- implementation and they may be not too convenient to use; users should--- exploit their counterparts.-class EntryPointsDerivation deriv cp where-  -- | Name and argument of each entrypoint.-  -- This may include intermediate ones, even root if necessary.-  ---  -- Touching this type family is costly (@O(N^2)@), don't use it often.-  ---  -- Note [order of entrypoints children]:-  -- If this contains entrypoints referring to indermediate nodes (not leaves)-  -- in @or@ tree, then each such entrypoint should be mentioned eariler than-  -- all of its children.-  type EpdAllEntryPoints deriv cp :: [(Symbol, Kind.Type)]--  -- | Get entrypoint argument by name.-  type EpdLookupEntryPoint deriv cp :: Symbol -> Exp (Maybe Kind.Type)--  -- | Construct parameter annotations corresponding to expected entrypoints set.-  ---  -- This method is implementation detail, for actual notes construction-  -- use 'parameterEntryPointsToNotes'.-  ---  -- TODO [#35]: Should also return field annotation-  epdNotes :: Notes (ToT cp)--  -- | Construct entrypoint caller.-  ---  -- This does not treat calls to default entrypoint in a special way.-  ---  -- This method is implementation detail, for actual entrypoint lookup-  -- use 'parameterEntryPointCall'.-  epdCall-    :: ParameterScope (ToT cp)-    => Label name-    -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))--  -- | Description of how each of the entrypoints is constructed.-  epdDescs :: Rec EpCallingDesc (EpdAllEntryPoints deriv cp)--type RequireAllUniqueEntryPoints' deriv cp =-  RequireAllUnique-    "entrypoint name"-    (Eval (Fcf.Map Fcf.Fst $ EpdAllEntryPoints deriv cp))---- | Ensure that all declared entrypoints are unique.-type RequireAllUniqueEntryPoints cp =-  RequireAllUniqueEntryPoints' (ParameterEntryPointsDerivation cp) cp---- | Result of entrypoint lookup at term level.-data EpConstructionRes (param :: T) (marg :: Maybe Kind.Type) where-  EpConstructed-    :: ParameterScope (ToT arg)-    => EpLiftSequence (ToT arg) param -> EpConstructionRes param ('Just arg)-  EpConstructionFailed-    :: EpConstructionRes param 'Nothing---- | How one of the entrypoints is called.------ Type arguments are name of the constructor which eventually gave--- name to the entrypoint and this entrypoint's argument.-data EpCallingDesc (info :: (Symbol, Kind.Type)) where-  EpCallingDesc ::-    { epcdArg :: Proxy (arg :: Kind.Type)-      -- ^ Entrypoint argument type.-    , epcdEntrypoint :: EpName-      -- ^ Name of assigned entrypoint.-    , epcdSteps :: [EpCallingStep]-      -- ^ If we emulated entrypoints calling via just wrapping an argument into-      -- constructors until getting the full parameter, how would it look like.-      -- Steps are enlisted in reversed order - top-level constructors go last.-    } -> EpCallingDesc '(name, arg)--deriving stock instance Show (EpCallingDesc info)--data EpCallingStep-  -- | Wrap into constructor with given name.-  = EpsWrapIn Text-  deriving stock (Show, Eq)---- | Which entrypoints given parameter declares.------ Note that usually this function should not be used as constraint, use--- 'ParameterDeclaresEntryPoints' for this purpose.-class ( EntryPointsDerivation (ParameterEntryPointsDerivation cp) cp-      , RequireAllUniqueEntryPoints cp-      ) =>-      ParameterHasEntryPoints cp where-  type ParameterEntryPointsDerivation cp :: Kind.Type---- | Parameter declares some entrypoints.------ This is a version of 'ParameterHasEntryPoints' which we actually use in--- constraints. When given type is a sum type or newtype, we refer to--- 'ParameterHasEntryPoints' instance, otherwise this instance is not--- necessary.-type ParameterDeclaresEntryPoints cp =-  ( If (CanHaveEntryPoints cp)-     (ParameterHasEntryPoints cp)-     (() :: Constraint)-  , NiceParameter cp-  , EntryPointsDerivation (GetParameterEpDerivation cp) cp-  )---- | Version of 'ParameterEntryPointsDerivation' which we actually use in--- function signatures. When given type is sum type or newtype, we refer to--- 'ParameterEntryPointsDerivation', otherwise we suppose that no entrypoints--- are declared.-type GetParameterEpDerivation cp =-  If (CanHaveEntryPoints cp)-     (ParameterEntryPointsDerivation cp)-     EpdNone---- | Version of 'epdNotes' which we actually use in code.--- It hides derivations stuff inside, and treats primitive types specially--- like 'GetParameterEpDerivation' does.-pepNotes :: forall cp. ParameterDeclaresEntryPoints cp => Notes (ToT cp)-pepNotes = epdNotes @(GetParameterEpDerivation cp) @cp---- | Version of 'epdCall' which we actually use in code.--- It hides derivations stuff inside, and treats primitive types specially--- like 'GetParameterEpDerivation' does.-pepCall-  :: forall cp name.-     (ParameterDeclaresEntryPoints cp, ParameterScope (ToT cp))-  => Label name-  -> EpConstructionRes (ToT cp) (Eval (LookupParameterEntryPoint cp name))-pepCall = epdCall @(GetParameterEpDerivation cp) @cp---- | Version of 'epdDescs' which we actually use in code.--- It hides derivations stuff inside, and treats primitive types specially--- like 'GetParameterEpDerivation' does.-pepDescs-  :: forall cp.-     (ParameterDeclaresEntryPoints cp)-  => Rec EpCallingDesc (AllParameterEntryPoints cp)-pepDescs = epdDescs @(GetParameterEpDerivation cp) @cp---- | Descriptions of how each of the entrypoints is constructed.------ Similar to 'pepDescs', but includes default entrypoint disregard whether it is--- explicit or not, while 'pepDescs' includes it only if it is explicit.--- Also this returns list, not 'Rec', for simplicity.------ Note that [order of entrypoints children] property still holds here.-pepDescsWithDef-  :: forall cp.-     (ParameterDeclaresEntryPoints cp)-  => [Some1 EpCallingDesc]-pepDescsWithDef = addDefaultIfImplicit $ pepDescs @cp-  where-    addDefaultIfImplicit descsRec =-      let descs = recordToSomeList descsRec-          hasDef =-            any (\(Some1 EpCallingDesc{..}) -> epcdEntrypoint == DefEpName) descs-      in if hasDef-         then descs-         else Some1 EpCallingDesc-              { epcdArg = Proxy @cp-              , epcdEntrypoint = DefEpName-              , epcdSteps = []-              } : descs---- Derived methods and type families--------------------------------------------------------------------------------- | Get all entrypoints declared for parameter.-type family AllParameterEntryPoints (cp :: Kind.Type)-             :: [(Symbol, Kind.Type)] where-  AllParameterEntryPoints cp =-    EpdAllEntryPoints (GetParameterEpDerivation cp) cp---- | Lookup for entrypoint type by name.------ Does not treat default entrypoints in a special way.-type family LookupParameterEntryPoint (cp :: Kind.Type)-             :: Symbol -> Exp (Maybe Kind.Type) where-  LookupParameterEntryPoint cp =-    EpdLookupEntryPoint (GetParameterEpDerivation cp) cp---- | Derive annotations for given parameter.-parameterEntryPointsToNotes-  :: forall cp. ParameterDeclaresEntryPoints cp-  => ParamNotes (ToT cp)-parameterEntryPointsToNotes =-  let notes = pepNotes @cp-  in case mkParamNotes notes U.noAnn of-       -- Normally this should be valid because-       -- 1. Constraint in superclass of 'ParameterHasEntryPoints' ensures that-       -- no entrypoint is duplicated.-       -- 2. Each entrypoint is callable by laws of 'EntryPointsDerivation'.-       Right n -> n-       Left e -> error $ mconcat-        [ "Lorentz unexpectedly compiled into contract with \-          \illegal parameter declaration.\n"-        , "Parameter: " <> show (typeRep (Proxy @cp)) <> "\n"-        , "Derived annotations: " <> show notes <> "\n"-        , "Failure reason: " <> pretty e-        ]---- | Prepare call to given entrypoint.------ This does not treat calls to default entrypoint in a special way.--- To call default entrypoint properly use 'parameterEntryPointCallDefault'.-parameterEntryPointCall-  :: forall cp name.-     ParameterDeclaresEntryPoints cp-  => Label name-  -> EntryPointCall cp (GetEntryPointArg cp name)-parameterEntryPointCall label@Label =-  withDict (niceParameterEvi @cp) $-  case pepCall @cp label of-    EpConstructed liftSeq -> EntryPointCall-      { epcName = ctorNameToEp @name-      , epcParamProxy = Proxy-      , epcLiftSequence = liftSeq-      }-    EpConstructionFailed ->-      -- Not possible by 'GetEntryPointArg' constraint.-      error "impossible"---- | Get type of entrypoint with given name, fail if not found.-type GetEntryPointArg cp name = Eval-  ( Fcf.LiftM2-      Fcf.FromMaybe-      (Fcf.TError ('Text "Entrypoint not found: " ':<>: 'ShowType name ':$$:-                   'Text "In contract parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"))-      (LookupParameterEntryPoint cp name)-  )--type DefaultEpName = "Default"---- | Call the default entrypoint.-parameterEntryPointCallDefault-  :: forall cp.-     (ParameterDeclaresEntryPoints cp)-  => EntryPointCall cp (GetDefaultEntryPointArg cp)-parameterEntryPointCallDefault =-  withDict (niceParameterEvi @cp) $-  case pepCall @cp (fromLabel @DefaultEpName) of-    EpConstructed liftSeq -> EntryPointCall-      { epcName = DefEpName-      , epcParamProxy = Proxy-      , epcLiftSequence = liftSeq-      }-    EpConstructionFailed ->-      EntryPointCall-      { epcName = DefEpName-      , epcParamProxy = Proxy-      , epcLiftSequence = EplArgHere-      }---- | Get type of entrypoint with given name, fail if not found.-type GetDefaultEntryPointArg cp = Eval-  ( Fcf.LiftM2-      Fcf.FromMaybe-      (Fcf.Pure cp)-      (LookupParameterEntryPoint cp DefaultEpName)-  )---- | Ensure that there is no explicit "default" entrypoint.-type ForbidExplicitDefaultEntryPoint cp = Eval-  (Fcf.LiftM3-      Fcf.UnMaybe-      (Fcf.Pure (Fcf.Pure (() :: Constraint)))-      (Fcf.TError-         ('Text "Parameter used here must have no explicit \"default\" entrypoint" ':$$:-          'Text "In parameter type `" ':<>: 'ShowType cp ':<>: 'Text "`"-         )-      )-      (LookupParameterEntryPoint cp DefaultEpName)-  )---- | Similar to 'ForbidExplicitDefaultEntryPoint', but in a version which--- the compiler can work with (and which produces errors confusing for users :/)-type NoExplicitDefaultEntryPoint cp =-  Eval (LookupParameterEntryPoint cp DefaultEpName) ~ 'Nothing---- | Call root entrypoint safely.-sepcCallRootChecked-  :: forall cp.-     (NiceParameter cp, ForbidExplicitDefaultEntryPoint cp)-  => SomeEntryPointCall cp-sepcCallRootChecked = sepcCallRootUnsafe \\ niceParameterEvi @cp-  where-    -- Avoiding redundant-constraints warning.-    _validUsage = Dict @(ForbidExplicitDefaultEntryPoint cp)---- | Which entrypoint to call.------ We intentionally distinguish default and non-default cases because--- this makes API more details-agnostic.-data EntryPointRef (mname :: Maybe Symbol) where-  -- | Call the default entrypoint, or root if no explicit default is assigned.-  CallDefault :: EntryPointRef 'Nothing--  -- | Call the given entrypoint; calling default is not treated specially.-  -- You have to provide entrypoint name via passing it as type argument.-  ---  -- Unfortunatelly, here we cannot accept a label because in most cases our-  -- entrypoints begin from capital letter (being derived from constructor name),-  -- while labels must start from a lower-case letter, and there is no way to-  -- make a conversion at type-level.-  Call :: NiceEntryPointName name => EntryPointRef ('Just name)---- | Constraint on type-level entrypoint name specifier.-type NiceEntryPointName name = (KnownSymbol name, ForbidDefaultName name)--type family ForbidDefaultName (name :: Symbol) :: Constraint where-  ForbidDefaultName "Default" =-    TypeError ('Text "Calling `Default` entrypoint is not allowed here")-  ForbidDefaultName _ = ()--eprName :: forall mname. EntryPointRef mname -> EpName-eprName = \case-  CallDefault -> DefEpName-  Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->-    epNameFromParamAnn (ctorNameToAnn @name)-    ?: error "Empty constructor-entrypoint name"---- | Universal entrypoint calling.-parameterEntryPointCallCustom-  :: forall cp mname.-     (ParameterDeclaresEntryPoints cp)-  => EntryPointRef mname-  -> EntryPointCall cp (GetEntryPointArgCustom cp mname)-parameterEntryPointCallCustom = \case-  CallDefault ->-    parameterEntryPointCallDefault @cp-  Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->-    parameterEntryPointCall @cp (fromLabel @name)---- | Universal entrypoint lookup.-type family GetEntryPointArgCustom cp mname :: Kind.Type where-  GetEntryPointArgCustom cp 'Nothing = GetDefaultEntryPointArg cp-  GetEntryPointArgCustom cp ('Just name) = GetEntryPointArg cp name--------------------------------------------------------------------------------- Type class for functions that take entrypoint name as argument--------------------------------------------------------------------------------- | When we call a Lorentz contract we should pass entrypoint name--- and corresponding argument. Ideally we want to statically check--- that parameter has entrypoint with given name and--- argument. Constraint defined by this type class holds for contract--- with parameter @cp@ that have entrypoint matching @name@ with type--- @arg@.------ In order to check this property statically, we need to know entrypoint--- name in compile time, 'EntryPointRef' type serves this purpose.--- If entrypoint name is not known, one can use 'TrustEpName' wrapper--- to take responsibility for presence of this entrypoint.------ If you want to call a function which has this constraint, you have--- two options:--- 1. Pass contract parameter @cp@ using type application, pass 'EntryPointRef'--- as a value and pass entrypoint argument. Type system will check that--- @cp@ has an entrypoint with given reference and type.--- 2. Pass 'EpName' wrapped into 'TrustEpName' and entrypoint argument.--- In this case passing contract parameter is not necessary, you do not even--- have to know it.-class HasEntryPointArg cp name arg where-  -- | Data returned by this method may look somewhat arbitrary.-  -- 'EpName' is obviously needed because @name@ can be-  -- 'EntryPointRef' or 'TrustEpName'.  @Dict@ is returned because in-  -- 'EntryPointRef' case we get this evidence for free and don't want-  -- to use it. We seem to always need it anyway.-  useHasEntryPointArg :: name -> (Dict (ParameterScope (ToT arg)), EpName)---- | 'HasEntryPointArg' constraint specialized to default entrypoint.-type HasDefEntryPointArg cp defEpName defArg =-  ( defEpName ~ EntryPointRef 'Nothing-  , HasEntryPointArg cp defEpName defArg-  )--instance-  (GetEntryPointArgCustom cp mname ~ arg, ParameterDeclaresEntryPoints cp) =>-  HasEntryPointArg cp (EntryPointRef mname) arg where-  useHasEntryPointArg epRef =-    withDict (niceParameterEvi @cp) $-    case parameterEntryPointCallCustom @cp epRef of-      EntryPointCall{} -> (Dict, eprName epRef)---- | This wrapper allows to pass untyped 'EpName' and bypass checking--- that entrypoint with given name and type exists.-newtype TrustEpName = TrustEpName EpName--instance (NiceParameter arg) =>-  HasEntryPointArg cp TrustEpName arg where-  useHasEntryPointArg (TrustEpName epName) = (Dict, epName) \\ niceParameterEvi @arg---- | Checks that the given parameter consists of some specific entrypoint. Similar as--- `HasEntryPointArg` but ensures that the argument matches the following datatype.-type HasEntryPointOfType param con exp-  = (GetEntryPointArgCustom param ('Just con) ~ exp, ParameterDeclaresEntryPoints param)---- | A helper datatype which prettifies interface for `ParameterContainsEntryPoints`.-data NamedEp = NamedEp Symbol Kind.Type-type n :> ty = 'NamedEp n ty-infixr 0 :>---- | Check that the given entrypoint has some fields inside.--- This interface allows for an abstraction of contract parameter so--- that it requires some *minimal* specification, but not a concrete one.-type family-    ParameterContainsEntryPoints param (fields :: [NamedEp]) :: Constraint-  where-  ParameterContainsEntryPoints _ '[] = ()-  ParameterContainsEntryPoints param ((n :> ty) ': rest) =-    (HasEntryPointOfType param n ty, ParameterContainsEntryPoints param rest)--------------------------------------------------------------------------------- Trivial implementation--------------------------------------------------------------------------------- | No entrypoints declared, parameter type will serve as argument type--- of the only existing entrypoint (default one).-data EpdNone-instance (HasTypeAnn cp) => EntryPointsDerivation EpdNone cp where-  type EpdAllEntryPoints EpdNone cp = '[]-  type EpdLookupEntryPoint EpdNone cp = Fcf.ConstFn 'Nothing-  epdNotes = getTypeAnn @cp-  epdCall _ = EpConstructionFailed-  epdDescs = RNil

@@ -1,563 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities for declaring and documenting entry points.-module Lorentz.EntryPoints.Doc-  ( DEntryPoint (..)-  , DEntryPointReference (..)-  , EntryArrow (..)-  , PlainEntryPointsKind-  , diEntryPointToMarkdown-  , DEntryPointArg (..)-  , DType (..)-  , DeriveCtorFieldDoc (..)-  , ParamBuilder (..)-  , ParamBuildingDesc (..)-  , ParamBuildingStep (..)-  , mkPbsWrapIn-  , clarifyParamBuildingSteps-  , constructDEpArg-  , emptyDEpArg-  , mkUType-  , mkDEpUType-  , mkDEntryPointArgSimple-  , DocumentEntryPoints-  , documentEntryPoint-  , entryCase-  , entryCase_-  , finalizeParamCallingDoc-  , areFinalizedParamBuildingSteps-  , entryCaseSimple_-  , entryCaseSimple-  , RequireFlatParamEps-  , RequireFlatEpDerivation-  ) where--import Control.Lens.Cons (_head)-import Data.Char (toLower)-import Data.Constraint (Dict(..))-import qualified Data.Kind as Kind-import Data.Vinyl.Core (RMap, rappend)-import Fmt (Buildable(..), listF)-import GHC.Generics ((:+:))-import qualified GHC.Generics as G-import qualified Text.Show--import Lorentz.ADT-import Lorentz.Base-import Lorentz.Constraints-import Lorentz.Doc-import Lorentz.EntryPoints.Core-import Lorentz.EntryPoints.Helpers-import Lorentz.EntryPoints.Impl-import Lorentz.TypeAnns-import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)-import Michelson.Typed (pattern DefEpName, EpName, mkUType)-import Michelson.Typed.Doc-import Michelson.Typed.Haskell.Doc-import Michelson.Typed.Haskell.Instr-import qualified Michelson.Untyped as Untyped-import Util.Label (Label)-import Util.Markdown-import Util.Type-import Util.TypeLits-import Util.TypeTuple---- | Gathers information about single entrypoint.------ We assume that entry points might be of different kinds,--- which is designated by phantom type parameter.--- For instance, you may want to have several groups of entry points--- corresponding to various parts of a contract - specifying different @kind@--- type argument for each of those groups will allow you defining different--- 'DocItem' instances with appropriate custom descriptions for them.-data DEntryPoint (kind :: Kind.Type) = DEntryPoint-  { depName :: Text-  , depSub :: SubDoc-  }---- | Default implementation of 'docItemToMarkdown' for entry points.-diEntryPointToMarkdown :: HeaderLevel -> DEntryPoint level -> Markdown-diEntryPointToMarkdown lvl (DEntryPoint name block) =-  mdSeparator <>-  mdHeader lvl (mdTicked . build . over _head toLower $ name) <>-  subDocToMarkdown (nextHeaderLevel lvl) block---- | Default value for 'DEntryPoint' type argument.-data PlainEntryPointsKind--instance DocItem (DEntryPoint PlainEntryPointsKind) where-  type DocItemPosition (DEntryPoint PlainEntryPointsKind) = 1000-  docItemSectionName = Just "Entrypoints"-  docItemToMarkdown = diEntryPointToMarkdown--data DEntryPointReference = DEntryPointReference Text Anchor--instance DocItem DEntryPointReference where-  type DocItemPosition DEntryPointReference = 13-  docItemSectionName = Nothing-  docItemToMarkdown _ (DEntryPointReference name anchor) =-    "Copies behaviour of " <>-    mdLocalRef (mdTicked $ build name) anchor <>-    " entrypoint."---- | When describing the way of parameter construction - piece of incremental--- builder for this description.-newtype ParamBuilder = ParamBuilder-  { unParamBuilder :: Markdown -> Markdown-    -- ^ Argument stands for previously constructed parameter piece, and-    -- returned value - a piece constructed after our step.-  }---- | Show what given 'ParamBuilder' does on a sample.-pbSample :: ParamBuilder -> Markdown-pbSample (ParamBuilder b) = b "·"--instance Buildable ParamBuilder where-  build = pbSample--instance Show ParamBuilder where-  show (ParamBuilder pb) =-    -- Using @'x'@ symbol here because unicode does not render well in 'show'-    "ParamBuilder " <> show (pb "x")--instance Eq ParamBuilder where-  (==) = (==) `on` pbSample--data ParamBuildingDesc = ParamBuildingDesc-  { pbdEnglish :: Markdown-    -- ^ Plain english description of this step.-  , pbdHaskell :: ParamBuilder-    -- ^ How to construct parameter in Haskell code.-  , pbdMichelson :: ParamBuilder-    -- ^ How to construct parameter working on raw Michelson.-  } deriving stock (Show, Eq)---- | Describes a parameter building step.------ This can be wrapping into (Haskell) constructor, or a more complex--- transformation.-data ParamBuildingStep-    -- | Wraps something into constructor with given name.-    -- Constructor should be the one which corresponds to an entrypoint-    -- defined via field annotation, for more complex cases use 'PbsCustom'.-  = PbsWrapIn Text ParamBuildingDesc-    -- | Directly call an entrypoint marked with a field annotation.-  | PbsCallEntrypoint EpName-    -- | Other action.-  | PbsCustom ParamBuildingDesc-    -- | This entrypoint cannot be called, which is possible when an explicit-    -- default entrypoint is present. This is not a true entrypoint but just some-    -- intermediate node in @or@ tree and neither it nor any of its parents-    -- are marked with a field annotation.-    ---    -- It contains dummy 'ParamBuildingStep's which were assigned before-    -- entrypoints were taken into account.-  | PbsUncallable [ParamBuildingStep]-  deriving stock (Show, Eq)--instance Buildable ParamBuildingStep where-  build = \case-    PbsWrapIn ctor _desc -> "Wrap in `" <> build ctor <> "`"-    PbsCallEntrypoint ep -> "Call entrypoint " <> build ep-    PbsCustom desc -> "Custom: \"" <> pbdEnglish desc <> "\""-    PbsUncallable steps -> "Uncallable; dummy steps: " <> listF steps---- | Make a 'ParamBuildingStep' that tells about wrapping an argument into--- a constructor with given name and uses given 'ParamBuilder' as description of--- Michelson part.-mkPbsWrapIn :: Text -> ParamBuilder -> ParamBuildingStep-mkPbsWrapIn ctorName michDesc =-  PbsWrapIn ctorName ParamBuildingDesc-    { pbdEnglish = "Wrap into " <> mdTicked (build ctorName) <> " constructor."-    , pbdHaskell = ParamBuilder $ \p -> build ctorName <> " (" <> p <> ")"-    , pbdMichelson = michDesc-    }---- | Describes argument of an entrypoint.-data DEntryPointArg =-  DEntryPointArg-  { epaArg :: Maybe DType-    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.-  , epaBuilding :: [ParamBuildingStep]-    -- ^ Describes a way to lift an entrypoint argument into full parameter-    -- which can be passed to the contract.-    ---    -- Steps are supposed to be applied in the order opposite to one in which-    -- they are given.-    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;-    -- then the first step (actual last) should describe wrapping into @Run@-    -- constructor, and the second step (actual first) should be about wrapping-    -- into @Service1@ constructor.-  , epaType :: Untyped.Type-    -- ^ Untyped representation of entrypoint, used for printing its michelson-    -- type representation.-  }--constructDEpArg-  :: forall arg.-     ( TypeHasDoc arg-     , HasTypeAnn arg-     , KnownValue arg-     )-  => DEntryPointArg-constructDEpArg = DEntryPointArg-  { epaArg = Just $ DType (Proxy @arg)-  , epaBuilding = []-  , epaType = mkDEpUType @arg-  }--emptyDEpArg :: DEntryPointArg-emptyDEpArg = DEntryPointArg-  { epaArg = Nothing-  , epaBuilding = []-  , epaType = Untyped.Type Untyped.TUnit Untyped.noAnn-  }--mkDEpUType :: forall t. (KnownValue t, HasTypeAnn t) => Untyped.Type-mkDEpUType = mkUType (getTypeAnn @t)--mkDEntryPointArgSimple-  :: forall t.-     ( KnownValue t-     , HasTypeAnn t-     , TypeHasDoc t-     )-  => DEntryPointArg-mkDEntryPointArgSimple = DEntryPointArg-  { epaArg = Just $ DType (Proxy @t)-  , epaBuilding = []-  , epaType = mkDEpUType @t-  }---- | Go over contract code and update every occurrence of 'DEntryPointArg'--- documentation item, modifying param building steps.-modifyParamBuildingSteps-  :: ([ParamBuildingStep] -> [ParamBuildingStep])-  -> (inp :-> out)-  -> (inp :-> out)-modifyParamBuildingSteps f =-  iMapAnyCode $-  modifyInstrDoc (\di -> Just di{ epaBuilding = f (epaBuilding di) })---- | Go over contract code and update every occurrence of 'DEntryPointArg'--- documentation item, adding the given step to its "how to build parameter"--- description.-clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> (inp :-> out)-clarifyParamBuildingSteps pbs =-  modifyParamBuildingSteps (pbs :)--instance DocItem DEntryPointArg where-  type DocItemPosition DEntryPointArg = 20-  docItemSectionName = Nothing-  docItemDependencies (DEntryPointArg mdty _ _) =-    [SomeDocDefinitionItem dty | Just dty <- pure mdty]-  docItemToMarkdown _ (DEntryPointArg mdty psteps et) =-    mconcat . Prelude.map (<> "\n\n") $-      [ mdSubsection "Argument" $-          case mdty of-            Nothing -> "none (pass unit)"-            Just (DType (dty :: Proxy ep)) -> mconcat . Prelude.intersperse "\n" $-              [ mempty-              , "  + " <>-                mdSubsection "In Haskell"-                  (typeDocMdReference dty (WithinParens False))-              , "  + " <>-                mdSubsection "In Michelson"-                  (mdTicked $ printDocB False . renderDoc needsParens $ et)-              ],-          mdSpoiler "How to call this entrypoint" $-            "\n0. Construct an argument for the entrypoint.\n" <>-            howToCall-      ]-    where-      howToCall =-        mconcat . Prelude.intersperse "\n" $-        -- Markdown re-enumerates enumerated lists automatically-        Prelude.map ("1. " <>) $-          reverse psteps <&> \case-            PbsWrapIn _ pbd ->-              renderPbDesc pbd-            PbsCallEntrypoint ep -> case ep of-              DefEpName ->-                "Call the contract (default entrypoint) with the constructed \-                \argument."-              _ ->-                "Call contract's " <> mdTicked (build ep) <> " entrypoint \-                \passing the constructed argument."-            PbsCustom pbd ->-              renderPbDesc pbd-            PbsUncallable _ ->-              "Feel sad: this entrypoint *cannot* be called and is enlisted \-              \here only to describe the parameter structure."-              -- We could hide such entrypoints, but then in case of incorrect-              -- use of 'entryCase's or a bug in documentation, understanding-              -- what's going on would be hard--      renderPbDesc ParamBuildingDesc{..} =-        mconcat . Prelude.intersperse "\n" $-        [ pbdEnglish-        , "    + " <>-          mdSubsection "In Haskell" (mdTicked $ pbSample pbdHaskell)-        , "    + " <>-          mdSubsection "In Michelson" (mdTicked $ pbSample pbdMichelson)-        ]---- | Pick a type documentation from 'CtorField'.-class (KnownSymbol con) => DeriveCtorFieldDoc con (cf :: CtorField) where-  deriveCtorFieldDoc :: DEntryPointArg--instance-    (KnownSymbol con)-  =>-    DeriveCtorFieldDoc con 'NoFields-  where-  deriveCtorFieldDoc = emptyDEpArg--instance-    (TypeHasDoc ty, HasTypeAnn ty, KnownValue ty, KnownSymbol con)-  =>-    DeriveCtorFieldDoc con ('OneField ty)-  where-  deriveCtorFieldDoc = constructDEpArg @ty---- | Add necessary documentation to entry points.-documentEntryPoints-  :: forall a kind inp out.-     DocumentEntryPoints kind a-  => Rec (CaseClauseL inp out) (CaseClauses a)-  -> Rec (CaseClauseL inp out) (CaseClauses a)-documentEntryPoints = gDocumentEntryPoints @kind @(G.Rep a) (ParamBuilder id)---- | Constraint for 'documentEntryPoints'.-type DocumentEntryPoints kind a =-  (Generic a, GDocumentEntryPoints kind (G.Rep a))---- | Traverse entry points and add parameter building step (which describes--- necessity to wrap parameter into some constructor of the given datatype)--- to all parameters described within given code.-class GDocumentEntryPoints (kind :: Kind.Type) (x :: Kind.Type -> Kind.Type) where-  -- | Add corresponding parameter building step.-  ---  -- First argument is accumulator for Michelson description of the building step.-  gDocumentEntryPoints-    :: ParamBuilder-    -> Rec (CaseClauseL inp out) (GCaseClauses x)-    -> Rec (CaseClauseL inp out) (GCaseClauses x)--instance GDocumentEntryPoints kind x => GDocumentEntryPoints kind (G.D1 i x) where-  gDocumentEntryPoints = gDocumentEntryPoints @kind @x--instance ( GDocumentEntryPoints kind x, GDocumentEntryPoints kind y-         , RSplit (GCaseClauses x) (GCaseClauses y)-         ) =>-         GDocumentEntryPoints kind (x :+: y) where-  gDocumentEntryPoints (ParamBuilder michDesc) clauses =-    let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses-    in gDocumentEntryPoints @kind @x-         (ParamBuilder $ \a -> michDesc $ "Left (" <> a <> ")")-         lclauses-       `rappend`-       gDocumentEntryPoints @kind @y-         (ParamBuilder $ \a -> michDesc $ "Right (" <> a <> ")")-         rclauses--instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x-         , KnownSymbol ctor-         , DocItem (DEntryPoint kind)-         , DeriveCtorFieldDoc ctor cf-         ) =>-         GDocumentEntryPoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where-  gDocumentEntryPoints michDesc (CaseClauseL clause :& RNil) =-    let entryPointName = toText $ symbolVal (Proxy @ctor)-        psteps = mkPbsWrapIn entryPointName michDesc-        addDoc instr =-          clarifyParamBuildingSteps psteps $-          docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $-          doc (deriveCtorFieldDoc @ctor @cf) # instr-    in CaseClauseL (addDoc clause) :& RNil---- | Like 'case_', to be used for pattern-matching on a parameter--- or its part.------ Modifies documentation accordingly. Including description of--- entrypoints' arguments, thus for them you will need to supply--- 'TypeHasDoc' instance.-entryCase_-  :: forall dt entryPointKind out inp.-     ( InstrCaseC dt-     , RMap (CaseClauses dt)-     , DocumentEntryPoints entryPointKind dt-     )-  => Proxy entryPointKind-  -> Rec (CaseClauseL inp out) (CaseClauses dt)-  -> dt & inp :-> out-entryCase_ _ = case_ . documentEntryPoints @dt @entryPointKind---- | Version of 'entryCase_' for tuples.-entryCase-  :: forall dt entryPointKind out inp clauses.-     ( CaseTC dt out inp clauses-     , DocumentEntryPoints entryPointKind dt-     )-  => Proxy entryPointKind -> IsoRecTuple clauses -> dt & inp :-> out-entryCase p = entryCase_ p . recFromTuple---- | Wrapper for documenting single entrypoint which parameter--- isn't going to be unwrapped from some datatype.------ @entryCase@ unwraps a datatype, however, sometimes we want to--- have entrypoint parameter to be not wrapped into some datatype.-documentEntryPoint-  :: forall kind epName param s out.-     ( KnownSymbol epName-     , DocItem (DEntryPoint kind)-     , TypeHasDoc param-     , HasTypeAnn param-     , KnownValue param-     )-  => param & s :-> out -> param & s :-> out-documentEntryPoint instr =-  let entryPointName = toText $ symbolVal (Proxy @epName) in-    docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $-    doc (constructDEpArg @param) # instr---- | Provides arror for convenient entrypoint documentation-class EntryArrow kind name body where-  -- | Lift entrypoint implementation.-  ---  -- Entrypoint names should go with "e" prefix.-  (#->) :: (Label name, Proxy kind) -> body -> body--instance ( name ~ ("e" `AppendSymbol` epName)-         , body ~ (param & s :-> out)-         , KnownSymbol epName-         , DocItem (DEntryPoint kind)-         , TypeHasDoc param-         , HasTypeAnn param-         , KnownValue param-         ) => EntryArrow kind name body where-  (#->) _ = documentEntryPoint @kind @epName---- | Modify param building steps with respect to entrypoints that given--- parameter declares.------ Each contract with entrypoints should eventually call this function,--- otherwise, in case if contract uses built-in entrypoints feature,--- the resulting parameter building steps in the generated documentation--- will not consider entrypoints and thus may be incorrect.------ Calling this twice over the same code is also prohibited.-finalizeParamCallingDoc-  :: forall cp inp out.-     (NiceParameterFull cp, RequireSumType cp, HasCallStack)-  => (cp : inp :-> out) -> (cp : inp :-> out)-finalizeParamCallingDoc = modifyParamBuildingSteps modifySteps-  where-    -- We do not actually need it, requiring this constraint only to avoid-    -- misapplication of our function.-    _needSumType :: Dict (RequireSumType cp)-    _needSumType = Dict--    epDescs :: [Some1 EpCallingDesc]-    epDescs =-      -- Reversing the list because if element @e1@ of this list is prefix of-      -- another element @e2@, we want @e2@ to appear eariler than @e1@ to-      -- match against it first. But without reverse exactly the opposite-      -- holds due to [order of entrypoints children] property.-      reverse $ pepDescsWithDef @cp--    modifySteps :: [ParamBuildingStep] -> [ParamBuildingStep]-    modifySteps pbs-      | areFinalizedParamBuildingSteps pbs =-          error "Applying finalization second time"-      | otherwise =-          fromMaybe [PbsUncallable pbs] . listToMaybe . catMaybes $-          epDescs <&> \epDesc -> tryShortcut epDesc pbs--    -- Further we check whether given 'EpCallingStep's form prefix of-    -- 'ParamBuildingStep's; if so, we can apply only part of building-    -- steps and then call the entrypoint directly--    match :: [EpCallingStep] -> [ParamBuildingStep] -> Bool-    match cSteps pbSteps =-      and $ zip cSteps (prolong pbSteps) <&> \case-        (EpsWrapIn ctor, Just (PbsWrapIn ctor2 _)) | ctor == ctor2 -> True-        _ -> False-      where-        prolong :: [a] -> [Maybe a]-        prolong l = map Just l ++ repeat Nothing--    tryShortcut-      :: Some1 EpCallingDesc-      -> [ParamBuildingStep]-      -> Maybe [ParamBuildingStep]-    tryShortcut (Some1 EpCallingDesc{ epcdSteps = cSteps, epcdEntrypoint = ep })-                pbSteps-      | match cSteps pbSteps =-          let truncated = drop (length cSteps) pbSteps-              callEpStep = PbsCallEntrypoint ep-          in Just $ callEpStep : truncated-      | otherwise = Nothing---- | Whether 'finalizeParamCallingDoc' has already been applied to these steps.-areFinalizedParamBuildingSteps :: [ParamBuildingStep] -> Bool-areFinalizedParamBuildingSteps =-  -- Currently, 'finalizeParamCallingDoc' puts either 'PbsCallEntrypoint' or-  -- 'PbsUncallable' to list, and only it, and we rely on this behaviour here.-  -- If something changes so that these heuristics do not work, we can always-  -- insert special markers which would tell us whether finalization has been-  -- applied.-  let-    hasFinalizationTraces = \case-      PbsWrapIn{} -> False-      PbsCallEntrypoint{} -> True-      PbsCustom{} -> False-      PbsUncallable{} -> True-  in any hasFinalizationTraces--entryCaseSimple_-  :: forall cp out inp.-     ( InstrCaseC cp-     , RMap (CaseClauses cp)-     , DocumentEntryPoints PlainEntryPointsKind cp-     , NiceParameterFull cp-     , RequireFlatParamEps cp-     )-  => Rec (CaseClauseL inp out) (CaseClauses cp)-  -> cp & inp :-> out-entryCaseSimple_ =-  finalizeParamCallingDoc . entryCase_ (Proxy @PlainEntryPointsKind)-  where-    _reqFlat = Dict @(RequireFlatEpDerivation cp (GetParameterEpDerivation cp))---- | Version of 'entryCase' for contracts with flat parameter, use it when you--- need only one 'entryCase' all over the contract implementation.------ This method calls 'finalizeParamCallingDoc' inside.-entryCaseSimple-  :: forall cp out inp clauses.-     ( CaseTC cp out inp clauses-     , DocumentEntryPoints PlainEntryPointsKind cp-     , NiceParameterFull cp-     , RequireFlatParamEps cp-     )-  => IsoRecTuple clauses -> cp & inp :-> out-entryCaseSimple = entryCaseSimple_ . recFromTuple--type family RequireFlatParamEps cp :: Constraint where-  RequireFlatParamEps cp =-    ( RequireFlatEpDerivation cp (GetParameterEpDerivation cp)-    , RequireSumType cp-    )---- Checking this is not strictly necessary, but let's try it-type family RequireFlatEpDerivation cp deriv :: Constraint where-  RequireFlatEpDerivation _ EpdNone = ()-  RequireFlatEpDerivation _ EpdPlain = ()-  RequireFlatEpDerivation cp deriv = TypeError-    ( 'Text "Parameter is not flat" ':$$:-      'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`" ':$$:-      'Text "With entrypoints derivation way `" ':<>: 'ShowType deriv ':<>: 'Text "`"-    )

@@ -1,59 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Lorentz.EntryPoints.Helpers-  ( ctorNameToAnn-  , ctorNameToEp-  , CanHaveEntryPoints-  , ShouldHaveEntryPoints (..)-  , RequireSumType-  ) where--import qualified Data.Kind as Kind--import Michelson.Typed.Haskell-import Michelson.Typed.T-import Michelson.Untyped (EpName, FieldAnn, ann, epNameFromParamAnn)-import Util.Text-import Util.Type-import Util.TypeLits--ctorNameToAnn :: forall ctor. (KnownSymbol ctor, HasCallStack) => FieldAnn-ctorNameToAnn = ann . headToLower $ (symbolValT' @ctor)--ctorNameToEp :: forall ctor. (KnownSymbol ctor, HasCallStack) => EpName-ctorNameToEp =-  epNameFromParamAnn (ctorNameToAnn @ctor)-  ?: error "Empty constructor-entrypoint name"---- | A special type which wraps over a primitive type and states that it has--- entrypoints (one).------ Assuming that any type can have entrypoints makes use of Lorentz entrypoints--- too annoying, so for declaring entrypoints for not sum types we require an--- explicit wrapper.-newtype ShouldHaveEntryPoints a = ShouldHaveEntryPoints { unHasEntryPoints :: a }-  deriving stock Generic--deriving anyclass instance (WellTypedIsoValue r) => IsoValue (ShouldHaveEntryPoints r)---- | Used to understand whether a type can potentially declare any entrypoints.-type family CanHaveEntryPoints (p :: Kind.Type) :: Bool where-  CanHaveEntryPoints (ShouldHaveEntryPoints _) = 'True-  CanHaveEntryPoints p = CanHaveEntryPointsT (ToT p)--type family CanHaveEntryPointsT (t :: T) :: Bool where-  CanHaveEntryPointsT ('TOr _ _) = 'True-  CanHaveEntryPointsT _ = 'False---- | Ensure that given type is a sum type.------ This helps to prevent attempts to apply a function to, for instance, a pair.-type family RequireSumType (a :: Kind.Type) :: Constraint where-  RequireSumType a =-    If (CanHaveEntryPoints a)-       (() :: Constraint)-       (TypeError ('Text "Expected Michelson sum type" ':$$:-                   'Text "In type `" ':<>: 'ShowType a ':<>: 'Text "`"-                  ))

@@ -1,364 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Common implementations of entrypoints.-module Lorentz.EntryPoints.Impl-  ( -- * Ways to implement 'ParameterHasEntryPoints'-    EpdPlain-  , EpdRecursive-  , EpdDelegate--  -- * Implementation details-  , PlainEntryPointsC-  , EPTree (..)-  , BuildEPTree-  ) where--import qualified Data.Kind as Kind-import Data.Singletons.Prelude (SBool(SFalse, STrue))-import Data.Singletons.Prelude.Eq ((%==))-import Data.Vinyl.Core (Rec(..), (<+>))-import Data.Vinyl.Recursive (rmap)-import Fcf (Eval, Exp)-import qualified Fcf-import qualified GHC.Generics as G-import Util.TypeLits--import Lorentz.Value-import Michelson.Typed-import Michelson.Typed.Haskell.Value (GValueType)-import Michelson.Untyped (FieldAnn, noAnn)-import Util.Fcf (type (<|>), Over2, TyEqSing)-import Util.Type--import Lorentz.EntryPoints.Core-import Lorentz.EntryPoints.Helpers-import Lorentz.TypeAnns---- | Implementation of 'ParameterHasEntryPoints' which fits for case when--- your contract exposes multiple entrypoints via having sum type as its--- parameter.------ In particular, each constructor would produce a homonymous entrypoint with--- argument type equal to type of constructor field (each constructor should--- have only one field).--- Constructor called 'Default' will designate the default entrypoint.-data EpdPlain-instance PlainEntryPointsC EpdPlain cp => EntryPointsDerivation EpdPlain cp where-  type EpdAllEntryPoints EpdPlain cp = PlainAllEntryPointsExt EpdPlain cp-  type EpdLookupEntryPoint EpdPlain cp = PlainLookupEntryPointExt EpdPlain cp-  epdNotes = plainEpdNotesExt @EpdPlain @cp-  epdCall = plainEpdCallExt @EpdPlain @cp-  epdDescs = plainEpdDescsExt @EpdPlain @cp---- | Extension of 'EpdPlain' on parameters being defined as several nested--- datatypes.------ In particular, this will traverse sum types recursively, stopping at--- Michelson primitives (like 'Natural') and constructors with number of--- fields different from one.------ It does not assign names to intermediate nodes of 'Or' tree, only to the very--- leaves.------ If some entrypoint arguments have custom 'IsoValue' instance, this--- derivation way will not work. As a workaround, you can wrap your--- argument into some primitive (e.g. ':!').-data EpdRecursive-instance PlainEntryPointsC EpdRecursive cp => EntryPointsDerivation EpdRecursive cp where-  type EpdAllEntryPoints EpdRecursive cp = PlainAllEntryPointsExt EpdRecursive cp-  type EpdLookupEntryPoint EpdRecursive cp = PlainLookupEntryPointExt EpdRecursive cp-  epdNotes = plainEpdNotesExt @EpdRecursive @cp-  epdCall = plainEpdCallExt @EpdRecursive @cp-  epdDescs = plainEpdDescsExt @EpdRecursive @cp---- | Extension of 'EpdPlain' on parameters being defined as several nested--- datatypes.------ In particular, it will traverse the immediate sum type, and require another--- 'ParameterHasEntryPoints' for the inner complex datatypes. Only those--- inner types are considered which are the only fields in their respective--- constructors.--- Inner types should not themselves declare default entrypoint, we enforce--- this for better modularity.--- Each top-level constructor will be treated as entrypoint even if it contains--- a complex datatype within, in such case that would be an entrypoint--- corresponding to intermediate node in @or@ tree.------ Comparing to 'EpdRecursive' this gives you more control over where and how--- entrypoints will be derived.-data EpdDelegate-instance (PlainEntryPointsC EpdDelegate cp) => EntryPointsDerivation EpdDelegate cp where-  type EpdAllEntryPoints EpdDelegate cp = PlainAllEntryPointsExt EpdDelegate cp-  type EpdLookupEntryPoint EpdDelegate cp = PlainLookupEntryPointExt EpdDelegate cp-  epdNotes = plainEpdNotesExt @EpdDelegate @cp-  epdCall = plainEpdCallExt @EpdDelegate @cp-  epdDescs = plainEpdDescsExt @EpdDelegate @cp--type PlainAllEntryPointsExt mode cp = AllEntryPoints mode (BuildEPTree mode cp) cp--type PlainLookupEntryPointExt mode cp = LookupEntryPoint mode (BuildEPTree mode cp) cp--plainEpdNotesExt-  :: forall mode cp.-     (PlainEntryPointsC mode cp, HasCallStack)-  => Notes (ToT cp)-plainEpdNotesExt = mkEntryPointsNotes @mode @(BuildEPTree mode cp) @cp--plainEpdCallExt-  :: forall mode cp name.-     (PlainEntryPointsC mode cp, ParameterScope (ToT cp))-  => Label name-  -> EpConstructionRes (ToT cp) (Eval (LookupEntryPoint mode (BuildEPTree mode cp) cp name))-plainEpdCallExt = mkEpLiftSequence @mode @(BuildEPTree mode cp) @cp--plainEpdDescsExt-  :: forall mode cp.-     (PlainEntryPointsC mode cp)-  => Rec EpCallingDesc (PlainAllEntryPointsExt mode cp)-plainEpdDescsExt = mkEpDescs @mode @(BuildEPTree mode cp) @cp--type PlainEntryPointsC mode cp =-  ( GenericIsoValue cp-  , EntryPointsNotes mode (BuildEPTree mode cp) cp-  , RequireSumType cp-  )---- | Entrypoints tree - skeleton on 'TOr' tree later used to distinguish--- between constructors-entrypoints and constructors which consolidate--- a whole pack of entrypoints.-data EPTree-  = EPNode EPTree EPTree-    -- ^ We are in the intermediate node and need to go deeper.-  | EPLeaf-    -- ^ We reached entrypoint argument.-  | EPDelegate-    -- ^ We reached complex parameter part and will need to ask how to process it.---- | Build 'EPTree' by parameter type.-type BuildEPTree mode a = GBuildEntryPointsTree mode (G.Rep a)--type family GBuildEntryPointsTree (mode :: Kind.Type) (x :: Kind.Type -> Kind.Type)-             :: EPTree where-  GBuildEntryPointsTree mode (G.D1 _ x) =-    GBuildEntryPointsTree mode x-  GBuildEntryPointsTree mode (x G.:+: y) =-    'EPNode (GBuildEntryPointsTree mode x) (GBuildEntryPointsTree mode y)--  GBuildEntryPointsTree EpdPlain (G.C1 _ _) =-    'EPLeaf-  GBuildEntryPointsTree EpdRecursive (G.C1 _ x) =-    GBuildEntryPointsTree EpdRecursive x-  GBuildEntryPointsTree EpdDelegate (G.C1 _ (G.S1 _ (G.Rec0 _))) =-    'EPDelegate-  GBuildEntryPointsTree EpdDelegate (G.C1 _ _) =-    'EPLeaf-  GBuildEntryPointsTree mode (G.S1 _ x) =-    GBuildEntryPointsTree mode x-  GBuildEntryPointsTree _ G.U1 =-    'EPLeaf-  GBuildEntryPointsTree _ (_ G.:*: _) =-    'EPLeaf-  GBuildEntryPointsTree mode (G.Rec0 a) =-    If (IsPrimitiveValue a)-       'EPLeaf-       (BuildEPTree mode a)---- | Traverses sum type and constructs 'Notes' which report--- constructor names via field annotations.-type EntryPointsNotes mode ep a = (Generic a, GEntryPointsNotes mode ep (G.Rep a))---- | Makes up notes with proper field annotations for given parameter.-mkEntryPointsNotes-  :: forall mode ep a.-      (EntryPointsNotes mode ep a, GenericIsoValue a, HasCallStack)-  => Notes (ToT a)-mkEntryPointsNotes = fst $ gMkEntryPointsNotes @mode @ep @(G.Rep a)---- | Makes up a way to lift entrypoint argument to full parameter.-mkEpLiftSequence-  :: forall mode ep a name.-      ( EntryPointsNotes mode ep a, ParameterScope (ToT a)-      , GenericIsoValue a-      )-  => Label name-  -> EpConstructionRes (ToT a) (Eval (LookupEntryPoint mode ep a name))-mkEpLiftSequence = gMkEpLiftSequence @mode @ep @(G.Rep a)---- | Makes up descriptions of entrypoints calling.-mkEpDescs-  :: forall mode ep a.-      (EntryPointsNotes mode ep a)-  => Rec EpCallingDesc (AllEntryPoints mode ep a)-mkEpDescs = gMkDescs @mode @ep @(G.Rep a)---- | Fetches information about all entrypoints - leaves of 'Or' tree.-type AllEntryPoints mode ep a = GAllEntryPoints mode ep (G.Rep a)---- | Fetches information about all entrypoints - leaves of 'Or' tree.-type LookupEntryPoint mode ep a = GLookupEntryPoint mode ep (G.Rep a)---- | Generic traversal for 'EntryPointsNotes'.-class GEntryPointsNotes (mode :: Kind.Type) (ep :: EPTree) (x :: Kind.Type -> Kind.Type) where-  type GAllEntryPoints mode ep x :: [(Symbol, Kind.Type)]-  type GLookupEntryPoint mode ep x :: Symbol -> Exp (Maybe Kind.Type)--  {- | Returns:-    1. Notes corresponding to this level;-    2. Field annotation for this level (and which should be used one level above).-  -}-  gMkEntryPointsNotes :: HasCallStack => (Notes (GValueType x), FieldAnn)--  gMkEpLiftSequence-    :: ParameterScope (GValueType x)-    => Label name-    -> EpConstructionRes (GValueType x) (Eval (GLookupEntryPoint mode ep x name))--  gMkDescs-    :: Rec EpCallingDesc (GAllEntryPoints mode ep x)--instance GEntryPointsNotes mode ep x => GEntryPointsNotes mode ep (G.D1 i x) where-  type GAllEntryPoints mode ep (G.D1 i x) = GAllEntryPoints mode ep x-  type GLookupEntryPoint mode ep (G.D1 i x) = GLookupEntryPoint mode ep x-  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x-  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x-  gMkDescs = gMkDescs @mode @ep @x--instance (GEntryPointsNotes mode epx x, GEntryPointsNotes mode epy y) =>-         GEntryPointsNotes mode ('EPNode epx epy) (x G.:+: y) where-  type GAllEntryPoints mode ('EPNode epx epy) (x G.:+: y) =-    GAllEntryPoints mode epx x ++ GAllEntryPoints mode epy y-  type GLookupEntryPoint mode ('EPNode epx epy) (x G.:+: y) =-    Over2 (<|>) (GLookupEntryPoint mode epx x) (GLookupEntryPoint mode epy y)-  gMkEntryPointsNotes =-    let (xnotes, xann) = gMkEntryPointsNotes @mode @epx @x-        (ynotes, yann) = gMkEntryPointsNotes @mode @epy @y-    in (NTOr noAnn xann yann xnotes ynotes, noAnn)-  gMkEpLiftSequence label =-    case sing @(GValueType (x G.:+: y)) of-      STOr sl _ -> case (checkOpPresence sl, checkNestedBigMapsPresence sl) of-        (OpAbsent, NestedBigMapsAbsent) ->-          case gMkEpLiftSequence @mode @epx @x label of-            EpConstructed liftSeq -> EpConstructed (EplWrapLeft liftSeq)-            EpConstructionFailed ->-              case gMkEpLiftSequence @mode @epy @y label of-                EpConstructed liftSeq -> EpConstructed (EplWrapRight liftSeq)-                EpConstructionFailed -> EpConstructionFailed-  gMkDescs =-    gMkDescs @mode @epx @x <+> gMkDescs @mode @epy @y--instance ( GHasTypeAnn x, KnownSymbol ctor-         , ToT (GExtractField x) ~ GValueType x-         ) =>-         GEntryPointsNotes mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) where-  type GAllEntryPoints mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =-    '[ '(ctor, GExtractField x) ]-  type GLookupEntryPoint mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =-    JustOnEq ctor (GExtractField x)-  gMkEntryPointsNotes =-    (gGetTypeAnn @x, ctorNameToAnn @ctor)-  gMkEpLiftSequence (Label :: Label name) =-    case sing @ctor %== sing @name of-      STrue -> EpConstructed EplArgHere-      SFalse -> EpConstructionFailed-  gMkDescs = addDescStep @ctor $-    EpCallingDesc-    { epcdArg = Proxy-    , epcdEntrypoint = ctorNameToEp @ctor-    , epcdSteps = []-    } :& RNil--instance (ep ~ 'EPNode epx epy, GEntryPointsNotes mode ep x, KnownSymbol ctor) =>-         GEntryPointsNotes mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) where-  type GAllEntryPoints mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =-    GAllEntryPoints mode ('EPNode epx epy) x-  type GLookupEntryPoint mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =-    GLookupEntryPoint mode ('EPNode epx epy) x-  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x-  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x-  gMkDescs = addDescStep @ctor $ gMkDescs @mode @ep @x--instance ( ep ~ 'EPDelegate, GEntryPointsNotes mode ep x-         , KnownSymbol ctor, ToT (GExtractField x) ~ GValueType x-         ) =>-         GEntryPointsNotes mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) where-  type GAllEntryPoints mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =-    '(ctor, GExtractField x) ': GAllEntryPoints mode 'EPDelegate x-  type GLookupEntryPoint mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =-    Over2 (<|>) (JustOnEq ctor (GExtractField x)) (GLookupEntryPoint mode 'EPDelegate x)-  gMkEntryPointsNotes =-    let (notes, _rootAnn) = gMkEntryPointsNotes @mode @ep @x-    in (notes, ctorNameToAnn @ctor)-  gMkEpLiftSequence label@(Label :: Label name) =-    case sing @ctor %== sing @name of-      STrue -> EpConstructed EplArgHere-      SFalse -> gMkEpLiftSequence @mode @ep @x label-  gMkDescs = addDescStep @ctor $-    EpCallingDesc-    { epcdArg = Proxy-    , epcdEntrypoint = ctorNameToEp @ctor-    , epcdSteps = []-    } :& gMkDescs @mode @ep @x--instance GEntryPointsNotes mode ep x => GEntryPointsNotes mode ep (G.S1 i x) where-  type GAllEntryPoints mode ep (G.S1 i x) = GAllEntryPoints mode ep x-  type GLookupEntryPoint mode ep (G.S1 i x) = GLookupEntryPoint mode ep x-  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x-  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x-  gMkDescs = gMkDescs @mode @ep @x--instance (EntryPointsNotes EpdRecursive ep a, GenericIsoValue a) =>-         GEntryPointsNotes EpdRecursive ep (G.Rec0 a) where-  type GAllEntryPoints EpdRecursive ep (G.Rec0 a) = AllEntryPoints EpdRecursive ep a-  type GLookupEntryPoint EpdRecursive ep (G.Rec0 a) = LookupEntryPoint EpdRecursive ep a-  gMkEntryPointsNotes = (mkEntryPointsNotes @EpdRecursive @ep @a, noAnn)-  gMkEpLiftSequence = mkEpLiftSequence @EpdRecursive @ep @a-  gMkDescs = mkEpDescs @EpdRecursive @ep @a--instance (ParameterDeclaresEntryPoints a) =>-         GEntryPointsNotes EpdDelegate 'EPDelegate (G.Rec0 a) where-  type GAllEntryPoints EpdDelegate 'EPDelegate (G.Rec0 a) = AllParameterEntryPoints a-  type GLookupEntryPoint EpdDelegate 'EPDelegate (G.Rec0 a) = LookupParameterEntryPoint a-  gMkEntryPointsNotes = (pepNotes @a, noAnn)-  -- TODO [#35]: should use field ann ^^^^^ returned by 'epdNotes'-  gMkEpLiftSequence = pepCall @a-  gMkDescs = pepDescs @a--instance GEntryPointsNotes mode 'EPLeaf G.U1 where-  type GAllEntryPoints mode 'EPLeaf G.U1 = '[]-  type GLookupEntryPoint mode 'EPLeaf G.U1 = Fcf.ConstFn 'Nothing-  gMkEntryPointsNotes = (starNotes, noAnn)-  gMkEpLiftSequence _ = EpConstructionFailed-  gMkDescs = RNil--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-  gMkEntryPointsNotes = (starNotes, noAnn)-  gMkEpLiftSequence _ = EpConstructionFailed-  gMkDescs = RNil---- Return 'Just' iff given entries of type @k1@ are equal.-type family JustOnEq (a :: k1) (b :: k2) :: k1 -> Exp (Maybe k2) where-  JustOnEq a b =-    Fcf.Case-      '[ Fcf.Is (TyEqSing a) ('Just b)-       , Fcf.Any 'Nothing-       ]---- Get field type under 'G.C1'.-type family GExtractField (x :: Kind.Type -> Kind.Type) where-  GExtractField (G.S1 _ x) = GExtractField x-  GExtractField (G.Rec0 a) = a-  GExtractField G.U1 = ()--addDescStep-  :: forall ctor eps.-      KnownSymbol ctor-  => Rec EpCallingDesc eps -> Rec EpCallingDesc eps-addDescStep =-  let step = EpsWrapIn $ symbolValT' @ctor-  in rmap $ \EpCallingDesc{..} ->-       EpCallingDesc{ epcdSteps = step : epcdSteps, .. }

@@ -1,43 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Allows specifying entrypoints without declaring 'ParamterHasEntryPoints'--- instance.-module Lorentz.EntryPoints.Manual-  ( ParameterWrapper (..)-  ) where--import Control.Lens (Wrapped)-import qualified Data.Kind as Kind--import Lorentz.Constraints-import Lorentz.EntryPoints.Core-import Michelson.Typed---- | Wrap parameter into this to locally assign a way to derive entrypoints for--- it.-newtype ParameterWrapper (deriv :: Kind.Type) cp = ParameterWrapper { unParameterWraper :: cp }-  deriving stock Generic-  deriving anyclass IsoValue--instance Wrapped (ParameterWrapper deriv cp)---- Helper for implementing @instance ParameterHasEntryPoints ParameterWrapper@.-data PwDeriv deriv-instance EntryPointsDerivation deriv cp =>-         EntryPointsDerivation (PwDeriv deriv) (ParameterWrapper deriv cp) where-  type EpdAllEntryPoints (PwDeriv deriv) (ParameterWrapper deriv cp) =-    EpdAllEntryPoints deriv cp-  type EpdLookupEntryPoint (PwDeriv deriv) (ParameterWrapper deriv cp) =-    EpdLookupEntryPoint deriv cp-  epdNotes = epdNotes @deriv @cp-  epdCall = epdCall @deriv @cp-  epdDescs = epdDescs @deriv @cp--instance ( NiceParameter cp-         , EntryPointsDerivation epd cp-         , RequireAllUniqueEntryPoints' epd cp-         ) =>-         ParameterHasEntryPoints (ParameterWrapper epd cp) where-  type ParameterEntryPointsDerivation (ParameterWrapper epd cp) = PwDeriv epd

@@ -0,0 +1,52 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Entrypoints utilities for Lorentz+module Lorentz.Entrypoints+  ( -- * Typeclasses+    EntrypointsDerivation (..)+  , ParameterHasEntrypoints (..)+  , ParameterDeclaresEntrypoints++    -- * Entrypoints API+  , AllParameterEntrypoints+  , LookupParameterEntrypoint+  , parameterEntrypointsToNotes+  , GetEntrypointArg+  , parameterEntrypointCall+  , GetDefaultEntrypointArg+  , parameterEntrypointCallDefault+  , ForbidExplicitDefaultEntrypoint+  , NoExplicitDefaultEntrypoint+  , sepcCallRootChecked+  , EntrypointRef (..)+  , eprName+  , GetEntrypointArgCustom+  , HasEntrypointArg (..)+  , HasDefEntrypointArg+  , HasEntrypointOfType+  , ParameterContainsEntrypoints+  , TrustEpName (..)+  , parameterEntrypointCallCustom+  , RequireAllUniqueEntrypoints+  , (:>)++    -- * Implementations+  , EpdNone+  , EpdPlain+  , EpdRecursive+  , EpdDelegate++    -- * Behaviour modifiers+  , ParameterWrapper (..)+  , ShouldHaveEntrypoints (..)+  ) where++import Lorentz.Entrypoints.Core+import Lorentz.Entrypoints.Helpers+import Lorentz.Entrypoints.Impl+import Lorentz.Entrypoints.Manual

@@ -0,0 +1,499 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE UndecidableSuperClasses #-}++-- | Primitives supplying entrypoints declarations and lookup.+module Lorentz.Entrypoints.Core+  ( CanHaveEntrypoints+  , EntrypointsDerivation (..)+  , EpConstructionRes (..)+  , EpCallingDesc (..)+  , EpCallingStep (..)+  , RequireAllUniqueEntrypoints+  , ParameterHasEntrypoints (..)+  , ParameterDeclaresEntrypoints+  , GetParameterEpDerivation+  , pepNotes+  , pepCall+  , pepDescs+  , pepDescsWithDef+  , AllParameterEntrypoints+  , LookupParameterEntrypoint+  , parameterEntrypointsToNotes+  , GetEntrypointArg+  , parameterEntrypointCall+  , GetDefaultEntrypointArg+  , parameterEntrypointCallDefault+  , ForbidExplicitDefaultEntrypoint+  , NoExplicitDefaultEntrypoint+  , sepcCallRootChecked+  , EntrypointRef (..)+  , NiceEntrypointName+  , eprName+  , GetEntrypointArgCustom+  , TrustEpName (..)+  , HasEntrypointArg (..)+  , HasDefEntrypointArg+  , HasEntrypointOfType+  , ParameterContainsEntrypoints+  , parameterEntrypointCallCustom+  , EpdNone+  , (:>)++    -- * Internals+  , RequireAllUniqueEntrypoints'+  ) where++import Data.Constraint ((\\))+import qualified Data.Kind as Kind+import Data.Typeable (typeRep)+import Data.Vinyl (Rec(..))+import Fcf (Eval, Exp)+import qualified Fcf+import qualified Fcf.Utils as Fcf+import Fmt (pretty)++import Michelson.Typed+import qualified Michelson.Untyped as U+import Util.Label+import Util.Type+import Util.TypeLits++import Lorentz.Annotation (HasAnnotation, getAnnotation)+import Lorentz.Constraints.Scopes+import Lorentz.Entrypoints.Helpers++-- | Defines a generalized way to declare entrypoints for various parameter types.+--+-- When defining instances of this typeclass, set concrete @deriv@ argument+-- and leave variable @cp@ argument.+-- Also keep in mind, that in presence of explicit default entrypoint, all other+-- 'Or' arms should be callable, though you can put this burden on user if very+-- necessary.+--+-- Methods of this typeclass aim to better type-safety when making up an+-- implementation and they may be not too convenient to use; users should+-- exploit their counterparts.+class EntrypointsDerivation deriv cp where+  -- | Name and argument of each entrypoint.+  -- This may include intermediate ones, even root if necessary.+  --+  -- Touching this type family is costly (@O(N^2)@), don't use it often.+  --+  -- Note [order of entrypoints children]:+  -- If this contains entrypoints referring to indermediate nodes (not leaves)+  -- in @or@ tree, then each such entrypoint should be mentioned eariler than+  -- all of its children.+  type EpdAllEntrypoints deriv cp :: [(Symbol, Kind.Type)]++  -- | Get entrypoint argument by name.+  type EpdLookupEntrypoint deriv cp :: Symbol -> Exp (Maybe Kind.Type)++  -- | Construct parameter annotations corresponding to expected entrypoints set.+  --+  -- This method is implementation detail, for actual notes construction+  -- use 'parameterEntrypointsToNotes'.+  --+  -- TODO [#35]: Should also return field annotation+  epdNotes :: Notes (ToT cp)++  -- | Construct entrypoint caller.+  --+  -- This does not treat calls to default entrypoint in a special way.+  --+  -- This method is implementation detail, for actual entrypoint lookup+  -- use 'parameterEntrypointCall'.+  epdCall+    :: ParameterScope (ToT cp)+    => Label name+    -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntrypoint deriv cp name))++  -- | Description of how each of the entrypoints is constructed.+  epdDescs :: Rec EpCallingDesc (EpdAllEntrypoints deriv cp)++type RequireAllUniqueEntrypoints' deriv cp =+  RequireAllUnique+    "entrypoint name"+    (Eval (Fcf.Map Fcf.Fst $ EpdAllEntrypoints deriv cp))++-- | Ensure that all declared entrypoints are unique.+type RequireAllUniqueEntrypoints cp =+  RequireAllUniqueEntrypoints' (ParameterEntrypointsDerivation cp) cp++-- | Result of entrypoint lookup at term level.+data EpConstructionRes (param :: T) (marg :: Maybe Kind.Type) where+  EpConstructed+    :: ParameterScope (ToT arg)+    => EpLiftSequence (ToT arg) param -> EpConstructionRes param ('Just arg)+  EpConstructionFailed+    :: EpConstructionRes param 'Nothing++-- | How one of the entrypoints is called.+--+-- Type arguments are name of the constructor which eventually gave+-- name to the entrypoint and this entrypoint's argument.+data EpCallingDesc (info :: (Symbol, Kind.Type)) where+  EpCallingDesc ::+    { epcdArg :: Proxy (arg :: Kind.Type)+      -- ^ Entrypoint argument type.+    , epcdEntrypoint :: EpName+      -- ^ Name of assigned entrypoint.+    , epcdSteps :: [EpCallingStep]+      -- ^ If we emulated entrypoints calling via just wrapping an argument into+      -- constructors until getting the full parameter, how would it look like.+      -- Steps are enlisted in reversed order - top-level constructors go last.+    } -> EpCallingDesc '(name, arg)++deriving stock instance Show (EpCallingDesc info)++data EpCallingStep+  -- | Wrap into constructor with given name.+  = EpsWrapIn Text+  deriving stock (Show, Eq)++-- | Which entrypoints given parameter declares.+--+-- Note that usually this function should not be used as constraint, use+-- 'ParameterDeclaresEntrypoints' for this purpose.+class ( EntrypointsDerivation (ParameterEntrypointsDerivation cp) cp+      , RequireAllUniqueEntrypoints cp+      ) =>+      ParameterHasEntrypoints cp where+  type ParameterEntrypointsDerivation cp :: Kind.Type++-- | Parameter declares some entrypoints.+--+-- This is a version of 'ParameterHasEntrypoints' which we actually use in+-- constraints. When given type is a sum type or newtype, we refer to+-- 'ParameterHasEntrypoints' instance, otherwise this instance is not+-- necessary.+type ParameterDeclaresEntrypoints cp =+  ( If (CanHaveEntrypoints cp)+     (ParameterHasEntrypoints cp)+     (() :: Constraint)+  , NiceParameter cp+  , EntrypointsDerivation (GetParameterEpDerivation cp) cp+  )++-- | Version of 'ParameterEntrypointsDerivation' which we actually use in+-- function signatures. When given type is sum type or newtype, we refer to+-- 'ParameterEntrypointsDerivation', otherwise we suppose that no entrypoints+-- are declared.+type GetParameterEpDerivation cp =+  If (CanHaveEntrypoints cp)+     (ParameterEntrypointsDerivation cp)+     EpdNone++-- | Version of 'epdNotes' which we actually use in code.+-- It hides derivations stuff inside, and treats primitive types specially+-- like 'GetParameterEpDerivation' does.+pepNotes :: forall cp. ParameterDeclaresEntrypoints cp => Notes (ToT cp)+pepNotes = epdNotes @(GetParameterEpDerivation cp) @cp++-- | Version of 'epdCall' which we actually use in code.+-- It hides derivations stuff inside, and treats primitive types specially+-- like 'GetParameterEpDerivation' does.+pepCall+  :: forall cp name.+     (ParameterDeclaresEntrypoints cp, ParameterScope (ToT cp))+  => Label name+  -> EpConstructionRes (ToT cp) (Eval (LookupParameterEntrypoint cp name))+pepCall = epdCall @(GetParameterEpDerivation cp) @cp++-- | Version of 'epdDescs' which we actually use in code.+-- It hides derivations stuff inside, and treats primitive types specially+-- like 'GetParameterEpDerivation' does.+pepDescs+  :: forall cp.+     (ParameterDeclaresEntrypoints cp)+  => Rec EpCallingDesc (AllParameterEntrypoints cp)+pepDescs = epdDescs @(GetParameterEpDerivation cp) @cp++-- | Descriptions of how each of the entrypoints is constructed.+--+-- Similar to 'pepDescs', but includes default entrypoint disregard whether it is+-- explicit or not, while 'pepDescs' includes it only if it is explicit.+-- Also this returns list, not 'Rec', for simplicity.+--+-- Note that [order of entrypoints children] property still holds here.+pepDescsWithDef+  :: forall cp.+     (ParameterDeclaresEntrypoints cp)+  => [Some1 EpCallingDesc]+pepDescsWithDef = addDefaultIfImplicit $ pepDescs @cp+  where+    addDefaultIfImplicit descsRec =+      let descs = recordToSomeList descsRec+          hasDef =+            any (\(Some1 EpCallingDesc{..}) -> epcdEntrypoint == DefEpName) descs+      in if hasDef+         then descs+         else Some1 EpCallingDesc+              { epcdArg = Proxy @cp+              , epcdEntrypoint = DefEpName+              , epcdSteps = []+              } : descs++-- Derived methods and type families+----------------------------------------------------------------------------++-- | Get all entrypoints declared for parameter.+type family AllParameterEntrypoints (cp :: Kind.Type)+             :: [(Symbol, Kind.Type)] where+  AllParameterEntrypoints cp =+    EpdAllEntrypoints (GetParameterEpDerivation cp) cp++-- | Lookup for entrypoint type by name.+--+-- Does not treat default entrypoints in a special way.+type family LookupParameterEntrypoint (cp :: Kind.Type)+             :: Symbol -> Exp (Maybe Kind.Type) where+  LookupParameterEntrypoint cp =+    EpdLookupEntrypoint (GetParameterEpDerivation cp) cp++-- | Derive annotations for given parameter.+parameterEntrypointsToNotes+  :: forall cp. ParameterDeclaresEntrypoints cp+  => ParamNotes (ToT cp)+parameterEntrypointsToNotes =+  let notes = pepNotes @cp+  in case mkParamNotes notes U.noAnn of+       -- Normally this should be valid because+       -- 1. Constraint in superclass of 'ParameterHasEntrypoints' ensures that+       -- no entrypoint is duplicated.+       -- 2. Each entrypoint is callable by laws of 'EntrypointsDerivation'.+       Right n -> n+       Left e -> error $ mconcat+        [ "Lorentz unexpectedly compiled into contract with \+          \illegal parameter declaration.\n"+        , "Parameter: " <> show (typeRep (Proxy @cp)) <> "\n"+        , "Derived annotations: " <> show notes <> "\n"+        , "Failure reason: " <> pretty e+        ]++-- | Prepare call to given entrypoint.+--+-- This does not treat calls to default entrypoint in a special way.+-- To call default entrypoint properly use 'parameterEntrypointCallDefault'.+parameterEntrypointCall+  :: forall cp name.+     ParameterDeclaresEntrypoints cp+  => Label name+  -> EntrypointCall cp (GetEntrypointArg cp name)+parameterEntrypointCall label@Label =+  withDict (niceParameterEvi @cp) $+  case pepCall @cp label of+    EpConstructed liftSeq -> EntrypointCall+      { epcName = ctorNameToEp @name+      , epcParamProxy = Proxy+      , epcLiftSequence = liftSeq+      }+    EpConstructionFailed ->+      -- Not possible by 'GetEntrypointArg' constraint.+      error "impossible"++-- | Get type of entrypoint with given name, fail if not found.+type GetEntrypointArg cp name = Eval+  ( Fcf.LiftM2+      Fcf.FromMaybe+      (Fcf.TError ('Text "Entrypoint not found: " ':<>: 'ShowType name ':$$:+                   'Text "In contract parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"))+      (LookupParameterEntrypoint cp name)+  )++type DefaultEpName = "Default"++-- | Call the default entrypoint.+parameterEntrypointCallDefault+  :: forall cp.+     (ParameterDeclaresEntrypoints cp)+  => EntrypointCall cp (GetDefaultEntrypointArg cp)+parameterEntrypointCallDefault =+  withDict (niceParameterEvi @cp) $+  case pepCall @cp (fromLabel @DefaultEpName) of+    EpConstructed liftSeq -> EntrypointCall+      { epcName = DefEpName+      , epcParamProxy = Proxy+      , epcLiftSequence = liftSeq+      }+    EpConstructionFailed ->+      EntrypointCall+      { epcName = DefEpName+      , epcParamProxy = Proxy+      , epcLiftSequence = EplArgHere+      }++-- | Get type of entrypoint with given name, fail if not found.+type GetDefaultEntrypointArg cp = Eval+  ( Fcf.LiftM2+      Fcf.FromMaybe+      (Fcf.Pure cp)+      (LookupParameterEntrypoint cp DefaultEpName)+  )++-- | Ensure that there is no explicit "default" entrypoint.+type ForbidExplicitDefaultEntrypoint cp = Eval+  (Fcf.LiftM3+      Fcf.UnMaybe+      (Fcf.Pure (Fcf.Pure (() :: Constraint)))+      (Fcf.TError+         ('Text "Parameter used here must have no explicit \"default\" entrypoint" ':$$:+          'Text "In parameter type `" ':<>: 'ShowType cp ':<>: 'Text "`"+         )+      )+      (LookupParameterEntrypoint cp DefaultEpName)+  )++-- | Similar to 'ForbidExplicitDefaultEntrypoint', but in a version which+-- the compiler can work with (and which produces errors confusing for users :/)+type NoExplicitDefaultEntrypoint cp =+  Eval (LookupParameterEntrypoint cp DefaultEpName) ~ 'Nothing++-- | Call root entrypoint safely.+sepcCallRootChecked+  :: forall cp.+     (NiceParameter cp, ForbidExplicitDefaultEntrypoint cp)+  => SomeEntrypointCall cp+sepcCallRootChecked = sepcCallRootUnsafe \\ niceParameterEvi @cp+  where+    -- Avoiding redundant-constraints warning.+    _validUsage = Dict @(ForbidExplicitDefaultEntrypoint cp)++-- | Which entrypoint to call.+--+-- We intentionally distinguish default and non-default cases because+-- this makes API more details-agnostic.+data EntrypointRef (mname :: Maybe Symbol) where+  -- | Call the default entrypoint, or root if no explicit default is assigned.+  CallDefault :: EntrypointRef 'Nothing++  -- | Call the given entrypoint; calling default is not treated specially.+  -- You have to provide entrypoint name via passing it as type argument.+  --+  -- Unfortunatelly, here we cannot accept a label because in most cases our+  -- entrypoints begin from capital letter (being derived from constructor name),+  -- while labels must start from a lower-case letter, and there is no way to+  -- make a conversion at type-level.+  Call :: NiceEntrypointName name => EntrypointRef ('Just name)++-- | Constraint on type-level entrypoint name specifier.+type NiceEntrypointName name = (KnownSymbol name, ForbidDefaultName name)++type family ForbidDefaultName (name :: Symbol) :: Constraint where+  ForbidDefaultName "Default" =+    TypeError ('Text "Calling `Default` entrypoint is not allowed here")+  ForbidDefaultName _ = ()++eprName :: forall mname. EntrypointRef mname -> EpName+eprName = \case+  CallDefault -> DefEpName+  Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->+    epNameFromParamAnn (ctorNameToAnn @name)+    ?: error "Empty constructor-entrypoint name"++-- | Universal entrypoint calling.+parameterEntrypointCallCustom+  :: forall cp mname.+     (ParameterDeclaresEntrypoints cp)+  => EntrypointRef mname+  -> EntrypointCall cp (GetEntrypointArgCustom cp mname)+parameterEntrypointCallCustom = \case+  CallDefault ->+    parameterEntrypointCallDefault @cp+  Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->+    parameterEntrypointCall @cp (fromLabel @name)++-- | Universal entrypoint lookup.+type family GetEntrypointArgCustom cp mname :: Kind.Type where+  GetEntrypointArgCustom cp 'Nothing = GetDefaultEntrypointArg cp+  GetEntrypointArgCustom cp ('Just name) = GetEntrypointArg cp name++----------------------------------------------------------------------------+-- Type class for functions that take entrypoint name as argument+----------------------------------------------------------------------------++-- | When we call a Lorentz contract we should pass entrypoint name+-- and corresponding argument. Ideally we want to statically check+-- that parameter has entrypoint with given name and+-- argument. Constraint defined by this type class holds for contract+-- with parameter @cp@ that have entrypoint matching @name@ with type+-- @arg@.+--+-- In order to check this property statically, we need to know entrypoint+-- name in compile time, 'EntrypointRef' type serves this purpose.+-- If entrypoint name is not known, one can use 'TrustEpName' wrapper+-- to take responsibility for presence of this entrypoint.+--+-- If you want to call a function which has this constraint, you have+-- two options:+-- 1. Pass contract parameter @cp@ using type application, pass 'EntrypointRef'+-- as a value and pass entrypoint argument. Type system will check that+-- @cp@ has an entrypoint with given reference and type.+-- 2. Pass 'EpName' wrapped into 'TrustEpName' and entrypoint argument.+-- In this case passing contract parameter is not necessary, you do not even+-- have to know it.+class HasEntrypointArg cp name arg where+  -- | Data returned by this method may look somewhat arbitrary.+  -- 'EpName' is obviously needed because @name@ can be+  -- 'EntrypointRef' or 'TrustEpName'.  @Dict@ is returned because in+  -- 'EntrypointRef' case we get this evidence for free and don't want+  -- to use it. We seem to always need it anyway.+  useHasEntrypointArg :: name -> (Dict (ParameterScope (ToT arg)), EpName)++-- | 'HasEntrypointArg' constraint specialized to default entrypoint.+type HasDefEntrypointArg cp defEpName defArg =+  ( defEpName ~ EntrypointRef 'Nothing+  , HasEntrypointArg cp defEpName defArg+  )++instance+  (GetEntrypointArgCustom cp mname ~ arg, ParameterDeclaresEntrypoints cp) =>+  HasEntrypointArg cp (EntrypointRef mname) arg where+  useHasEntrypointArg epRef =+    withDict (niceParameterEvi @cp) $+    case parameterEntrypointCallCustom @cp epRef of+      EntrypointCall{} -> (Dict, eprName epRef)++-- | This wrapper allows to pass untyped 'EpName' and bypass checking+-- that entrypoint with given name and type exists.+newtype TrustEpName = TrustEpName EpName++instance (NiceParameter arg) =>+  HasEntrypointArg cp TrustEpName arg where+  useHasEntrypointArg (TrustEpName epName) = (Dict, epName) \\ niceParameterEvi @arg++-- | Checks that the given parameter consists of some specific entrypoint. Similar as+-- `HasEntrypointArg` but ensures that the argument matches the following datatype.+type HasEntrypointOfType param con exp+  = (GetEntrypointArgCustom param ('Just con) ~ exp, ParameterDeclaresEntrypoints param)++-- | A helper datatype which prettifies interface for `ParameterContainsEntrypoints`.+data NamedEp = NamedEp Symbol Kind.Type+type n :> ty = 'NamedEp n ty+infixr 0 :>++-- | Check that the given entrypoint has some fields inside.+-- This interface allows for an abstraction of contract parameter so+-- that it requires some *minimal* specification, but not a concrete one.+type family+    ParameterContainsEntrypoints param (fields :: [NamedEp]) :: Constraint+  where+  ParameterContainsEntrypoints _ '[] = ()+  ParameterContainsEntrypoints param ((n :> ty) ': rest) =+    (HasEntrypointOfType param n ty, ParameterContainsEntrypoints param rest)++----------------------------------------------------------------------------+-- Trivial implementation+----------------------------------------------------------------------------++-- | No entrypoints declared, parameter type will serve as argument type+-- of the only existing entrypoint (default one).+data EpdNone+instance (HasAnnotation cp) => EntrypointsDerivation EpdNone cp where+  type EpdAllEntrypoints EpdNone cp = '[]+  type EpdLookupEntrypoint EpdNone cp = Fcf.ConstFn 'Nothing+  epdNotes = getAnnotation @cp+  epdCall _ = EpConstructionFailed+  epdDescs = RNil

@@ -0,0 +1,563 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities for declaring and documenting entry points.+module Lorentz.Entrypoints.Doc+  ( DEntrypoint (..)+  , DEntrypointReference (..)+  , EntryArrow (..)+  , PlainEntrypointsKind+  , diEntrypointToMarkdown+  , DEntrypointArg (..)+  , DType (..)+  , DeriveCtorFieldDoc (..)+  , ParamBuilder (..)+  , ParamBuildingDesc (..)+  , ParamBuildingStep (..)+  , mkPbsWrapIn+  , clarifyParamBuildingSteps+  , constructDEpArg+  , emptyDEpArg+  , mkUType+  , mkDEpUType+  , mkDEntrypointArgSimple+  , DocumentEntrypoints+  , documentEntrypoint+  , entryCase+  , entryCase_+  , finalizeParamCallingDoc+  , areFinalizedParamBuildingSteps+  , entryCaseSimple_+  , entryCaseSimple+  , RequireFlatParamEps+  , RequireFlatEpDerivation+  ) where++import Control.Lens.Cons (_head)+import Data.Char (toLower)+import Data.Constraint (Dict(..))+import qualified Data.Kind as Kind+import Data.Vinyl.Core (RMap, rappend)+import Fmt (Buildable(..), listF)+import GHC.Generics ((:+:))+import qualified GHC.Generics as G+import qualified Text.Show++import Lorentz.ADT+import Lorentz.Annotation+import Lorentz.Base+import Lorentz.Constraints+import Lorentz.Doc+import Lorentz.Entrypoints.Core+import Lorentz.Entrypoints.Helpers+import Lorentz.Entrypoints.Impl+import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)+import Michelson.Typed (pattern DefEpName, EpName, mkUType)+import Michelson.Typed.Doc+import Michelson.Typed.Haskell.Doc+import Michelson.Typed.Haskell.Instr+import qualified Michelson.Untyped as Untyped+import Util.Label (Label)+import Util.Markdown+import Util.Type+import Util.TypeLits+import Util.TypeTuple++-- | Gathers information about single entrypoint.+--+-- We assume that entry points might be of different kinds,+-- which is designated by phantom type parameter.+-- For instance, you may want to have several groups of entry points+-- corresponding to various parts of a contract - specifying different @kind@+-- type argument for each of those groups will allow you defining different+-- 'DocItem' instances with appropriate custom descriptions for them.+data DEntrypoint (kind :: Kind.Type) = DEntrypoint+  { depName :: Text+  , depSub :: SubDoc+  }++-- | Default implementation of 'docItemToMarkdown' for entry points.+diEntrypointToMarkdown :: HeaderLevel -> DEntrypoint level -> Markdown+diEntrypointToMarkdown lvl (DEntrypoint name block) =+  mdSeparator <>+  mdHeader lvl (mdTicked . build . over _head toLower $ name) <>+  subDocToMarkdown (nextHeaderLevel lvl) block++-- | Default value for 'DEntrypoint' type argument.+data PlainEntrypointsKind++instance DocItem (DEntrypoint PlainEntrypointsKind) where+  docItemPos = 1000+  docItemSectionName = Just "Entrypoints"+  docItemToMarkdown = diEntrypointToMarkdown++data DEntrypointReference = DEntrypointReference Text Anchor++instance DocItem DEntrypointReference where+  docItemPos = 13+  docItemSectionName = Nothing+  docItemToMarkdown _ (DEntrypointReference name anchor) =+    "Copies behaviour of " <>+    mdLocalRef (mdTicked $ build name) anchor <>+    " entrypoint."++-- | When describing the way of parameter construction - piece of incremental+-- builder for this description.+newtype ParamBuilder = ParamBuilder+  { unParamBuilder :: Markdown -> Markdown+    -- ^ Argument stands for previously constructed parameter piece, and+    -- returned value - a piece constructed after our step.+  }++-- | Show what given 'ParamBuilder' does on a sample.+pbSample :: ParamBuilder -> Markdown+pbSample (ParamBuilder b) = b "·"++instance Buildable ParamBuilder where+  build = pbSample++instance Show ParamBuilder where+  show (ParamBuilder pb) =+    -- Using @'x'@ symbol here because unicode does not render well in 'show'+    "ParamBuilder " <> show (pb "x")++instance Eq ParamBuilder where+  (==) = (==) `on` pbSample++data ParamBuildingDesc = ParamBuildingDesc+  { pbdEnglish :: Markdown+    -- ^ Plain english description of this step.+  , pbdHaskell :: ParamBuilder+    -- ^ How to construct parameter in Haskell code.+  , pbdMichelson :: ParamBuilder+    -- ^ How to construct parameter working on raw Michelson.+  } deriving stock (Show, Eq)++-- | Describes a parameter building step.+--+-- This can be wrapping into (Haskell) constructor, or a more complex+-- transformation.+data ParamBuildingStep+    -- | Wraps something into constructor with given name.+    -- Constructor should be the one which corresponds to an entrypoint+    -- defined via field annotation, for more complex cases use 'PbsCustom'.+  = PbsWrapIn Text ParamBuildingDesc+    -- | Directly call an entrypoint marked with a field annotation.+  | PbsCallEntrypoint EpName+    -- | Other action.+  | PbsCustom ParamBuildingDesc+    -- | This entrypoint cannot be called, which is possible when an explicit+    -- default entrypoint is present. This is not a true entrypoint but just some+    -- intermediate node in @or@ tree and neither it nor any of its parents+    -- are marked with a field annotation.+    --+    -- It contains dummy 'ParamBuildingStep's which were assigned before+    -- entrypoints were taken into account.+  | PbsUncallable [ParamBuildingStep]+  deriving stock (Show, Eq)++instance Buildable ParamBuildingStep where+  build = \case+    PbsWrapIn ctor _desc -> "Wrap in `" <> build ctor <> "`"+    PbsCallEntrypoint ep -> "Call entrypoint " <> build ep+    PbsCustom desc -> "Custom: \"" <> pbdEnglish desc <> "\""+    PbsUncallable steps -> "Uncallable; dummy steps: " <> listF steps++-- | Make a 'ParamBuildingStep' that tells about wrapping an argument into+-- a constructor with given name and uses given 'ParamBuilder' as description of+-- Michelson part.+mkPbsWrapIn :: Text -> ParamBuilder -> ParamBuildingStep+mkPbsWrapIn ctorName michDesc =+  PbsWrapIn ctorName ParamBuildingDesc+    { pbdEnglish = "Wrap into " <> mdTicked (build ctorName) <> " constructor."+    , pbdHaskell = ParamBuilder $ \p -> build ctorName <> " (" <> p <> ")"+    , pbdMichelson = michDesc+    }++-- | Describes argument of an entrypoint.+data DEntrypointArg =+  DEntrypointArg+  { epaArg :: Maybe DType+    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.+  , epaBuilding :: [ParamBuildingStep]+    -- ^ Describes a way to lift an entrypoint argument into full parameter+    -- which can be passed to the contract.+    --+    -- Steps are supposed to be applied in the order opposite to one in which+    -- they are given.+    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;+    -- then the first step (actual last) should describe wrapping into @Run@+    -- constructor, and the second step (actual first) should be about wrapping+    -- into @Service1@ constructor.+  , epaType :: Untyped.Type+    -- ^ Untyped representation of entrypoint, used for printing its michelson+    -- type representation.+  }++constructDEpArg+  :: forall arg.+     ( TypeHasDoc arg+     , HasAnnotation arg+     , KnownValue arg+     )+  => DEntrypointArg+constructDEpArg = DEntrypointArg+  { epaArg = Just $ DType (Proxy @arg)+  , epaBuilding = []+  , epaType = mkDEpUType @arg+  }++emptyDEpArg :: DEntrypointArg+emptyDEpArg = DEntrypointArg+  { epaArg = Nothing+  , epaBuilding = []+  , epaType = Untyped.Type Untyped.TUnit Untyped.noAnn+  }++mkDEpUType :: forall t. (KnownValue t, HasAnnotation t) => Untyped.Type+mkDEpUType = mkUType (getAnnotation @t)++mkDEntrypointArgSimple+  :: forall t.+     ( KnownValue t+     , HasAnnotation t+     , TypeHasDoc t+     )+  => DEntrypointArg+mkDEntrypointArgSimple = DEntrypointArg+  { epaArg = Just $ DType (Proxy @t)+  , epaBuilding = []+  , epaType = mkDEpUType @t+  }++-- | Go over contract code and update every occurrence of 'DEntrypointArg'+-- documentation item, modifying param building steps.+modifyParamBuildingSteps+  :: ([ParamBuildingStep] -> [ParamBuildingStep])+  -> (inp :-> out)+  -> (inp :-> out)+modifyParamBuildingSteps f =+  iMapAnyCode $+  modifyInstrDoc (\di -> Just di{ epaBuilding = f (epaBuilding di) })++-- | Go over contract code and update every occurrence of 'DEntrypointArg'+-- documentation item, adding the given step to its "how to build parameter"+-- description.+clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> (inp :-> out)+clarifyParamBuildingSteps pbs =+  modifyParamBuildingSteps (pbs :)++instance DocItem DEntrypointArg where+  docItemPos = 20+  docItemSectionName = Nothing+  docItemDependencies (DEntrypointArg mdty _ _) =+    [SomeDocDefinitionItem dty | Just dty <- pure mdty]+  docItemToMarkdown _ (DEntrypointArg mdty psteps et) =+    mconcat . Prelude.map (<> "\n\n") $+      [ mdSubsection "Argument" $+          case mdty of+            Nothing -> "none (pass unit)"+            Just (DType (dty :: Proxy ep)) -> mconcat . Prelude.intersperse "\n" $+              [ mempty+              , "  + " <>+                mdSubsection "In Haskell"+                  (typeDocMdReference dty (WithinParens False))+              , "  + " <>+                mdSubsection "In Michelson"+                  (mdTicked $ printDocB False . renderDoc needsParens $ et)+              ],+          mdSpoiler "How to call this entrypoint" $+            "\n0. Construct an argument for the entrypoint.\n" <>+            howToCall+      ]+    where+      howToCall =+        mconcat . Prelude.intersperse "\n" $+        -- Markdown re-enumerates enumerated lists automatically+        Prelude.map ("1. " <>) $+          reverse psteps <&> \case+            PbsWrapIn _ pbd ->+              renderPbDesc pbd+            PbsCallEntrypoint ep -> case ep of+              DefEpName ->+                "Call the contract (default entrypoint) with the constructed \+                \argument."+              _ ->+                "Call contract's " <> mdTicked (build ep) <> " entrypoint \+                \passing the constructed argument."+            PbsCustom pbd ->+              renderPbDesc pbd+            PbsUncallable _ ->+              "Feel sad: this entrypoint *cannot* be called and is enlisted \+              \here only to describe the parameter structure."+              -- We could hide such entrypoints, but then in case of incorrect+              -- use of 'entryCase's or a bug in documentation, understanding+              -- what's going on would be hard++      renderPbDesc ParamBuildingDesc{..} =+        mconcat . Prelude.intersperse "\n" $+        [ pbdEnglish+        , "    + " <>+          mdSubsection "In Haskell" (mdTicked $ pbSample pbdHaskell)+        , "    + " <>+          mdSubsection "In Michelson" (mdTicked $ pbSample pbdMichelson)+        ]++-- | Pick a type documentation from 'CtorField'.+class (KnownSymbol con) => DeriveCtorFieldDoc con (cf :: CtorField) where+  deriveCtorFieldDoc :: DEntrypointArg++instance+    (KnownSymbol con)+  =>+    DeriveCtorFieldDoc con 'NoFields+  where+  deriveCtorFieldDoc = emptyDEpArg++instance+    (TypeHasDoc ty, HasAnnotation ty, KnownValue ty, KnownSymbol con)+  =>+    DeriveCtorFieldDoc con ('OneField ty)+  where+  deriveCtorFieldDoc = constructDEpArg @ty++-- | Add necessary documentation to entry points.+documentEntrypoints+  :: forall a kind inp out.+     DocumentEntrypoints kind a+  => Rec (CaseClauseL inp out) (CaseClauses a)+  -> Rec (CaseClauseL inp out) (CaseClauses a)+documentEntrypoints = gDocumentEntrypoints @kind @(G.Rep a) (ParamBuilder id)++-- | Constraint for 'documentEntrypoints'.+type DocumentEntrypoints kind a =+  (Generic a, GDocumentEntrypoints kind (G.Rep a))++-- | Traverse entry points and add parameter building step (which describes+-- necessity to wrap parameter into some constructor of the given datatype)+-- to all parameters described within given code.+class GDocumentEntrypoints (kind :: Kind.Type) (x :: Kind.Type -> Kind.Type) where+  -- | Add corresponding parameter building step.+  --+  -- First argument is accumulator for Michelson description of the building step.+  gDocumentEntrypoints+    :: ParamBuilder+    -> Rec (CaseClauseL inp out) (GCaseClauses x)+    -> Rec (CaseClauseL inp out) (GCaseClauses x)++instance GDocumentEntrypoints kind x => GDocumentEntrypoints kind (G.D1 i x) where+  gDocumentEntrypoints = gDocumentEntrypoints @kind @x++instance ( GDocumentEntrypoints kind x, GDocumentEntrypoints kind y+         , RSplit (GCaseClauses x) (GCaseClauses y)+         ) =>+         GDocumentEntrypoints kind (x :+: y) where+  gDocumentEntrypoints (ParamBuilder michDesc) clauses =+    let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses+    in gDocumentEntrypoints @kind @x+         (ParamBuilder $ \a -> michDesc $ "Left (" <> a <> ")")+         lclauses+       `rappend`+       gDocumentEntrypoints @kind @y+         (ParamBuilder $ \a -> michDesc $ "Right (" <> a <> ")")+         rclauses++instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x+         , KnownSymbol ctor+         , DocItem (DEntrypoint kind)+         , DeriveCtorFieldDoc ctor cf+         ) =>+         GDocumentEntrypoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where+  gDocumentEntrypoints michDesc (CaseClauseL clause :& RNil) =+    let entrypointName = toText $ symbolVal (Proxy @ctor)+        psteps = mkPbsWrapIn entrypointName michDesc+        addDoc instr =+          clarifyParamBuildingSteps psteps $+          docGroup (SomeDocItem . DEntrypoint @kind entrypointName) $+          doc (deriveCtorFieldDoc @ctor @cf) # instr+    in CaseClauseL (addDoc clause) :& RNil++-- | Like 'case_', to be used for pattern-matching on a parameter+-- or its part.+--+-- Modifies documentation accordingly. Including description of+-- entrypoints' arguments, thus for them you will need to supply+-- 'TypeHasDoc' instance.+entryCase_+  :: forall dt entrypointKind out inp.+     ( InstrCaseC dt+     , RMap (CaseClauses dt)+     , DocumentEntrypoints entrypointKind dt+     )+  => Proxy entrypointKind+  -> Rec (CaseClauseL inp out) (CaseClauses dt)+  -> dt & inp :-> out+entryCase_ _ = case_ . documentEntrypoints @dt @entrypointKind++-- | Version of 'entryCase_' for tuples.+entryCase+  :: forall dt entrypointKind out inp clauses.+     ( CaseTC dt out inp clauses+     , DocumentEntrypoints entrypointKind dt+     )+  => Proxy entrypointKind -> IsoRecTuple clauses -> dt & inp :-> out+entryCase p = entryCase_ p . recFromTuple++-- | Wrapper for documenting single entrypoint which parameter+-- isn't going to be unwrapped from some datatype.+--+-- @entryCase@ unwraps a datatype, however, sometimes we want to+-- have entrypoint parameter to be not wrapped into some datatype.+documentEntrypoint+  :: forall kind epName param s out.+     ( KnownSymbol epName+     , DocItem (DEntrypoint kind)+     , TypeHasDoc param+     , HasAnnotation param+     , KnownValue param+     )+  => param & s :-> out -> param & s :-> out+documentEntrypoint instr =+  let entrypointName = toText $ symbolVal (Proxy @epName) in+    docGroup (SomeDocItem . DEntrypoint @kind entrypointName) $+    doc (constructDEpArg @param) # instr++-- | Provides arror for convenient entrypoint documentation+class EntryArrow kind name body where+  -- | Lift entrypoint implementation.+  --+  -- Entrypoint names should go with "e" prefix.+  (#->) :: (Label name, Proxy kind) -> body -> body++instance ( name ~ ("e" `AppendSymbol` epName)+         , body ~ (param & s :-> out)+         , KnownSymbol epName+         , DocItem (DEntrypoint kind)+         , TypeHasDoc param+         , HasAnnotation param+         , KnownValue param+         ) => EntryArrow kind name body where+  (#->) _ = documentEntrypoint @kind @epName++-- | Modify param building steps with respect to entrypoints that given+-- parameter declares.+--+-- Each contract with entrypoints should eventually call this function,+-- otherwise, in case if contract uses built-in entrypoints feature,+-- the resulting parameter building steps in the generated documentation+-- will not consider entrypoints and thus may be incorrect.+--+-- Calling this twice over the same code is also prohibited.+finalizeParamCallingDoc+  :: forall cp inp out.+     (NiceParameterFull cp, RequireSumType cp, HasCallStack)+  => (cp : inp :-> out) -> (cp : inp :-> out)+finalizeParamCallingDoc = modifyParamBuildingSteps modifySteps+  where+    -- We do not actually need it, requiring this constraint only to avoid+    -- misapplication of our function.+    _needSumType :: Dict (RequireSumType cp)+    _needSumType = Dict++    epDescs :: [Some1 EpCallingDesc]+    epDescs =+      -- Reversing the list because if element @e1@ of this list is prefix of+      -- another element @e2@, we want @e2@ to appear eariler than @e1@ to+      -- match against it first. But without reverse exactly the opposite+      -- holds due to [order of entrypoints children] property.+      reverse $ pepDescsWithDef @cp++    modifySteps :: [ParamBuildingStep] -> [ParamBuildingStep]+    modifySteps pbs+      | areFinalizedParamBuildingSteps pbs =+          error "Applying finalization second time"+      | otherwise =+          fromMaybe [PbsUncallable pbs] . listToMaybe . catMaybes $+          epDescs <&> \epDesc -> tryShortcut epDesc pbs++    -- Further we check whether given 'EpCallingStep's form prefix of+    -- 'ParamBuildingStep's; if so, we can apply only part of building+    -- steps and then call the entrypoint directly++    match :: [EpCallingStep] -> [ParamBuildingStep] -> Bool+    match cSteps pbSteps =+      and $ zip cSteps (prolong pbSteps) <&> \case+        (EpsWrapIn ctor, Just (PbsWrapIn ctor2 _)) | ctor == ctor2 -> True+        _ -> False+      where+        prolong :: [a] -> [Maybe a]+        prolong l = map Just l ++ repeat Nothing++    tryShortcut+      :: Some1 EpCallingDesc+      -> [ParamBuildingStep]+      -> Maybe [ParamBuildingStep]+    tryShortcut (Some1 EpCallingDesc{ epcdSteps = cSteps, epcdEntrypoint = ep })+                pbSteps+      | match cSteps pbSteps =+          let truncated = drop (length cSteps) pbSteps+              callEpStep = PbsCallEntrypoint ep+          in Just $ callEpStep : truncated+      | otherwise = Nothing++-- | Whether 'finalizeParamCallingDoc' has already been applied to these steps.+areFinalizedParamBuildingSteps :: [ParamBuildingStep] -> Bool+areFinalizedParamBuildingSteps =+  -- Currently, 'finalizeParamCallingDoc' puts either 'PbsCallEntrypoint' or+  -- 'PbsUncallable' to list, and only it, and we rely on this behaviour here.+  -- If something changes so that these heuristics do not work, we can always+  -- insert special markers which would tell us whether finalization has been+  -- applied.+  let+    hasFinalizationTraces = \case+      PbsWrapIn{} -> False+      PbsCallEntrypoint{} -> True+      PbsCustom{} -> False+      PbsUncallable{} -> True+  in any hasFinalizationTraces++entryCaseSimple_+  :: forall cp out inp.+     ( InstrCaseC cp+     , RMap (CaseClauses cp)+     , DocumentEntrypoints PlainEntrypointsKind cp+     , NiceParameterFull cp+     , RequireFlatParamEps cp+     )+  => Rec (CaseClauseL inp out) (CaseClauses cp)+  -> cp & inp :-> out+entryCaseSimple_ =+  finalizeParamCallingDoc . entryCase_ (Proxy @PlainEntrypointsKind)+  where+    _reqFlat = Dict @(RequireFlatEpDerivation cp (GetParameterEpDerivation cp))++-- | Version of 'entryCase' for contracts with flat parameter, use it when you+-- need only one 'entryCase' all over the contract implementation.+--+-- This method calls 'finalizeParamCallingDoc' inside.+entryCaseSimple+  :: forall cp out inp clauses.+     ( CaseTC cp out inp clauses+     , DocumentEntrypoints PlainEntrypointsKind cp+     , NiceParameterFull cp+     , RequireFlatParamEps cp+     )+  => IsoRecTuple clauses -> cp & inp :-> out+entryCaseSimple = entryCaseSimple_ . recFromTuple++type family RequireFlatParamEps cp :: Constraint where+  RequireFlatParamEps cp =+    ( RequireFlatEpDerivation cp (GetParameterEpDerivation cp)+    , RequireSumType cp+    )++-- Checking this is not strictly necessary, but let's try it+type family RequireFlatEpDerivation cp deriv :: Constraint where+  RequireFlatEpDerivation _ EpdNone = ()+  RequireFlatEpDerivation _ EpdPlain = ()+  RequireFlatEpDerivation cp deriv = TypeError+    ( 'Text "Parameter is not flat" ':$$:+      'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`" ':$$:+      'Text "With entrypoints derivation way `" ':<>: 'ShowType deriv ':<>: 'Text "`"+    )

@@ -0,0 +1,59 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Entrypoints.Helpers+  ( ctorNameToAnn+  , ctorNameToEp+  , CanHaveEntrypoints+  , ShouldHaveEntrypoints (..)+  , RequireSumType+  ) where++import qualified Data.Kind as Kind++import Michelson.Typed.Haskell+import Michelson.Typed.T+import Michelson.Untyped (EpName, FieldAnn, ann, epNameFromParamAnn)+import Util.Text+import Util.Type+import Util.TypeLits++ctorNameToAnn :: forall ctor. (KnownSymbol ctor, HasCallStack) => FieldAnn+ctorNameToAnn = ann . headToLower $ (symbolValT' @ctor)++ctorNameToEp :: forall ctor. (KnownSymbol ctor, HasCallStack) => EpName+ctorNameToEp =+  epNameFromParamAnn (ctorNameToAnn @ctor)+  ?: error "Empty constructor-entrypoint name"++-- | A special type which wraps over a primitive type and states that it has+-- entrypoints (one).+--+-- Assuming that any type can have entrypoints makes use of Lorentz entrypoints+-- too annoying, so for declaring entrypoints for not sum types we require an+-- explicit wrapper.+newtype ShouldHaveEntrypoints a = ShouldHaveEntrypoints { unHasEntrypoints :: a }+  deriving stock Generic++deriving anyclass instance (WellTypedIsoValue r) => IsoValue (ShouldHaveEntrypoints r)++-- | Used to understand whether a type can potentially declare any entrypoints.+type family CanHaveEntrypoints (p :: Kind.Type) :: Bool where+  CanHaveEntrypoints (ShouldHaveEntrypoints _) = 'True+  CanHaveEntrypoints p = CanHaveEntrypointsT (ToT p)++type family CanHaveEntrypointsT (t :: T) :: Bool where+  CanHaveEntrypointsT ('TOr _ _) = 'True+  CanHaveEntrypointsT _ = 'False++-- | Ensure that given type is a sum type.+--+-- This helps to prevent attempts to apply a function to, for instance, a pair.+type family RequireSumType (a :: Kind.Type) :: Constraint where+  RequireSumType a =+    If (CanHaveEntrypoints a)+       (() :: Constraint)+       (TypeError ('Text "Expected Michelson sum type" ':$$:+                   'Text "In type `" ':<>: 'ShowType a ':<>: 'Text "`"+                  ))

@@ -0,0 +1,364 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Common implementations of entrypoints.+module Lorentz.Entrypoints.Impl+  ( -- * Ways to implement 'ParameterHasEntrypoints'+    EpdPlain+  , EpdRecursive+  , EpdDelegate++  -- * Implementation details+  , PlainEntrypointsC+  , EPTree (..)+  , BuildEPTree+  ) where++import qualified Data.Kind as Kind+import Data.Singletons.Prelude (SBool(SFalse, STrue))+import Data.Singletons.Prelude.Eq ((%==))+import Data.Vinyl.Core (Rec(..), (<+>))+import Data.Vinyl.Recursive (rmap)+import Fcf (Eval, Exp)+import qualified Fcf+import qualified GHC.Generics as G+import Util.TypeLits++import Lorentz.Value+import Michelson.Typed+import Michelson.Typed.Haskell.Value (GValueType)+import Michelson.Untyped (FieldAnn, noAnn)+import Util.Fcf (type (<|>), Over2, TyEqSing)+import Util.Type++import Lorentz.Annotation+import Lorentz.Entrypoints.Core+import Lorentz.Entrypoints.Helpers++-- | Implementation of 'ParameterHasEntrypoints' which fits for case when+-- your contract exposes multiple entrypoints via having sum type as its+-- parameter.+--+-- In particular, each constructor would produce a homonymous entrypoint with+-- argument type equal to type of constructor field (each constructor should+-- have only one field).+-- Constructor called 'Default' will designate the default entrypoint.+data EpdPlain+instance PlainEntrypointsC EpdPlain cp => EntrypointsDerivation EpdPlain cp where+  type EpdAllEntrypoints EpdPlain cp = PlainAllEntrypointsExt EpdPlain cp+  type EpdLookupEntrypoint EpdPlain cp = PlainLookupEntrypointExt EpdPlain cp+  epdNotes = plainEpdNotesExt @EpdPlain @cp+  epdCall = plainEpdCallExt @EpdPlain @cp+  epdDescs = plainEpdDescsExt @EpdPlain @cp++-- | Extension of 'EpdPlain' on parameters being defined as several nested+-- datatypes.+--+-- In particular, this will traverse sum types recursively, stopping at+-- Michelson primitives (like 'Natural') and constructors with number of+-- fields different from one.+--+-- It does not assign names to intermediate nodes of 'Or' tree, only to the very+-- leaves.+--+-- If some entrypoint arguments have custom 'IsoValue' instance, this+-- derivation way will not work. As a workaround, you can wrap your+-- argument into some primitive (e.g. ':!').+data EpdRecursive+instance PlainEntrypointsC EpdRecursive cp => EntrypointsDerivation EpdRecursive cp where+  type EpdAllEntrypoints EpdRecursive cp = PlainAllEntrypointsExt EpdRecursive cp+  type EpdLookupEntrypoint EpdRecursive cp = PlainLookupEntrypointExt EpdRecursive cp+  epdNotes = plainEpdNotesExt @EpdRecursive @cp+  epdCall = plainEpdCallExt @EpdRecursive @cp+  epdDescs = plainEpdDescsExt @EpdRecursive @cp++-- | Extension of 'EpdPlain' on parameters being defined as several nested+-- datatypes.+--+-- In particular, it will traverse the immediate sum type, and require another+-- 'ParameterHasEntrypoints' for the inner complex datatypes. Only those+-- inner types are considered which are the only fields in their respective+-- constructors.+-- Inner types should not themselves declare default entrypoint, we enforce+-- this for better modularity.+-- Each top-level constructor will be treated as entrypoint even if it contains+-- a complex datatype within, in such case that would be an entrypoint+-- corresponding to intermediate node in @or@ tree.+--+-- Comparing to 'EpdRecursive' this gives you more control over where and how+-- entrypoints will be derived.+data EpdDelegate+instance (PlainEntrypointsC EpdDelegate cp) => EntrypointsDerivation EpdDelegate cp where+  type EpdAllEntrypoints EpdDelegate cp = PlainAllEntrypointsExt EpdDelegate cp+  type EpdLookupEntrypoint EpdDelegate cp = PlainLookupEntrypointExt EpdDelegate cp+  epdNotes = plainEpdNotesExt @EpdDelegate @cp+  epdCall = plainEpdCallExt @EpdDelegate @cp+  epdDescs = plainEpdDescsExt @EpdDelegate @cp++type PlainAllEntrypointsExt mode cp = AllEntrypoints mode (BuildEPTree mode cp) cp++type PlainLookupEntrypointExt mode cp = LookupEntrypoint mode (BuildEPTree mode cp) cp++plainEpdNotesExt+  :: forall mode cp.+     (PlainEntrypointsC mode cp, HasCallStack)+  => Notes (ToT cp)+plainEpdNotesExt = mkEntrypointsNotes @mode @(BuildEPTree mode cp) @cp++plainEpdCallExt+  :: forall mode cp name.+     (PlainEntrypointsC mode cp, ParameterScope (ToT cp))+  => Label name+  -> EpConstructionRes (ToT cp) (Eval (LookupEntrypoint mode (BuildEPTree mode cp) cp name))+plainEpdCallExt = mkEpLiftSequence @mode @(BuildEPTree mode cp) @cp++plainEpdDescsExt+  :: forall mode cp.+     (PlainEntrypointsC mode cp)+  => Rec EpCallingDesc (PlainAllEntrypointsExt mode cp)+plainEpdDescsExt = mkEpDescs @mode @(BuildEPTree mode cp) @cp++type PlainEntrypointsC mode cp =+  ( GenericIsoValue cp+  , EntrypointsNotes mode (BuildEPTree mode cp) cp+  , RequireSumType cp+  )++-- | Entrypoints tree - skeleton on 'TOr' tree later used to distinguish+-- between constructors-entrypoints and constructors which consolidate+-- a whole pack of entrypoints.+data EPTree+  = EPNode EPTree EPTree+    -- ^ We are in the intermediate node and need to go deeper.+  | EPLeaf+    -- ^ We reached entrypoint argument.+  | EPDelegate+    -- ^ We reached complex parameter part and will need to ask how to process it.++-- | Build 'EPTree' by parameter type.+type BuildEPTree mode a = GBuildEntrypointsTree mode (G.Rep a)++type family GBuildEntrypointsTree (mode :: Kind.Type) (x :: Kind.Type -> Kind.Type)+             :: EPTree where+  GBuildEntrypointsTree mode (G.D1 _ x) =+    GBuildEntrypointsTree mode x+  GBuildEntrypointsTree mode (x G.:+: y) =+    'EPNode (GBuildEntrypointsTree mode x) (GBuildEntrypointsTree mode y)++  GBuildEntrypointsTree EpdPlain (G.C1 _ _) =+    'EPLeaf+  GBuildEntrypointsTree EpdRecursive (G.C1 _ x) =+    GBuildEntrypointsTree EpdRecursive x+  GBuildEntrypointsTree EpdDelegate (G.C1 _ (G.S1 _ (G.Rec0 _))) =+    'EPDelegate+  GBuildEntrypointsTree EpdDelegate (G.C1 _ _) =+    'EPLeaf+  GBuildEntrypointsTree mode (G.S1 _ x) =+    GBuildEntrypointsTree mode x+  GBuildEntrypointsTree _ G.U1 =+    'EPLeaf+  GBuildEntrypointsTree _ (_ G.:*: _) =+    'EPLeaf+  GBuildEntrypointsTree mode (G.Rec0 a) =+    If (IsPrimitiveValue a)+       'EPLeaf+       (BuildEPTree mode a)++-- | Traverses sum type and constructs 'Notes' which report+-- constructor names via field annotations.+type EntrypointsNotes mode ep a = (Generic a, GEntrypointsNotes mode ep (G.Rep a))++-- | Makes up notes with proper field annotations for given parameter.+mkEntrypointsNotes+  :: forall mode ep a.+      (EntrypointsNotes mode ep a, GenericIsoValue a, HasCallStack)+  => Notes (ToT a)+mkEntrypointsNotes = fst $ gMkEntrypointsNotes @mode @ep @(G.Rep a)++-- | Makes up a way to lift entrypoint argument to full parameter.+mkEpLiftSequence+  :: forall mode ep a name.+      ( EntrypointsNotes mode ep a, ParameterScope (ToT a)+      , GenericIsoValue a+      )+  => Label name+  -> EpConstructionRes (ToT a) (Eval (LookupEntrypoint mode ep a name))+mkEpLiftSequence = gMkEpLiftSequence @mode @ep @(G.Rep a)++-- | Makes up descriptions of entrypoints calling.+mkEpDescs+  :: forall mode ep a.+      (EntrypointsNotes mode ep a)+  => Rec EpCallingDesc (AllEntrypoints mode ep a)+mkEpDescs = gMkDescs @mode @ep @(G.Rep a)++-- | Fetches information about all entrypoints - leaves of 'Or' tree.+type AllEntrypoints mode ep a = GAllEntrypoints mode ep (G.Rep a)++-- | Fetches information about all entrypoints - leaves of 'Or' tree.+type LookupEntrypoint mode ep a = GLookupEntrypoint mode ep (G.Rep a)++-- | Generic traversal for 'EntrypointsNotes'.+class GEntrypointsNotes (mode :: Kind.Type) (ep :: EPTree) (x :: Kind.Type -> Kind.Type) where+  type GAllEntrypoints mode ep x :: [(Symbol, Kind.Type)]+  type GLookupEntrypoint mode ep x :: Symbol -> Exp (Maybe Kind.Type)++  {- | Returns:+    1. Notes corresponding to this level;+    2. Field annotation for this level (and which should be used one level above).+  -}+  gMkEntrypointsNotes :: HasCallStack => (Notes (GValueType x), FieldAnn)++  gMkEpLiftSequence+    :: ParameterScope (GValueType x)+    => Label name+    -> EpConstructionRes (GValueType x) (Eval (GLookupEntrypoint mode ep x name))++  gMkDescs+    :: Rec EpCallingDesc (GAllEntrypoints mode ep x)++instance GEntrypointsNotes mode ep x => GEntrypointsNotes mode ep (G.D1 i x) where+  type GAllEntrypoints mode ep (G.D1 i x) = GAllEntrypoints mode ep x+  type GLookupEntrypoint mode ep (G.D1 i x) = GLookupEntrypoint mode ep x+  gMkEntrypointsNotes = gMkEntrypointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x+  gMkDescs = gMkDescs @mode @ep @x++instance (GEntrypointsNotes mode epx x, GEntrypointsNotes mode epy y) =>+         GEntrypointsNotes mode ('EPNode epx epy) (x G.:+: y) where+  type GAllEntrypoints mode ('EPNode epx epy) (x G.:+: y) =+    GAllEntrypoints mode epx x ++ GAllEntrypoints mode epy y+  type GLookupEntrypoint mode ('EPNode epx epy) (x G.:+: y) =+    Over2 (<|>) (GLookupEntrypoint mode epx x) (GLookupEntrypoint mode epy y)+  gMkEntrypointsNotes =+    let (xnotes, xann) = gMkEntrypointsNotes @mode @epx @x+        (ynotes, yann) = gMkEntrypointsNotes @mode @epy @y+    in (NTOr noAnn xann yann xnotes ynotes, noAnn)+  gMkEpLiftSequence label =+    case sing @(GValueType (x G.:+: y)) of+      STOr sl _ -> case (checkOpPresence sl, checkNestedBigMapsPresence sl) of+        (OpAbsent, NestedBigMapsAbsent) ->+          case gMkEpLiftSequence @mode @epx @x label of+            EpConstructed liftSeq -> EpConstructed (EplWrapLeft liftSeq)+            EpConstructionFailed ->+              case gMkEpLiftSequence @mode @epy @y label of+                EpConstructed liftSeq -> EpConstructed (EplWrapRight liftSeq)+                EpConstructionFailed -> EpConstructionFailed+  gMkDescs =+    gMkDescs @mode @epx @x <+> gMkDescs @mode @epy @y++instance ( GHasAnnotation x, KnownSymbol ctor+         , ToT (GExtractField x) ~ GValueType x+         ) =>+         GEntrypointsNotes mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntrypoints mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =+    '[ '(ctor, GExtractField x) ]+  type GLookupEntrypoint mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =+    JustOnEq ctor (GExtractField x)+  gMkEntrypointsNotes =+    (fst $ gGetAnnotation @x False, ctorNameToAnn @ctor)+  gMkEpLiftSequence (Label :: Label name) =+    case sing @ctor %== sing @name of+      STrue -> EpConstructed EplArgHere+      SFalse -> EpConstructionFailed+  gMkDescs = addDescStep @ctor $+    EpCallingDesc+    { epcdArg = Proxy+    , epcdEntrypoint = ctorNameToEp @ctor+    , epcdSteps = []+    } :& RNil++instance (ep ~ 'EPNode epx epy, GEntrypointsNotes mode ep x, KnownSymbol ctor) =>+         GEntrypointsNotes mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntrypoints mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =+    GAllEntrypoints mode ('EPNode epx epy) x+  type GLookupEntrypoint mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =+    GLookupEntrypoint mode ('EPNode epx epy) x+  gMkEntrypointsNotes = gMkEntrypointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x+  gMkDescs = addDescStep @ctor $ gMkDescs @mode @ep @x++instance ( ep ~ 'EPDelegate, GEntrypointsNotes mode ep x+         , KnownSymbol ctor, ToT (GExtractField x) ~ GValueType x+         ) =>+         GEntrypointsNotes mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntrypoints mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =+    '(ctor, GExtractField x) ': GAllEntrypoints mode 'EPDelegate x+  type GLookupEntrypoint mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =+    Over2 (<|>) (JustOnEq ctor (GExtractField x)) (GLookupEntrypoint mode 'EPDelegate x)+  gMkEntrypointsNotes =+    let (notes, _rootAnn) = gMkEntrypointsNotes @mode @ep @x+    in (notes, ctorNameToAnn @ctor)+  gMkEpLiftSequence label@(Label :: Label name) =+    case sing @ctor %== sing @name of+      STrue -> EpConstructed EplArgHere+      SFalse -> gMkEpLiftSequence @mode @ep @x label+  gMkDescs = addDescStep @ctor $+    EpCallingDesc+    { epcdArg = Proxy+    , epcdEntrypoint = ctorNameToEp @ctor+    , epcdSteps = []+    } :& gMkDescs @mode @ep @x++instance GEntrypointsNotes mode ep x => GEntrypointsNotes mode ep (G.S1 i x) where+  type GAllEntrypoints mode ep (G.S1 i x) = GAllEntrypoints mode ep x+  type GLookupEntrypoint mode ep (G.S1 i x) = GLookupEntrypoint mode ep x+  gMkEntrypointsNotes = gMkEntrypointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x+  gMkDescs = gMkDescs @mode @ep @x++instance (EntrypointsNotes EpdRecursive ep a, GenericIsoValue a) =>+         GEntrypointsNotes EpdRecursive ep (G.Rec0 a) where+  type GAllEntrypoints EpdRecursive ep (G.Rec0 a) = AllEntrypoints EpdRecursive ep a+  type GLookupEntrypoint EpdRecursive ep (G.Rec0 a) = LookupEntrypoint EpdRecursive ep a+  gMkEntrypointsNotes = (mkEntrypointsNotes @EpdRecursive @ep @a, noAnn)+  gMkEpLiftSequence = mkEpLiftSequence @EpdRecursive @ep @a+  gMkDescs = mkEpDescs @EpdRecursive @ep @a++instance (ParameterDeclaresEntrypoints a) =>+         GEntrypointsNotes EpdDelegate 'EPDelegate (G.Rec0 a) where+  type GAllEntrypoints EpdDelegate 'EPDelegate (G.Rec0 a) = AllParameterEntrypoints a+  type GLookupEntrypoint EpdDelegate 'EPDelegate (G.Rec0 a) = LookupParameterEntrypoint a+  gMkEntrypointsNotes = (pepNotes @a, noAnn)+  -- TODO [#35]: should use field ann ^^^^^ returned by 'epdNotes'+  gMkEpLiftSequence = pepCall @a+  gMkDescs = pepDescs @a++instance GEntrypointsNotes mode 'EPLeaf G.U1 where+  type GAllEntrypoints mode 'EPLeaf G.U1 = '[]+  type GLookupEntrypoint mode 'EPLeaf G.U1 = Fcf.ConstFn 'Nothing+  gMkEntrypointsNotes = (starNotes, noAnn)+  gMkEpLiftSequence _ = EpConstructionFailed+  gMkDescs = RNil++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+  gMkEntrypointsNotes = (starNotes, noAnn)+  gMkEpLiftSequence _ = EpConstructionFailed+  gMkDescs = RNil++-- Return 'Just' iff given entries of type @k1@ are equal.+type family JustOnEq (a :: k1) (b :: k2) :: k1 -> Exp (Maybe k2) where+  JustOnEq a b =+    Fcf.Case+      '[ Fcf.Is (TyEqSing a) ('Just b)+       , Fcf.Any 'Nothing+       ]++-- Get field type under 'G.C1'.+type family GExtractField (x :: Kind.Type -> Kind.Type) where+  GExtractField (G.S1 _ x) = GExtractField x+  GExtractField (G.Rec0 a) = a+  GExtractField G.U1 = ()++addDescStep+  :: forall ctor eps.+      KnownSymbol ctor+  => Rec EpCallingDesc eps -> Rec EpCallingDesc eps+addDescStep =+  let step = EpsWrapIn $ symbolValT' @ctor+  in rmap $ \EpCallingDesc{..} ->+       EpCallingDesc{ epcdSteps = step : epcdSteps, .. }

@@ -0,0 +1,41 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Allows specifying entrypoints without declaring 'ParamterHasEntrypoints'+-- instance.+module Lorentz.Entrypoints.Manual+  ( ParameterWrapper (..)+  ) where++import qualified Data.Kind as Kind++import Lorentz.Constraints+import Lorentz.Entrypoints.Core+import Michelson.Typed+import Lorentz.Wrappable (Wrappable)++-- | Wrap parameter into this to locally assign a way to derive entrypoints for+-- it.+newtype ParameterWrapper (deriv :: Kind.Type) cp = ParameterWrapper { unParameterWraper :: cp }+  deriving stock Generic+  deriving anyclass (IsoValue, Wrappable)++-- Helper for implementing @instance ParameterHasEntrypoints ParameterWrapper@.+data PwDeriv deriv+instance EntrypointsDerivation deriv cp =>+         EntrypointsDerivation (PwDeriv deriv) (ParameterWrapper deriv cp) where+  type EpdAllEntrypoints (PwDeriv deriv) (ParameterWrapper deriv cp) =+    EpdAllEntrypoints deriv cp+  type EpdLookupEntrypoint (PwDeriv deriv) (ParameterWrapper deriv cp) =+    EpdLookupEntrypoint deriv cp+  epdNotes = epdNotes @deriv @cp+  epdCall = epdCall @deriv @cp+  epdDescs = epdDescs @deriv @cp++instance ( NiceParameter cp+         , EntrypointsDerivation epd cp+         , RequireAllUniqueEntrypoints' epd cp+         ) =>+         ParameterHasEntrypoints (ParameterWrapper epd cp) where+  type ParameterEntrypointsDerivation (ParameterWrapper epd cp) = PwDeriv epd

@@ -36,14 +36,6 @@   , DError (..)   , DThrows (..) -    -- * Old interface (DEPRECATED)-  , customErrorToVal-  , customErrorFromVal-  , failUsingArg-  , FailUsingArg-  , CustomErrorNoIsoValue-  , deriveCustomError-     -- * Internals   , errorTagToText   , errorTagToMText@@ -54,12 +46,10 @@ import qualified Data.List as L import Data.Singletons (demote) import Data.Typeable (cast)-import Fmt (Buildable, build, fmt, pretty, (+|), (+||), (|+), (||+))-import qualified Language.Haskell.TH as TH+import Fmt (Buildable, build, fmt, pretty, (+|), (|+)) import qualified Text.Show  import Lorentz.Base-import Lorentz.Constraints (KnownValue) import Lorentz.Doc import Lorentz.Instr hiding (cast) import Lorentz.Value@@ -68,9 +58,7 @@ import Michelson.Typed.Haskell import Michelson.Typed.Instr import Michelson.Typed.Scope-import Michelson.Typed.Sing import Michelson.Typed.T-import Michelson.Typed.Value import Util.Markdown import Util.Type import Util.Typeable@@ -524,8 +512,8 @@   DError e1 `compare` DError e2 = e1 `compareExt` e2  instance DocItem DError where-  type DocItemPosition DError = 5010   type DocItemPlacement DError = 'DocItemInDefinitions+  docItemPos = 5010   docItemSectionName = Just "Errors"   docItemSectionDescription = Just errorsDocumentation   docItemRef (DError (_ :: Proxy e)) = DocItemRef $@@ -557,7 +545,7 @@   DThrows e1 == DThrows e2 = eqParam1 e1 e2  instance DocItem DThrows where-  type DocItemPosition DThrows = 5011+  docItemPos = 5011   docItemSectionName = Just "Possible errors"   docItemSectionNameStyle = DocSectionNameSmall   docItemDependencies (DThrows ds) =@@ -623,119 +611,3 @@      If an internal error is thrown, please report it to the author of this contract.   |]--------------------------------------------------------------------------------- Old interface (DEPRECATED)-------------------------------------------------------------------------------{- This API implements an approach when errors are declared via datatype-with constructors corresponding to error scenarios.--}---- | Implementation of 'errorToVal' for custom errors.-customErrorToVal-  :: (LooseSumC e, HasCallStack)-  => e-  -> (forall t. ErrorScope t => Value t -> r)-  -> r-customErrorToVal e cont =-  case toTaggedVal e of-    (tag, SomeValue (datVal :: Value t)) ->-      -- Tags come from constructors names, so we can assume-      -- the event of weird chars occurrence to be quite improbable-      let tag' = mkMTextUnsafe tag-      in case (opAbsense (sing @t), bigMapAbsense (sing @t), contractTypeAbsense (sing @t)) of-        (Just Dict, Just Dict, Just Dict) -> cont $ VPair (VString tag', datVal)--        -- We could check this at type-level, but this would require-        -- specializing 'Michelson.Typed.LooseSum' to errors.-        -- We can do so, or assume that no one will ever try to put 'Operation'-        -- to error datatypes:-        (Nothing, _, _) -> error "Operation in constructor data"-        (_, Nothing, _) -> error "BigMap in constructor data"-        (_, _, Nothing) -> error "Contract in constructor data"-{-# DEPRECATED customErrorToVal "Datatype error declarations has been deprecated" #-}---- | Implementation of 'errorFromVal' for custom errors.------ This function is deprecated.-customErrorFromVal-  :: forall t e.-      (SingI t, LooseSumC e)-  => Value t -> Either Text e-customErrorFromVal v = case (v, sing @t) of-  (VPair (VString tag, datVal), STPair _ _) ->-    case fromTaggedVal (toText tag, SomeValue datVal) of-      ComposeOk e ->-        Right e-      ComposeCtorNotFound ->-        Left $ "Unknown error constructor " +| tag |+ ""-      ComposeFieldTypeMismatch got expected ->-        Left $ "Error data type mismatch, expected " +|| expected ||+-                                            ", got " +|| got ||+ ""-  _ -> Left $ "Expected a (tag, dat) pair representing error"-{-# DEPRECATED customErrorFromVal "Datatype error declarations has been deprecated" #-}---- | Prompt an error message saying that 'IsoValue' is not applicable for this type.-type family CustomErrorNoIsoValue a where-  CustomErrorNoIsoValue a = TypeError-    ('Text "No IsoValue instance for " ':<>: 'ShowType a ':$$:-     'Text "It has custom error representation")---- | Derive 'IsError' instance for given type.------ This will also forbid deriving 'IsoValue' instance for that type to avoid--- having multiple different Michelson representations.-deriveCustomError :: TH.Name -> TH.Q [TH.Dec]-deriveCustomError name =-  [d|-    instance IsError $ty where-      errorToVal = customErrorToVal-      errorFromVal = customErrorFromVal--    instance (WellTypedIsoValue $ty, CustomErrorNoIsoValue $ty) => IsoValue $ty where-      type ToT $ty = CustomErrorNoIsoValue $ty-      toVal = error "impossible"-      fromVal = error "impossible"--    instance ErrorHasDoc $ty where-      errorDocName = "Some error"-      errorDocMdCause = "An error occurred."-      errorDocHaskellRep = "-"-      errorDocClass = ErrClassUnknown-      errorDocDependencies = []-  |]-  where-    ty = pure (TH.ConT name)-{-# DEPRECATED deriveCustomError "Datatype error declarations has been deprecated" #-}---- | Signature of 'userFailWith'.-type FailUsingArg e name fieldTy s s'-  = ( KnownSymbol name, IsError e-    , KnownValue fieldTy-    , CtorHasOnlyField name e fieldTy-    , HasCallStack-    )-  => Label name -> fieldTy : s :-> s'---- | Fail with given error, picking argument for error from the top--- of the stack.------ If your error constructor does not carry an argument, use 'failUsing'--- function instead.--- Consider the following practice: once error datatype for your contract--- is defined, create a specialization of this function to the error type.------ This function is deprecated.-failUsingArg-  :: forall err name fieldTy s s'.-     FailUsingArg err name fieldTy s s'-failUsingArg _ =-  push (mkMTextUnsafe ctor) #-  pair #-  failWith-  where-    ctor = case symbolVal (Proxy @name) of-      'c' : other -> toText other-      other -> error $ "Bad label provided: " +| other |+ ""-{-# DEPRECATED failUsingArg "Datatype error declarations has been deprecated" #-}

@@ -42,8 +42,8 @@   deriving stock (Eq, Ord)  instance DocItem DDescribeErrorTagMap where-  type DocItemPosition DDescribeErrorTagMap = 4090   type DocItemPlacement DDescribeErrorTagMap = 'DocItemInDefinitions+  docItemPos = 4090   docItemSectionName = Just "About error tags mapping"   docItemRef DDescribeErrorTagMap{..} = DocItemRef $     DocItemId $ "error-mapping-" <> detmSrcLoc

@@ -64,13 +64,13 @@ import GHC.TypeLits (Nat) import GHC.TypeNats (type (+)) +import Lorentz.Annotation import Lorentz.Base import Lorentz.Coercions import Lorentz.Constraints import Lorentz.Doc import Lorentz.Instr import Lorentz.Pack-import Lorentz.TypeAnns import Michelson.Typed import Util.Label (Label) import Util.Markdown@@ -79,9 +79,7 @@  newtype Extensible x = Extensible (Natural, ByteString)   deriving stock (Generic, Eq, Show)-  deriving anyclass (IsoValue, HasTypeAnn)--instance Wrapped (Extensible x)+  deriving anyclass (IsoValue, HasAnnotation, Wrappable)  type ExtVal x = (Generic x, GExtVal x (G.Rep x)) type GetCtors x = GGetCtors (G.Rep x)

@@ -117,15 +117,15 @@ import Lorentz.Arith import Lorentz.Base import Lorentz.Constraints-import Lorentz.EntryPoints+import Lorentz.Entrypoints import Lorentz.Polymorphic import Lorentz.Run (Contract, compileLorentzContract) import Lorentz.Value import Lorentz.Zip import Michelson.Typed   (pattern CAR, pattern CDR, CommentType(..), ConstraintDIG, ConstraintDIG', ConstraintDIPN,-  ConstraintDIPN', ConstraintDUG, ConstraintDUG', EntryPointCallT(..), ExtInstr(..), Instr(..),-  RemFail(..), SomeEntryPointCallT(..), Value'(..), sepcName, starNotes)+  ConstraintDIPN', ConstraintDUG, ConstraintDUG', EntrypointCallT(..), ExtInstr(..), Instr(..),+  RemFail(..), SomeEntrypointCallT(..), Value'(..), sepcName, starNotes) import Michelson.Typed.Arith import Michelson.Typed.Haskell.Value import Util.Peano@@ -514,7 +514,7 @@ -- If you are going to call a specific entrypoint of the contract, see 'selfCalling'. self   :: forall p s.-      (NiceParameterFull p, ForbidExplicitDefaultEntryPoint p)+      (NiceParameterFull p, ForbidExplicitDefaultEntrypoint p)   => s :-> ContractRef p & s self = I (SELF $ sepcCallRootChecked @p) \\ niceParameterEvi @p @@ -526,12 +526,12 @@ selfCalling   :: forall p mname s.      (NiceParameterFull p)-  => EntryPointRef mname-  -> s :-> ContractRef (GetEntryPointArgCustom p mname) & s+  => EntrypointRef mname+  -> s :-> ContractRef (GetEntrypointArgCustom p mname) & s selfCalling epRef = I $   withDict (niceParameterEvi @p) $-  case parameterEntryPointCallCustom @p epRef of-    epc@EntryPointCall{} -> SELF (SomeEpc epc)+  case parameterEntrypointCallCustom @p epRef of+    epc@EntrypointCall{} -> SELF (SomeEpc epc)  -- | Get a reference to a contract by its address. --@@ -542,7 +542,7 @@ -- If you are going to call a specific entrypoint of the contract, see 'contractCalling'. contract   :: forall p addr s.-      ( NiceParameterFull p, ForbidExplicitDefaultEntryPoint p+      ( NiceParameterFull p, ForbidExplicitDefaultEntrypoint p       , ToTAddress_ p addr       )   => addr & s :-> Maybe (ContractRef p) & s@@ -557,18 +557,18 @@ -- stack argument. contractCalling   :: forall cp epRef epArg addr s.-     (HasEntryPointArg cp epRef epArg, ToTAddress_ cp addr)+     (HasEntrypointArg cp epRef epArg, ToTAddress_ cp addr)   => epRef   -> addr & s :-> Maybe (ContractRef epArg) & s contractCalling epRef = I $-  case useHasEntryPointArg @cp @epRef @epArg epRef of+  case useHasEntrypointArg @cp @epRef @epArg epRef of     (Dict, epName) -> CONTRACT starNotes epName  -- | Specialized version of 'contractCalling' for the case when you do--- not have compile-time evidence of appropriate 'HasEntryPointArg'.+-- not have compile-time evidence of appropriate 'HasEntrypointArg'. -- For instance, if you have untyped 'EpName' you can not have this -- evidence (the value is only available in runtime).--- If you have typed 'EntryPointRef', use 'eprName' to construct 'EpName'.+-- If you have typed 'EntrypointRef', use 'eprName' to construct 'EpName'. contractCallingUnsafe   :: forall arg s.      (NiceParameter arg)

@@ -125,9 +125,11 @@ import Data.Singletons (SingI(..)) import Fmt (Buildable(..), Builder, pretty, tupleF, (+|), (|+)) import Fmt.Internal.Tuple (TupleF)+import qualified GHC.TypeLits as Lit import GHC.TypeNats (type (-)) import qualified GHC.TypeNats as GHC (Nat) +import Lorentz.Annotation import Lorentz.Arith import Lorentz.Base import Lorentz.Coercions@@ -136,7 +138,6 @@ import Lorentz.Errors import Lorentz.Ext (stackType) import Lorentz.Instr-import Lorentz.TypeAnns import Lorentz.Value import Michelson.Typed (ConstraintDIG', ConstraintDIPN', ConstraintDUG', T) import Michelson.Typed.Arith@@ -637,7 +638,7 @@   { viewParam :: a   , viewCallbackTo :: ContractRef r   } deriving stock (Eq, Show, Generic)-    deriving anyclass (HasTypeAnn)+    deriving anyclass (HasAnnotation)  deriving anyclass instance (WellTypedIsoValue r, WellTypedIsoValue a) => IsoValue (View a r) @@ -688,11 +689,11 @@  view_ ::      (NiceParameter r)-  => (forall s0. (a, storage) & s0 :-> r : s0)+  => (forall s0. a & storage & s0 :-> r : s0)   -> View a r & storage & s :-> (List Operation, storage) & s view_ code =   unwrapView #-  unpair # dip (duupX @2) # pair # code # dip amount #+  unpair # dip (duupX @2) # code # dip amount #   transferTokens # nil # swap # cons # pair  -- | @void@ type synonym as described in A1.@@ -702,7 +703,7 @@   , voidResProxy :: Lambda b b     -- ^ Type of result reported via 'failWith'.   } deriving stock (Generic, Show)-    deriving anyclass (HasTypeAnn)+    deriving anyclass (HasAnnotation)  deriving anyclass instance (WellTypedIsoValue r, WellTypedIsoValue a) => IsoValue (Void_ a r) @@ -783,8 +784,12 @@   errorDocDependencies =     [dTypeDep @MText, dTypeDep @r] -instance (WellTypedIsoValue (VoidResult r), CustomErrorNoIsoValue (VoidResult r)) => IsoValue (VoidResult r) where-  type ToT (VoidResult r) = CustomErrorNoIsoValue (VoidResult r)+instance+  ( WellTypedIsoValue (VoidResult r)+  , Lit.TypeError ('Lit.Text "No IsoValue instance for VoidResult " 'Lit.:<>: 'Lit.ShowType r)+  ) => IsoValue (VoidResult r) where+  type ToT (VoidResult r) =+    Lit.TypeError ('Lit.Text "No IsoValue instance for VoidResult " 'Lit.:<>: 'Lit.ShowType r)   toVal = error "impossible"   fromVal = error "impossible" 

@@ -23,16 +23,17 @@ import Data.Default (def) import Data.Vinyl.Core (Rec(..)) +import Lorentz.Annotation import Lorentz.Base import Lorentz.Constraints-import Lorentz.EntryPoints+import Lorentz.Entrypoints import Michelson.Analyzer (AnalyzerRes, analyze) import Michelson.Interpret import Michelson.Optimizer (OptimizerConf, optimizeWithConf) import Michelson.Text (MText)-import Michelson.Typed-  (Instr(..), IsoValue, IsoValuesStack(..), ToT, ToTs, starNotes, starParamNotes)+import Michelson.Typed (Instr(..), IsoValue, IsoValuesStack(..), ToT, ToTs, starParamNotes) import qualified Michelson.Typed as M (Contract(..))+import qualified Michelson.Untyped as U (canonicalEntriesOrder)  -- | Options to control Lorentz to Michelson compilation. data CompilationOptions = CompilationOptions@@ -112,11 +113,12 @@       else -- Perform CAST otherwise.         compileLorentzWithOptions cCompilationOptions (I CAST # cCode :: ContractCode cp st)   , cParamNotes = cpNotes-  , cStoreNotes = starNotes+  , cStoreNotes = getAnnotation @st+  , cEntriesOrder = U.canonicalEntriesOrder   } \\ niceParameterEvi @cp     \\ niceStorageEvi @st   where-    cpNotes = parameterEntryPointsToNotes @cp+    cpNotes = parameterEntrypointsToNotes @cp  -- | Interpret a Lorentz instruction, for test purposes. Note that this does not run the -- optimizer.

@@ -1,706 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Impementation of @Store@ - object incapsulating multiple 'BigMap's.------ This module also provides template for the contract storage ---- 'StorageSkeleton'.------ We represent 'Store' as @big_map bytes (a | b | ...)@.------ Key of this map is formed as @(index, orig_key)@, where @index@ is--- zero-based index of emulated map, @orig_key@ is key of this emulated map.------ Value of this map is just a union of emulated map's values.--{- Note on store inner representation (@martoon)--I see an alternative approach - representing store as-@big_map bytes (option a, option b, ...)@.--This would allow for saner implementation and more convenient interface.-An obvious shortcoming here is gas consumption. But this overhead seems-insignificant against the background of some other instructions.---}-module Lorentz.Store-  {-# DEPRECATED "Contract storage can contain multiple big_maps starting from Michelson 005" #-}-  ( -- * Store and related type definitions-    Store (..)-  , type (|->)--    -- ** Type-lookup-by-name-  , GetStoreKey-  , GetStoreValue--    -- ** Instructions-  , storeMem-  , storeGet-  , storeUpdate-  , storeInsert-  , storeInsertNew-  , storeDelete--    -- ** Instruction constraints-  , StoreMemC-  , StoreGetC-  , StoreUpdateC-  , StoreInsertC-  , StoreDeleteC-  , HasStore-  , HasStoreForAllIn--    -- * Storage skeleton-  , StorageSkeleton (..)-  , storageUnpack-  , storagePack-  , storageMem-  , storageGet-  , storageInsert-  , storageInsertNew-  , storageDelete--    -- * Store management from Haskell-  , storePiece-  , storeKeyValueList-  , storeLookup--    -- ** Function constraints-  , StorePieceC-  ) where--import Data.Default (Default)-import qualified Data.Kind as Kind-import qualified Data.Map as Map-import Data.Type.Bool (If, type (||))-import Data.Type.Equality (type (==))-import GHC.Generics ((:+:))-import qualified GHC.Generics as G-import GHC.TypeLits (AppendSymbol, ErrorMessage(..), Symbol, TypeError)-import GHC.TypeNats (type (+), Nat)-import Type.Reflection ((:~:)(Refl))--import Lorentz.ADT-import Lorentz.Base-import Lorentz.Coercions-import Lorentz.Constraints-import Lorentz.Instr as L-import Lorentz.Macro-import Lorentz.Pack-import Lorentz.StoreClass-import Michelson.Typed.Haskell.Instr.Sum-import Michelson.Typed.Haskell.Value-import Michelson.Typed.Instr-import Util.Label (Label)--{-# ANN module ("HLint: ignore Use 'natVal' from Universum" :: Text) #-}--------------------------------------------------------------------------------- Store--------------------------------------------------------------------------------- | Gathers multple 'BigMap's under one object.------ Type argument of this datatype stands for a "map template" ---- a datatype with multiple constructors, each containing an object of--- type '|->' and corresponding to single virtual 'BigMap'.--- It's also possible to parameterize it with a larger type which is--- a sum of types satisfying the above property.------ Inside it keeps only one 'BigMap' thus not violating Michelson limitations.------ See examples below.-newtype Store a = Store { unStore :: BigMap ByteString a }-  deriving stock (Eq, Show)-  deriving newtype (Default, Semigroup, Monoid, IsoValue)---- | Describes one virtual big map.-data k |-> v = BigMapImage v-  deriving stock Generic-  deriving anyclass IsoValue--{- 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 constructor 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'.---}---- | Position of a constructor in the corresponding datatype declaration.-type CtorIdx = Nat---- | Number of datatype constructors.-type CtorsNum = Nat---- | Type arguments of '|->'.-data MapSignature = MapSignature Kind.Type Kind.Type CtorIdx---- 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 where-  MSKey ('MapSignature k _ _) = k-type family MSValue ms where-  MSValue ('MapSignature _ v _) = v-type family MSCtorIdx ms where-  MSCtorIdx ('MapSignature _ _ ci) = ci---- | Get map signature from the constructor with a given name.-type GetStore name a = MSRequireFound name a (GLookupStore name (G.Rep a))--data MapLookupRes-  = MapFound MapSignature-  | MapAbsent CtorsNum--type family MSRequireFound-  (name :: Symbol)-  (a :: Kind.Type)-  (mlr :: MapLookupRes)-    :: MapSignature where-  MSRequireFound _ _ ('MapFound ms) = ms-  MSRequireFound name a ('MapAbsent _) = TypeError-    ('Text "Failed to find store template: datatype " ':<>: 'ShowType a ':<>:-     'Text " has no constructor " ':<>: 'ShowType name)---- | Prepend a constructor name with a lower-case character so that you--- could make a label with @OverloadedLabels@ extension matching--- resulting thing.-type CtorNameToLabel name = "c" `AppendSymbol` name--type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)-              :: MapLookupRes where-  GLookupStore name (G.D1 _ x) = GLookupStore name x-  GLookupStore name (x :+: y) = LSMergeFound name (GLookupStore name x)-                                                  (GLookupStore name y)-  -- When we encounter a constructor there are two cases we are interested in:-  -- 1. This constructor has one field with type `|->`. Then we check its name-  -- and return 'MapFound' if it matches and 'MapAbsent' otherwise (storing-  -- information that we've found one constructor).-  -- 2. This constructor has one field with a different type. Then we expect-  -- this field to store '|->' somewhere deeper and try to find it there.-  GLookupStore name (G.C1 ('G.MetaCons ctorName _ _) x) =-    If (IsLeafCtor x)-      (If (name == ctorName || name == CtorNameToLabel ctorName)-         ('MapFound $ GExtractMapSignature ctorName x)-         ('MapAbsent 1)-      )-      (GLookupStoreDeeper name x)-  GLookupStore _ G.V1 = 'MapAbsent 0---- Helper type family to check whether ADT constructor has one field--- with type `|->`.-type family IsLeafCtor (x :: Kind.Type -> Kind.Type) :: Bool where-  IsLeafCtor (G.S1 _ (G.Rec0 (_ |-> _))) = 'True-  IsLeafCtor _ = 'False---- Helper type family to go deeper during type-level store lookup.-type family GLookupStoreDeeper (name :: Symbol) (x :: Kind.Type -> Kind.Type)-              :: MapLookupRes where-  GLookupStoreDeeper name (G.S1 _ (G.Rec0 y))  = GLookupStore name (G.Rep y)-  GLookupStoreDeeper name _ = TypeError-    ('Text "Attempt to go deeper failed while looking for" ':<>: 'ShowType name-    ':$$:-    'Text "Make sure that all constructors have exactly one field inside.")--type family LSMergeFound (name :: Symbol)-  (f1 :: MapLookupRes) (f2 :: MapLookupRes)-  :: MapLookupRes where-  LSMergeFound _ ('MapAbsent n1) ('MapAbsent n2) = 'MapAbsent (n1 + n2)-  LSMergeFound _ ('MapFound ms) ('MapAbsent _) = 'MapFound ms-  LSMergeFound _ ('MapAbsent n) ('MapFound ('MapSignature k v i)) =-    'MapFound ('MapSignature k v (n + i))-  -- 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 ('MapFound _) ('MapFound _) = TypeError-    ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)--type family GExtractMapSignature (ctor :: Symbol) (x :: Kind.Type -> Kind.Type)-             :: MapSignature where-  GExtractMapSignature _ (G.S1 _ (G.Rec0 (k |-> v))) = 'MapSignature k v 0-  GExtractMapSignature ctor _ = TypeError-    ('Text "Expected exactly one field of type `k |-> v`" ':$$:-     'Text "In constructor " ':<>: 'ShowType ctor)--type GetStoreKey store name = MSKey (GetStore name store)-type GetStoreValue store name = MSValue (GetStore name store)--packKey-  :: forall (idx :: CtorIdx) a s.-     (KnownNat idx, NicePackedValue a)-  => (a : s) :-> (ByteString : s)-packKey =-  withDict (nicePackedValueEvi @a) $-    push (natVal $ Proxy @idx) #-    pair @Natural @a #-    pack--wrapBigMapImage :: (v : s) :-> ((k |-> v) : s)-wrapBigMapImage = forcedCoerce_--unwrapBigMapImage :: ((k |-> v) : s) :-> (v : s)-unwrapBigMapImage = forcedCoerce_--type StoreOpC store name =-  ( NicePackedValue (MSKey (GetStore name store))-  , KnownNat (MSCtorIdx (GetStore name store))-  )--{- Note on store initialization:--It's not possible to create an empty store, because Michelson provides no way-to create a new empty @big_map@.--}--storeMem-  :: forall store name s.-     (StoreMemC store name)-  => Label name-  -> GetStoreKey store name : Store store : s :-> Bool : s-storeMem _ =-  packKey @(MSCtorIdx (GetStore name store)) #-  I MEM--type StoreMemC store name = StoreOpC store name--storeGet-  :: forall store name s.-     StoreGetC store name-  => Label name-  -> GetStoreKey store name : Store store : s-       :-> Maybe (GetStoreValue store name) : s-storeGet label =-  packKey @(MSCtorIdx (GetStore name store)) #-  I GET #-  ifNone none (unwrapUnsafe_ @store label # unwrapBigMapImage # L.some)--type StoreGetC store name =-  ( StoreOpC store name-  , InstrUnwrapC store name-  , KnownValue (GetStoreValue store name)-  , CtorHasOnlyField name store-      (GetStoreKey store name |-> GetStoreValue store name)-  )--storeUpdate-  :: forall store name s.-     StoreUpdateC store name-  => Label name-  -> GetStoreKey store name-      : Maybe (GetStoreValue store name)-      : Store store-      : s-  :-> Store store : s-storeUpdate label =-  packKey @(MSCtorIdx (GetStore name store)) #-  dip (ifNone none (wrapBigMapImage # wrap_ @store label # L.some)) #-  I UPDATE--type StoreUpdateC store name =-  ( KnownValue store-  , StoreOpC store name-  , InstrWrapC store name-  , CtorHasOnlyField name store-      (GetStoreKey store name |-> GetStoreValue store name)-  )--storeInsert-  :: forall store name s.-     StoreInsertC store name-  => Label name-  -> GetStoreKey store name-      : GetStoreValue store name-      : Store store-      : s-  :-> Store store : s-storeInsert label =-  packKey @(MSCtorIdx (GetStore name store)) #-  dip (wrapBigMapImage # wrap_ @store label # L.some) #-  I UPDATE--type StoreInsertC store name =-  ( StoreOpC store name-  , InstrWrapC store name-  , CtorHasOnlyField name store-      (GetStoreKey store name |-> GetStoreValue store name)-  )---- | Insert a key-value pair, but fail if it will overwrite some existing entry.-storeInsertNew-  :: forall store name s.-     StoreInsertC store name-  => Label name-  -> (forall s0 any. GetStoreKey store name : s0 :-> any)-  -> GetStoreKey store name-      : GetStoreValue store name-      : Store store-      : s-  :-> Store store : s-storeInsertNew label doFail =-  duupX @3 # duupX @2 # storeMem label #-  if_ doFail-      (storeInsert label)--storeDelete-  :: forall store name s.-     ( StoreDeleteC store name-     )-  => Label name-  -> GetStoreKey store name : Store store : s-     :-> Store store : s-storeDelete _ =-  packKey @(MSCtorIdx (GetStore name store)) #-  dip (none @store) #-  I UPDATE--type StoreDeleteC store name =-  ( StoreOpC store name-  , KnownValue store-  )---- | This constraint can be used if a function needs to work with--- /big/ store, but needs to know only about some part(s) of it.------ It can use all Store operations for a particular name, key and--- value without knowing whole template.-type HasStore name key value store =-   ( StoreGetC store name-   , StoreInsertC store name-   , StoreDeleteC store name-   , GetStoreKey store name ~ key-   , GetStoreValue store name ~ value-   , StorePieceC store name key value-   )---- | Write down all sensisble constraints which given @store@ satisfies--- and apply them to @constrained@.------ This store should have '|->' datatype in its immediate fields,--- no deep inspection is performed.-type HasStoreForAllIn store constrained =-  GForAllHasStore constrained (G.Rep store)--type family GForAllHasStore (store :: Kind.Type) (x :: Kind.Type -> Kind.Type)-            :: Constraint where-  GForAllHasStore store (G.D1 _ x) = GForAllHasStore store x-  GForAllHasStore store (x :+: y) = ( GForAllHasStore store x-                                    , GForAllHasStore store y )-  GForAllHasStore store (G.C1 ('G.MetaCons ctorName _ _)-                          (G.S1 _ (G.Rec0 (key |-> value)))) =-    HasStore (CtorNameToLabel ctorName) key value store-  GForAllHasStore _ (G.C1 _ _) = ()-  GForAllHasStore _ G.V1 = ()---- Instances-------------------------------------------------------------------------------instance ( StoreMemC store name, StoreGetC store name-         , StoreUpdateC store name-         , key ~ GetStoreKey store name, value ~ GetStoreValue store name-         ) =>-         StoreHasSubmap (Store store) name key value where-  storeSubmapOps = StoreSubmapOps-    { sopMem = storeMem-    , sopGet = storeGet-    , sopUpdate = storeUpdate-    , sopDelete = Just storeDelete-    , sopInsert = Just storeInsert-    }---- Examples-------------------------------------------------------------------------------data MyStoreTemplate-  = IntsStore (Integer |-> ())-  | BytesStore (ByteString |-> ByteString)-  deriving stock Generic-  deriving anyclass IsoValue--type MyStore = Store MyStoreTemplate--_sample1 :: Integer : MyStore : s :-> MyStore : s-_sample1 = storeDelete @MyStoreTemplate #cIntsStore--_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s-_sample2 = storeInsert @MyStoreTemplate #cBytesStore--data MyStoreTemplate2-  = BoolsStore (Bool |-> Bool)-  | IntsStore2 (Integer |-> Integer)-  | IntsStore3 (Integer |-> Bool)-  deriving stock Generic-  deriving anyclass IsoValue---- You must derive 'Generic' instance for all custom types, even--- newtypes.-newtype MyNatural = MyNatural Natural-  deriving stock Generic-  deriving newtype (IsoValue)--data MyStoreTemplate3 = MyStoreTemplate3 (Natural |-> MyNatural)-  deriving stock Generic-  deriving anyclass IsoValue--data MyStoreTemplateBig-  = BigTemplatePart1 MyStoreTemplate-  | BigTemplatePart2 MyStoreTemplate2-  | BigTemplatePart3 MyStoreTemplate3-  deriving stock Generic-  deriving anyclass IsoValue--_MyStoreTemplateBigTextsStore ::-  GetStore "cBytesStore" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString 1-_MyStoreTemplateBigTextsStore = Refl--_MyStoreTemplateBigBoolsStore ::-  GetStore "cBoolsStore" MyStoreTemplateBig :~: 'MapSignature Bool Bool 2-_MyStoreTemplateBigBoolsStore = Refl--_MyStoreTemplateBigMyStoreTemplate3 ::-  GetStore "cMyStoreTemplate3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural 5-_MyStoreTemplateBigMyStoreTemplate3 = Refl--_MyStoreBigHasAllStores-  :: HasStoreForAllIn MyStoreTemplate store-  => Dict ( HasStore "cIntsStore" Integer () store-          , HasStore "cBytesStore" ByteString ByteString store-          )-_MyStoreBigHasAllStores = Dict--type MyStoreBig = Store MyStoreTemplateBig--_sample3 :: Integer : MyStoreBig : s :-> MyStoreBig : s-_sample3 = storeDelete @MyStoreTemplateBig #cIntsStore2--_sample4 :: ByteString : MyStoreBig : s :-> Bool : s-_sample4 = storeMem @MyStoreTemplateBig #cBytesStore--_sample5 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s-_sample5 = storeInsert @MyStoreTemplateBig #cMyStoreTemplate3---- Example of 'HasStoreForAllIn' use.--- This function will work with any @store@ which has 'MyStoreTemplate3' inside.-_sample6-  :: forall store s.-      HasStoreForAllIn MyStoreTemplate3 store-  => Natural : MyNatural : Store store : s :-> Store store : s-_sample6 = storeInsert @store #cMyStoreTemplate3---- For instance, 'sample6' works for 'MyStoreBig'.-_sample6' :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s-_sample6' = _sample6--------------------------------------------------------------------------------- Storage skeleton--------------------------------------------------------------------------------- | Contract storage with @big_map@.------ Due to Michelson constraints it is the only possible layout containing--- @big_map@.-data StorageSkeleton storeTemplate other = StorageSkeleton-  { sMap :: Store storeTemplate-  , sFields :: other-  } deriving stock (Eq, Show, Generic)-    deriving anyclass Default--deriving anyclass instance (WellTypedIsoValue st, WellTypedIsoValue o) => IsoValue (StorageSkeleton st o)---- | Unpack 'StorageSkeleton' into a pair.-storageUnpack :: StorageSkeleton store fields : s :-> (Store store, fields) : s-storageUnpack = forcedCoerce_---- | Pack a pair into 'StorageSkeleton'.-storagePack :: (Store store, fields) : s :-> StorageSkeleton store fields : s-storagePack = forcedCoerce_--storageMem-  :: forall store name fields s.-     (StoreMemC store name)-  => Label name-  -> GetStoreKey store name : StorageSkeleton store fields : s :-> Bool : s-storageMem label = dip (storageUnpack # car) # storeMem label--storageGet-  :: forall store name fields s.-     StoreGetC store name-  => Label name-  -> GetStoreKey store name : StorageSkeleton store fields : s-       :-> Maybe (GetStoreValue store name) : s-storageGet label = dip (storageUnpack # car) # storeGet label--storageInsert-  :: forall store name fields s.-     StoreInsertC store name-  => Label name-  -> GetStoreKey store name-      : GetStoreValue store name-      : StorageSkeleton store fields-      : s-  :-> StorageSkeleton store fields : s-storageInsert label =-  dip (dip (storageUnpack # dup # car # dip cdr)) #-  storeInsert label #-  pair # storagePack---- | Insert a key-value pair, but fail if it will overwrite some existing entry.-storageInsertNew-  :: forall store name fields s.-     StoreInsertC store name-  => Label name-  -> (forall s0 any. GetStoreKey store name : s0 :-> any)-  -> GetStoreKey store name-      : GetStoreValue store name-      : StorageSkeleton store fields-      : s-  :-> StorageSkeleton store fields : s-storageInsertNew label doFail =-  dip (dip (storageUnpack # dup # car # dip cdr)) #-  storeInsertNew label doFail #-  pair # storagePack--storageDelete-  :: forall store name fields s.-     ( StoreDeleteC store name-     )-  => Label name-  -> GetStoreKey store name : StorageSkeleton store fields : s-     :-> StorageSkeleton store fields : s-storageDelete label =-  dip (storageUnpack # dup # car # dip cdr) #-  storeDelete label #-  pair # storagePack---- Instances-------------------------------------------------------------------------------instance (StoreHasField other fname ftype, IsoValue store, IsoValue other) =>-         StoreHasField (StorageSkeleton store other) fname ftype where-  storeFieldOps = storeFieldOpsDeeper #sFields--instance ( StoreMemC store name, StoreGetC store name-         , StoreUpdateC store name-         , key ~ GetStoreKey store name, value ~ GetStoreValue store name-         , IsoValue other-         ) =>-         StoreHasSubmap (StorageSkeleton store other) name key value where-  storeSubmapOps = storeSubmapOpsDeeper #sMap---- Examples-------------------------------------------------------------------------------type MyStorage = StorageSkeleton MyStoreTemplate (Integer, ByteString)---- You can access both Store...-_storageSample1 :: Integer : MyStorage : s :-> MyStorage : s-_storageSample1 = storageDelete @MyStoreTemplate #cIntsStore---- and other fields of the storage created with 'StorageSkeleton'.-_storageSample2 :: MyStorage : s :-> Integer : s-_storageSample2 = toField #sFields # car--------------------------------------------------------------------------------- Store construction from Haskell-------------------------------------------------------------------------------packHsKey-  :: forall ctorIdx key.-     (NicePackedValue key, KnownNat ctorIdx)-  => key -> ByteString-packHsKey key =-  lPackValue (natVal (Proxy @ctorIdx), key)---- | Lift a key-value pair to 'Store'.------ Further you can use 'Monoid' instance of @Store@ to make up large stores.-storePiece-  :: forall name store key value.-     StorePieceC store name key value-  => Label name-  -> key-  -> value-  -> Store store-storePiece label key val =-  Store . BigMap $ one-    ( packHsKey @(MSCtorIdx (GetStore name store)) key-    , hsWrap @store label (BigMapImage val)-    )--storeKeyValueList-  :: forall name store key value.-     StorePieceC store name key value-  => Label name-  -> [(key, value)]-  -> Store store-storeKeyValueList label keyValues =-  Store . BigMap . Map.fromList $-  Prelude.map (\(key, val) ->-                 ( packHsKey @(MSCtorIdx (GetStore name store)) key-                 , hsWrap @store label (BigMapImage val)-                 )) keyValues--type StorePieceC store name key value =-  ( key ~ GetStoreKey store name-  , value ~ GetStoreValue store name-  , NicePackedValue key-  , KnownNat (MSCtorIdx (GetStore name store))-  , InstrWrapC store name, Generic store-  , ExtractCtorField (GetCtorField store name) ~ (key |-> value)-  )---- | Get a value from store by key.------ It expects map to be consistent, otherwise call to this function fails--- with error.-storeLookup-  :: forall name store key value ctorIdx.-     ( key ~ GetStoreKey store name-     , value ~ GetStoreValue store name-     , ctorIdx ~ MSCtorIdx (GetStore name store)-     , NicePackedValue key-     , KnownNat ctorIdx-     , InstrUnwrapC store name, Generic store-     , CtorOnlyField name store ~ (key |-> value)-     )-  => Label name-  -> key-  -> Store store-  -> Maybe value-storeLookup label key (Store (BigMap m)) =-  Map.lookup (packHsKey @ctorIdx key) m <&> \val ->-    case hsUnwrap label val of-      Nothing -> error "Invalid store, keys and values types \-                       \correspondence is violated"-      Just (BigMapImage x) -> x---- Examples-------------------------------------------------------------------------------_storeSample :: Store MyStoreTemplate-_storeSample = mconcat-  [ storePiece #cIntsStore 1 ()-  , storePiece #cBytesStore "a" "b"-  ]--_lookupSample :: Maybe ByteString-_lookupSample = storeLookup #cBytesStore "a" _storeSample--_storeSampleBig :: Store MyStoreTemplateBig-_storeSampleBig = mconcat-  [ storePiece #cIntsStore 1 ()-  , storePiece #cBoolsStore True True-  , storePiece #cIntsStore3 2 False-  ]--_lookupSampleBig :: Maybe Bool-_lookupSampleBig = storeLookup #cIntsStore3 2 _storeSampleBig

@@ -1,126 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Lorentz.Test-  ( -- * Importing a contract-    specWithContract-  , specWithTypedContract-  , specWithUntypedContract--  -- * Unit testing-  , ContractReturn-  , ContractPropValidator-  , contractProp-  , contractPropVal-  , expectContractEntrypoints--  -- * Integrational testing-  -- ** Testing engine-  , IntegrationalScenario-  , IntegrationalScenarioM-  , TestError (..)-  , integrationalTestExpectation-  , integrationalTestProp-  , lOriginate-  , lOriginateEmpty-  , lTransfer-  , lCall-  , lCallEP-  , EntryPointRef (..)-  , lCallDef-  , integrationalFail-  , unexpectedInterpreterError-  , setMaxSteps-  , setNow-  , rewindTime-  , withSender-  , setChainId-  , branchout-  , (?-)-  , offshoot--  -- ** Validators-  , expectNoUpdates-  , expectNoStorageUpdates-  , lExpectStorageUpdate-  , lExpectBalance-  , lExpectStorage-  , lExpectStorageConst--  -- ** Errors-  , attempt-  , expectError-  , catchExpectedError-  , lExpectMichelsonFailed-  , lExpectFailWith-  , lExpectError-  , lExpectErrorNumeric-  , lExpectCustomError-  , lExpectCustomErrorNumeric-  , lExpectCustomError_-  , lExpectCustomErrorNumeric_-  , lExpectConsumerStorage-  , lExpectViewConsumerStorage--  -- ** Various-  , TxData (..)-  , genesisAddresses-  , genesisAddress-  , genesisAddress1-  , genesisAddress2-  , genesisAddress3-  , genesisAddress4-  , genesisAddress5-  , genesisAddress6--  -- * Autodoc testing-  , runDocTests-  , testLorentzDoc-  , excludeDocTests--  -- * General utilities-  , 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--  -- * Arbitrary data-  , minTimestamp-  , maxTimestamp-  , midTimestamp--  -- * Special contracts for testing-  , contractConsumer--  -- * Deprecated-  , integrationalTestProperty-  , failedProp-  , succeededProp-  , qcIsLeft-  , qcIsRight-  ) where--import Michelson.Doc.Test-import Michelson.Test.Dummy-import Michelson.Test.Gen-import Michelson.Test.Import-import Michelson.Test.Unit-import Michelson.Test.Util--import Lorentz.Test.Consumer-import Lorentz.Test.Doc-import Lorentz.Test.Integrational-import Lorentz.Test.Unit

@@ -1,20 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Contract which remembers all parameters it has been called with.------ Useful to save return values of @View@ entry points.-module Lorentz.Test.Consumer-  ( contractConsumer-  ) where--import Lorentz.Base-import Lorentz.Instr-import Lorentz.Macro-import Lorentz.Run---- | Remembers parameters it was called with, last goes first.-contractConsumer :: Contract cp [cp]-contractConsumer = defaultContract $-  unpair # cons # nil # pair

@@ -1,160 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Testing predicates for documentation of Lorentz contracts.-module Lorentz.Test.Doc-  ( -- * Test predicates-    testLorentzDoc--    -- * Individual test predicates-  , testDeclaresParameter-  , testEachEntrypointIsDescribed-  , testParamBuildingStepsAreFinalized-  , testAllEntrypointsAreCallable--  , module Michelson.Doc.Test-  ) where--import Fmt (Buildable(..), blockListF, fmt, nameF, pretty)-import Test.HUnit (assertBool, assertFailure)--import Lorentz.EntryPoints.Doc-import Michelson.Doc-import Michelson.Doc.Test-import Util.Markdown-import Util.Typeable---- | All ways of describing an entrypoint behaviour.-data DocEpDescription-  = DocEpDescription DDescription-  | DocEpReference DEntryPointReference--instance Buildable DocEpDescription where-  build = \case-    DocEpDescription (DDescription txt) ->-      "description: " <> txt-    DocEpReference (DEntryPointReference name (Anchor anchor)) ->-      "reference \"" <> build name <> "\" (" <> build anchor <> ")"---- | Extract 'DocEpDescription's of a documentation block.-lookupDocEpDescription :: DocBlock -> [DocEpDescription]-lookupDocEpDescription block = mconcat-  [ map DocEpDescription . maybe [] toList $ lookupDocBlockSection block-  , map DocEpReference . maybe [] toList $ lookupDocBlockSection block-  ]---- | Check that contract documents its parameter.-testDeclaresParameter :: DocTest-testDeclaresParameter =-  mkDocTest "Contract parameter is documented" $-  \contractDoc ->-    assertBool "No doc items describing contract parameter found" $-      or $ forEachContractLayer contractDoc check-  where-    check Nothing _ = False-    check (Just sdi) _ =-      -- Currently the only way to document parameter (mentioning type of each arm)-      -- is using 'entryCase'. This may not suit for small contracts, then-      -- someone needs to invent another way to document parameter and also mention-      -- it below.-      case sdi of-        SomeDocItem (castIgnoringPhantom -> Just DEntryPoint{}) -> True-        _ -> False---- | Check that no group contains two 'DDescription' or 'DEntryPointReference'--- items.------ This is a stricter version of 'testNoAdjacentDescriptions' test.-testNoAdjacentEpDescriptions :: DocTest-testNoAdjacentEpDescriptions =-  mkDocTest "No two 'DDescription' appear under the same group" $-  \contractDoc ->-    sequence_ . forEachContractLayer contractDoc $ \_ block ->-      case lookupDocEpDescription block of-        ds@(_ : _ : _) ->-          assertFailure . fmt $-             nameF "Found multiple adjacent entrypoint descriptions" $-             blockListF $ map (quotes . build) (toList ds)-        _ -> pass-    where-      quotes t = "\"" <> t <> "\""---- | It's a common issue to forget to describe an entrypoint.-testEachEntrypointIsDescribed :: DocTest-testEachEntrypointIsDescribed =-  mkDocTest "Each entrypoint has 'DDescription'" $-  \contractDoc ->-    sequence_ . forEachContractLayer contractDoc $ \mDocItem block ->-      runMaybeT $ do-        SomeDocItem docItem <- MaybeT . pure $ mDocItem-        dep@DEntryPoint{} <- MaybeT . pure $ castIgnoringPhantom docItem-        [] <- pure $ lookupDocEpDescription block-        MaybeT . assertFailure $-          "Entrypoint '" <> pretty (depName dep) <> "' does not contain \-          \any description.\n\-          \Put e.g. `doc $ DDescription \"text\"` in the entrypoint logic to \-          \fix this."---- | Check that 'finalizeParamCallingDoc' is applied to the contract as it--- always should.-testParamBuildingStepsAreFinalized :: DocTest-testParamBuildingStepsAreFinalized =-  mkDocTest "'finalizeParamCallingDoc' is applied" $-  \contractDoc ->-    sequence_ . forEachContractDocItem contractDoc $ \DEntryPointArg{..} ->-      unless (areFinalizedParamBuildingSteps epaBuilding) $-        assertFailure-          "Found unfinalized param building steps, \-          \'How to call this entrypoint' section may be incorrect.\n\-          \Have you applied 'finalizeParamCallingDoc' to your contract?"---- | Check that all documented entrypoints are callable.------ Sometimes having such an entrypoint is fine, e.g. when you have an explicit--- default entrypoint deep in one arm then other arms (entire arms, not--- individual entrypoints within them) are uncallable unless also assigned a--- field annotation; for example see [doc for uncallable entrypoints] note.--- If this is your case, exclude this test suite with 'excludeDocTest'.--- But such situations are rare.------ More often, this test failure indicates that entrypoints are documented--- incorrectly, e.g. `caseT` is used in some place instead of `entryCase`.--- Check whether printed building steps are correct.------ NB: another, simplified example of case when disabling this test is--- justified:------ @--- data SubParam1 = Do1 | Default--- data SubParam2 = Do2 | Do3--- data Param = Arm1 SubParam1 | Arm2 SubParam2---   -- ^ with entrypoints derived via 'EpdRecursive'--- @------ In this case entire @Arm1@ and @Arm2@ are not true entrypoints, only @Default@--- and @Do{1,2,3}@ are, but @Arm1@ and @Arm2@ will still appear in documentation--- as entrypoints.-testAllEntrypointsAreCallable :: DocTest-testAllEntrypointsAreCallable =-  mkDocTest "All entrypoints are callable" $-  \contractDoc ->-    sequence_ . forEachContractDocItem contractDoc $ \DEntryPointArg{..} ->-      forM_ epaBuilding $ \case-        PbsUncallable pbs ->-          assertFailure . fmt $-            "Found an uncallable entrypoint.\n\-            \Dummy parameter building steps for it: " <> blockListF (reverse pbs)-        _ -> pass---- | Tests all properties.-testLorentzDoc :: [DocTest]-testLorentzDoc = mconcat-  [ testDocBasic-  , [ testDeclaresParameter-    , testNoAdjacentEpDescriptions-    , testEachEntrypointIsDescribed-    , testParamBuildingStepsAreFinalized-    , testAllEntrypointsAreCallable-    ]-  ]

@@ -1,356 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Mirrors 'Michelson.Test.Integrational' module in a Lorentz way.-module Lorentz.Test.Integrational-  (-    -- * Re-exports-    TxData (..)-  , genesisAddresses-  , genesisAddress-  -- * More genesis addresses which can be used in tests-  , genesisAddress1-  , genesisAddress2-  , genesisAddress3-  , genesisAddress4-  , genesisAddress5-  , genesisAddress6--    -- * Testing engine for bare Typed primitives-  , I.tOriginate-  , I.tTransfer-  , I.tExpectStorageConst--    -- * Testing engine-  , IntegrationalScenarioM-  , I.IntegrationalScenario-  , I.TestError (..)-  , I.integrationalTestExpectation-  , I.integrationalTestProp-  , lOriginate-  , lOriginateEmpty-  , lTransfer-  , lCall-  , lCallEP-  , EntryPointRef (..)-  , lCallDef-  , I.integrationalFail-  , I.unexpectedInterpreterError-  , I.setMaxSteps-  , I.setNow-  , I.rewindTime-  , I.withSender-  , I.setChainId-  , I.branchout-  , (I.?-)-  , I.offshoot--  -- * Validators-  , I.expectNoUpdates-  , I.expectNoStorageUpdates-  , lExpectStorageUpdate-  , lExpectBalance-  , lExpectStorage-  , lExpectStorageConst--  -- * Errors-  , I.attempt-  , I.expectError-  , I.catchExpectedError-  , lExpectMichelsonFailed-  , lExpectFailWith-  , lExpectError-  , lExpectErrorNumeric-  , lExpectCustomError-  , lExpectCustomErrorNumeric-  , lExpectCustomError_-  , lExpectCustomErrorNumeric_--  -- ** Consumer-  , lExpectConsumerStorage-  , lExpectViewConsumerStorage--  -- * Deprecated-  , I.integrationalTestProperty-  ) where--import Data.Constraint (Dict(..))-import Data.Typeable (gcast)-import Fmt (Buildable, listF, (+|), (|+))-import Named ((:!), arg)--import Lorentz.Constraints-import Lorentz.EntryPoints-import qualified Lorentz.Errors as L-import qualified Lorentz.Errors.Numeric as L-import Lorentz.Run-import Lorentz.Value-import qualified Lorentz.Value as L-import Michelson.Interpret (InterpretError(..), MichelsonFailed(..))-import Michelson.Runtime-import Michelson.Runtime.GState-import Michelson.Test.Integrational-import qualified Michelson.Test.Integrational as I-import Michelson.TypeCheck (typeCheckValue)-import qualified Michelson.Typed as T-import qualified Michelson.Untyped as U-import Tezos.Core-import Util.Named ((.!))--------------------------------------------------------------------------------- Interface--------------------------------------------------------------------------------- TODO: how to call they normally? :thinking:--- Preserving just the same names like @transfer@ or @originate@--- looks very bad because no one will import this or--- 'Michelson.Test.Integrational' module qualified--- and thus finding which exact function is used would become too painful.---- | Like 'originate', but for Lorentz contracts.-lOriginate-  :: forall cp st.-     (NiceParameterFull cp, NiceStorage st)-  => Contract cp st-  -> Text-  -> st-  -> Mutez-  -> IntegrationalScenarioM (TAddress cp)-lOriginate contract name value balance =-  withDict (niceParameterEvi @cp) $-  withDict (niceStorageEvi @st) $ do-    addr <- I.tOriginate (compileLorentzContract contract) name (T.toVal value) balance-    return (L.TAddress addr)---- | Originate a contract with empty balance and default storage.-lOriginateEmpty-  :: (NiceParameterFull cp, NiceStorage st, Default st)-  => Contract cp st-  -> Text-  -> IntegrationalScenarioM (TAddress cp)-lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)---- | Similar to 'transfer', for Lorentz values.-lTransfer-  :: forall cp epRef epArg addr.-     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)-  => "from" :! Address-  -> "to" :! addr-  -> Mutez-  -> epRef-  -> epArg-  -> IntegrationalScenarioM ()-lTransfer from (toTAddress @cp . arg #to -> TAddress to) money epRef param =-  case useHasEntryPointArg @cp @epRef @epArg epRef of-    (Dict, epName) -> I.tTransfer from (#to .! to) money epName (T.toVal param)--{-# DEPRECATED lCall "'lCall' will likely be replaced with 'lCallEP' in future version" #-}--- | Legacy version of 'lCallEP' function. Calls default entrypoint of--- a contract assuming its argument is the same as contract parameter--- (which is equivalent to absence of explicit default entrypoint).------ This function is DEPRECATED and exists only for backwards compatibility.-lCall-  :: forall cp defEpName addr.-     ( HasDefEntryPointArg cp defEpName cp-     , IsoValue cp-     , ToTAddress cp addr-     )-  => addr -> cp -> IntegrationalScenarioM ()-lCall = lCallDef @cp @defEpName @cp @addr---- | Call an entrypoint of a contract without caring about the source--- address. Transfers 0 mutez.-lCallEP-  :: forall cp epRef epArg addr.-     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)-  => addr -> epRef -> epArg -> IntegrationalScenarioM ()-lCallEP addr epRef param =-  lTransfer @cp @epRef @epArg-    (#from .! genesisAddress) (#to .! addr)-    (unsafeMkMutez 0) epRef param---- | 'lCallEP' for default entrypoint.-lCallDef-  :: forall cp defEpName defArg addr.-     ( HasDefEntryPointArg cp defEpName defArg-     , IsoValue defArg-     , ToTAddress cp addr-     )-  => addr -> defArg -> IntegrationalScenarioM ()-lCallDef addr =-  lCallEP @cp @defEpName @defArg addr CallDefault--------------------------------------------------------------------------------- Validators to be used within 'IntegrationalValidator'--------------------------------------------------------------------------------- Expect something successful---- | Internal function that proceeds storage validation from by untyping--- the value passed to callback.-validateStorageCb-  :: forall st addr.-     (NiceStorage st, ToAddress addr, HasCallStack)-  => (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-    predicate $ T.fromVal val-  where-    typeCheck uval =-      evaluatingState initSt . runExceptT $-      usingReaderT def $-      typeCheckValue uval-    initSt = error "Typechecker state unavailable"---- | Similar to 'expectStorage', but for Lorentz values.-lExpectStorage-  :: forall st addr.-     (NiceStorage st, ToAddress addr, HasCallStack)-  => 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.TestError ()) -> IntegrationalScenario-lExpectStorageUpdate = validateStorageCb I.expectStorageUpdate---- | Like 'expectBalance', for Lorentz values.-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 -> IntegrationalScenario-lExpectStorageConst (toAddress -> addr) expected =-  withDict (niceStorageEvi @st) $-    I.tExpectStorageConst addr (T.toVal expected)---- Expect errors---- | Expect that interpretation of contract with given address ended--- with [FAILED].-lExpectMichelsonFailed-  :: forall addr. (ToAddress addr)-  => (MichelsonFailed -> Bool) -> addr -> ExecutorError -> IntegrationalScenario-lExpectMichelsonFailed predicate (toAddress -> addr) =-  I.expectMichelsonFailed predicate addr---- | Expect contract to fail with "FAILWITH" instruction and provided value--- to match against the given predicate.-lExpectFailWith-  :: forall e.-      (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 -> IntegrationalScenario-lExpectError = lExpectError' L.errorFromVal---- | Version of 'lExpectError' for the case when numeric--- representation of errors is used.-lExpectErrorNumeric-  :: forall e.-      (L.IsError e)-  => L.ErrorTagMap -> (e -> Bool) -> ExecutorError -> IntegrationalScenario-lExpectErrorNumeric errorTagMap =-  lExpectError' (L.errorFromValNumeric errorTagMap)--lExpectError' ::-     forall e.-     (forall t. T.KnownT t => Value t -> Either Text e)-  -> (e -> Bool)-  -> ExecutorError-  -> 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 -> IntegrationalScenario-lExpectCustomError l a =-  lExpectError (== L.CustomError l a)---- | Version of 'lExpectCustomError' for the case when numeric--- representation of errors is used.-lExpectCustomErrorNumeric-  :: forall tag arg.-      (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)-  => L.ErrorTagMap -> Label tag -> arg -> ExecutorError -> IntegrationalScenario-lExpectCustomErrorNumeric errorTagMap l a =-  lExpectErrorNumeric errorTagMap (== L.CustomError l a)---- | Specialization of 'lExpectCustomError' for non-arg error case.-lExpectCustomError_-  :: forall tag.-      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())-  => Label tag -> ExecutorError -> IntegrationalScenario-lExpectCustomError_ l =-  lExpectCustomError l ()---- | Version of 'lExpectCustomError_' for the case when numeric--- representation of errors is used.-lExpectCustomErrorNumeric_-  :: forall tag.-      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())-  => L.ErrorTagMap -> Label tag -> ExecutorError -> IntegrationalScenario-lExpectCustomErrorNumeric_ errorTagMap l =-  lExpectCustomErrorNumeric errorTagMap l ()---- Consumer---- | Version of 'lExpectStorageUpdate' specialized to "consumer" contract--- (see 'Lorentz.Contracts.Consumer.contractConsumer').-lExpectConsumerStorage-  :: forall cp st addr.-     (st ~ [cp], NiceStorage st, ToTAddress cp addr)-  => addr -> (st -> Either I.TestError ()) -> IntegrationalScenario-lExpectConsumerStorage addr = lExpectStorageUpdate (toTAddress @cp addr)---- | Assuming that "consumer" contract receives a value from 'View', expect--- this view return value to be the given one.------ Despite consumer stores parameters it was called with in reversed order,--- this function cares about it, so you should provide a list of expected values--- in the same order in which the corresponding events were happenning.-lExpectViewConsumerStorage-  :: ( st ~ [cp]-     , Eq cp, Buildable cp-     , NiceStorage st-     , ToTAddress cp addr-     )-  => addr -> [cp] -> IntegrationalScenario-lExpectViewConsumerStorage addr expected =-  lExpectConsumerStorage addr (matchExpected . reverse)-  where-    mkError = Left . I.CustomTestError-    matchExpected got-      | got == expected = pass-      | otherwise = mkError $ "Expected " +| listF expected |+-                              ", but got " +| listF got |+ ""

@@ -1,32 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Unit tests for Lorentz.-module Lorentz.Test.Unit-    ( expectContractEntrypoints-    ) where--import Test.HUnit (Assertion, assertFailure)--import Lorentz hiding (contract)-import Michelson.Test.Unit (matchContractEntryPoints)-import Michelson.Typed (convertContract, flattenEntryPoints)---- | Expect the given contract to have some specific entrypoints.-expectContractEntrypoints-  :: forall expectedEps contractEps st.-     ( NiceParameterFull expectedEps-     , NiceParameterFull contractEps-     , NiceStorage st-     )-  => Contract contractEps st -> Assertion-expectContractEntrypoints contract =-  withDict (niceParameterEvi @expectedEps) $-  withDict (niceParameterEvi @contractEps) $-  withDict (niceStorageEvi @st) $ do-    let entrypoints = flattenEntryPoints $ parameterEntryPointsToNotes @expectedEps-        contract' = convertContract . compileLorentzContract $ contract-    case matchContractEntryPoints contract' entrypoints of-      Left eps -> assertFailure $ "Some entrypoints were not found " <> show eps-      Right _ -> pass

@@ -3,7 +3,7 @@ -- SPDX-License-Identifier: LicenseRef-MIT-TQ  module Lorentz.TestScenario-  {-# DEPRECATED "Use morley-nettest instead" #-}+  {-# DEPRECATED "Use cleveland instead" #-}   ( TestScenario   , showTestScenario   ) where

@@ -1,158 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE UndecidableSuperClasses #-}---- | Type annotations for Lorentz types.-module Lorentz.TypeAnns-  ( HasTypeAnn (..)-  , GHasTypeAnn (..)-  , insertTypeAnn-  ) where--import qualified GHC.Generics as G-import Named (NamedF)--import Michelson.Text-import Michelson.Typed-  (BigMap, ContractRef(..), EpAddress, KnownIsoT, Notes(..), Operation, ToT, insertTypeAnn,-  starNotes)-import Michelson.Typed.Haskell.Value (GValueType)-import Michelson.Untyped (TypeAnn, ann, noAnn)-import Tezos.Address-import Tezos.Core-import Tezos.Crypto-import Util.TypeLits---- For supporting type annotations of entrypoint arguments.------At the botton of this infra is the HasTypeAnn class, which defines the type---annotations for a given type. Right now the type annotations can only come---from names in a named field. That is, we are not deriving names from, for---example, record field names.--class HasTypeAnn a where-  getTypeAnn :: Notes (ToT a)--  default getTypeAnn-    :: (GHasTypeAnn (G.Rep a), GValueType (G.Rep a) ~ ToT a) => Notes (ToT a)-  getTypeAnn = gGetTypeAnn @(G.Rep a)--instance (HasTypeAnn a, KnownSymbol name)-  => HasTypeAnn (NamedF Identity a name) where-  getTypeAnn = insertTypeAnn (symbolAnn @name) $ getTypeAnn @a-    where-      symbolAnn :: forall s. KnownSymbol s => TypeAnn-      symbolAnn = ann $ symbolValT' @s--instance (HasTypeAnn (Maybe a), KnownSymbol name)-  => HasTypeAnn (NamedF Maybe a name) where-  getTypeAnn = getTypeAnn @(NamedF Identity (Maybe a) name)---- Primitive instances-instance (HasTypeAnn a) => HasTypeAnn (Maybe a) where-  getTypeAnn = NTOption noAnn (getTypeAnn @a)--instance HasTypeAnn ()--instance HasTypeAnn Integer where-  getTypeAnn = starNotes--instance HasTypeAnn Natural where-  getTypeAnn = starNotes--instance HasTypeAnn MText where-  getTypeAnn = starNotes--instance HasTypeAnn Bool where-  getTypeAnn = starNotes--instance HasTypeAnn ByteString where-  getTypeAnn = starNotes--instance HasTypeAnn Mutez where-  getTypeAnn = starNotes--instance HasTypeAnn Address where-  getTypeAnn = starNotes--instance HasTypeAnn EpAddress where-  getTypeAnn = starNotes--instance HasTypeAnn KeyHash where-  getTypeAnn = starNotes--instance HasTypeAnn Timestamp where-  getTypeAnn = starNotes--instance HasTypeAnn PublicKey where-  getTypeAnn = starNotes--instance HasTypeAnn Signature where-  getTypeAnn = starNotes--instance (HasTypeAnn a) => HasTypeAnn (ContractRef a) where-  getTypeAnn = NTContract noAnn (getTypeAnn @a)--instance (HasTypeAnn k, HasTypeAnn v) => HasTypeAnn (Map k v) where-  getTypeAnn = NTMap noAnn (getTypeAnn @k) (getTypeAnn @v)--instance (HasTypeAnn k, HasTypeAnn v) => HasTypeAnn (BigMap k v) where-  getTypeAnn = NTBigMap noAnn (getTypeAnn @k) (getTypeAnn @v)--instance (KnownIsoT v) => HasTypeAnn (Set v) where-  getTypeAnn = starNotes--instance (HasTypeAnn a) => HasTypeAnn [a] where-  getTypeAnn = NTList noAnn (getTypeAnn @a)--instance HasTypeAnn Operation where-  getTypeAnn = starNotes--instance (HasTypeAnn a, HasTypeAnn b) => HasTypeAnn (a, b)-instance (HasTypeAnn a, HasTypeAnn b, HasTypeAnn c) => HasTypeAnn (a, b, c)-instance (HasTypeAnn a, HasTypeAnn b, HasTypeAnn c, HasTypeAnn d) => HasTypeAnn (a, b, c, d)-instance (HasTypeAnn a, HasTypeAnn b, HasTypeAnn c, HasTypeAnn d, HasTypeAnn e)-  => HasTypeAnn (a, b, c, d, e)-instance (HasTypeAnn a, HasTypeAnn b, HasTypeAnn c, HasTypeAnn d, HasTypeAnn e, HasTypeAnn f)-  => HasTypeAnn (a, b, c, d, e, f)-instance-  ( HasTypeAnn a, HasTypeAnn b, HasTypeAnn c, HasTypeAnn d, HasTypeAnn e-  , HasTypeAnn f, HasTypeAnn g)-  => HasTypeAnn (a, b, c, d, e, f, g)---- A Generic HasTypeAnn implementation-class GHasTypeAnn a where-  gGetTypeAnn :: Notes (GValueType a)--instance GHasTypeAnn G.U1 where-  gGetTypeAnn = starNotes--instance (GHasTypeAnn x) => GHasTypeAnn (G.M1 i0 i1 x) where-  gGetTypeAnn = gGetTypeAnn @x--instance-    ( GHasTypeAnn x-    , GHasTypeAnn y-    )-  =>-    GHasTypeAnn (x G.:+: y)-  where-  gGetTypeAnn = NTOr noAnn noAnn noAnn-    (gGetTypeAnn @x)-    (gGetTypeAnn @y)--instance-    ( GHasTypeAnn x-    , GHasTypeAnn y-    )-  =>-    GHasTypeAnn (x G.:*: y)-  where-  gGetTypeAnn = NTPair noAnn noAnn noAnn-    (gGetTypeAnn @x)-    (gGetTypeAnn @y)--instance (HasTypeAnn x) => GHasTypeAnn (G.Rec0 x) where-  gGetTypeAnn = getTypeAnn @x

@@ -7,7 +7,7 @@  module Lorentz.UParam   ( UParam (..)-  , EntryPointKind+  , EntrypointKind   , type (?:)      -- * Construction@@ -23,17 +23,17 @@   , UParam_      -- * Pattern-matching-  , EntryPointsImpl+  , EntrypointsImpl   , UParamFallback-  , EntryPointLookupError (..)+  , EntrypointLookupError (..)   , CaseUParam   , caseUParam   , caseUParamT   , uparamFallbackFail      -- * Constraints-  , LookupEntryPoint-  , RequireUniqueEntryPoints+  , LookupEntrypoint+  , RequireUniqueEntrypoints      -- * Conversion from ADT   , uparamFromAdt@@ -56,15 +56,15 @@ import qualified Text.Show  import Lorentz.ADT+import Lorentz.Annotation (HasAnnotation) import Lorentz.Base import Lorentz.Coercions import Lorentz.Constraints-import Lorentz.EntryPoints.Doc+import Lorentz.Entrypoints.Doc import Lorentz.Errors import Lorentz.Instr as L import Lorentz.Macro import Lorentz.Pack-import Lorentz.TypeAnns (HasTypeAnn) import Michelson.Text import Michelson.Typed import Util.Label (Label)@@ -74,7 +74,7 @@ import Util.TypeTuple  -- | An entrypoint is described by two types: its name and type of argument.-type EntryPointKind = (Symbol, Kind.Type)+type EntrypointKind = (Symbol, Kind.Type)  -- | A convenient alias for type-level name-something pair. type (n :: Symbol) ?: (a :: k) = '(n, a)@@ -84,11 +84,9 @@ -- -- In Haskell world, we keep an invariant of that contained value relates -- to one of entry points from @entries@ list.-newtype UParam (entries :: [EntryPointKind]) = UParamUnsafe (MText, ByteString)+newtype UParam (entries :: [EntrypointKind]) = UParamUnsafe (MText, ByteString)   deriving stock (Generic, Eq, Show)-  deriving anyclass (IsoValue, HasTypeAnn)--instance Wrapped (UParam entries)+  deriving anyclass (IsoValue, HasAnnotation, Wrappable)  -- Casting to homomorphic value ----------------------------------------------------------------------------@@ -103,7 +101,7 @@ instance SameEntries entries1 entries2 =>          UParam entries1 `CanCastTo` UParam entries2 -type family SameEntries (es1 :: [EntryPointKind]) (es :: [EntryPointKind])+type family SameEntries (es1 :: [EntrypointKind]) (es :: [EntrypointKind])               :: Constraint where   SameEntries e e = ()   SameEntries SomeInterface _ = ()@@ -115,18 +113,18 @@ ----------------------------------------------------------------------------  -- | Get type of entrypoint argument by its name.-type family LookupEntryPoint (name :: Symbol) (entries :: [EntryPointKind])+type family LookupEntrypoint (name :: Symbol) (entries :: [EntrypointKind])              :: Kind.Type where-  LookupEntryPoint name ('(name, a) ': _) = a-  LookupEntryPoint name (_ ': entries) = LookupEntryPoint name entries-  LookupEntryPoint name '[] =+  LookupEntrypoint name ('(name, a) ': _) = a+  LookupEntrypoint name (_ ': entries) = LookupEntrypoint name entries+  LookupEntrypoint name '[] =     TypeError ('Text "Entry point " ':<>: 'ShowType name ':<>:                'Text " in not in the entry points list")  -- | Ensure that given entry points do no contain duplicated names.-type family RequireUniqueEntryPoints (entries :: [EntryPointKind])+type family RequireUniqueEntrypoints (entries :: [EntrypointKind])              :: Constraint where-  RequireUniqueEntryPoints entries =+  RequireUniqueEntrypoints entries =     RequireAllUnique "entrypoint" (Fcf.Eval (Fcf.Map Fcf.Fst entries))  ----------------------------------------------------------------------------@@ -136,8 +134,8 @@ -- | Construct a 'UParam' safely. mkUParam   :: ( NicePackedValue a-     , LookupEntryPoint name entries ~ a-     , RequireUniqueEntryPoints entries+     , LookupEntrypoint name entries ~ a+     , RequireUniqueEntrypoints entries      )   => Label name -> a -> UParam entries mkUParam label (a :: a) =@@ -147,12 +145,12 @@ -- Example ---------------------------------------------------------------------------- -type MyEntryPoints =+type MyEntrypoints =   [ "add" ?: Integer   , "reset" ?: ()   ] -_mkParamSample1 :: UParam MyEntryPoints+_mkParamSample1 :: UParam MyEntrypoints _mkParamSample1 = mkUParam #add 5  ----------------------------------------------------------------------------@@ -176,10 +174,10 @@   -- 'ConstrainedSome'. The user of this function can require arbitrary   -- constraint to hold (depending on how they want to use the result).   unpackUParam ::-    UParam entries -> Either EntryPointLookupError (MText, ConstrainedSome c)+    UParam entries -> Either EntrypointLookupError (MText, ConstrainedSome c)  instance UnpackUParam c '[] where-  unpackUParam (UParamUnsafe (name, _)) = Left (NoSuchEntryPoint name)+  unpackUParam (UParamUnsafe (name, _)) = Left (NoSuchEntrypoint name)  instance   ( KnownSymbol name@@ -205,34 +203,34 @@ unwrapUParam = coerceUnwrap  -- | Wrapper for a single "case" branch.-data CaseClauseU inp out (entry :: EntryPointKind) where+data CaseClauseU inp out (entry :: EntrypointKind) where   CaseClauseU :: (arg : inp) :-> out -> CaseClauseU inp out '(name, arg)  instance (name ~ name', body ~ ((arg : inp) :-> out)) =>          CaseArrow name' body (CaseClauseU inp out '(name, arg)) where   (/->) _ = CaseClauseU -data EntryPointLookupError-  = NoSuchEntryPoint MText+data EntrypointLookupError+  = NoSuchEntrypoint MText   | ArgumentUnpackFailed   deriving stock (Generic, Eq, Show) -instance Buildable EntryPointLookupError where+instance Buildable EntrypointLookupError where   build =     \case-      NoSuchEntryPoint name -> "No such entrypoint: " <> build name+      NoSuchEntrypoint name -> "No such entrypoint: " <> build name       ArgumentUnpackFailed -> "UNPACK failed" -type instance ErrorArg "uparamNoSuchEntryPoint" = MText+type instance ErrorArg "uparamNoSuchEntrypoint" = MText type instance ErrorArg "uparamArgumentUnpackFailed" = () -instance Buildable (CustomError "uparamNoSuchEntryPoint") where+instance Buildable (CustomError "uparamNoSuchEntrypoint") where   build (CustomError _ name) = "No such entrypoint: " <> build name  instance Buildable (CustomError "uparamArgumentUnpackFailed") where   build (CustomError _ ()) = "UNPACK failed" -instance CustomErrorHasDoc "uparamNoSuchEntryPoint" where+instance CustomErrorHasDoc "uparamNoSuchEntrypoint" where   customErrClass = ErrClassBadArgument   customErrDocMdCause = "Entrypoint with given name does not exist." @@ -245,7 +243,7 @@ -- Note that this thing inherits properties of 'Rec', e.g. you can -- @Data.Vinyl.Core.rappend@ implementations for two entrypoint sets -- when assembling scattered parts of a contract.-type EntryPointsImpl inp out entries =+type EntrypointsImpl inp out entries =   Rec (CaseClauseU inp out) entries  -- | An action invoked when user-provided entrypoint is not found.@@ -254,10 +252,10 @@ -- | Default implementation for 'UParamFallback', simply reports an error. uparamFallbackFail :: UParamFallback inp out uparamFallbackFail =-  car # failCustom #uparamNoSuchEntryPoint+  car # failCustom #uparamNoSuchEntrypoint  -- | Make up a "case" over entry points.-class CaseUParam (entries :: [EntryPointKind]) where+class CaseUParam (entries :: [EntrypointKind]) where   -- | Pattern-match on given @UParam entries@.   --   -- You have to provide all case branches and a fallback action on case@@ -293,7 +291,7 @@ -- You have to provide all case branches and a fallback action on case -- when entrypoint is not found. caseUParam-  :: (CaseUParam entries, RequireUniqueEntryPoints entries)+  :: (CaseUParam entries, RequireUniqueEntrypoints entries)   => Rec (CaseClauseU inp out) entries   -> UParamFallback inp out   -> (UParam entries : inp) :-> out@@ -314,7 +312,7 @@ -- Example ---------------------------------------------------------------------------- -_caseSample :: UParam MyEntryPoints : s :-> Integer : s+_caseSample :: UParam MyEntrypoints : s :-> Integer : s _caseSample = caseUParamT   ( #add /-> nop   , #reset /-> L.drop @() # push 0

@@ -4,8 +4,9 @@  {- | This module contains implementation of 'UStore'. -@UStore@ is essentially 'Lorentz.Store.Store' modified for the sake of-upgradeability.+@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;

@@ -96,9 +96,9 @@   DUStoreTemplate p1 `compare` DUStoreTemplate p2 = compareExt p1 p2  instance DocItem DUStoreTemplate where-  type DocItemPosition DUStoreTemplate = 12700   type DocItemPlacement DUStoreTemplate = 'DocItemInDefinitions +  docItemPos = 12700   docItemSectionName = Just "Used upgradeable storage formats"   docItemSectionDescription = Just     "This section describes formats (aka _templates_) of upgradeable storages \

@@ -97,18 +97,18 @@   , formMigrationAtom   ) where -import Control.Lens (traversed)+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.TypeAnns (HasTypeAnn) import Lorentz.Instr (nop) import Lorentz.Run import Lorentz.UStore.Types@@ -165,9 +165,7 @@   MigrationScript   { unMigrationScript :: Lambda UStore_ UStore_   } deriving stock (Show, Generic)-    deriving anyclass (IsoValue, HasTypeAnn)--instance Wrapped (MigrationScript oldStore newStore)+    deriving anyclass (IsoValue, HasAnnotation, Wrappable)  instance (Each [Typeable, UStoreTemplateHasDoc] [oldStore, newStore]) =>          TypeHasDoc (MigrationScript oldStore newStore) where@@ -267,7 +265,7 @@ -- worth generalizing @doc_group@ and @doc_item@ instructions so that they -- could serve as multi-purpose markers. instance DocItem DMigrationActionDesc where-  type DocItemPosition DMigrationActionDesc = 105010+  docItemPos = 105010   docItemSectionName = Nothing   docItemToMarkdown _ _ = "Migration action" @@ -320,7 +318,9 @@ instance MapLorentzInstr (UStoreMigration os ns) where   mapLorentzInstr f (UStoreMigration atoms) =     UStoreMigration $-      atoms & traversed . maScriptL . _Wrapped' %~ f+      atoms & traversed . maScriptL . wrapped %~ f+    where+      wrapped = iso unMigrationScript MigrationScript  -- | Modify all code in migration. mapMigrationCode

@@ -35,27 +35,19 @@   , MSValue   , FSValue   , FSMarker--   -- * Generators-  , genUStoreSubMap-  , genUStoreFieldExt   ) where -import Control.Lens (Wrapped) import qualified Data.Kind as Kind 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.Annotation (HasAnnotation)+import Lorentz.Coercions (Wrappable) import Lorentz.Pack-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@@ -73,9 +65,7 @@   } deriving stock (Eq, Show, Generic)     deriving newtype (Default, Semigroup, Monoid, IsoValue,                       MemOpHs, GetOpHs, UpdOpHs)-    deriving anyclass HasTypeAnn--instance Wrapped (UStore a)+    deriving anyclass (HasAnnotation, Wrappable)  -- | Describes one virtual big map in the storage. newtype k |~> v = UStoreSubMap { unUStoreSubMap :: Map k v }@@ -280,13 +270,3 @@     '[]   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

@@ -36,11 +36,13 @@    , M.EpName   , pattern M.DefEpName-  , EntryPointCall-  , SomeEntryPointCall+  , EntrypointCall+  , SomeEntrypointCall      -- * Constructors   , toMutez+  , zeroMutez+  , oneMutez   , mt   , timestampFromSeconds   , timestampFromUTCTime@@ -59,17 +61,22 @@     -- * Misc   , Default (..)   , Label (..)++  -- * Re-exports+  , module ReExports   ) where  import Data.Default (Default(..))  import Lorentz.Address import Michelson.Text-import Michelson.Typed (EntryPointCall, IsoValue(..), SomeEntryPointCall, Value, WellTypedIsoValue)+import Michelson.Typed (EntrypointCall, IsoValue(..), SomeEntrypointCall, Value, WellTypedIsoValue) import qualified Michelson.Typed as M import Tezos.Core-  (ChainId, Mutez, Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampQuote, toMutez)+  (ChainId, Mutez, Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampQuote, toMutez,+  zeroMutez, oneMutez) import Tezos.Crypto (KeyHash, PublicKey, Signature)+import Util.CustomGeneric as ReExports import Util.Label (Label(..))  type List = []

@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Wrappable+  ( Wrappable+  , Unwrappable+  ) where++import Data.Kind (Type)+import GHC.Generics+import GHC.TypeLits+import Named (NamedF(..))++import Michelson.Typed (ToT)++-- | 'Wrappable' is similar to lens 'Wrapped' class without the method.+-- It provides type family that is mainly used as constraint when+-- unwrapping Lorentz instruction into a Haskell newtype and vice versa.+class ToT s ~ ToT (Unwrappable s) => Wrappable (s :: Type) where+  type Unwrappable s :: Type+  type Unwrappable s = GUnwrappable (Rep s)++type family GUnwrappable (rep :: Type -> Type) :: Type where+  GUnwrappable (D1 ('MetaData _ _ _ 'True) (C1 _ (S1 _ (Rec0 a)))) = a+  GUnwrappable _ = TypeError ('Text "Type is not a newtype")++instance Wrappable (NamedF Identity a name) where+  type Unwrappable (NamedF Identity a name) = a++instance Wrappable (NamedF Maybe a name) where+  type Unwrappable (NamedF Maybe a name) = Maybe a

@@ -21,8 +21,8 @@  import qualified Data.Kind as Kind +import Lorentz.Annotation import Lorentz.Base-import Lorentz.TypeAnns import Michelson.Typed import Michelson.Untyped (noAnn) @@ -79,12 +79,12 @@   fromVal (VLam i) = zipInstr ## LorentzInstr i ## unzipInstr  instance-    ( HasTypeAnn (ZippedStack i)-    , HasTypeAnn (ZippedStack o)+    ( HasAnnotation (ZippedStack i)+    , HasAnnotation (ZippedStack o)     )   =>-    HasTypeAnn (i :-> o)+    HasAnnotation (i :-> o)   where-  getTypeAnn = NTLambda noAnn-    (getTypeAnn @(ZippedStack i))-    (getTypeAnn @(ZippedStack o))+  getAnnotation = NTLambda noAnn+    (getAnnotation @(ZippedStack i))+    (getAnnotation @(ZippedStack o))

@@ -1,16 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Main-  ( main-  ) where--import Test.Tasty (defaultMainWithIngredients)--import Util.Test.Ingredients (ourIngredients)--import Tree (tests)--main :: IO ()-main = tests >>= defaultMainWithIngredients ourIngredients

@@ -1,161 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Tests on automatic documentation generation.--module Test.Doc-  ( test_General_doc_scan-  , test_Dependencies_loops-  , test_Cutting_all_except_doc-  , test_fakeCoerce-  ) where--import qualified Data.Set as Set-import Fmt (build)-import Hedgehog (property)-import Test.HUnit (assertBool, assertFailure, (@?=))-import Test.Tasty (TestTree)-import Test.Tasty.Hedgehog (testProperty)-import Test.Tasty.HUnit (testCase)--import Lorentz (( # ))-import qualified Lorentz as L-import Michelson.Doc-import Michelson.Test (total)-import Michelson.Typed-import Util.Named---- General tests on contract doc scan-------------------------------------------------------------------------------newtype MyType = MyType Integer-  deriving stock (Generic)-  deriving anyclass (IsoValue)--instance TypeHasDoc MyType where-  typeDocMdDescription = ""--data MyGroup = MyGroup Text SubDoc--instance DocItem MyGroup where-  type DocItemPosition MyGroup = 91232-  docItemSectionName = Nothing-  docItemToMarkdown lvl (MyGroup name subDoc) =-    build name <> subDocToMarkdown lvl subDoc--test_General_doc_scan :: [TestTree]-test_General_doc_scan =-  [ testCase "Type declaration is found" $-      let contract = L.doc $ DType (Proxy @MyType)-          doc = L.buildLorentzDoc contract-      in case lookupDocBlockSection @DType $ cdDefinitions doc of-            Just (toList -> ds) ->-              sort ds @?= sort [DType (Proxy @MyType), DType (Proxy @Integer)]-            Nothing ->-              assertFailure "DTypes not found"--  , testCase "Dependencies of polymorphic types are found" $-      -- There once was a bug which caused, in the following scenario,-      -- 'Integer' type to be found while 'Natural' to be not, doc items-      -- discovery thought that ":!" has already been traversed and didn't-      -- pick its dependencies the second time.-      let contract = L.doc $ L.mkDEntryPointArgSimple @("a" :! Integer, "b" :! Natural)-          doc = L.buildLorentzDoc contract-          defs = cdDefinitionsSet doc-      in do-         assertBool "'Integer' declaration is present" $-            Set.member (SomeDocDefinitionItem $ DType (Proxy @Integer)) defs-         assertBool "'Natural' declaration is present" $-            Set.member (SomeDocDefinitionItem $ DType (Proxy @Natural)) defs--  , testCase "Doc group is handled correctly" $-      let contract = L.docGroup (SomeDocItem . MyGroup "a") $-                     L.doc $ DDescription "a"-          doc = L.buildLorentzDoc contract-          contents = cdContents doc-      in case lookupDocBlockSection contents of-            Just (MyGroup "a" (SubDoc subcontents) :| []) ->-               case lookupDocBlockSection subcontents of-                 Just (DDescription "a" :| []) ->-                   pass-                 _ -> assertFailure $ "Unexpected subcontents: " <> show subcontents-            _ -> assertFailure $ "Unexpected contents: " <> show contents-  ]---- Test on loops on dependency graph of doc items--------------------------------------------------------------------------------- | Type, documentation for which somehow depends on itself.-newtype MyLoopedType = MyLoopedType Integer-  deriving stock (Generic)-  deriving anyclass (IsoValue)--instance TypeHasDoc MyLoopedType where-  typeDocDependencies _ = [dTypeDep @MyLoopedType]-  typeDocMdDescription = ""--newtype MyMutuallyDependentType1 = MyMutuallyDependentType1 Integer-  deriving stock (Generic)-  deriving anyclass (IsoValue)--newtype MyMutuallyDependentType2 = MyMutuallyDependentType2 Integer-  deriving stock (Generic)-  deriving anyclass (IsoValue)--instance TypeHasDoc MyMutuallyDependentType1 where-  typeDocDependencies _ = [dTypeDep @MyMutuallyDependentType2]-  typeDocMdDescription = ""--instance TypeHasDoc MyMutuallyDependentType2 where-  typeDocDependencies _ = [dTypeDep @MyMutuallyDependentType1]-  typeDocMdDescription = ""--test_Dependencies_loops :: [TestTree]-test_Dependencies_loops =-  [ testProperty "Type depending on itself" $ property $-      let contract = L.doc $ DType (Proxy @MyLoopedType)-      in void . total . contractDocToMarkdown $ L.buildLorentzDoc contract-  , testProperty "Mutually dependent types" $ property $-      let contract = L.doc $ DType (Proxy @MyMutuallyDependentType1)-      in void . total . contractDocToMarkdown $ L.buildLorentzDoc contract-  ]---- Functions semantics-------------------------------------------------------------------------------test_Cutting_all_except_doc :: [TestTree]-test_Cutting_all_except_doc =-  [ testCase "Cleaning simple code" $-      let contract =-            L.doc (DDescription "a") #-            L.push True #-            L.if_ (L.contractName "aaa" $ L.doc $ DDescription "b") (L.sender # L.drop)-            :: '[] L.:-> '[]-          cutContract =-            L.doc (DDescription "a") #-            L.contractName "aaa" (L.doc $ DDescription "b")-      in L.renderLorentzDoc (L.cutLorentzNonDoc contract)-         @?=-         L.renderLorentzDoc cutContract--  , testCase "DocGroup is handled correctly" $-      let contract =-            L.docGroup (SomeDocItem . MyGroup "b") $-              L.doc (DDescription "a") # L.nop-          cutContract =-            L.docGroup (SomeDocItem . MyGroup "b") $-              L.doc (DDescription "a")-      in L.renderLorentzDoc (L.cutLorentzNonDoc contract)-         @?=-         L.renderLorentzDoc cutContract-  ]--test_fakeCoerce :: [TestTree]-test_fakeCoerce =-  [ testCase "Does not truncate the following documentation" $-      let contract = L.doc (DDescription "a") :: '[] L.:-> '[]-      in L.renderLorentzDoc (L.fakeCoerce # contract)-         @?=-         L.renderLorentzDoc contract-  ]