morley 0.7.0 → 1.0.0

raw patch · 95 files changed

+208/−12748 lines, 95 filesdep −bimapdep −pretty-terminaldep −spoondep ~constraintsdep ~first-class-familiesPVP ok

version bump matches the API change (PVP)

Dependencies removed: bimap, pretty-terminal, spoon, type-spec

Dependency ranges changed: constraints, first-class-families

API changes (from Hackage documentation)

Files

• CHANGES.md +7/−0
• README.md +1/−15
• morley.cabal +5/−91
• src/Lorentz.hs +0/−33
• src/Lorentz/ADT.hs +0/−240
• src/Lorentz/Arith.hs +0/−127
• src/Lorentz/Base.hs +0/−193
• src/Lorentz/Coercions.hs +0/−196
• src/Lorentz/Common.hs +0/−17
• src/Lorentz/Constraints.hs +0/−6
• src/Lorentz/Constraints/Derivative.hs +0/−12
• src/Lorentz/Constraints/Scopes.hs +0/−110
• src/Lorentz/ContractRegistry.hs +0/−109
• src/Lorentz/Doc.hs +0/−132
• src/Lorentz/Empty.hs +0/−51
• src/Lorentz/EntryPoints.hs +0/−46
• src/Lorentz/EntryPoints/Core.hs +0/−440
• src/Lorentz/EntryPoints/Doc.hs +0/−355
• src/Lorentz/EntryPoints/Helpers.hs +0/−46
• src/Lorentz/EntryPoints/Impl.hs +0/−306
• src/Lorentz/EntryPoints/Manual.hs +0/−38
• src/Lorentz/Errors.hs +0/−682
• src/Lorentz/Errors/Common.hs +0/−28
• src/Lorentz/Errors/Numeric.hs +0/−174
• src/Lorentz/Ext.hs +0/−39
• src/Lorentz/Extensible.hs +0/−270
• src/Lorentz/Instr.hs +0/−691
• src/Lorentz/Macro.hs +0/−687
• src/Lorentz/Pack.hs +0/−26
• src/Lorentz/Polymorphic.hs +0/−171
• src/Lorentz/Prelude.hs +0/−19
• src/Lorentz/Print.hs +0/−31
• src/Lorentz/Rebinded.hs +0/−179
• src/Lorentz/Referenced.hs +0/−157
• src/Lorentz/Run.hs +0/−97
• src/Lorentz/Store.hs +0/−701
• src/Lorentz/StoreClass.hs +0/−351
• src/Lorentz/Test.hs +0/−106
• src/Lorentz/Test/Consumer.hs +0/−14
• src/Lorentz/Test/Doc.hs +0/−61
• src/Lorentz/Test/Integrational.hs +0/−392
• src/Lorentz/Test/Unit.hs +0/−28
• src/Lorentz/TestScenario.hs +0/−53
• src/Lorentz/TypeAnns.hs +0/−170
• src/Lorentz/UParam.hs +0/−417
• src/Lorentz/UStore.hs +0/−93
• src/Lorentz/UStore/Common.hs +0/−13
• src/Lorentz/UStore/Haskell.hs +0/−335
• src/Lorentz/UStore/Instances.hs +0/−24
• src/Lorentz/UStore/Instr.hs +0/−351
• src/Lorentz/UStore/Lift.hs +0/−111
• src/Lorentz/UStore/Migration.hs +0/−89
• src/Lorentz/UStore/Migration/Base.hs +0/−497
• src/Lorentz/UStore/Migration/Batching.hs +0/−113
• src/Lorentz/UStore/Migration/Blocks.hs +0/−287
• src/Lorentz/UStore/Migration/Diff.hs +0/−196
• src/Lorentz/UStore/Types.hs +0/−282
• src/Lorentz/Value.hs +0/−247
• src/Lorentz/Zip.hs +0/−73
• src/Michelson/Test.hs +8/−2
• src/Michelson/Test/Import.hs +1/−16
• src/Michelson/Test/Integrational.hs +53/−1
• src/Michelson/Test/Unit.hs +15/−0
• src/Michelson/Test/Util.hs +31/−1
• src/Util/Test/Arbitrary.hs +3/−11
• test/Test/Doc.hs +0/−156
• test/Test/DocTest.hs +0/−73
• test/Test/Integrational.hs +14/−7
• test/Test/Interpreter.hs +2/−50
• test/Test/Interpreter/Apply.hs +33/−0
• test/Test/Interpreter/StackRef.hs +26/−0
• test/Test/Lorentz/Base.hs +0/−27
• test/Test/Lorentz/Conditionals.hs +0/−28
• test/Test/Lorentz/DeadCode.hs +0/−43
• test/Test/Lorentz/EntryPoints.hs +0/−447
• test/Test/Lorentz/Errors.hs +0/−140
• test/Test/Lorentz/Extensible.hs +0/−71
• test/Test/Lorentz/Macro.hs +0/−45
• test/Test/Lorentz/Pack.hs +0/−43
• test/Test/Lorentz/Print.hs +0/−51
• test/Test/Lorentz/UParam.hs +0/−96
• test/Test/Lorentz/UStore/Behaviour.hs +0/−175
• test/Test/Lorentz/UStore/Migration/Batched.hs +0/−76
• test/Test/Lorentz/UStore/Migration/Batched/V1.hs +0/−15
• test/Test/Lorentz/UStore/Migration/Batched/V2.hs +0/−12
• test/Test/Lorentz/UStore/Migration/FillInParts.hs +0/−84
• test/Test/Lorentz/UStore/Migration/Simple.hs +0/−82
• test/Test/Lorentz/UStore/Migration/Simple/V1.hs +0/−13
• test/Test/Lorentz/UStore/Migration/Simple/V2.hs +0/−13
• test/Test/Lorentz/UStore/SafeLift.hs +0/−42
• test/Test/Lorentz/UStore/SafeLift/Helpers.hs +0/−14
• test/Test/Printer/Michelson.hs +1/−22
• test/Test/Tasty/TypeSpec.hs +0/−27
• test/Test/Util/QuickCheck.hs +8/−27
• test/Test/Util/TypeSpec.hs +0/−20

@@ -2,6 +2,13 @@ ========== <!-- Append new entries here --> +1.0.0+=====++* [!215](https://gitlab.com/morley-framework/morley/merge_requests/215)+  Major change: all Lorentz functionality was moved into `morley-lorentz` package.+  A small portion of testing library code was moved around (from `Lorentz.*` to `Michelson.*` or vice versa).+ 0.7.0 ===== 

@@ -35,21 +35,7 @@ 1. If your contract is called `foo.mtz`, use `morley print --contract foo.mtz --output foo.tz`. Note that normally you should not use `morley` directly, you should use `morley.sh` or `stack exec -- morley`. See usage instructions below. 2. After that, you can use existing Tezos tools to deploy your contract. You can also typecheck or interpret it using a reference implementation. If you are not familiar with the Tezos tooling, please read [Tezos documentation](https://tezos.gitlab.io/index.html) or [Michelson tutorial](https://gitlab.com/morley-framework/michelson-tutorial). -## IV: Lorentz EDSL--<!-- This section is to be proof-read -->--Lorentz is a powerful meta-programming tool which allows one to write contracts directly in Haskell.--Haskell's type checker and automatic type inference facilitate contracts implementation and reduce boilerplate related to types. Adoption of Algebraic Data Types makes work with complex objects safe and convenient.-Later Lorentz contract can be dumped as a plain textual Michelson contract using functions from [`Michelson.Printer`](/src/Michelson/Printer.hs).--You can find Lorentz instructions in [`Lorentz`](/src/Lorentz.hs) modules.--Examples of using Lorentz eDSL reside in the [`morley-ledgers`](/morley-ledgers) package.-For more information, refer to this package [README](/morley-ledgers/README.md).--## V: Testing EDSL+## IV: Testing EDSL  Another way to test Michelson contracts is to write tests in Haskell using the testing EDSL provided by Morley. It supports both integrational and unit tests.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 33cc1385806c0bba34d30ab3ced63fed49ed649195dbcaa6e240edf9cbe6cd01+-- hash: 0e0daabc72a430afec07d1e179157ea8879f37c1581d88a8ce1fd0bd1410264d  name:           morley-version:        0.7.0+version:        1.0.0 synopsis:       Developer tools for the Michelson Language description:    A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category:       Language@@ -30,62 +30,6 @@  library   exposed-modules:-      Lorentz-      Lorentz.ADT-      Lorentz.Arith-      Lorentz.Base-      Lorentz.Coercions-      Lorentz.Common-      Lorentz.Constraints-      Lorentz.Constraints.Derivative-      Lorentz.Constraints.Scopes-      Lorentz.ContractRegistry-      Lorentz.Doc-      Lorentz.Empty-      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-      Lorentz.Ext-      Lorentz.Extensible-      Lorentz.Instr-      Lorentz.Macro-      Lorentz.Pack-      Lorentz.Polymorphic-      Lorentz.Prelude-      Lorentz.Print-      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-      Lorentz.UStore.Haskell-      Lorentz.UStore.Instances-      Lorentz.UStore.Instr-      Lorentz.UStore.Lift-      Lorentz.UStore.Migration-      Lorentz.UStore.Migration.Base-      Lorentz.UStore.Migration.Batching-      Lorentz.UStore.Migration.Blocks-      Lorentz.UStore.Migration.Diff-      Lorentz.UStore.Types-      Lorentz.Value-      Lorentz.Zip       Michelson.Analyzer       Michelson.Doc       Michelson.Doc.Test@@ -211,7 +155,6 @@     , base-noprelude >=4.7 && <5     , base16-bytestring     , base58-bytestring-    , bimap     , binary     , bytestring     , constraints >=0.11@@ -232,9 +175,7 @@     , morley-prelude >=0.3.0     , mtl     , named-    , optparse-applicative     , parser-combinators >=1.0.0-    , pretty-terminal     , quickcheck-arbitrary-adt     , quickcheck-instances     , show-type@@ -243,6 +184,7 @@     , tasty     , tasty-ant-xml     , tasty-hunit-compat+    , tasty-quickcheck     , template-haskell     , text     , th-lift@@ -282,12 +224,11 @@   other-modules:       Test.Analyzer       Test.CValConversion-      Test.Doc-      Test.DocTest       Test.EntryPoints       Test.Ext       Test.Integrational       Test.Interpreter+      Test.Interpreter.Apply       Test.Interpreter.Auction       Test.Interpreter.CallSelf       Test.Interpreter.Compare@@ -295,27 +236,8 @@       Test.Interpreter.Conditionals       Test.Interpreter.ContractOp       Test.Interpreter.EnvironmentSpec+      Test.Interpreter.StackRef       Test.Interpreter.StringCaller-      Test.Lorentz.Base-      Test.Lorentz.Conditionals-      Test.Lorentz.DeadCode-      Test.Lorentz.EntryPoints-      Test.Lorentz.Errors-      Test.Lorentz.Extensible-      Test.Lorentz.Macro-      Test.Lorentz.Pack-      Test.Lorentz.Print-      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.Macro       Test.Michelson.Runtime       Test.Michelson.Text@@ -327,7 +249,6 @@       Test.Printer.Michelson       Test.Serialization.Aeson       Test.Serialization.Michelson-      Test.Tasty.TypeSpec       Test.Tezos.Address       Test.Tezos.Core       Test.Tezos.Crypto@@ -339,7 +260,6 @@       Test.Util.HUnit       Test.Util.Parser       Test.Util.QuickCheck-      Test.Util.TypeSpec       Test.ValConversion       Tree       Paths_morley@@ -354,14 +274,11 @@     , QuickCheck     , aeson     , base-noprelude >=4.7 && <5-    , bimap     , bytestring-    , constraints     , containers     , data-default     , directory     , filepath-    , first-class-families     , fmt     , formatting     , hex-text@@ -374,14 +291,11 @@     , quickcheck-arbitrary-adt     , quickcheck-instances     , singletons-    , spoon     , syb     , tasty     , tasty-hspec     , tasty-hunit-compat     , tasty-quickcheck     , text-    , type-spec     , unordered-containers-    , vinyl   default-language: Haskell2010

@@ -1,33 +0,0 @@-module Lorentz-  ( module Exports-  ) where--import Lorentz.ADT as Exports-import Lorentz.Arith as Exports-import Lorentz.Base as Exports-import Lorentz.Coercions as Exports-import Lorentz.Common as Exports-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.Errors as Exports-import Lorentz.Errors.Common as Exports ()-import Lorentz.Errors.Numeric as Exports-import Lorentz.Ext as Exports-import Lorentz.Instr as Exports-import Lorentz.Macro as Exports-import Lorentz.Pack as Exports-import Lorentz.Polymorphic as Exports-import Lorentz.Prelude as Exports-import Lorentz.Print as Exports-import Lorentz.Rebinded as Exports-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-import Lorentz.Zip as Exports ()

@@ -1,240 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}--module Lorentz.ADT-  ( HasField-  , HasFieldOfType-  , HasFieldsOfType-  , NamedField (..)-  , (:=)-  , toField-  , toFieldNamed-  , getField-  , getFieldNamed-  , setField-  , modifyField-  , construct-  , constructT-  , fieldCtor-  , wrap_-  , case_-  , caseT-  , unwrapUnsafe_-  , CaseTC-  , CaseArrow (..)-  , CaseClauseL (..)-  , InstrConstructC-  , ConstructorFieldTypes--    -- * Useful re-exports-  , Rec (..)-  , (:!)-  , (:?)-  , arg-  , argDef-  , argF-  ) where--import Data.Constraint (Dict(..))-import qualified Data.Kind as Kind-import Data.Vinyl.Core (RMap(..), Rec(..))-import Data.Vinyl.Derived (Label)-import GHC.TypeLits (AppendSymbol, Symbol)-import Named ((:!), (:?), arg, argDef, argF)--import Lorentz.Base-import Lorentz.Coercions-import Lorentz.Instr-import Michelson.Typed.Haskell.Instr-import Michelson.Typed.Haskell.Value-import Util.TypeTuple---- | Allows field access and modification.-type HasField dt fname =-  ( InstrGetFieldC dt fname-  , InstrSetFieldC dt fname-  )---- | Like 'HasField', but allows constrainting field type.-type HasFieldOfType dt fname fieldTy =-  ( HasField dt fname-  , GetFieldType dt fname ~ fieldTy-  )---- | A pair of field name and type.-data NamedField = NamedField Symbol Kind.Type-type n := ty = 'NamedField n ty-infixr 0 :=---- | Shortcut for multiple 'HasFieldOfType' constraints.-type family HasFieldsOfType (dt :: Kind.Type) (fs :: [NamedField])-             :: Constraint where-  HasFieldsOfType _ '[] = ()-  HasFieldsOfType dt ((n := ty) ': fs) =-    (HasFieldOfType dt n ty, HasFieldsOfType dt fs)---- | Extract a field of a datatype replacing the value of this--- datatype with the extracted field.------ For this and the following functions you have to specify field name--- which is either record name or name attached with @(:!)@ operator.-toField-  :: forall dt name st.-     InstrGetFieldC dt name-  => Label name -> dt & st :-> GetFieldType dt name & st-toField = I . instrGetField @dt---- | Like 'toField', but leaves field named.-toFieldNamed-  :: forall dt name st.-     InstrGetFieldC dt name-  => Label name -> dt & st :-> (name :! GetFieldType dt name) & st-toFieldNamed l = toField l # forcedCoerce_---- | Extract a field of a datatype, leaving the original datatype on stack.-getField-  :: forall dt name st.-     InstrGetFieldC dt name-  => Label name -> dt & st :-> GetFieldType dt name & dt ': st-getField l = dup # toField @dt l---- | Like 'getField', but leaves field named.-getFieldNamed-  :: forall dt name st.-     InstrGetFieldC dt name-  => Label name -> dt & st :-> (name :! GetFieldType dt name) & dt ': st-getFieldNamed l = getField l # coerceWrap---- | Set a field of a datatype.-setField-  :: forall dt name st.-     InstrSetFieldC dt name-  => Label name -> (GetFieldType dt name ': dt ': st) :-> (dt ': st)-setField = I . instrSetField @dt---- | Apply given modifier to a datatype field.-modifyField-  :: forall dt name st.-     ( InstrGetFieldC dt name-     , InstrSetFieldC dt name-     )-  => Label name-  -> (forall st0. (GetFieldType dt name ': st0) :-> (GetFieldType dt name ': st0))-  -> dt & st :-> dt & st-modifyField l i = getField @dt l # i # setField @dt l---- | Make up a datatype. You provide a pack of individual fields constructors.------ Each element of the accepted record should be an instruction wrapped with--- 'fieldCtor' function. This instruction will have access to the stack at--- the moment of calling @construct@.--- Instructions have to output fields of the built datatype, one per instruction;--- instructions order is expected to correspond to the order of fields in the--- datatype.-construct-  :: forall dt st.-     ( InstrConstructC dt-     , RMap (ConstructorFieldTypes dt)-     )-  => Rec (FieldConstructor st) (ConstructorFieldTypes dt)-  -> st :-> dt & st-construct fctors =-  I $ instrConstruct @dt $-  rmap (\(FieldConstructor i) -> FieldConstructor i) fctors---- | Version of 'construct' which accepts tuple of field constructors.-constructT-  :: forall dt fctors st.-     ( InstrConstructC dt-     , RMap (ConstructorFieldTypes dt)-     , fctors ~ Rec (FieldConstructor st) (ConstructorFieldTypes dt)-     , RecFromTuple fctors-     )-  => IsoRecTuple fctors-  -> st :-> dt & st-constructT = construct . recFromTuple---- | Lift an instruction to field constructor.-fieldCtor :: HasCallStack => (st :-> f & st) -> FieldConstructor st f-fieldCtor = \case-  I i -> FieldConstructor i-  FI _ -> error "Field constructor always fails"---- | Wrap entry in constructor. Useful for sum types.-wrap_-  :: forall dt name st.-     InstrWrapC dt name-  => Label name -> (AppendCtorField (GetCtorField dt name) st) :-> dt & st-wrap_ =-  case appendCtorFieldAxiom @(GetCtorField dt name) @st of-    Dict -> I . instrWrap @dt---- | Lorentz analogy of 'CaseClause', it works on plain 'Kind.Type' types.-data CaseClauseL (inp :: [Kind.Type]) (out :: [Kind.Type]) (param :: CaseClauseParam) where-  CaseClauseL :: AppendCtorField x inp :-> out -> CaseClauseL inp out ('CaseClauseParam ctor x)---- | Provides "case" arrow which works on different wrappers for clauses.-class CaseArrow name body clause | clause -> name, clause -> body where-  -- | Lift an instruction to case clause.-  ---  -- You should write out constructor name corresponding to the clause-  -- explicitly. Prefix constructor name with "c" letter, otherwise-  -- your label will not be recognized by Haskell parser.-  -- Passing constructor name can be circumvented but doing so is not recomended-  -- as mentioning contructor name improves readability and allows avoiding-  -- some mistakes.-  (/->) :: Label name -> body -> clause-  infixr 0 /->--instance ( name ~ ("c" `AppendSymbol` ctor)-         , body ~ (AppendCtorField x inp :-> out)-         ) => CaseArrow name body-                (CaseClauseL inp out ('CaseClauseParam ctor x)) where-  (/->) _ = CaseClauseL---- | Pattern match on the given sum type.------ You have to provide a 'Rec' containing case branches.--- To construct a case branch use '/->' operator.-case_-  :: forall dt out inp.-     ( InstrCaseC dt inp out-     , RMap (CaseClauses dt)-     )-  => Rec (CaseClauseL inp out) (CaseClauses dt) -> dt & inp :-> out-case_ = LorentzInstr . instrCase @dt . rmap coerceCaseClause-  where-    coerceCaseClause-      :: forall clauses.-         CaseClauseL inp out clauses -> CaseClause (ToTs inp) (ToTs out) clauses-    coerceCaseClause (CaseClauseL (LorentzInstr cc)) =-      CaseClause $ case Proxy @clauses of-        (_ :: Proxy ('CaseClauseParam ctor cc)) ->-          case appendCtorFieldAxiom @cc @inp of Dict -> cc---- | Like 'case_', accepts a tuple of clauses, which may be more convenient.------ If user is experiencing problems with wierd errors about tuples while using--- this function, he should take look at `Util.TypeTuple.Instances` and ensure--- that his tuple isn't bigger than generated instances, if so, he should probably--- extend number of generated instances.-caseT-  :: forall dt out inp clauses.-     CaseTC dt out inp clauses-  => IsoRecTuple clauses -> dt & inp :-> out-caseT = case_ @dt . recFromTuple--type CaseTC dt out inp clauses =-  ( InstrCaseC dt inp out-  , RMap (CaseClauses dt)-  , RecFromTuple clauses-  , clauses ~ Rec (CaseClauseL inp out) (CaseClauses dt)-  )---- | Wrap entry in constructor. Useful for sum types.-unwrapUnsafe_-  :: forall dt name st.-     InstrUnwrapC dt name-  => Label name -> dt & st :-> (CtorOnlyField name dt ': st)-unwrapUnsafe_ =-  case appendCtorFieldAxiom @(GetCtorField dt name) @st of-    Dict -> I . instrUnwrapUnsafe @dt

@@ -1,127 +0,0 @@--- | Type families from 'Michelson.Typed.Arith' lifted to Haskell types.-module Lorentz.Arith-  ( ArithOpHs (..)-  , UnaryArithOpHs (..)-  ) where--import qualified Data.Kind as Kind--import Lorentz.Value-import Michelson.Typed.Arith-import Michelson.Typed.Haskell.Value-import Michelson.Typed.T---- | Lifted 'AithOp'.-class ( ArithOp aop (ToCT n) (ToCT m)-      , IsComparable n, IsComparable m-      , Typeable (ToCT n), Typeable (ToCT m)-      , ToT (ArithResHs aop n m) ~ 'Tc (ArithRes aop (ToCT n) (ToCT m))-      ) => ArithOpHs (aop :: Kind.Type) (n :: Kind.Type) (m :: Kind.Type) where-  type ArithResHs aop n m :: Kind.Type---- | Lifted 'UnaryAithOp'.-class ( UnaryArithOp aop (ToCT n)-      , IsComparable n-      , Typeable (ToCT n)-      , ToT (UnaryArithResHs aop n) ~ 'Tc (UnaryArithRes aop (ToCT n))-      ) => UnaryArithOpHs (aop :: Kind.Type) (n :: Kind.Type) where-  type UnaryArithResHs aop n :: Kind.Type--instance ArithOpHs Add Natural Integer where-  type ArithResHs Add Natural Integer = Integer-instance ArithOpHs Add Integer Natural where-  type ArithResHs Add Integer Natural = Integer-instance ArithOpHs Add Natural Natural where-  type ArithResHs Add Natural Natural = Natural-instance ArithOpHs Add Integer Integer where-  type ArithResHs Add Integer Integer = Integer-instance ArithOpHs Add Timestamp Integer where-  type ArithResHs Add Timestamp Integer = Timestamp-instance ArithOpHs Add Integer Timestamp where-  type ArithResHs Add Integer Timestamp = Timestamp-instance ArithOpHs Add Mutez Mutez where-  type ArithResHs Add Mutez Mutez = Mutez--instance ArithOpHs Sub Natural Integer where-  type ArithResHs Sub Natural Integer = Integer-instance ArithOpHs Sub Integer Natural where-  type ArithResHs Sub Integer Natural = Integer-instance ArithOpHs Sub Natural Natural where-  type ArithResHs Sub Natural Natural = Integer-instance ArithOpHs Sub Integer Integer where-  type ArithResHs Sub Integer Integer = Integer-instance ArithOpHs Sub Timestamp Integer where-  type ArithResHs Sub Timestamp Integer = Timestamp-instance ArithOpHs Sub Timestamp Timestamp where-  type ArithResHs Sub Timestamp Timestamp = Integer-instance ArithOpHs Sub Mutez Mutez where-  type ArithResHs Sub Mutez Mutez = Mutez--instance ArithOpHs Mul Natural Integer where-  type ArithResHs Mul Natural Integer = Integer-instance ArithOpHs Mul Integer Natural where-  type ArithResHs Mul Integer Natural = Integer-instance ArithOpHs Mul Natural Natural where-  type ArithResHs Mul Natural Natural = Natural-instance ArithOpHs Mul Integer Integer where-  type ArithResHs Mul Integer Integer = Integer-instance ArithOpHs Mul Natural Mutez where-  type ArithResHs Mul Natural Mutez = Mutez-instance ArithOpHs Mul Mutez Natural where-  type ArithResHs Mul Mutez Natural = Mutez--instance UnaryArithOpHs Abs Integer where-  type UnaryArithResHs Abs Integer = Natural--instance UnaryArithOpHs Neg Integer where-  type UnaryArithResHs Neg Integer = Integer-instance UnaryArithOpHs Neg Natural where-  type UnaryArithResHs Neg Natural = Integer--instance ArithOpHs Or Natural Natural where-  type ArithResHs Or Natural Natural = Natural-instance ArithOpHs Or Bool Bool where-  type ArithResHs Or Bool Bool = Bool--instance ArithOpHs And Integer Natural where-  type ArithResHs And Integer Natural = Integer-instance ArithOpHs And Natural Natural where-  type ArithResHs And Natural Natural = Natural-instance ArithOpHs And Bool Bool where-  type ArithResHs And Bool Bool = Bool--instance ArithOpHs Xor Natural Natural where-  type ArithResHs Xor Natural Natural = Natural-instance ArithOpHs Xor Bool Bool where-  type ArithResHs Xor Bool Bool = Bool--instance ArithOpHs Lsl Natural Natural where-  type ArithResHs Lsl Natural Natural = Natural--instance ArithOpHs Lsr Natural Natural where-  type ArithResHs Lsr Natural Natural = Natural--instance UnaryArithOpHs Not Integer where-  type UnaryArithResHs Not Integer = Integer-instance UnaryArithOpHs Not Natural where-  type UnaryArithResHs Not Natural = Integer-instance UnaryArithOpHs Not Bool where-  type UnaryArithResHs Not Bool = Bool--instance UnaryArithOpHs Eq' Integer where-  type UnaryArithResHs Eq' Integer = Bool--instance UnaryArithOpHs Neq Integer where-  type UnaryArithResHs Neq Integer = Bool--instance UnaryArithOpHs Lt Integer where-  type UnaryArithResHs Lt Integer = Bool--instance UnaryArithOpHs Gt Integer where-  type UnaryArithResHs Gt Integer = Bool--instance UnaryArithOpHs Le Integer where-  type UnaryArithResHs Le Integer = Bool--instance UnaryArithOpHs Ge Integer where-  type UnaryArithResHs Ge Integer = Bool

@@ -1,193 +0,0 @@-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Foundation of Lorentz development.-module Lorentz.Base-  ( (:->) (..)-  , type (%>)-  , type (&)-  , (#)-  , (##)-  , pattern I-  , pattern FI-  , iGenericIf-  , iAnyCode-  , iNonFailingCode-  , iMapAnyCode-  , iForceNotFail-  , iWithVarAnnotations--  , parseLorentzValue-  , transformStringsLorentz-  , transformBytesLorentz-  , optimizeLorentz-  , optimizeLorentzWithConf--  , ContractOut-  , Contract-  , SomeContract (..)-  , Lambda-  ) where--import Data.Default (def)-import qualified Data.Kind as Kind-import qualified Data.List.NonEmpty as NE (fromList)-import Data.Singletons (SingI(..))-import Fmt (Buildable(..))--import Lorentz.Constraints-import Lorentz.Value-import Michelson.ErrorPos (InstrCallStack)-import Michelson.Optimizer (OptimizerConf, optimizeWithConf)-import Michelson.Parser (ParserException, parseExpandValue)-import Michelson.Preprocess (transformBytes, transformStrings)-import Michelson.TypeCheck (TCError, runTypeCheckIsolated, typeVerifyValue)-import Michelson.Typed-  (Instr(..), RemFail(..), ToT, ToTs, Value, rfAnyInstr, rfMapAnyInstr, rfMerge)-import qualified Michelson.Untyped as U---- | Alias for instruction which hides inner types representation via 'T'.-newtype (inp :: [Kind.Type]) :-> (out :: [Kind.Type]) = LorentzInstr-  { unLorentzInstr :: RemFail Instr (ToTs inp) (ToTs out)-  } deriving newtype (Show, Eq)-infixr 1 :->--instance Semigroup (s :-> s) where-  (<>) = (#)-instance Monoid (s :-> s) where-  mempty = I Nop--pattern I :: Instr (ToTs inp) (ToTs out) -> inp :-> out-pattern I i = LorentzInstr (RfNormal i)--pattern FI :: (forall out'. Instr (ToTs inp) out') -> inp :-> out-pattern FI i = LorentzInstr (RfAlwaysFails i)--{-# COMPLETE I, FI #-}--iGenericIf-  :: (forall s'. Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s')-  -> (a :-> s) -> (b :-> s) -> (c :-> s)-iGenericIf merger (LorentzInstr instr1) (LorentzInstr instr2) =-  LorentzInstr (rfMerge merger instr1 instr2)--iAnyCode :: inp :-> out -> Instr (ToTs inp) (ToTs out)-iAnyCode = rfAnyInstr . unLorentzInstr--iNonFailingCode :: HasCallStack => inp :-> out -> Instr (ToTs inp) (ToTs out)-iNonFailingCode (I i) = i-iNonFailingCode (FI _) = error "Always failing code cannot appear here"--iMapAnyCode-  :: (forall o'. Instr (ToTs i1) o' -> Instr (ToTs i2) o')-  -> (i1 :-> o)-  -> (i2 :-> o)-iMapAnyCode f (LorentzInstr i) = LorentzInstr $ rfMapAnyInstr f i--iForceNotFail :: (i :-> o) -> (i :-> o)-iForceNotFail = I . iAnyCode---- | Wrap Lorentz instruction with variable annotations, @annots@ list has to be--- non-empty, otherwise this function raises an error.-iWithVarAnnotations :: HasCallStack => [Text] -> inp :-> out -> inp :-> out-iWithVarAnnotations annots (LorentzInstr i) = case i of-  RfNormal instr -> LorentzInstr $ RfNormal $-    InstrWithVarNotes (NE.fromList $ map U.AnnotationUnsafe annots) instr-  RfAlwaysFails instr -> LorentzInstr $ RfAlwaysFails $-    InstrWithVarNotes (NE.fromList $ map U.AnnotationUnsafe annots) instr---- There is also @instance IsoValue (i :-> o)@ in a separate module.---- | Alias for ':->', seems to make signatures more readable sometimes.------ Let's someday decide which one of these two should remain.-type (%>) = (:->)-infixr 1 %>--type ContractOut st = '[([Operation], st)]-type Contract cp st = '[(cp, st)] :-> ContractOut st--data SomeContract where-  SomeContract-    :: (NiceParameterFull cp, NiceStorage st)-    => Contract cp st-    -> SomeContract--type (&) (a :: Kind.Type) (b :: [Kind.Type]) = a ': b-infixr 2 &--(#) :: (a :-> b) -> (b :-> c) -> a :-> c-I l # I r = I (l `Seq` r)-I l # FI r = FI (l `Seq` r)-FI l # _ = FI l-infixl 8 #---- | Version of '#' which performs some optimizations immediately.-(##) :: (a :-> b) -> (b :-> c) -> (a :-> c)-l ## r = case (l, r) of-  (I Nop, I x) -> I x-  (I x, I Nop) -> I x-  _ -> l # r---type Lambda i o = '[i] :-> '[o]---- | Errors that can happen during parsing into a Lorentz value.-data ParseLorentzError-  = ParseLorentzParseError ParserException-  | ParseLorentzTypecheckError TCError-  deriving stock (Show, Eq)--instance Buildable ParseLorentzError where-  build =-    \case-      ParseLorentzParseError e -> build e-      ParseLorentzTypecheckError e -> build e---- | Parse textual representation of a Michelson value and turn it--- into corresponding Haskell value.------ Note: it won't work in some complex cases, e. g. if there is a--- lambda which uses an instruction which depends on current--- contract's type. Obviously it can not work, because we don't have--- any information about a contract to which this value belongs (there--- is no such contract at all).-parseLorentzValue ::-     forall v. (IsoValue v, SingI (ToT v), Typeable (ToT v))-  => Text-  -> Either ParseLorentzError v-parseLorentzValue =-  fmap fromVal . (toTyped <=< first ParseLorentzParseError . parseExpandValue)-  where-    toTyped :: U.Value -> Either ParseLorentzError (Value (ToT v))-    toTyped =-      first ParseLorentzTypecheckError .-      runTypeCheckIsolated .-      usingReaderT (def @InstrCallStack) .-      typeVerifyValue---- | Lorentz version of 'transformStrings'.-transformStringsLorentz ::-  Bool -> (MText -> MText) -> inp :-> out -> inp :-> out-transformStringsLorentz goToValues f =-  iMapAnyCode $ transformStrings goToValues f---- | Lorentz version of 'transformBytes'.-transformBytesLorentz ::-  Bool -> (ByteString -> ByteString) -> inp :-> out -> inp :-> out-transformBytesLorentz goToValues f =-  iMapAnyCode $ transformBytes goToValues f--optimizeLorentzWithConf-  :: OptimizerConf-  -> inp :-> out-  -> inp :-> out-optimizeLorentzWithConf conf =-  -- Optimizer can produce dead code.-  -- Example: @push True # if_ failWith nop # ...@ will fold to @failWith # ...@.-  -- But let's not care about this case for now until need in it fires.-  iMapAnyCode (optimizeWithConf conf)--optimizeLorentz-  :: inp :-> out-  -> inp :-> out-optimizeLorentz = optimizeLorentzWithConf def

@@ -1,196 +0,0 @@--- | Identity transformations between different Haskell types.-module Lorentz.Coercions-  ( -- * Safe coercions-    CanCastTo (..)-  , checkedCoerce-  , Coercible_-  , checkedCoerce_-  , checkedCoercing_-  , allowCheckedCoerceTo-  , allowCheckedCoerce-  , coerceUnwrap-  , coerceWrap-  , toNamed-  , fromNamed--    -- * Unsafe coercions-  , MichelsonCoercible-  , forcedCoerce-  , forcedCoerce_-  , gForcedCoerce_-  , fakeCoerce-  , fakeCoercing--    -- * Re-exports-  , Wrapped (..)-  ) where--import Control.Lens (Wrapped(..))-import qualified Data.Coerce as Coerce-import Data.Constraint (Dict(..), (\\))-import Data.Vinyl.Derived (Label)-import Named (NamedF)-import Unsafe.Coerce (unsafeCoerce)--import Lorentz.Base-import Lorentz.Instr-import Lorentz.Value-import Michelson.Typed--------------------------------------------------------------------------------- Unsafe coercions--------------------------------------------------------------------------------- | Coercion for Haskell world.------ We discourage using this function on Lorentz types, consider using 'coerce'--- instead.--- One of the reasons forthat is that in Lorentz it's common to declare types as--- newtypes consisting of existing primitives, and @forcedCoerce@ tends to ignore--- all phantom type variables of newtypes thus violating their invariants.-forcedCoerce :: Coerce.Coercible a b => a -> b-forcedCoerce = Coerce.coerce---- | Whether two types have the same Michelson representation.-type MichelsonCoercible a b = ToT a ~ ToT b---- | Convert between values of types that have the same representation.------ This function is not safe in a sense that this allows breaking invariants of--- casted type (example: @UStore@) or may stop compile on code changes (example:--- coercion of pair to a datatype with two fields will break if new field is--- added).--- Still, produced Michelson code will always be valid.------ Prefer using one of more specific functions from this module.-forcedCoerce_ :: MichelsonCoercible a b => a & s :-> b & s-forcedCoerce_ = I Nop--gForcedCoerce_ :: MichelsonCoercible (t a) (t b) => t a : s :-> t b : s-gForcedCoerce_ = forcedCoerce_---- | Convert between two stacks via failing.-fakeCoerce :: s1 :-> s2-fakeCoerce = unit # I FAILWITH--fakeCoercing :: (s1 :-> s2) -> s1' :-> s2'-fakeCoercing i = fakeCoerce # iForceNotFail i # fakeCoerce--------------------------------------------------------------------------------- Safe coercions--------------------------------------------------------------------------------- | 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-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-coerceUnwrap = forcedCoerce_---- | Lift given value to a named value.-toNamed :: Label name -> a : s :-> NamedF Identity a name : s-toNamed _ = coerceWrap---- | Unpack named value.-fromNamed :: Label name -> NamedF Identity a name : s :-> a : s-fromNamed _ = coerceUnwrap---- Arbitrary coercions--------------------------------------------------------------------------------- | Explicitly allowed coercions.-class a `CanCastTo` b where-  -- | An optional method which helps passing -Wredundant-constraints check.-  castDummy :: ()-  castDummy = ()---- | Coercion in Haskell world which respects 'CanCastTo'.-checkedCoerce :: forall a b. (CanCastTo a b, Coerce.Coercible a b) => a -> b-checkedCoerce = Coerce.coerce-  where _useCast = castDummy @a @b---- Incoherent instance are generally evil because arbitrary instance can be--- picked, but in our case this is exactly what we want: permit cast if--- /any/ instance matches.-instance {-# INCOHERENT #-} CanCastTo a a where-  castDummy = castDummy @a @a--instance CanCastTo a b => CanCastTo [a] [b] where-  castDummy = castDummy @a @b--instance (CanCastTo a1 a2, CanCastTo b1 b2) =>-         CanCastTo (a1, b1) (a2, b2) where-  castDummy = castDummy @a1 @a2 `seq` castDummy @b1 @b2--instance (CanCastTo i1 i2, CanCastTo o1 o2) =>-         CanCastTo (Lambda i1 o1) (Lambda i2 o2)-  -- That's magic, having default impl for 'castDummy' disables-  -- -Wredundant-constraints automatically--instance CanCastTo a b => CanCastTo (Maybe a) (Maybe b)---- | Coercion from @a@ to @b@ is permitted and safe.-type Castable_ a b = (MichelsonCoercible a b, CanCastTo a b)---- | Coercions between @a@ to @b@ are permitted and safe.-type Coercible_ a b = (MichelsonCoercible a b, CanCastTo a b, CanCastTo b a)---- | Coerce between types which have an explicit permission for that in the--- face of 'CanCastTo' constraint.-checkedCoerce_ :: forall a b s. (Castable_ a b) => a : s :-> b : s-checkedCoerce_ = forcedCoerce_---- | Pretends that the top item of the stack was coerced.-checkedCoercing_-  :: forall a b s. (Coercible_ a b)-  => (b ': s :-> b ': s) -> (a ': s :-> a ': s)-checkedCoercing_ f = checkedCoerce_ @a @b # f # checkedCoerce_ @b @a---- | Locally provide given 'CanCastTo' instance.-allowCheckedCoerceTo :: forall b a. Dict (CanCastTo a b)-allowCheckedCoerceTo =-  unsafeCoerce-    @(Dict $ CanCastTo () ())-    @(Dict $ CanCastTo a b)-    Dict---- | Locally provide bidirectional 'CanCastTo' instance.-allowCheckedCoerce :: forall a b. Dict (CanCastTo a b, CanCastTo b a)-allowCheckedCoerce =-  Dict \\ allowCheckedCoerceTo @a @b \\ allowCheckedCoerceTo @b @a--{- Note about potential use of 'Coercible'.--Alternative to 'CanCastTo' would be using 'Coercible' constraint.--Pros:-* Reflexivity, symmetry and transitivity properties hold automatically.-* Complex structures are handled automatically.--Cons:-* When declaring a datatype type, one should always care to set the corresponding-type role (in most cases it will nominal or representational). Newtypes are-even more difficult to control as they are always coercible if constructor is-in scope.-* Where are some cases where going with 'Coercible' does not work, e.g.-allow @MigrationScriptFrom oldStore@ to @MigrationScript oldStore newStore@.--Despite the mentioned cons, described 'coerce_' may be useful someday.---}--------------------------------------------------------------------------------- Coercions for some basic types-------------------------------------------------------------------------------instance TAddress p `CanCastTo` Address-instance Address `CanCastTo` TAddress p--instance FutureContract p `CanCastTo` EpAddress

@@ -1,17 +0,0 @@--- | Common primitives.-module Lorentz.Common-  ( Entrypoint-  , Entrypoint_-  ) where--import Lorentz.Base---- | Single entrypoint of a contract.------ Note that we cannot make it return @[[Operation], store]@ because--- such entrypoint should've been followed by @pair@, and this is not--- possible if entrypoint implementation ends with 'failWith'.-type Entrypoint param store = '[ param, store ] :-> ContractOut store---- | Version of 'Entrypoint' which accepts no argument.-type Entrypoint_ store = '[ store ] :-> ContractOut store

@@ -1,6 +0,0 @@-module Lorentz.Constraints-  ( module Exports-  ) where--import Lorentz.Constraints.Derivative as Exports-import Lorentz.Constraints.Scopes as Exports

@@ -1,12 +0,0 @@--- | Some derivative constraints.------ They are moved to separate module because they need to lie quite high in--- modules dependencies graph (unlike "Lorentz.Constraints.Scopes").-module Lorentz.Constraints.Derivative-  ( NiceParameterFull-  ) where--import Lorentz.EntryPoints.Core---- | Constraint applied to a whole parameter type.-type NiceParameterFull cp = (Typeable cp, ParameterDeclaresEntryPoints cp)

@@ -1,110 +0,0 @@-{-# LANGUAGE UndecidableSuperClasses #-}---- | Scope-related constraints used in Lorentz.------ This contains constraints from 'Michelson.Typed.Scope' modified for use--- in Lorentz.-module Lorentz.Constraints.Scopes-  ( -- * Grouped constraints-    NiceParameter-  , NiceStorage-  , NiceConstant-  , NicePackedValue-  , NiceUnpackedValue-  , NiceFullPackedValue-  , NicePrintedValue-  , NiceComparable--  , niceParameterEvi-  , niceStorageEvi-  , niceConstantEvi-  , nicePackedValueEvi-  , niceUnpackedValueEvi-  , nicePrintedValueEvi--    -- * Individual constraints (internals)-  , CanHaveBigMap-  , KnownValue-  , KnownCValue-  , NoOperation-  , NoContractType-  , NoBigMap--  , -- * Re-exports-    withDict-  ) where--import Data.Constraint (trans, weaken2)-import Data.Singletons (SingI)--import Michelson.Typed---- We write these constraints as class + instance, rather than--- type aliases, in order to allow their partial application.---- | Gathers constraints, commonly required for values.-class (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a-instance (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a--class (IsoValue a, Typeable (ToCT a), SingI (ToCT a)) => KnownCValue a-instance (IsoValue a, Typeable (ToCT a), SingI (ToCT a)) => KnownCValue a---- | Ensure given type does not contain "operation".-class (IsoValue a, ForbidOp (ToT a)) => NoOperation a-instance (IsoValue a, ForbidOp (ToT a)) => NoOperation a--class (IsoValue a, ForbidContract (ToT a)) => NoContractType a-instance (IsoValue a, ForbidContract (ToT a)) => NoContractType a--class (IsoValue a, ForbidBigMap (ToT a)) => NoBigMap a-instance (IsoValue a, ForbidBigMap (ToT a)) => NoBigMap a--class (IsoValue a, HasNoNestedBigMaps (ToT a)) => CanHaveBigMap a-instance (IsoValue a, HasNoNestedBigMaps (ToT a)) => CanHaveBigMap a---- | Constraint applied to any part of parameter type.------ Note that you don't usually apply this constraint to the whole parameter,--- consider using 'Lorentz.Constraints.Derivative.NiceParameterFull' in such case.------ Using this type is justified e.g. when calling another contract, there--- 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 NiceConstant a = (KnownValue a, ProperConstantBetterErrors (ToT a))--type NicePackedValue a = (KnownValue a, ProperPackedValBetterErrors (ToT a))--type NiceUnpackedValue a = (KnownValue a, ProperUnpackedValBetterErrors (ToT a))--type NiceFullPackedValue a = (NicePackedValue a, NiceUnpackedValue a)--type NicePrintedValue a = (KnownValue a, ProperPrintedValBetterErrors (ToT a))--type NiceComparable a = (KnownValue a, ProperComparabilityBetterErrors (ToT a))--niceParameterEvi :: forall a. NiceParameter a :- ParameterScope (ToT a)-niceParameterEvi =-  properParameterEvi @(ToT a) `trans` weaken2--niceStorageEvi :: forall a. NiceStorage a :- StorageScope (ToT a)-niceStorageEvi =-  properStorageEvi @(ToT a) `trans` weaken2--niceConstantEvi :: forall a. NiceConstant a :- ConstantScope (ToT a)-niceConstantEvi =-  properConstantEvi @(ToT a) `trans` weaken2--nicePackedValueEvi :: forall a. NicePackedValue a :- PackedValScope (ToT a)-nicePackedValueEvi =-  properPackedValEvi @(ToT a) `trans` weaken2--niceUnpackedValueEvi :: forall a. NiceUnpackedValue a :- UnpackedValScope (ToT a)-niceUnpackedValueEvi =-  properUnpackedValEvi @(ToT a) `trans` weaken2--nicePrintedValueEvi :: forall a. NicePrintedValue a :- PrintedValScope (ToT a)-nicePrintedValueEvi =-  properPrintedValEvi @(ToT a) `trans` weaken2

@@ -1,109 +0,0 @@--- | This module contains various datatypes and functions which are--- common for contract registry packages (e.g. morley-ledgers and morley-multisig).-module Lorentz.ContractRegistry-  ( ContractInfo (..)-  , ContractRegistry (..)-  , getContract-  , printContractFromRegistryDoc-  , (?::)-  -- Common CLI stuff-  , CmdLnArgs (..)-  , argParser-  ) where--import qualified Data.Map as Map-import qualified Data.Text.Lazy.IO as TL-import Fmt (Buildable(..), blockListF, nameF, (+|), (|+))-import qualified Options.Applicative as Opt--import Lorentz.Base-import Lorentz.Constraints-import Lorentz.Doc-import Util.IO--data ContractInfo =-  forall cp st.-    (NiceParameterFull cp, NiceStorage st) =>-  ContractInfo-  { ciContract :: Contract cp st-  , ciIsDocumented :: Bool-  }--(?::) :: Text -> a -> (Text, a)-(?::) = (,)--newtype ContractRegistry = ContractRegistry-  { unContractRegistry :: Map Text ContractInfo }--getContract :: Text -> ContractRegistry -> Either String ContractInfo-getContract name registry =-  case Map.lookup name (unContractRegistry registry) of-    Nothing ->-      Left $ "No contract with name '" +| name |+ "' found\n" +| registry |+ ""-    Just c -> Right c--instance Buildable ContractRegistry where-  build registry =-    nameF "Available contracts" (blockListF $ keys (unContractRegistry registry))--printContractFromRegistryDoc :: Text -> ContractRegistry -> Maybe FilePath -> IO ()-printContractFromRegistryDoc name contracts mOutput = do-  ContractInfo{..} <- either die pure $ getContract name contracts-  let writeFunc = case mOutput of-        Nothing -> TL.putStrLn-        Just "def" -> writeFileUtf8 $ toString name <> ".md"-        Just output -> writeFileUtf8 output-  if ciIsDocumented-  then writeFunc $ contractDocToMarkdown $ buildLorentzDoc ciContract-  else die "This contract is not documented"--data CmdLnArgs-  = List-  | Print Text (Maybe FilePath) Bool-  | Document Text (Maybe FilePath)--argParser :: Opt.Parser CmdLnArgs-argParser = Opt.subparser $ mconcat-  [ listSubCmd-  , printSubCmd-  , documentSubCmd-  ]-  where-    mkCommandParser commandName parser desc =-      Opt.command commandName $-      Opt.info (Opt.helper <*> parser) $-      Opt.progDesc desc--    listSubCmd =-      mkCommandParser "list"-      (pure List)-      "Show all available contracts"--    printSubCmd =-      mkCommandParser "print"-      (Print <$> printOptions <*> outputOptions <*> onelineOption)-      "Dump a contract in form of Michelson code"--    documentSubCmd =-      mkCommandParser "document"-      (Document <$> printOptions <*> outputOptions)-      "Dump contract documentation in Markdown"--    printOptions = Opt.strOption $ mconcat-      [ Opt.short 'n'-      , Opt.long "name"-      , Opt.metavar "IDENTIFIER"-      , Opt.help "Name of a contract returned by `list` command."-      ]--    outputOptions = optional . Opt.strOption $ mconcat-      [ Opt.short 'o'-      , Opt.long "output"-      , Opt.metavar "FILEPATH"-      , Opt.help "File to use as output. If not specified, stdout is used."-      ]--    onelineOption :: Opt.Parser Bool-    onelineOption = Opt.switch (-      Opt.long "oneline" <>-      Opt.help "Force single line output")

@@ -1,132 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}--module Lorentz.Doc-  ( doc-  , docGroup-  , buildLorentzDoc-  , renderLorentzDoc-  , contractName-  , cutLorentzNonDoc--    -- * Re-exports-  , Markdown-  , DocItem (..)-  , docItemPosition-  , DocItemId (..)-  , DocItemPlacementKind (..)-  , DocItemRef (..)-  , DocSectionNameStyle (..)-  , SomeDocItem (..)-  , SomeDocDefinitionItem (..)-  , SubDoc (..)-  , DocGrouping-  , ContractDoc (..)-  , DDescription (..)-  , DGitRevision (..)-  , GitRepoSettings (..)-  , mkDGitRevision-  , morleyRepoSettings-  , DComment (..)-  , DType (..)-  , docDefinitionRef-  , contractDocToMarkdown-  , subDocToMarkdown--  , TypeHasDoc (..)-  , SomeTypeWithDoc (..)--  , HaveCommonTypeCtor-  , IsHomomorphic-  , genericTypeDocDependencies-  , customTypeDocMdReference-  , homomorphicTypeDocMdReference-  , poly1TypeDocMdReference-  , poly2TypeDocMdReference-  , homomorphicTypeDocHaskellRep-  , concreteTypeDocHaskellRep-  , concreteTypeDocHaskellRepUnsafe-  , haskellRepNoFields-  , haskellRepStripFieldPrefix-  , homomorphicTypeDocMichelsonRep-  , concreteTypeDocMichelsonRep-  , concreteTypeDocMichelsonRepUnsafe-  ) where--import Data.Singletons (demote)--import Lorentz.Base-import Lorentz.Value-import Lorentz.Zip ()-import Michelson.Doc-import Michelson.Optimizer-import Michelson.Typed-import Util.Markdown-import Util.Type---- | Put a document item.-doc :: DocItem di => di -> s :-> s-doc = I . Ext . DOC_ITEM . SomeDocItem---- | Group documentation built in the given piece of code--- into block dedicated to one thing, e.g. to one entrypoint.-docGroup :: DocGrouping -> (inp :-> out) -> (inp :-> out)-docGroup gr = iMapAnyCode (DocGroup gr)---- | Give a name to given contract. Apply it to the whole contract code.-contractName :: Text -> (inp :-> out) -> (inp :-> out)-contractName name = docGroup (SomeDocItem . DName name)--buildLorentzDoc :: inp :-> out -> ContractDoc-buildLorentzDoc (iAnyCode -> code) = buildInstrDoc code--renderLorentzDoc :: inp :-> out -> LText-renderLorentzDoc = contractDocToMarkdown . buildLorentzDoc---- | Leave only instructions related to documentation.------ This function is useful when your method executes a lambda coming from outside,--- but you know its properties and want to propagate its documentation to your--- contract code.-cutLorentzNonDoc :: (inp :-> out) -> (s :-> s)-cutLorentzNonDoc (iAnyCode -> code) = I $ cutInstrNonDoc optimize code--instance Each [Typeable, ReifyList TypeHasDoc] [i, o] =>-         TypeHasDoc (i :-> o) where-  typeDocName _ = "Code (extended lambda)"-  typeDocMdReference tp wp =-    let DocItemRef (DocItemId ctorDocItemId) = docItemRef (DType tp)-        refToThis = mdLocalRef (mdTicked "Code") ctorDocItemId-    in applyWithinParens wp $-      mconcat $ intersperse " " [refToThis, refToStack @i, refToStack @o]-    where-    refToStack :: forall s. ReifyList TypeHasDoc s => Markdown-    refToStack =-      let stack = reifyList @_ @TypeHasDoc @s (\p -> typeDocMdReference p (WithinParens False))-      in mconcat-          [ mdBold "["-          , case stack of-              [] -> " "-              st -> mconcat $ intersperse (mdBold "," <> " ") st-          , mdBold "]"-          ]--  typeDocMdDescription =-    "`Code i o` stands for a sequence of instructions which accepts stack \-    \of type `i` and returns stack of type `o`.\n\n\-    \When both `i` and `o` are of length 1, this primitive corresponds to \-    \the Michelson lambda. In more complex cases code is surrounded with `pair`\-    \and `unpair` instructions until fits into mentioned restriction.\-    \"-  typeDocDependencies _ = mconcat-    [ reifyList @_ @TypeHasDoc @i SomeTypeWithDoc-    , reifyList @_ @TypeHasDoc @o SomeTypeWithDoc-    , [ SomeTypeWithDoc (Proxy @Integer)-      , SomeTypeWithDoc (Proxy @Natural)-      , SomeTypeWithDoc (Proxy @MText)-      ]-    ]-  typeDocHaskellRep _ = Nothing-  typeDocMichelsonRep _ =-    ( Just "Code [Integer, Natural, MText, ()] [ByteString]"-    , demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString]))-    )

@@ -1,51 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}---- | Support for uninhabited type.------ Currently they are not supported my Michelson, so we provide--- a sort of replacement.------ This module should be removed once the proposal is implemented:--- https://gitlab.com/tezos/tezos/issues/662-module Lorentz.Empty-  ( Empty-  , absurd_-  ) where--import Fmt (Buildable(..))--import Lorentz.Base-import Lorentz.Doc-import Lorentz.Errors-import Lorentz.Value-import Michelson.Typed.Haskell.Doc---- | Replacement for uninhabited type.-newtype Empty = Empty ()-  deriving stock Generic-  deriving anyclass IsoValue--instance TypeHasDoc Empty where-  typeDocMdDescription =-    "Type which should never be constructed.\n\n\-    \If appears as part of entrypoint argument, this means that the entrypoint \-    \should never be called."---- | Someone constructed 'Empty' type.-type instance ErrorArg "emptySupplied" = ()--instance Buildable (CustomError "emptySupplied") where-  build (CustomError _ ()) =-    "'Empty' value was passed to the contract."--instance CustomErrorHasDoc "emptySupplied" where-  customErrClass = ErrClassBadArgument-  customErrDocMdCause =-    "Value of type " <> typeDocMdReference (Proxy @Empty) (WithinParens False)-    <> " has been supplied."---- | Witness of that this code is unreachable.-absurd_ :: Empty : s :-> s'-absurd_ =-  failCustom_ #emptySupplied #-  doc (DDescription "Should never be called")

@@ -1,46 +0,0 @@-{-# LANGUAGE UndecidableSuperClasses #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Entrypoints utilities for Lorentz-module Lorentz.EntryPoints-  ( -- * Typeclasses-    EntryPointsDerivation (..)-  , ParameterHasEntryPoints (..)-  , ParameterDeclaresEntryPoints--    -- * Entrypoints API-  , AllParameterEntryPoints-  , LookupParameterEntryPoint-  , parameterEntryPointsToNotes-  , flattenEntryPoints-  , GetEntryPointArg-  , parameterEntryPointCall-  , GetDefaultEntryPointArg-  , parameterEntryPointCallDefault-  , ForbidExplicitDefaultEntryPoint-  , NoExplicitDefaultEntryPoint-  , sepcCallRootChecked-  , EntryPointRef (..)-  , eprName-  , GetEntryPointArgCustom-  , HasEntryPointArg (..)-  , HasDefEntryPointArg-  , 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,440 +0,0 @@-{-# LANGUAGE UndecidableSuperClasses #-}---- | Primitives supplying entrypoints declarations and lookup.-module Lorentz.EntryPoints.Core-  ( CanHaveEntryPoints-  , EntryPointsDerivation (..)-  , EpConstructionRes (..)-  , RequireAllUniqueEntryPoints-  , ParameterHasEntryPoints (..)-  , ParameterDeclaresEntryPoints-  , GetParameterEpDerivation-  , pepNotes-  , pepCall-  , AllParameterEntryPoints-  , LookupParameterEntryPoint-  , parameterEntryPointsToNotes-  , GetEntryPointArg-  , parameterEntryPointCall-  , GetDefaultEntryPointArg-  , parameterEntryPointCallDefault-  , flattenEntryPoints-  , ForbidExplicitDefaultEntryPoint-  , NoExplicitDefaultEntryPoint-  , sepcCallRootChecked-  , EntryPointRef (..)-  , NiceEntryPointName-  , eprName-  , GetEntryPointArgCustom-  , TrustEpName (..)-  , HasEntryPointArg (..)-  , HasDefEntryPointArg-  , parameterEntryPointCallCustom-  , EpdNone--    -- * Internals-  , RequireAllUniqueEntryPoints'-  ) where--import Data.Constraint (Dict(..), (\\))-import qualified Data.Kind as Kind-import Data.Map (Map, insert)-import Data.Singletons (SingI, sing)-import Data.Typeable (typeRep)-import Data.Vinyl.Derived (Label)-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.Type-import Util.TypeLits--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.-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.-  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-    :: (KnownSymbol name, ParameterScope (ToT cp))-    => Label name-    -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))--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---- | 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 deriv.-     ( ParameterDeclaresEntryPoints cp, ParameterScope (ToT cp)-     , KnownSymbol name, deriv ~ GetParameterEpDerivation cp-     )-  => Label name-  -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))-pepCall = epdCall @(GetParameterEpDerivation cp) @cp---- 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.-     (Typeable cp, ParameterDeclaresEntryPoints cp)-  => ParamNotes (ToT cp)-parameterEntryPointsToNotes =-  let notes = pepNotes @cp-  in case mkParamNotes notes 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-     , KnownSymbol name-     )-  => Label name-  -> EntryPointCall cp (GetEntryPointArg cp name)-parameterEntryPointCall label =-  withDict (niceParameterEvi @cp) $-  case pepCall @cp label of-    EpConstructed liftSeq -> EntryPointCall-      { epcName = epNameFromParamAnn (ctorNameToAnn @name)-               ?: error "Empty constructor-entrypoint 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)---- | Flatten a provided list of notes to a map of its entrypoints--- and its corresponding utype.------ It is obtained by constructing `insert k1 v1 (insert k2 v2 ... mempty)`--- pipe using `Endo` so that it is more concise rather than stacking composition--- of monoidal endomorphisms explicitly. Note that here no duplicates can appear--- in returned map for `ParamNotes` even if they may appear inside passed `Notes` tree.-flattenEntryPoints :: SingI t => ParamNotes t -> Map EpName U.Type-flattenEntryPoints (unParamNotes -> notes) = appEndo (gatherEPs (sing, notes)) mempty-  where-    gatherEPs-      :: forall n.-         (Sing n, Notes n)-      -> Endo (Map EpName U.Type)-    gatherEPs = \case-      (STOr ls rs, NTOr _ fn1 fn2 ln rn) -> mconcat-        [ Endo . maybe id (uncurry insert) . psi ln $ epNameFromParamAnn fn1-        , Endo . maybe id (uncurry insert) . psi rn $ epNameFromParamAnn fn2-        , gatherEPs (ls, ln)-        , gatherEPs (rs, rn)-        ]-      _ -> mempty--    psi-      :: forall n.-         SingI n-      => Notes n-      -> Maybe EpName-      -> Maybe (EpName, U.Type)-    psi n x = tensor x $ mkUType sing n--    -- Tensorial strength criteria-    tensor :: Functor f => f a -> b -> f (a,b)-    tensor fa b = fmap (,b) fa---- | 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--------------------------------------------------------------------------------- Trivial implementation--------------------------------------------------------------------------------- | No entrypoints declared, parameter type will serve as argument type--- of the only existing entrypoint (default one).-data EpdNone-instance SingI (ToT cp) => EntryPointsDerivation EpdNone cp where-  type EpdAllEntryPoints EpdNone cp = '[]-  type EpdLookupEntryPoint EpdNone cp = Fcf.ConstFn 'Nothing-  epdNotes = starNotes-  epdCall _ = EpConstructionFailed

@@ -1,355 +0,0 @@--- | Utilities for declaring and documenting entry points.-module Lorentz.EntryPoints.Doc-  ( DEntryPoint (..)-  , EntryArrow (..)-  , PlainEntryPointsKind-  , diEntryPointToMarkdown-  , DEntryPointArg (..)-  , DType (..)-  , DeriveCtorFieldDoc (..)-  , ParamBuildingStep (..)-  , clarifyParamBuildingSteps-  , constructDEpArg-  , emptyDEpArg-  , mkUType-  , mkDEpUType-  , mkDEntryPointArgSimple-  , DocumentEntryPoints-  , documentEntryPoint-  , entryCase-  , entryCase_-  ) where--import Control.Lens.Cons (_head)-import Data.Char (toLower)-import qualified Data.Kind as Kind-import Data.Singletons (sing)-import Data.Vinyl.Core (RMap, Rec(..), rappend)-import Data.Vinyl.Derived (Label)-import Fmt (build)-import GHC.Generics ((:+:))-import qualified GHC.Generics as G-import GHC.TypeLits (AppendSymbol, KnownSymbol, symbolVal)--import Lorentz.ADT-import Lorentz.Base-import Lorentz.Constraints.Scopes-import Lorentz.Doc-import Lorentz.TypeAnns-import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)-import Michelson.Typed (mkUType)-import Michelson.Typed.Doc-import Michelson.Typed.Haskell.Doc-import Michelson.Typed.Haskell.Instr-import qualified Michelson.Untyped as Untyped-import Util.Markdown-import Util.Type-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---- | During incremental assembly of parameter building steps ---- current representation of parameter.-type CurrentParam = Markdown---- | Describes a parameter building step.------ This can be wrapping into (Haskell) constructor, or a more complex--- transformation.-data ParamBuildingStep = ParamBuildingStep-  { pbsEnglish :: Markdown-    -- ^ Plain english description of this step.-  , pbsHaskell :: CurrentParam -> Markdown-    -- ^ How to construct parameter in Haskell code.-  , pbsMichelson :: CurrentParam -> Markdown-    -- ^ How to construct parameter working on raw Michelson.-  }---- | Describes argument of an entrypoint.-data DEntryPointArg =-  DEntryPointArg-  { epaArg :: Maybe DType-    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.-  , epaHasAnnotation :: Bool-    -- ^ Whether this entrypoint has a field annotation (and thus is-    -- callable using the standard "lightweigth entrypoints"-    -- mechanism) or is a virtual entrypoint which requires-    -- constructing a value of the full parameter type.-  , 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 in which they are given.-    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;-    -- then the first step should describe wrapping into @Service1@ constructor,-    -- and the second step should be about wrapping into @Run@ constructor.-  , epaType :: Untyped.Type-    -- ^ Untyped representation of entrypoint, used for printing its michelson-    -- type representation.-  }--constructDEpArg-  :: forall arg.-     ( TypeHasDoc arg-     , HasTypeAnn arg-     , KnownValue arg-     )-  => Bool -> DEntryPointArg-constructDEpArg epaHasAnnotation = DEntryPointArg-  { epaArg = Just $ DType (Proxy @arg)-  , epaHasAnnotation = epaHasAnnotation-  , epaBuilding = []-  , epaType = mkDEpUType @arg-  }--emptyDEpArg :: Bool -> DEntryPointArg-emptyDEpArg epaHasAnnotation = DEntryPointArg-  { epaArg = Nothing-  , epaHasAnnotation = epaHasAnnotation-  , epaBuilding = []-  , epaType = Untyped.Type Untyped.TUnit Untyped.noAnn-  }--mkDEpUType :: forall t. (KnownValue t, HasTypeAnn t) => Untyped.Type-mkDEpUType = mkUType sing (getTypeAnn @t)--mkDEntryPointArgSimple-  :: forall t.-     ( KnownValue t-     , HasTypeAnn t-     , TypeHasDoc t-     )-  => DEntryPointArg-mkDEntryPointArgSimple = DEntryPointArg-  { epaArg = Just $ DType (Proxy @t)-  , epaHasAnnotation = False-  , epaBuilding = []-  , epaType = mkDEpUType @t-  }---- | 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 =-  iMapAnyCode $-  modifyInstrDoc (\di -> di{ epaBuilding = epaBuilding di ++ [pbs] })--instance DocItem DEntryPointArg where-  type DocItemPosition DEntryPointArg = 20-  docItemSectionName = Nothing-  docItemDependencies (DEntryPointArg mdty _ _ _) =-    [SomeDocDefinitionItem dty | Just dty <- pure mdty]-  docItemToMarkdown _ (DEntryPointArg mdty hasAnnotation 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" <>-            mconcat howToCall-      ]-    where-      howToCall-        | hasAnnotation = howToCallAnnotatedEntrypoint-        | otherwise = howToCallVirtualEntrypoint--      -- TODO: currently we always set @hasAnnotation@ to @True@,-      -- hence this case in unreachable.  It is still useful, we-      -- should set @hasAnnotation@ properly and improve handling of-      -- this case.  Specifically, for virtual entrypoints we should-      -- wrap them into constructors until we reach one having a field-      -- annotation. As soon as it is reached, we can call the-      -- contract by an entrypoint name.-      howToCallVirtualEntrypoint =-        [ mconcat . Prelude.intersperse "\n" $-            psteps <&> \ParamBuildingStep{..} ->-              mconcat . Prelude.intersperse "\n" $-              [ -- Markdown re-enumerates enumerated lists automatically-                "1. " <> pbsEnglish-              , "  + " <>-                mdSubsection "In Haskell" (mdTicked $ pbsHaskell "·")-              , "  + " <>-                mdSubsection "In Michelson" (mdTicked $ pbsMichelson "·")-              ]-        , "\n\nPass resulting value as parameter to the contract.\n"-        ]--      howToCallAnnotatedEntrypoint =-        [ "1. Make a transfer to the contract passing this entrypoint's name " <>-          "and the constructed value as an argument."-        ]---- | 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 True--instance-    (TypeHasDoc ty, HasTypeAnn ty, KnownValue ty, KnownSymbol con)-  =>-    DeriveCtorFieldDoc con ('OneField ty)-  where-  deriveCtorFieldDoc = constructDEpArg @ty True---- | 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) 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-    :: (Markdown -> Markdown)-    -> 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 michDesc clauses =-    let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses-    in gDocumentEntryPoints @kind @x-         (\a -> michDesc $ "Left (" <> a <> ")")-         lclauses-       `rappend`-       gDocumentEntryPoints @kind @y-         (\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 = ParamBuildingStep-          { pbsEnglish = "Wrap into " <> mdTicked (build entryPointName) <> " constructor."-          , pbsHaskell = \p -> build entryPointName <> " (" <> p <> ")"-          , pbsMichelson = 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 parameter.------ 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 inp out-     , 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 True) # 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

@@ -1,46 +0,0 @@-module Lorentz.EntryPoints.Helpers-  ( ctorNameToAnn-  , CanHaveEntryPoints-  , ShouldHaveEntryPoints (..)-  , RequireSumType-  ) where--import qualified Data.Kind as Kind--import Michelson.Typed.Haskell-import Michelson.Typed.T-import Michelson.Untyped (FieldAnn, ann)-import Util.Text-import Util.Type-import Util.TypeLits--ctorNameToAnn :: forall ctor. (KnownSymbol ctor, HasCallStack) => FieldAnn-ctorNameToAnn = ann . headToLower $ (symbolValT' @ctor)---- | 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 IsoValue---- | 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"))

@@ -1,306 +0,0 @@--- | Common implementations of entrypoints.-module Lorentz.EntryPoints.Impl-  ( EpdPlain-  , EpdRecursive-  , EpdDelegate-  ) where--import qualified Data.Kind as Kind-import Data.Singletons (SingI (..))-import Data.Singletons.Prelude (Sing (STrue, SFalse))-import Data.Singletons.Prelude.Eq ((%==))-import Data.Type.Bool (If)-import qualified GHC.Generics as G-import Util.TypeLits-import Fcf (Exp, Eval)-import qualified Fcf--import Michelson.Typed-import Michelson.Typed.Haskell.Instr.Sum (IsPrimitiveValue)-import Michelson.Typed.Haskell.Value (GValueType, GenericIsoValue)-import Michelson.Untyped (FieldAnn, noAnn)-import Lorentz.Value-import Util.Type-import Util.Fcf (Over2, type (<|>), TyEqSing)--import Lorentz.EntryPoints.Helpers-import Lorentz.EntryPoints.Core-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---- | 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---- | 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--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), KnownSymbol name)-  => Label name-  -> EpConstructionRes (ToT cp) (Eval (LookupEntryPoint mode (BuildEPTree mode cp) cp name))-plainEpdCallExt = mkEpLiftSequence @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, KnownSymbol name-      )-  => Label name-  -> EpConstructionRes (ToT a) (Eval (LookupEntryPoint mode ep a name))-mkEpLiftSequence = gMkEpLiftSequence @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-    :: (KnownSymbol name, ParameterScope (GValueType x))-    => Label name-    -> EpConstructionRes (GValueType x) (Eval (GLookupEntryPoint mode ep x name))--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--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--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 name) =-    case sing @ctor %== sing @name of-      STrue -> EpConstructed EplArgHere-      SFalse -> EpConstructionFailed--instance (ep ~ 'EPNode epx epy, GEntryPointsNotes mode ep x) =>-         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--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 name) =-    case sing @ctor %== sing @name of-      STrue -> EpConstructed EplArgHere-      SFalse -> gMkEpLiftSequence @mode @ep @x label--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--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--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--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--instance Each [Typeable, SingI] [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---- 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.Flip Fcf.Guarded-      '[ TyEqSing a 'Fcf.:= Fcf.Pure ('Just b)-       , Fcf.Otherwise 'Fcf.:= Fcf.Pure '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 = ()

@@ -1,38 +0,0 @@--- | 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--instance ( NiceParameter cp-         , EntryPointsDerivation epd cp-         , RequireAllUniqueEntryPoints' epd cp-         ) =>-         ParameterHasEntryPoints (ParameterWrapper epd cp) where-  type ParameterEntryPointsDerivation (ParameterWrapper epd cp) = PwDeriv epd

@@ -1,682 +0,0 @@-{-# LANGUAGE TypeFamilyDependencies #-}---- We want to make sure 'failUsingArg' is used with sane argument.-{-# OPTIONS_GHC -Wno-redundant-constraints #-}--module Lorentz.Errors-  ( -- * Haskell to 'Value' conversion-    IsError (..)-  , isoErrorToVal-  , isoErrorFromVal-  , ErrorHasDoc (..)-  , typeDocMdDescriptionReferToError--  , UnspecifiedError (..)--    -- * General instructions-  , failUsing-  , failUnexpected--    -- * Custom errors-  , ErrorArg-  , CustomError (..)-  , failCustom-  , RequireNoArgError-  , failCustom_--    -- * Documentation-  , ErrorClass (..)-  , CustomErrorHasDoc (..)-  , DError (..)-  , DThrows (..)--    -- * Old interface (DEPRECATED)-  , customErrorToVal-  , customErrorFromVal-  , failUsingArg-  , FailUsingArg-  , CustomErrorNoIsoValue-  , deriveCustomError--  , errorsDocumentation-  ) where--import qualified Data.Char as C-import Data.Constraint (Dict(..))-import qualified Data.Kind as Kind-import qualified Data.List as L-import Data.Singletons (SingI(..), demote)-import Data.Type.Equality (type (==))-import Data.Typeable (cast)-import Data.Vinyl.Derived (Label)-import Fmt (Buildable, build, fmt, pretty, (+|), (+||), (|+), (||+))-import GHC.TypeLits (ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal)-import qualified Language.Haskell.TH as TH-import qualified Text.Show--import Lorentz.Base-import Lorentz.Doc-import Lorentz.Instr hiding (cast)-import Lorentz.Value-import Michelson.Text-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-import Util.TypeLits--------------------------------------------------------------------------------- IsError-------------------------------------------------------------------------------type ErrorScope t =-  -- We can require a weaker constraint (e.g. no 'HasNoOp'), but-  -- for now it's the simplest way to make 'failUsing' work-  ( Typeable t-  , ConstantScope t-  )--type KnownError a = ErrorScope (ToT a)---- | Haskell type representing error.-class (Typeable e, ErrorHasDoc e) => IsError e where--  -- | Converts a Haskell error into @Value@ representation.-  errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r--  -- | Converts a @Value@ into Haskell error.-  errorFromVal :: (Typeable t, SingI t) => Value t -> Either Text e---- | Implementation of 'errorToVal' via 'IsoValue'.-isoErrorToVal-  :: (KnownError e, IsoValue e)-  => e -> (forall t. ErrorScope t => Value t -> r) -> r-isoErrorToVal e cont = cont $ toVal e---- | Implementation of 'errorFromVal' via 'IsoValue'.-isoErrorFromVal-  :: (Typeable t, Typeable (ToT e), IsoValue e)-  => Value t -> Either Text e-isoErrorFromVal e = fromVal <$> gcastE e--class ErrorHasDoc e where-  -- | Name of error as it appears in the corresponding section title.-  errorDocName :: Text--  -- | What should happen for this error to be raised.-  errorDocMdCause :: Markdown--  -- | Brief version of 'errorDocMdCause'.-  ---  -- This will appear along with the error when mentioned in entrypoint description.-  -- By default, the first sentence of the full description is used.-  errorDocMdCauseInEntrypoint :: Markdown-  errorDocMdCauseInEntrypoint = pickFirstSentence $ errorDocMdCause @e--  -- | How this error is represented in Haskell.-  errorDocHaskellRep :: Markdown--  -- | Error class.-  errorDocClass :: ErrorClass-  errorDocClass = ErrClassUnknown--  -- | Which definitions documentation for this error mentions.-  errorDocDependencies :: [SomeDocDefinitionItem]---- | Helper for managing descriptions.-pickFirstSentence :: Markdown -> Markdown-pickFirstSentence = build . toText . go . fmt-  where-    go :: String -> String-    go = \case-      '.' : c : _ | C.isSpace c -> "."-      c : s -> c : go s-      "" -> ""---- Instances--------------------------------------------------------------------------------- | Use this for internal errors only.------ "Normal" error scenarios should use the mechanism of custom errors, see below.-instance IsError MText where-  errorToVal = isoErrorToVal-  errorFromVal = isoErrorFromVal--instance ErrorHasDoc MText where-  errorDocName = "InternalError"-  errorDocMdCause =-    "Internal error occured."-  errorDocHaskellRep =-    "Textual error message, see " <>-    typeDocMdReference (Proxy @MText) (WithinParens False) <> "."-  errorDocClass = ErrClassContractInternal-  errorDocDependencies = [SomeDocDefinitionItem (DType $ Proxy @MText)]--instance TypeError ('Text "Use representative error messages") => IsError () where-  errorToVal _ _ = error "impossible"-  errorFromVal = error "impossible"--instance TypeError ('Text "Use representative error messages") => ErrorHasDoc () where-  errorDocName = error "impossible"-  errorDocMdCause = error "impossible"-  errorDocHaskellRep = error "impossible"-  errorDocDependencies = error "impossible"---- | Use this type as replacement for @()@ when you __really__ want to leave--- error cause unspecified.-data UnspecifiedError = UnspecifiedError-  deriving stock Generic-  deriving anyclass IsoValue--instance IsError UnspecifiedError where-  errorToVal = isoErrorToVal-  errorFromVal = isoErrorFromVal--instance ErrorHasDoc UnspecifiedError where-  errorDocName = "Unspecified error"-  errorDocMdCause = "Some error occured."-  errorDocHaskellRep = typeDocMdReference (Proxy @()) (WithinParens False) <> "."-  errorDocDependencies = typeDocDependencies' (Proxy @())--------------------------------------------------------------------------------- General instructions--------------------------------------------------------------------------------- | Fail with the given Haskell value.-failUsing-  :: forall e s t.-     (IsError e)-  => e -> s :-> t-failUsing err =-  errorToVal err $ \eval ->-    doc (DThrows (Proxy @e)) #-    (FI $ PUSH eval `Seq` FAILWITH)---- | Fail, providing a reference to the place in the code where--- this function is called.------ Like 'error' in Haskell code, this instruction is for internal errors only.-failUnexpected :: MText -> s :-> t-failUnexpected msg = failUsing $ [mt|Internal: |] <> msg--------------------------------------------------------------------------------- Custom errors-------------------------------------------------------------------------------{- | Declares a custom error, defining @error name - error argument@ relation.--If your error is supposed to carry no argument, then provide @()@.--Note that this relation is defined globally rather than on per-contract basis,-so define errors accordingly. If your error has argument specific to your-contract, call it such that error name reflects its belonging to this contract.--}--{- About global registry of errors:--Pros: this allows defining pieces of code which can be reused among the contracts.--Cons: possible name collisions. Example of worst case: two libraries define-different errors for the same tag, attempt to use both of these libraries would-cause compile-time error. But such infrastructure will barely take place in-practice.--}-{- For future work:--* Assosiating unique numeric error codes to tags, and put codes into-the contract instead of tags. This allows getting rid of overhead related to-often long tag literals.--* Allow using arbitrary type instead of tag (and 'KnownSymbol' constraint will-be replaced with a more generic one).-Some users may prefer using datatypes as tags rather than type-level strings as tags-because-  * there will be no orphan instances then-  * no problem with name collisions-  * compiler will prompt a hint in case of typo in tag name-  * in some cases autocomplete handles declarations in code better than strings-(and cons here is that each such tag will need to be declared first).---}-type family ErrorArg (tag :: Symbol) :: Kind.Type---- | Material custom error.------ Use this in pattern matches against error (e.g. in tests).-data CustomError (tag :: Symbol) = CustomError-  { ceTag :: Label tag-  , ceArg :: ErrorArg tag-  }--deriving stock instance Eq (ErrorArg tag) => Eq (CustomError tag)-deriving stock instance Show (ErrorArg tag) => Show (CustomError tag)---- | How 'CustomError' is actually represented in Michelson.-type CustomErrorRep tag = (MText, ErrorArg tag)---- | This instance cannot be implemented, use 'IsError' instance instead.-instance TypeError ('Text "CustomError has no IsoValue instance") =>-         IsoValue (CustomError tag) where-  type ToT (CustomError tag) = TypeError ('Text "CustomError has no IsoValue instance")-  toVal = error "impossible"-  fromVal = error "impossible"--instance (CustomErrorHasDoc tag, KnownError (ErrorArg tag), IsoValue (ErrorArg tag)) =>-         IsError (CustomError tag) where-  errorToVal (CustomError l arg) cont =-    cont $ toVal @(CustomErrorRep tag) (errorTagToMText l, arg)-  errorFromVal (v :: Value t) =-    let expectedTag = errorTagToMText (fromLabel @tag)-    in case cast v of-        Just v' ->-          let (tag, arg) = fromVal @(CustomErrorRep tag) v'-          in if tag == expectedTag-             then Right $ CustomError fromLabel arg-             else Left $ "Bad tag, expected " +| expectedTag |+ ", got " +| tag |+ ""-        Nothing -> Left $ "Wrong type for custom error: " <> pretty (demote @t)--instance (CustomErrorHasDoc tag, SingI (ToT (ErrorArg tag))) =>-         ErrorHasDoc (CustomError tag) where-  errorDocName = errorTagToText @tag-  errorDocDependencies = [SomeDocDefinitionItem $ DType $ Proxy @(ErrorArg tag)]-  errorDocMdCause = customErrDocMdCause @tag-  errorDocMdCauseInEntrypoint = customErrDocMdCauseInEntrypoint @tag-  errorDocClass = customErrClass @tag-  errorDocHaskellRep =-    let hasArg = demote @(ToT (ErrorArg tag)) /= TUnit-        name = build $ errorTagToText @tag-    in mconcat $ catMaybes-      [ Just $-          ( if hasArg-            then mdTicked ("(\"" <> name <> "\", " <> "<error argument>" <> ")")-            else mdTicked ("(\"" <> name <> "\", ())")-          ) <> "."-      , guard hasArg $>-          ("\n\nProvided error argument will be of type "-          <> typeDocMdReference (Proxy @(ErrorArg tag)) (WithinParens False)-          <> (maybe "" (\txt -> " and stand for " <> txt) (customErrArgumentSemantics @tag))-          <> "."-          )-      ]---- | Demote error tag to term level.-errorTagToMText :: KnownSymbol tag => Label tag -> MText-errorTagToMText l =-  -- Now tags come not from constructor names, but from labels,-  -- we have to lead the first letter to upper case to preserve-  -- compatibility with FA1.2 interface.-  mtextHeadToUpper $-    labelToMText l--errorTagToText :: forall tag. KnownSymbol tag => Text-errorTagToText = toText $ errorTagToMText (fromLabel @tag)---- | Fail with given custom error.-failCustom-  :: forall tag err s any.-     ( err ~ ErrorArg tag-     , CustomErrorHasDoc tag-     , KnownError err-     )-  => Label tag -> err : s :-> any-failCustom l =-  doc (DThrows (Proxy @(CustomError tag))) #-  push (errorTagToMText l) # pair @MText @err #-  FI (FAILWITH @(ToT (CustomErrorRep tag)))--type RequireNoArgError tag msg =-  ( TypeErrorUnless (ErrorArg tag == ()) msg-  , msg ~-    ('Text "Expected no-arg error, but given error requires argument of type "-      ':<>: 'ShowType (ErrorArg tag)-    )-  )---- | Specialization of 'failCustom' for no-arg errors.-failCustom_-  :: forall tag s any notVoidErrorMsg.-     ( RequireNoArgError tag notVoidErrorMsg-     , CustomErrorHasDoc tag-     )-  => Label tag -> s :-> any-failCustom_ l =-  inTypeErrorUnless @(ErrorArg tag == ()) @notVoidErrorMsg $-  reifyTypeEquality @(ErrorArg tag) @() $-    unit # failCustom l---- Special treatment of no-arg errors-------------------------------------------------------------------------------instance Eq (ErrorArg tag) => Eq (() -> CustomError tag) where-  e1 == e2 = e1 () == e2 ()-instance Show (ErrorArg tag) => Show (() -> CustomError tag) where-  show e = show (e ())---- | If 'CustomError' constructor is not provided its argument, we assume--- that this is no-arg error and interpret the passed value as complete.-instance ( Typeable arg-         , IsError (CustomError tag)-         , TypeErrorUnless (arg == ()) notVoidError-         , arg ~ ErrorArg tag-         , notVoidError ~-            ('Text "This error requires argument of type "-              ':<>: 'ShowType (ErrorArg tag)-            )-         ) =>-         IsError (arg -> CustomError tag) where-  errorToVal mkCustomError cont =-    inTypeErrorUnless @(arg == ()) @notVoidError $-    reifyTypeEquality @arg @() $-      errorToVal (mkCustomError ()) cont-  errorFromVal v =-    inTypeErrorUnless @(arg == ()) @notVoidError $-    reifyTypeEquality @arg @() $-      errorFromVal v <&> \(CustomError l ()) -> CustomError l--instance ErrorHasDoc (CustomError tag) => ErrorHasDoc (arg -> CustomError tag) where-  errorDocName = errorDocName @(CustomError tag)-  errorDocMdCauseInEntrypoint = errorDocMdCauseInEntrypoint @(CustomError tag)-  errorDocMdCause = errorDocMdCause @(CustomError tag)-  errorDocHaskellRep = errorDocHaskellRep @(CustomError tag)-  errorDocDependencies = errorDocDependencies @(CustomError tag)--------------------------------------------------------------------------------- Errors documentation injection into contracts--------------------------------------------------------------------------------- | Error class on how the error should be handled by the client.-data ErrorClass-  = ErrClassActionException-    -- ^ Normal expected error.-    -- Examples: "insufficient balance", "wallet does not exist".-  | ErrClassBadArgument-    -- ^ Invalid argument passed to entrypoint.-    -- Examples: your entrypoint accepts an enum represented as @nat@, and-    -- unknown value is provided.-    -- This includes more complex cases which involve multiple entrypoints.-    -- E.g. API provides iterator interface, middleware should care about using it-    -- hiding complex details and exposing a simpler API to user; then an attempt to-    -- request non-existing element would also correspond to an error from this class.-  | ErrClassContractInternal-    -- ^ Unexpected error. Most likely it means that there is a bug in-    -- the contract or the contract has been deployed incorrectly.-  | ErrClassUnknown-    -- ^ It's possible to leave error class unspecified.--instance Buildable ErrorClass where-  build = \case-    ErrClassActionException -> "Action exception"-    ErrClassBadArgument -> "Bad argument"-    ErrClassContractInternal -> "Internal"-    ErrClassUnknown -> "-"--isInternalErrorClass :: ErrorClass -> Bool-isInternalErrorClass = \case-  ErrClassActionException -> False-  ErrClassBadArgument -> False-  ErrClassContractInternal -> True-  ErrClassUnknown -> False--class (KnownSymbol tag, TypeHasDoc (ErrorArg tag), IsError (CustomError tag)) =>-      CustomErrorHasDoc tag where-  -- | What should happen for this error to be raised.-  customErrDocMdCause :: Markdown--  -- | Brief version of 'customErrDocMdCause'.-  -- This will appear along with the error when mentioned in entrypoint description.-  ---  -- By default, the first sentence of the full description is used.-  customErrDocMdCauseInEntrypoint :: Markdown-  customErrDocMdCauseInEntrypoint = pickFirstSentence $ customErrDocMdCause @tag--  -- | Error class.-  ---  -- By default this returns "unknown error" class; though you should provide-  -- explicit implementation in order to avoid a warning.-  customErrClass :: ErrorClass-  customErrClass = ErrClassUnknown--  -- | Clarification of error argument meaning.-  ---  -- Provide when it's not obvious, e.g. argument is not named with ':!'.-  ---  -- NOTE: This should /not/ be an entire sentence, rather just the semantic-  -- backbone.-  ---  -- Bad:-  -- * @Error argument stands for the previous value of approval.@-  ---  -- Good:-  -- * @the previous value of approval@-  -- * @pair, first argument of which is one thing, and the second is another@-  customErrArgumentSemantics :: Maybe Markdown-  customErrArgumentSemantics = Nothing-  {-# MINIMAL customErrDocMdCause, customErrClass #-}---- | Mentions that contract uses given error.-data DError where-  DError :: IsError e => Proxy e -> DError--instance Eq DError where-  DError e1 == DError e2 = e1 `eqParam1` e2-instance Ord DError where-  DError e1 `compare` DError e2 = e1 `compareExt` e2--instance DocItem DError where-  type DocItemPosition DError = 5010-  type DocItemPlacement DError = 'DocItemInDefinitions-  docItemSectionName = Just "Errors"-  docItemSectionDescription = Just errorsDocumentation-  docItemRef (DError (_ :: Proxy e)) = DocItemRef $-    DocItemId ("errors-" <> errorDocName @e)-  docItemToMarkdown lvl (DError (_ :: Proxy e)) =-    mconcat-    [ mdSeparator-    , mdHeader lvl (mdTicked . build $ errorDocName @e)-    , mdSubsection "Class" (build $ errorDocClass @e)-    , "\n\n"-    , mdSubsection "Fires if" $ errorDocMdCause @e-    , "\n\n"-    , mdSubsection "Representation" $ errorDocHaskellRep @e-    ]-  docItemDependencies (DError (_ :: Proxy e)) = errorDocDependencies @e--errorDocMdReference :: forall e. IsError e => Markdown-errorDocMdReference =-  let DocItemRef (DocItemId anchor) = docItemRef $ DError (Proxy @e)-  in mdLocalRef (mdTicked . build $ errorDocName @e) anchor---- | Documentation for custom errors.---- | Mentions that entrypoint throws given error.-data DThrows where-  DThrows :: IsError e => Proxy e -> DThrows--instance Eq DThrows where-  DThrows e1 == DThrows e2 = eqParam1 e1 e2--instance DocItem DThrows where-  type DocItemPosition DThrows = 5011-  docItemSectionName = Just "Possible errors"-  docItemSectionNameStyle = DocSectionNameSmall-  docItemDependencies (DThrows ds) =-    [SomeDocDefinitionItem (DError ds)]-  docItemToMarkdown _ (DThrows (_ :: Proxy e)) =-    "* " <> errorDocMdReference @e <> " — " <> errorDocMdCauseInEntrypoint @e-  docItemsOrder =-    let errType (DThrows (_ :: Proxy e)) = errorDocClass @e-    in L.nub . filter (Prelude.not . isInternalErrorClass . errType)---- | Implementation of 'typeDocMdDescription' (of 'TypeHasDoc' typeclass)--- for Haskell types which sole purpose is to be error.-typeDocMdDescriptionReferToError :: forall e. IsError e => Markdown-typeDocMdDescriptionReferToError =-  "This type is primarily used as error, see " <>-  docDefinitionRef "description in section with errors" (DError (Proxy @e))---- | This is to be included on top of @Errors@ section of the generated--- documentation.-errorsDocumentation :: Markdown-errorsDocumentation = [md|-  Our contract implies the possibility of error scenarios, this section enlists-  all values which the contract can produce via calling `FAILWITH` instruction-  on them. In case of error, no changes to contract state will be applied.--  Each entrypoint also contains a list of errors which can be raised during its-  execution; only for no-throw entrypoints this list will be omitted.-  Errors in these lists are placed in the order in which the corresponding-  properties are checked unless the opposite is specified. I.e., if for a-  given entrypoint call two different errors may take place, the one which-  appears in the list first will be thrown.--  Most of the errors are represented according to the same-  `(error name, error argument)` pattern. See the list of errors below-  for details.--  We distinquish several error classes:-  + #{mdBold $ build ErrClassActionException}: given action cannot be performed with-    regard to the current contract state.--    Examples: "insufficient balance", "wallet does not exist".--    If you are implementing a middleware, such errors should be propagated to-    the client.--  + #{mdBold $ build ErrClassBadArgument}: invalid argument supplied to the entrypoint.--    Examples: entrypoint accepts a natural number from `0-3` range, and you-    supply `5`.--    If you are implementing a middleware, you should care about not letting-    such errors happen.--  + #{mdBold $ build ErrClassContractInternal}: contract-internal error.--    In ideal case, such errors should not take place, but still, make sure-    that you are ready to handle them. They can signal either invalid contract-    deployment or a bug in contract implementation.--    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 (VC (CvString 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 (VC (CvString 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 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-    , IsoValue fieldTy-    , CtorHasOnlyField name e fieldTy, Each [Typeable, SingI] '[ToT 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" #-}

@@ -1,28 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}---- | Some common errors.------ Such registry makes sense, as soon as errors are declared globally.-module Lorentz.Errors.Common () where--import Fmt (Buildable(..))--import Lorentz.Errors--------------------------------------------------------------------------------- Authorization--------------------------------------------------------------------------------- | Contract initiator should be contract admin in order to perform this--- operation.-type instance ErrorArg "senderIsNotAdmin" = ()--instance Buildable (CustomError "senderIsNotAdmin") where-  build (CustomError _ ()) =-    "This operation can be executed only by admin, but is invoked by \-    \someone else"--instance CustomErrorHasDoc "senderIsNotAdmin" where-  customErrClass = ErrClassActionException-  customErrDocMdCause =-    "Entrypoint executed not by its administrator."

@@ -1,174 +0,0 @@--- | By default we represent error tags using strings. This module--- makes it possible to use numbers instead.------ There are two possible ways to use it:--- 1. If you have just one Lorentz instruction (potentially a big one),--- just use 'useNumericErrors' function. It will change error representation--- there and return a map that can be used to interpret new error codes.--- 2. If your contract consists of multiple parts, start with gathering all--- error tags ('gatherErrorTags'). Then build 'ErrorTagMap' using--- 'addNewErrorTags'. Pass empty map if you are building from scratch--- (you can use 'buildErrorTagMap' shortcut) or an existing--- map if you have one (e. g. you are upgrading a contract).--module Lorentz.Errors.Numeric-  ( ErrorTagMap-  , ErrorTagExclusions-  , gatherErrorTags-  , addNewErrorTags-  , buildErrorTagMap-  , excludeErrorTags-  , applyErrorTagMap-  , applyErrorTagMapWithExclusions-  , useNumericErrors--  , errorFromValNumeric-  ) where--import Data.Bimap (Bimap)-import qualified Data.Bimap as Bimap-import Data.Default (def)-import qualified Data.HashSet as HS-import Data.Singletons (SingI, sing)-import Fmt (pretty)--import Lorentz.Base-import Lorentz.Errors-import Michelson.Analyzer-import Michelson.FailPattern-import Michelson.Text (MText)-import Michelson.Typed---- | This is a bidirectional map with correspondence between numeric--- and textual error tags.-type ErrorTagMap = Bimap Natural MText---- | Tags excluded from map.-type ErrorTagExclusions = HashSet MText---- | Find all textual error tags that are used in typical--- @FAILWITH@ patterns within given instruction.--- Map them to natural numbers.-gatherErrorTags :: inp :-> out -> HashSet MText-gatherErrorTags = HS.fromMap . void . arErrorTags . analyze . iAnyCode---- | Add more error tags to an existing 'ErrorTagMap'. It is useful when--- your contract consists of multiple parts (e. g. in case of contract--- upgrade), you have existing map for some part and want to add tags--- from another part to it.--- You can pass empty map as existing one if you just want to build--- 'ErrorTagMap' from a set of textual tags. See 'buildErrorTagMap'.-addNewErrorTags :: ErrorTagMap -> HashSet MText -> ErrorTagMap-addNewErrorTags existingMap newTags =-  foldl' (flip $ uncurry Bimap.tryInsert) existingMap newItems-  where-    firstUnusedNumeric-      | Bimap.null existingMap = 0-      | otherwise = fst (Bimap.findMax existingMap) + 1--    newItems :: [(Natural, MText)]-    newItems = zip [firstUnusedNumeric .. ] (toList newTags)---- | Build 'ErrorTagMap' from a set of textual tags.-buildErrorTagMap :: HashSet MText -> ErrorTagMap-buildErrorTagMap = addNewErrorTags Bimap.empty---- | Remove some error tags from map.--- This way you say to remain these string tags intact, while others will be--- converted to numbers when this map is applied.------ Note that later you have to apply this map using--- 'applyErrorTagMapWithExclusions', otherwise an error would be raised.-excludeErrorTags-  :: HasCallStack-  => ErrorTagExclusions -> ErrorTagMap -> ErrorTagMap-excludeErrorTags toExclude errMap =-  foldl' (flip deleteExistingR) errMap toExclude-  where-    deleteExistingR k m = case Bimap.lookupR k m of-      Just _ -> Bimap.deleteR k m-      Nothing ->-        error $ "Tag " <> show k <> " does not appear in the contract"---- | For each typical 'FAILWITH' that uses a string to represent error--- tag this function changes error tag to be a number using the--- supplied conversion map.--- It assumes that supplied map contains all such strings--- (and will error out if it does not).--- It will always be the case if you gather all error tags using--- 'gatherErrorTags' and build 'ErrorTagMap' from them using 'addNewErrorTags'.-applyErrorTagMap :: HasCallStack => ErrorTagMap -> inp :-> out -> inp :-> out-applyErrorTagMap errorTagMap = applyErrorTagMapWithExclusions errorTagMap mempty---- | Similar to 'applyErrorTagMap', but for case when you have excluded some--- tags from map via 'excludeErrorTags'.--- Needed, because both 'excludeErrorTags' and this function do not tolerate--- unknown errors in contract code (for your safety).-applyErrorTagMapWithExclusions-  :: HasCallStack-  => ErrorTagMap -> ErrorTagExclusions -> inp :-> out -> inp :-> out-applyErrorTagMapWithExclusions errorTagMap exclusions =-  iMapAnyCode (applyErrorTagMapWithExcT errorTagMap exclusions)---- | This function implements the simplest scenario of using this--- module's functionality:--- 1. Gather all error tags from a single instruction.--- 2. Turn them into error conversion map.--- 3. Apply this conversion.-useNumericErrors ::-  HasCallStack => inp :-> out -> (inp :-> out, ErrorTagMap)-useNumericErrors instr = (applyErrorTagMap errorTagMap instr, errorTagMap)-  where-    errorTagMap = buildErrorTagMap $ gatherErrorTags instr---- This function works with 'Michelson.Typed' representation, not with Lorentz.-applyErrorTagMapWithExcT ::-     HasCallStack-  => ErrorTagMap-  -> ErrorTagExclusions-  -> Instr inp out-  -> Instr inp out-applyErrorTagMapWithExcT errorTagMap exclusions instr =-  dfsModifyInstr dfsSettings step instr-  where-    dfsSettings :: DfsSettings ()-    dfsSettings = def-      { dsGoToValues = True-      }--    tagToNatValue :: HasCallStack => MText -> SomeConstrainedValue ConstantScope'-    tagToNatValue tag =-      case (HS.member tag exclusions, Bimap.lookupR tag errorTagMap) of-        (True, _) -> SomeConstrainedValue (VC $ CvString tag)-        -- It will be applied to textual tags detected by 'modifyTypicalFailWith'.-        -- Here we assume that all of them are discovered by the analyzer.-        -- If this error ever happens, it means that someone used-        -- 'applyErrorTagMap' with incomplete 'ErrorTagMap' or there is an-        -- internal bug somewhere.-        (False, Nothing) -> error $ "Can't find a tag: " <> pretty tag-        (False, Just n) -> SomeConstrainedValue (VC $ CvNat n)--    step :: HasCallStack => Instr inp out -> Instr inp out-    step = modifyTypicalFailWith tagToNatValue---- | If you apply numeric error representation in your contract, 'errorFromVal'--- will stop working because it doesn't know about this--- transformation.--- This function takes this transformation into account.--- If a number is used as a tag, but it is not found in the passed--- map, we conservatively preserve that number (because this whole--- approach is rather a heuristic).-errorFromValNumeric ::-  (Typeable t, SingI t, IsError e) => ErrorTagMap -> Value t -> Either Text e-errorFromValNumeric errorTagMap v =-  case v of-    VC (CvNat tag)-      | Just textualTag <- Bimap.lookup tag errorTagMap ->-        errorFromVal . VC . CvString $ textualTag-    VPair (VC (CvNat tag), something)-      | Just textualTag <- Bimap.lookup tag errorTagMap-      , _ :: Value pair <- v ->-        case sing @pair of-          STPair {} ->-            errorFromVal $ VPair (VC $ CvString textualTag, something)-    _ -> errorFromVal v

@@ -1,39 +0,0 @@-module Lorentz.Ext-  ( stackRef-  , printComment-  , testAssert-  , stackType-  ) where--import Data.Singletons (SingI)-import GHC.TypeNats (Nat)--import Lorentz.Base-import Michelson.Typed.Haskell-import Michelson.Typed.Instr-import Util.Peano hiding (Nat)--stackRef-  :: forall (gn :: Nat) st n.-      (n ~ ToPeano gn, SingI n, KnownPeano n, RequireLongerThan st n)-  => PrintComment st-stackRef = PrintComment . one . Right $ mkStackRef @gn--printComment :: PrintComment (ToTs s) -> s :-> s-printComment = I . Ext . PRINT--testAssert-  :: (Typeable (ToTs out), HasCallStack)-  => Text -> PrintComment (ToTs inp) -> inp :-> Bool & out -> inp :-> inp-testAssert msg comment = \case-  I instr -> I . Ext . TEST_ASSERT $ TestAssert msg comment instr-  FI _ -> error "test assert branch always fails"--stackType :: forall s. s :-> s-stackType = I Nop--_sample1 :: s ~ (a & s') => s :-> s-_sample1 = printComment $ "Head is " <> stackRef @0--_sample2 :: Integer & Natural & s :-> Integer & Natural & s-_sample2 = stackType @(Integer & _)

@@ -1,270 +0,0 @@-{- | This module contains implementation of 'Extensible' values.--@Extensible@ values are an alternative representation of sum-types-for Michelson. Instead of representing them as nested options, we-treat them as (Natural, ByteString) pair, where the first element-of the pair represents the constructor index, while the second is-a packed argument.--With such a representation sum types can be easily upgraded: it is-possible to add new elements to the sum type, and the representation-would not change.--However, such representation essentially limits the applicability of-the values. This module does not provide Michelson-level function to-unwrap the value because it would require traversing all the possible-options in the contract code. While this is possible, it is very-inefficient. Up to this moment, we have not come up with a decent-reason to allow such behavior, so Extensible types are write-only-in Michelson code. They can be unwrapped off-chain with @fromExtVal@.--In order to preserve previous values during migrations, users should-ONLY APPEND items to the underlying sum type. Changing, reordering and-deleting items is not allowed and would lead to compatibility breakage.-Currently, this restriction in not enforced. Only no-argument and-one-argument constructors are supported.--GOOD:-  -- `Extensible GoodSumTypeV1` is backwards compatible-  -- with `Extensible GoodSumTypeV2`-  data GoodSumTypeV1 = A Natural | B-  data GoodSumTypeV2 = A Natural | B | C MText--BAD:-  -- `Extensible BadSumTypeV1` is NOT backwards compatible-  -- with `Extensible BadSumTypeV2`-  data BadSumTypeV1 = A | B-  data BadSumTypeV2 = A Natural | B | C MText--}--{-# LANGUAGE InstanceSigs #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}--module Lorentz.Extensible-  ( Extensible (..)-  , ExtConversionError (..)-  , ExtVal-  , ExtensibleHasDoc (..)-  , toExtVal-  , fromExtVal-  , wrapExt-  , WrapExtC-  ) where--import Data.Char (isSpace)-import qualified Data.Kind as Kind-import qualified Data.Text as T-import Data.Typeable (Proxy(..))-import Data.Vinyl.Derived (Label)-import Data.Vinyl.TypeLevel (type (++))-import Fmt (Buildable(build), (+||), (|+), (||+))-import GHC.Generics ((:+:)(..))-import qualified GHC.Generics as G-import GHC.TypeLits (AppendSymbol, Nat, Symbol)-import GHC.TypeNats (type (+))--import Lorentz.Base-import Lorentz.Coercions-import Lorentz.Constraints-import Lorentz.Instr-import Lorentz.Pack-import Michelson.Typed-import Util.Markdown-import Util.Type-import Util.TypeLits--newtype Extensible x = Extensible (Natural, ByteString)-  deriving stock (Generic, Eq, Show)-  deriving anyclass (IsoValue)--instance Wrapped (Extensible x)--type ExtVal x = (Generic x, GExtVal x (G.Rep x))-type GetCtors x = GGetCtors (G.Rep x)---- | Converts a value from a Haskell representation to its---   extensible Michelson representation (i.e. (Natural, Bytestring) pair).-toExtVal :: ExtVal a => a -> Extensible a-toExtVal = gToExtVal . G.from---- | Converts a value from an extensible Michelson representation to its---   Haskell sum-type representation. Fails if the Michelson representation---   points to a nun-existent constructor, or if we failed to unpack---   the argument.-fromExtVal :: ExtVal a => Extensible a -> Either ExtConversionError a-fromExtVal val = fmap G.to $ gFromExtVal val---- | Helper typeclass which allows us to sanely handle cases of no-arg--- constructor and constructor with one argument.-class WrapExt (cf :: CtorField) where-  -- | Pack argument on top of the stack, if any required.-  packForWrap :: AppendCtorField cf s :-> ByteString : s--instance (NicePackedValue param) =>-         WrapExt ('OneField param) where-  packForWrap = pack--instance WrapExt 'NoFields where-  packForWrap = unit # pack---- | Wraps an argument on top of the stack into an Extensible representation-wrapExt-  :: forall t (n :: Nat) name field s.-     (WrapExtC t n name field s)-  => Label ("c" `AppendSymbol` name) -> AppendCtorField field s :-> Extensible t ': s-wrapExt _ = packForWrap @field # push (natVal (Proxy @n)) # pair # coerceWrap--type WrapExtC t n name field s =-  ( 'Ctor n name field ~ LookupCtor name (EnumerateCtors (GetCtors t))-  , WrapExt field-  , KnownNat n-  )---- | Errors related to fromExtVal conversion-data ExtConversionError-  = ConstructorIndexNotFound Natural-  | ArgumentUnpackFailed-  deriving stock (Eq, Show)--instance Buildable ExtConversionError where-  build =-    \case-      ConstructorIndexNotFound idx ->-        "Could not convert Extensible value into its Haskell representation: \-        \constructor #" +|| idx ||+ " was not found in the sum type \-        \constructors list"-      ArgumentUnpackFailed ->-        "Could not convert Extensible value into its Haskell representation: \-        \failed to unpack constructor argument"--data Position = Position Nat-data Ctor = Ctor { _n :: Nat, _name :: Symbol, _param :: CtorField }-type CtorKind = (Symbol, CtorField)---- | Finds the constructor's position and argument type by its name-type family LookupCtor (name :: Symbol) (entries :: [Ctor])-             :: Ctor where-  LookupCtor name ('Ctor pos name param ': _) = 'Ctor pos name param-  LookupCtor name (_ ': entries) =-    LookupCtor name entries-  LookupCtor name '[] =-    TypeError ('Text "Constructor " ':<>: 'ShowType name ':<>:-               'Text " is not in the sum type constructor list")---- | Transform list of 'CtorKind's to list of 'Ctor's, assigning numbers--- to elements starting from 0.-type EnumerateCtors ctors = EnumerateCtorsImpl ('Position 0) ctors--type family EnumerateCtorsImpl (pos :: Position) (ctors :: [CtorKind]) :: [Ctor] where-  EnumerateCtorsImpl _ '[] = '[]-  EnumerateCtorsImpl ('Position i) ('(name, param) ': cs) =-    'Ctor i name param ': EnumerateCtorsImpl ('Position (i + 1)) cs---- | Having a sum-type, yields a type-level list of its constructors-type family GGetCtors (x :: Kind.Type -> Kind.Type) :: [CtorKind] where-  GGetCtors (G.D1 _ x) = GGetCtors x-  GGetCtors (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param)))-    = '[ '(name, 'OneField param) ]-  GGetCtors (G.C1 ('G.MetaCons name _1 _2) G.U1)-    = '[ '(name, 'NoFields) ]-  GGetCtors (x :+: y) = GGetCtors x ++ GGetCtors y---- | Generic implementation of toExtVal and fromExtVal-class GExtVal t (x :: Kind.Type -> Kind.Type) where-  gToExtVal :: x p -> Extensible t-  gFromExtVal :: Extensible t -> Either ExtConversionError (x p)--instance GExtVal t x => GExtVal t (G.D1 i x) where-  gToExtVal = gToExtVal @t . G.unM1-  gFromExtVal val = fmap G.M1 (gFromExtVal @t val)--instance ( 'Ctor n name 'NoFields ~ LookupCtor name (EnumerateCtors (GetCtors t))-         , KnownNat n-         )-         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) G.U1) where-  gToExtVal (G.M1 G.U1) = Extensible-    ( natVal (Proxy @n)-    , lPackValue ()-    )-  gFromExtVal (Extensible (idx, _))-    | idx == natVal (Proxy @n)-        = Right $ G.M1 G.U1-    | otherwise = Left $ ConstructorIndexNotFound idx--instance ( NiceFullPackedValue param-         , 'Ctor n name ('OneField param) ~ LookupCtor name (EnumerateCtors (GetCtors t))-         , KnownNat n-         )-         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param))) where-  gToExtVal (G.M1 (G.M1 (G.K1 param))) = Extensible-    ( natVal (Proxy @n)-    , lPackValue param-    )-  gFromExtVal (Extensible (idx, bs))-    | idx == natVal (Proxy @n)-        = first (\_ -> ArgumentUnpackFailed) $-          fmap (G.M1 . G.M1 . G.K1) $ lUnpackValue @param bs-    | otherwise = Left $ ConstructorIndexNotFound idx--instance (GExtVal t x, GExtVal t y) => GExtVal t (x :+: y) where-  gToExtVal = \case-    G.L1 x -> let Extensible val = gToExtVal @t x in Extensible val-    G.R1 y -> let Extensible val = gToExtVal @t y in Extensible val-  gFromExtVal val =-    let l = fmap G.L1 (gFromExtVal @t val)-        r = fmap G.R1 (gFromExtVal @t val)-    in l <> r---- | Information to be provided for documenting some @'Extensible' x@.-class Typeable x => ExtensibleHasDoc x where-  -- | Implementation for 'typeDocName' of the corresponding @Extensible@.-  extensibleDocName :: Proxy x -> Text--  -- | Implementation for 'typeDocDependencies' of the corresponding @Extensible@.-  extensibleDocDependencies :: Proxy x -> [SomeTypeWithDoc]-  default extensibleDocDependencies-    :: (Generic x, GTypeHasDoc (G.Rep x))-    => Proxy x -> [SomeTypeWithDoc]-  extensibleDocDependencies = genericTypeDocDependencies--  -- | Overall description of this type.-  extensibleDocMdDescription :: Markdown---- | Helper which documents single constructor.-class DocumentCtor (ctor :: Ctor) where-  documentCtor :: Proxy ctor -> Markdown-instance ( KnownNat pos, KnownSymbol name, TypeHasDoc param-         , param ~ ExtractCtorField field-         ) =>-         DocumentCtor ('Ctor pos name field) where-  documentCtor _ =-    natVal (Proxy @pos) |+ ": " <> mdBold (build $ symbolValT' @name) <>-    " " <> typeDocMdReference (Proxy @param) (WithinParens True)--instance ( ExtensibleHasDoc x-         , ReifyList DocumentCtor (EnumerateCtors (GetCtors x))-         ) => TypeHasDoc (Extensible x) where-  typeDocName _ = extensibleDocName (Proxy @x)-  typeDocMdReference p (WithinParens wp) =-    let name = typeDocName p-        safeName = case T.find isSpace name of-          Nothing -> name-          Just _-            | wp -> "(" <> name <> ")"-            | otherwise -> name-    in customTypeDocMdReference (safeName, DType p) [] (WithinParens False)-  typeDocDependencies _ = extensibleDocDependencies (Proxy @x)-  typeDocHaskellRep = homomorphicTypeDocHaskellRep-  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep-  typeDocMdDescription = mconcat-    [ extensibleDocMdDescription @x-    , "\n\n"-    , "For extensibility purposes this type is represented as `(idx, pack param)`, \-      \where `idx` is a natural number which designates constructor used to \-      \make up given value, and `param` is the argument carried in that \-      \constructor.\n\n"-    , "Value must be one of:\n\n"-    , mconcat $-        Prelude.map (<> "\n\n") $-        reifyList @Ctor @DocumentCtor @(EnumerateCtors (GetCtors x)) documentCtor-    ]

@@ -1,691 +0,0 @@-module Lorentz.Instr-  ( nop-  , drop-  , dropN-  , dup-  , swap-  , digPeano-  , dig-  , dug-  , push-  , some-  , none-  , unit-  , ifNone-  , pair-  , car-  , cdr-  , left-  , right-  , ifLeft-  , nil-  , cons-  , size-  , emptySet-  , emptyMap-  , emptyBigMap-  , map-  , iter-  , mem-  , get-  , update-  , failingWhenPresent-  , updateNew-  , if_-  , ifCons-  , loop-  , loopLeft-  , lambda-  , exec-  , execute-  , apply-  , dip-  , ConstraintDIPNLorentz-  , dipNPeano-  , dipN-  , failWith-  , cast-  , pack-  , unpack-  , concat-  , concat'-  , slice, isNat, add, sub, rsub, mul, ediv, abs-  , neg-  , lsl-  , lsr-  , or-  , and-  , xor-  , not-  , compare-  , eq0-  , neq0-  , lt0-  , gt0-  , le0-  , ge0-  , int-  , toTAddress_-  , self-  , selfCalling-  , contract-  , contractCalling-  , contractCallingUnsafe-  , runFutureContract-  , epAddressToContract-  , transferTokens-  , setDelegate-  , createContract-  , implicitAccount-  , now-  , amount-  , balance-  , checkSignature-  , sha256-  , sha512-  , blake2B-  , hashKey-  , stepsToQuota-  , source-  , sender-  , address-  , chainId-  , framed-  , LorentzFunctor (..)-  , nonZero-  ) where--import Prelude hiding-  (EQ, GT, LT, abs, and, compare, concat, drop, get, map, not, or, some, swap, xor)--import Data.Constraint (Dict(..), (\\))-import qualified Data.Kind as Kind-import Data.Singletons (SingI, sing)-import qualified GHC.TypeNats as GHC (Nat)--import Lorentz.Arith-import Lorentz.Base-import Lorentz.Constraints-import Lorentz.EntryPoints-import Lorentz.Polymorphic-import Lorentz.Run (compileLorentzContract)-import Lorentz.Value-import Lorentz.Zip-import Michelson.Typed-  (pattern CAR, pattern CDR, ConstraintDIG, ConstraintDIG', ConstraintDIPN, ConstraintDIPN',-  ConstraintDUG, ConstraintDUG', pattern DefEpName, EntryPointCallT(..), Instr(..), RemFail(..),-  SomeEntryPointCallT(..), ToTs, Value'(..), sepcName, starNotes)-import Michelson.Typed.Arith-import Michelson.Typed.Haskell.Value-import Util.Peano-import Util.Type--nop :: s :-> s-nop = I Nop--drop :: a & s :-> s-drop = I DROP---- | Drop top @n@ elements from the stack.-dropN ::-  forall (n :: GHC.Nat) (s :: [Kind.Type]).-  -- Note: if we introduce `nPeano ~ ToPeano n` variable,-  -- GHC will complain that this constraint is redundant.-  ( SingI (ToPeano n), KnownPeano (ToPeano n)-  , RequireLongerOrSameLength (ToTs s) (ToPeano n)-  -- ↓ Kinda obvious, but not to GHC.-  , Drop (ToPeano n) (ToTs s) ~ ToTs (Drop (ToPeano n) s)-  ) => s :-> Drop (ToPeano n) s-dropN = I (DROPN $ sing @(ToPeano n))-  where-    _example :: '[ Integer, Integer, Integer ] :-> '[]-    _example = dropN @3--dup  :: a & s :-> a & a & s-dup = I DUP--swap :: a & b & s :-> b & a & s-swap = I SWAP---- See a comment about `ConstraintDIPNLorentz'.-type ConstraintDIGLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])-  (a :: Kind.Type) =-  ( ConstraintDIG n (ToTs inp) (ToTs out) (ToT a)-  , ConstraintDIG' Kind.Type n inp out a-  )--type ConstraintDUGLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])-  (a :: Kind.Type) =-  ( ConstraintDUG n (ToTs inp) (ToTs out) (ToT a)-  , ConstraintDUG' Kind.Type n inp out a-  )---- | Version of `dig` which uses Peano number.--- It is inteded for internal usage in Lorentz.-digPeano ::-  forall (n :: Peano) inp out a.-  ( ConstraintDIGLorentz n inp out a-  ) => inp :-> out-digPeano = I (DIG $ sing @n)--dig ::-  forall (n :: GHC.Nat) inp out a.-  ( ConstraintDIGLorentz (ToPeano n) inp out a-  ) => inp :-> out-dig = digPeano @(ToPeano n)-  where-    _example ::-      '[ Integer, Integer, Integer, Bool ] :->-      '[ Bool, Integer, Integer, Integer ]-    _example = dig @3--dug ::-  forall (n :: GHC.Nat) inp out a.-  ( ConstraintDUGLorentz (ToPeano n) inp out a-  ) => inp :-> out-dug = I (DUG $ sing @(ToPeano n))-  where-    _example ::-      '[ Bool, Integer, Integer, Integer ] :->-      '[ Integer, Integer, Integer, Bool ]-    _example = dug @3--push :: forall t s . NiceConstant t => t -> (s :-> t & s)-push a = I $ PUSH (toVal a) \\ niceConstantEvi @t--some :: a & s :-> Maybe a & s-some = I SOME--none :: forall a s . KnownValue a => s :-> (Maybe a & s)-none = I NONE--unit :: s :-> () & s-unit = I UNIT--ifNone-  :: (s :-> s') -> (a & s :-> s') -> (Maybe a & s :-> s')-ifNone = iGenericIf IF_NONE--pair :: a & b & s :-> (a, b) & s-pair = I PAIR--car :: (a, b) & s :-> a & s-car = I CAR--cdr :: (a, b) & s :-> b & s-cdr = I CDR--left :: forall a b s. KnownValue b => a & s :-> Either a b & s-left = I LEFT--right :: forall a b s. KnownValue a => b & s :-> Either a b & s-right = I RIGHT--ifLeft-  :: (a & s :-> s') -> (b & s :-> s') -> (Either a b & s :-> s')-ifLeft = iGenericIf IF_LEFT--nil :: KnownValue p => s :-> List p & s-nil = I NIL--cons :: a & List a & s :-> List a & s-cons = I CONS--ifCons-  :: (a & List a & s :-> s') -> (s :-> s') -> (List a & s :-> s')-ifCons = iGenericIf IF_CONS--size :: SizeOpHs c => c & s :-> Natural & s-size = I SIZE--emptySet :: (KnownCValue e) => s :-> Set e & s-emptySet = I EMPTY_SET--emptyMap :: (KnownCValue k, KnownValue v)-         => s :-> Map k v & s-emptyMap = I EMPTY_MAP--emptyBigMap :: (KnownCValue k, KnownValue v)-            => s :-> BigMap k v & s-emptyBigMap = I EMPTY_BIG_MAP--map-  :: (MapOpHs c, IsoMapOpRes c b, HasCallStack)-  => (MapOpInpHs c & s :-> b & s) -> (c & s :-> MapOpResHs c b & s)-map (iNonFailingCode -> action) = I (MAP action)--iter-  :: (IterOpHs c, HasCallStack)-  => (IterOpElHs c & s :-> s) -> (c & s :-> s)-iter (iNonFailingCode -> action) = I (ITER action)--mem :: MemOpHs c => MemOpKeyHs c & c & s :-> Bool & s-mem = I MEM--get :: GetOpHs c => GetOpKeyHs c & c & s :-> Maybe (GetOpValHs c) & s-get = I GET--update :: UpdOpHs c => UpdOpKeyHs c & UpdOpParamsHs c & c & s :-> c & s-update = I UPDATE--if_ :: (s :-> s') -> (s :-> s') -> (Bool & s :-> s')-if_ = iGenericIf IF--loop :: (s :-> Bool & s) -> (Bool & s :-> s)-loop (iAnyCode -> b) = I (LOOP b)--loopLeft-  :: (a & s :-> Either a b & s) -> (Either a b & s :-> b & s)-loopLeft (iAnyCode -> b) = I (LOOP_LEFT b)--lambda-  :: (ZipInstrs [i, o], KnownValue (ZippedStack i), KnownValue (ZippedStack o))-  => (i :-> o) -> (s :-> (i :-> o) & s)-lambda instr = case zippingStack instr of-  I l -> I (LAMBDA . VLam $ RfNormal l)-  FI l -> I (LAMBDA . VLam $ RfAlwaysFails l)--exec :: a & Lambda a b & s :-> b & s-exec = I EXEC---- | Similar to 'exec' but works for lambdas with arbitrary size of input--- and output.------ Note that this instruction has its arguments flipped, lambda goes first.--- This seems to be the only reasonable way to achieve good inference.-execute-  :: forall i o s.-      (Each [KnownList, ZipInstr] [i, o])-  => ((i :-> o) : (i ++ s)) :-> (o ++ s)-execute = framed @s $-  dip (zipInstr @i) # swap # I EXEC # unzipInstr @o-  where-    _example-      :: ([Integer, Natural] :-> [(), ()]) : Integer : Natural : s-      :-> () : () : s-    _example = execute--apply-  :: forall a b c s.-     (NiceConstant a)-  => a & Lambda (a, b) c & s :-> Lambda b c & s-apply = I $ APPLY \\ niceConstantEvi @a--dip :: forall a s s'. HasCallStack => (s :-> s') -> (a & s :-> a & s')-dip (iNonFailingCode -> a) = I (DIP a)---- Helper constraint we need for 'dipN'.--- The first constraint here is sufficient to make 'dipN' compile.--- However, it is not enough for good type inference. If we use only the first--- constraint, '_example' below will not compile because GHC will not be able--- to deduce type of the input stack for 'unit'.--- It can only deduce that 'ToTs s0' is empty (where 's0' is input stack), but--- 'ToTs' is not injective, hence 's0' is ambiguous.--- So we need both and we merge them into one to avoid a warning about--- a redundant constraint.-type ConstraintDIPNLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])-  (s :: [Kind.Type]) (s' :: [Kind.Type]) =-  ( ConstraintDIPN n (ToTs inp) (ToTs out) (ToTs s) (ToTs s')-  , ConstraintDIPN' Kind.Type n inp out s s'-  )---- | Version of `dipN` which uses Peano number.--- It is inteded for internal usage in Lorentz.-dipNPeano ::-  forall (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]).-  ( ConstraintDIPNLorentz n inp out s s'-  ) => s :-> s' -> inp :-> out-dipNPeano (iNonFailingCode -> a) = I (DIPN (sing @n) a)--dipN ::-  forall (n :: GHC.Nat) (inp :: [Kind.Type]) (out :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]).-  ( ConstraintDIPNLorentz (ToPeano n) inp out s s'-  ) => s :-> s' -> inp :-> out-dipN = dipNPeano @(ToPeano n)-  where-    _example :: '[ Integer, Integer, Integer ] :-> '[ Integer, Integer, Integer, () ]-    _example = dipN @3 unit--failWith :: (KnownValue a) => a & s :-> t-failWith = FI FAILWITH--cast :: KnownValue a => (a & s :-> a & s)-cast = I CAST--pack-  :: forall a s. (NicePackedValue a)-  => a & s :-> ByteString & s-pack = I $ PACK \\ nicePackedValueEvi @a--unpack-  :: forall a s. (NiceUnpackedValue a)-  => ByteString & s :-> Maybe a & s-unpack = I $ UNPACK \\ niceUnpackedValueEvi @a--concat :: ConcatOpHs c => c & c & s :-> c & s-concat = I CONCAT--concat' :: ConcatOpHs c => List c & s :-> c & s-concat' = I CONCAT'--slice :: SliceOpHs c => Natural & Natural & c & s :-> Maybe c & s-slice = I SLICE--isNat :: Integer & s :-> Maybe Natural & s-isNat = I ISNAT--add-  :: ArithOpHs Add n m-  => n & m & s :-> ArithResHs Add n m & s-add = I ADD--sub-  :: ArithOpHs Sub n m-  => n & m & s :-> ArithResHs Sub n m & s-sub = I SUB--rsub-  :: ArithOpHs Sub n m-  => m & n & s :-> ArithResHs Sub n m & s-rsub = swap # sub--mul-  :: ArithOpHs Mul n m-  => n & m & s :-> ArithResHs Mul n m & s-mul = I MUL--ediv :: EDivOpHs n m-     => n & m & s-     :-> Maybe ((EDivOpResHs n m, EModOpResHs n m)) & s-ediv = I EDIV--abs :: UnaryArithOpHs Abs n => n & s :-> UnaryArithResHs Abs n & s-abs = I ABS--neg :: UnaryArithOpHs Neg n => n & s :-> UnaryArithResHs Neg n & s-neg = I NEG---lsl-  :: ArithOpHs Lsl n m-  => n & m & s :-> ArithResHs Lsl n m & s-lsl = I LSL--lsr-  :: ArithOpHs Lsr n m-  => n & m & s :-> ArithResHs Lsr n m & s-lsr = I LSR--or-  :: ArithOpHs Or n m-  => n & m & s :-> ArithResHs Or n m & s-or = I OR--and-  :: ArithOpHs And n m-  => n & m & s :-> ArithResHs And n m & s-and = I AND--xor-  :: (ArithOpHs Xor n m)-  => n & m & s :-> ArithResHs Xor n m & s-xor = I XOR--not :: UnaryArithOpHs Not n => n & s :-> UnaryArithResHs Not n & s-not = I NOT--compare :: NiceComparable n-        => n & n & s :-> Integer & s-compare = I COMPARE--eq0 :: UnaryArithOpHs Eq' n => n & s :-> UnaryArithResHs Eq' n & s-eq0 = I EQ--neq0 :: UnaryArithOpHs Neq n => n & s :-> UnaryArithResHs Neq n & s-neq0 = I NEQ--lt0 :: UnaryArithOpHs Lt n => n & s :-> UnaryArithResHs Lt n & s-lt0 = I LT--gt0 :: UnaryArithOpHs Gt n => n & s :-> UnaryArithResHs Gt n & s-gt0 = I GT--le0 :: UnaryArithOpHs Le n => n & s :-> UnaryArithResHs Le n & s-le0 = I LE--ge0 :: UnaryArithOpHs Ge n => n & s :-> UnaryArithResHs Ge n & s-ge0 = I GE--int :: Natural & s :-> Integer & s-int = I INT---- | Cast something appropriate to 'TAddress'.--- TODO [TM-280]: try to move somewhere-toTAddress_-  :: (ToTAddress_ cp addr)-  => addr : s :-> TAddress cp : s-toTAddress_ = I Nop---- | Something coercible to 'TAddress cp'.-type ToTAddress_ cp addr = (ToTAddress cp addr, ToT addr ~ ToT Address)---- | Get a reference to the current contract.------ Note that, similar to 'CONTRACT' instruction, in Michelson 'SELF' instruction--- can accept an entrypoint as field annotation, and without annotation specified--- it creates a @contract@ value which calls the default entrypoint.------ This particular function carries the behaviour of @SELF@ before introduction--- of lightweight entrypoints feature.--- Thus the contract must __not__ have explicit "default" entrypoint for this to--- work.------ If you are going to call a specific entrypoint of the contract, see 'selfCalling'.-self-  :: forall p s.-      (NiceParameterFull p, ForbidExplicitDefaultEntryPoint p)-  => s :-> ContractRef p & s-self = I (SELF $ sepcCallRootChecked @p) \\ niceParameterEvi @p---- | Make a reference to the current contract, maybe a specific entrypoint.------ Note that, since information about parameter of the current contract is not--- carried around, in this function you need to specify parameter type @p@--- explicitly.-selfCalling-  :: forall p mname s.-     (NiceParameterFull p)-  => EntryPointRef mname-  -> s :-> ContractRef (GetEntryPointArgCustom p mname) & s-selfCalling epRef = I $-  withDict (niceParameterEvi @p) $-  case parameterEntryPointCallCustom @p epRef of-    epc@EntryPointCall{} -> SELF (SomeEpc epc)---- | Get a reference to a contract by its address.------ This instruction carries the behaviour of @CONTRACT@ before introduction--- of lightweight entrypoints feature.--- The contract must __not__ have explicit "default" entrypoint for this to work.------ If you are going to call a specific entrypoint of the contract, see 'contractCalling'.-contract-  :: forall p addr s.-      ( NiceParameterFull p, ForbidExplicitDefaultEntryPoint p-      , ToTAddress_ p addr-      )-  => addr & s :-> Maybe (ContractRef p) & s-contract = I (CONTRACT starNotes epName) \\ niceParameterEvi @p-  where-    epName = sepcName (sepcCallRootChecked @p)---- | Make a reference to a contract, maybe a specific entrypoint.------ When calling this function, make sure that parameter type is known.--- It's recommended that you supply 'TAddress' with a concrete parameter as the--- stack argument.-contractCalling-  :: forall cp epRef epArg addr s.-     (HasEntryPointArg cp epRef epArg, ToTAddress_ cp addr)-  => epRef-  -> addr & s :-> Maybe (ContractRef epArg) & s-contractCalling epRef = I $-  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'.--- 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'.-contractCallingUnsafe-  :: forall arg s.-     (NiceParameter arg)-  => EpName-  -> Address & s :-> Maybe (ContractRef arg) & s-contractCallingUnsafe epName = contractCalling (TrustEpName epName)---- | Version of 'contract' instruction which may accept address with already--- specified entrypoint name.------ Also you cannot specify entrypoint name here because this could result in--- conflict.-runFutureContract-  :: forall p s. (NiceParameter p)-  => FutureContract p & s :-> Maybe (ContractRef p) & s-runFutureContract =-  I Nop # epAddressToContract---- | Similar to 'runFutureContract', works with 'EpAddress'.------ Validity of such operation cannot be ensured at compile time.-epAddressToContract-  :: forall p s. (NiceParameter p)-  => EpAddress & s :-> Maybe (ContractRef p) & s-epAddressToContract =-  I (CONTRACT starNotes DefEpName) \\ niceParameterEvi @p--transferTokens-  :: forall p s. (NiceParameter p)-  => p & Mutez & ContractRef p & s :-> Operation & s-transferTokens = I $ TRANSFER_TOKENS \\ niceParameterEvi @p--setDelegate :: Maybe KeyHash & s :-> Operation & s-setDelegate = I SET_DELEGATE--createContract-  :: forall p g s. (NiceStorage g, NiceParameterFull p)-  => Contract p g-  -> Maybe KeyHash & Mutez & g & s-  :-> Operation & Address & s-createContract cntrc =-  I $ CREATE_CONTRACT (compileLorentzContract cntrc)-    \\ niceParameterEvi @p-    \\ niceStorageEvi @g--implicitAccount :: KeyHash & s :-> ContractRef () & s-implicitAccount = I IMPLICIT_ACCOUNT--now :: s :-> Timestamp & s-now = I NOW--amount :: s :-> Mutez & s-amount = I AMOUNT--balance :: s :-> Mutez & s-balance = I BALANCE--checkSignature :: PublicKey & Signature & ByteString & s :-> Bool & s-checkSignature = I CHECK_SIGNATURE--sha256 :: ByteString & s :-> ByteString & s-sha256 = I SHA256--sha512 :: ByteString & s :-> ByteString & s-sha512 = I SHA512--blake2B :: ByteString & s :-> ByteString & s-blake2B = I BLAKE2B--hashKey :: PublicKey & s :-> KeyHash & s-hashKey = I HASH_KEY--{-# WARNING stepsToQuota "STEPS_TO_QUOTA instruction is deprecated in Michelson 005" #-}-stepsToQuota :: s :-> Natural & s-stepsToQuota = I STEPS_TO_QUOTA--{-# WARNING source-    "Using `source` is considered a bad practice.\n\-\    Consider using `sender` instead until further investigation" #-}-source :: s :-> Address & s-source = I SOURCE--sender :: s :-> Address & s-sender = I SENDER--address :: ContractRef a & s :-> Address & s-address = I ADDRESS--chainId :: s :-> ChainId & s-chainId = I CHAIN_ID---- | Execute given instruction on truncated stack.------ This instruction requires you to specify the piece of stack to truncate--- as type argument.-framed-  :: forall s i o.-      (KnownList i, KnownList o)-  => (i :-> o) -> ((i ++ s) :-> (o ++ s))-framed (iNonFailingCode -> i) =-  I $ FrameInstr (Proxy @(ToTs s)) i-    \\ totsKnownLemma @i-    \\ totsKnownLemma @o-    \\ totsAppendLemma @i @s-    \\ totsAppendLemma @o @s--------------------------------------------------------------------------------- Non-canonical instructions--------------------------------------------------------------------------------- | Helper instruction.------ Checks whether given key present in the storage and fails if it is.--- This instruction leaves stack intact.-failingWhenPresent-  :: forall c k s v st e.-     ( MemOpHs c, k ~ MemOpKeyHs c-     , KnownValue e-     , st ~ (k & v & c & s)-     )-  => (forall s0. k : s0 :-> e : s0)-  -> st :-> st-failingWhenPresent mkErr =-  dip (dip dup # swap) # swap # dip dup # swap # mem #-  if_ (mkErr # failWith) nop---- | Like 'update', but throw an error on attempt to overwrite existing entry.-updateNew-  :: forall c k s e.-     ( UpdOpHs c, MemOpHs c, k ~ UpdOpKeyHs c, k ~ MemOpKeyHs c-     , KnownValue e-     )-  => (forall s0. k : s0 :-> e : s0)-  -> k & UpdOpParamsHs c & c & s :-> c & s-updateNew mkErr = failingWhenPresent mkErr # update--class LorentzFunctor (c :: Kind.Type -> Kind.Type) where-  lmap :: KnownValue b => (a : s :-> b : s) -> (c a : s :-> c b : s)--instance LorentzFunctor Maybe where-  lmap f = ifNone none (f # some)--class NonZero t where-  -- | Retain the value only if it is not zero.-  nonZero :: t : s :-> Maybe t : s--instance NonZero Integer where-  nonZero = dup # eq0 # if_ (drop # none) some--instance NonZero Natural where-  nonZero = dup # int # eq0 # if_ (drop # none) some

@@ -1,687 +0,0 @@-{-# LANGUAGE PartialTypeSignatures #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Common Michelson macros defined using Lorentz syntax.-module Lorentz.Macro-  ( -- * Compare-    NiceComparable-  , eq-  , neq-  , lt-  , gt-  , le-  , ge-  , ifEq0-  , ifGe0-  , ifGt0-  , ifLe0-  , ifLt0-  , ifNeq0-  , ifEq-  , ifGe-  , ifGt-  , ifLe-  , ifLt-  , ifNeq--  -- * Fail-  , fail_--  -- * Assertion macros-  -- |-  -- They differ from the same macros in Michelson, because those-  -- macros use FAIL macro which is not informative (fails with unit).-  -- If you __really__ want Michelson versions (maybe to produce exact-  -- copy of an existing contract), you can pass 'UnspecifiedError', then-  -- FAILWITH will be called with unit.-  , assert-  , assertEq0-  , assertNeq0-  , assertLt0-  , assertGt0-  , assertLe0-  , assertGe0-  , assertEq-  , assertNeq-  , assertLt-  , assertGt-  , assertLe-  , assertGe-  , assertNone-  , assertSome-  , assertLeft-  , assertRight-  , assertUsing--  -- * Syntactic Conveniences-  , dropX-  , cloneX-  , duupX-  , framedN-  , caar-  , cadr-  , cdar-  , cddr-  , ifRight-  , ifSome-  , when_-  , unless_-  , whenSome-  , mapCar-  , mapCdr-  , papair-  , ppaiir-  , unpair-  , setCar-  , setCdr-  , setInsert-  , mapInsert-  , setInsertNew-  , mapInsertNew-  , deleteMap-  , setDelete--  -- * Additional Morley macros-  , View (..)-  , Void_ (..)-  , VoidResult(..)-  , view_-  , mkView-  , wrapView-  , unwrapView-  , void_-  , mkVoid--  -- * Buildable utils for additional Morley macros-  , buildView-  , buildViewTuple--  -- * Macros for working with @address@ and @contract@-like types-  , addressToEpAddress-  , pushContractRef-  ) where--import Prelude hiding (compare, drop, some, swap)--import qualified Data.Kind as Kind-import Data.Singletons (SingI(..))-import Data.Vinyl.TypeLevel (Nat(..))-import Fmt (Buildable(..), Builder, pretty, tupleF, (+|), (|+))-import Fmt.Internal.Tuple (TupleF)-import GHC.TypeNats (type (-))-import qualified GHC.TypeNats as GHC (Nat)--import Lorentz.Arith-import Lorentz.Base-import Lorentz.Coercions-import Lorentz.Constraints-import Lorentz.Doc-import Lorentz.Errors-import Lorentz.Ext (stackType)-import Lorentz.Instr-import Lorentz.Value-import Michelson.Typed (ConstraintDIG', ConstraintDIPN', T, typeDocDependencies')-import Michelson.Typed.Arith-import Michelson.Typed.Haskell.Value-import Util.Markdown-import Util.Peano-import Util.Type--------------------------------------------------------------------------------- Compare-------------------------------------------------------------------------------eq :: NiceComparable n-   => n & n & s :-> Bool & s-eq = compare # eq0--neq :: NiceComparable n-   => n & n & s :-> Bool & s-neq = compare # neq0--gt :: NiceComparable n-   => n & n & s :-> Bool & s-gt = compare # gt0--le :: NiceComparable n-   => n & n & s :-> Bool & s-le = compare # le0--ge :: NiceComparable n-   => n & n & s :-> Bool & s-ge = compare # ge0--lt :: NiceComparable n-   => n & n & s :-> Bool & s-lt = compare # lt0--type IfCmp0Constraints a op =-  (UnaryArithOpHs op a, (UnaryArithResHs op a ~ Bool), SingI (ToCT a))--ifEq0-  :: (IfCmp0Constraints a Eq')-  => (s :-> s') -> (s :-> s') -> (a & s :-> s')-ifEq0 l r = eq0 # if_ l r--ifNeq0-  :: (IfCmp0Constraints a Neq)-  => (s :-> s') -> (s :-> s') -> (a & s :-> s')-ifNeq0 l r = neq0 # if_ l r--ifLt0-  :: (IfCmp0Constraints a Lt)-  => (s :-> s') -> (s :-> s') -> (a & s :-> s')-ifLt0 l r = lt0 # if_ l r--ifGt0-  :: (IfCmp0Constraints a Gt)-  => (s :-> s') -> (s :-> s') -> (a & s :-> s')-ifGt0 l r = gt0 # if_ l r--ifLe0-  :: (IfCmp0Constraints a Le)-  => (s :-> s') -> (s :-> s') -> (a & s :-> s')-ifLe0 l r = le0 # if_ l r--ifGe0-  :: (IfCmp0Constraints a Ge)-  => (s :-> s') -> (s :-> s') -> (a & s :-> s')-ifGe0 l r = ge0 # if_ l r--ifEq-  :: (NiceComparable a)-  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')-ifEq l r = eq # if_ l r--ifNeq-  :: (NiceComparable a)-  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')-ifNeq l r = neq # if_ l r--ifLt-  :: (NiceComparable a)-  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')-ifLt l r = lt # if_ l r--ifGt-  :: (NiceComparable a)-  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')-ifGt l r = gt # if_ l r--ifLe-  :: (NiceComparable a)-  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')-ifLe l r = le # if_ l r--ifGe-  :: (NiceComparable a)-  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')-ifGe l r = ge # if_ l r--------------------------------------------------------------------------------- Fail--------------------------------------------------------------------------------- | Analog of the FAIL macro in Michelson. Its usage is discouraged--- because it doesn't carry any information about failure.-{-# WARNING fail_ "'fail_' remains in code" #-}-fail_ :: a :-> c-fail_ = unit # failWith--------------------------------------------------------------------------------- Assertions-------------------------------------------------------------------------------assert :: IsError err => err -> Bool & s :-> s-assert reason = if_ nop (failUsing reason)--assertEq0 :: (IfCmp0Constraints a Eq', IsError err) => err -> a & s :-> s-assertEq0 reason = ifEq0 nop (failUsing reason)--assertNeq0 :: (IfCmp0Constraints a Neq, IsError err) => err -> a & s :-> s-assertNeq0 reason = ifNeq0 nop (failUsing reason)--assertLt0 :: (IfCmp0Constraints a Lt, IsError err) => err -> a & s :-> s-assertLt0 reason = ifLt0 nop (failUsing reason)--assertGt0 :: (IfCmp0Constraints a Gt, IsError err) => err -> a & s :-> s-assertGt0 reason = ifGt0 nop (failUsing reason)--assertLe0 :: (IfCmp0Constraints a Le, IsError err) => err -> a & s :-> s-assertLe0 reason = ifLe0 nop (failUsing reason)--assertGe0 :: (IfCmp0Constraints a Ge, IsError err) => err -> a & s :-> s-assertGe0 reason = ifGe0 nop (failUsing reason)--assertEq :: (NiceComparable a, IsError err) => err -> a & a & s :-> s-assertEq reason = ifEq nop (failUsing reason)--assertNeq :: (NiceComparable a, IsError err) => err -> a & a & s :-> s-assertNeq reason = ifNeq nop (failUsing reason)--assertLt :: (NiceComparable a, IsError err) => err -> a & a & s :-> s-assertLt reason = ifLt nop (failUsing reason)--assertGt :: (NiceComparable a, IsError err) => err -> a & a & s :-> s-assertGt reason = ifGt nop (failUsing reason)--assertLe :: (NiceComparable a, IsError err) => err -> a & a & s :-> s-assertLe reason = ifLe nop (failUsing reason)--assertGe :: (NiceComparable a, IsError err) => err -> a & a & s :-> s-assertGe reason = ifGe nop (failUsing reason)--assertNone :: IsError err => err -> Maybe a & s :-> s-assertNone reason = ifNone nop (failUsing reason)--assertSome :: IsError err => err -> Maybe a & s :-> a & s-assertSome reason = ifNone (failUsing reason) nop--assertLeft :: IsError err => err -> Either a b & s :-> a & s-assertLeft reason = ifLeft nop (failUsing reason)--assertRight :: IsError err => err -> Either a b & s :-> b & s-assertRight reason = ifLeft (failUsing reason) nop--assertUsing-  :: IsError a-  => a -> Bool & s :-> s-assertUsing err = if_ nop $ failUsing err--------------------------------------------------------------------------------- Syntactic Conveniences--------------------------------------------------------------------------------- | Custom Lorentz macro that drops element with given index--- (starting from 0) from the stack.-dropX-  :: forall (n :: GHC.Nat) a inp out s s'.-  ( ConstraintDIPNLorentz (ToPeano n) inp out s s'-  , s ~ (a ': s')-  )-  => inp :-> out-dropX = dipN @n @inp @out @s @s' drop--class CloneX (n :: Peano) a s where-  type CloneXT n a s :: [Kind.Type]-  cloneXImpl :: a & s :-> CloneXT n a s-instance CloneX 'Z a s where-  type CloneXT 'Z a s = a & s-  cloneXImpl = nop-instance (CloneX n a s) => CloneX ('S n) a s where-  type CloneXT ('S n) a s = a ': CloneXT n a s-  cloneXImpl = dup # dip (cloneXImpl @n)---- | Duplicate the top of the stack @n@ times.------ For example, `cloneX @3` has type `a & s :-> a & a & a & a & s`.-cloneX-  :: forall (n :: GHC.Nat) a s. CloneX (ToPeano n) a s-  => a & s :-> CloneXT (ToPeano n) a s-cloneX = cloneXImpl @(ToPeano n)---- | Kind-agnostic constraint for duupX-type DuupXConstraint' kind (n :: Peano)-  (s :: [kind]) (a :: kind) (s1 :: [kind]) (tail :: [kind]) =-  ( tail ~ Drop ('S n) s-  , ConstraintDIPN' kind n s s1 (a ': tail) (a ': a ': tail)-  , ConstraintDIG' kind n s1 (a ': s) a-  )---- | Constraint for duupX that combines kind-agnostic constraint for--- Lorentz (Haskell) types and for our typed Michelson.-type ConstraintDuupXLorentz (n :: Peano)-  (s :: [Kind.Type]) (a :: Kind.Type)-  (s1 :: [Kind.Type]) (tail :: [Kind.Type]) =-  ( DuupXConstraint' T n (ToTs s) (ToT a) (ToTs s1) (ToTs tail)-  , DuupXConstraint' Kind.Type n s a s1 tail-  )--class DuupX (n :: Peano) (s :: [Kind.Type]) (a :: Kind.Type) s1 tail where-  duupXImpl :: s :-> a ': s--instance {-# OVERLAPPING #-} (s ~ (a ': xs)) => DuupX ('S 'Z) s a s1 tail where-  duupXImpl = dup--instance {-# OVERLAPPING #-} DuupX ('S ('S 'Z)) (b ': a ': xs) a s1 tail where-  duupXImpl = dip dup # swap--instance {-# OVERLAPPABLE #-} (ConstraintDuupXLorentz ('S ('S n)) s a s1 tail) =>-  DuupX ('S ('S ('S n))) s a s1 tail where-  duupXImpl =-    -- 'stackType' helps GHC deduce types-    dipNPeano @('S ('S n)) (dup # stackType @(a ': a ': tail)) #-    digPeano @('S ('S n))---- | @DUU+P@ macro. For example, `duupX @3` is `DUUUP`, it puts--- the 3-rd (starting from 1) element to the top of the stack.--- Note that it is implemented differently for `n ≤ 2` and for `n > 2`.--- In the latter case it is implemented using `dipN`, `dig` and `dup`.--- In the former case it uses specialized versions.--- There is also a minor difference with the implementation of `DUU*P` in--- Michelson.--- They implement `DUUUUP` as `DIP 3 { DUP }; DIG 4`.--- We implement it as `DIP 3 { DUP }; DIG 3`. These are equivalent.--- Our version is supposedly cheaper, at least it should be packed--- more efficiently due to the way numbers are packed.-duupX :: forall (n :: GHC.Nat) a (s :: [Kind.Type]) (s1 :: [Kind.Type]) (tail :: [Kind.Type]).-  ( ConstraintDuupXLorentz (ToPeano (n - 1)) s a s1 tail-  , DuupX (ToPeano n) s a s1 tail-  )-  => s :-> a ': s-duupX = duupXImpl @(ToPeano n) @s @a @s1 @tail-  where-    _example ::-      '[ Integer, (), Bool ] :->-      '[ Bool, Integer, (), Bool ]-    _example = duupX @3---- | Version of 'framed' which accepts number of elements on input stack--- which should be preserved.------ You can treat this macro as calling a Michelson function with given number--- of arguments.-framedN-  :: forall n nNat s i i' o o'.-     ( nNat ~ ToPeano n-     , i' ~ Take nNat i, s ~ Drop nNat i-     , i ~ (i' ++ s), o ~ (o' ++ s)-     , KnownList i', KnownList o'-     )-  => (i' :-> o') -> (i :-> o)-framedN = framed @s-  where-  _example-    :: [Integer, Natural] :-> '[ByteString]-    -> Integer : Natural : () : s :-> ByteString : () : s-  _example = framedN @2--papair :: a & b & c & s :-> ((a, b), c) & s-papair = pair # pair--ppaiir :: a & b & c & s :-> (a, (b, c)) & s-ppaiir = dip pair # pair--unpair :: (a, b) & s :-> a & b & s-unpair = dup # car # dip cdr--cdar :: (a1, (a2, b)) & s :-> a2 & s-cdar = cdr # car--cddr :: (a1, (a2, b)) & s :-> b & s-cddr = cdr # cdr--caar :: ((a, b1), b2) & s :-> a & s-caar = car # car--cadr :: ((a, b1), b2) & s :-> b1 & s-cadr = car # cdr--setCar :: (a, b1) & (b2 & s) :-> (b2, b1) & s-setCar = cdr # swap # pair--setCdr :: (a, b1) & (b2 & s) :-> (a, b2) & s-setCdr = car # pair--mapCar-  :: a & s :-> a1 & s-  -> (a, b) & s :-> (a1, b) & s-mapCar op = dup # cdr # dip (car # op) # swap # pair--mapCdr-  :: b & (a, b) & s :-> b1 & (a, b) & s-  -> (a, b) & s :-> (a, b1) & s-mapCdr op = dup # cdr # op # swap # car # pair--ifRight :: (b & s :-> s') -> (a & s :-> s') -> (Either a b & s :-> s')-ifRight l r = ifLeft r l--ifSome-  :: (a & s :-> s') -> (s :-> s') -> (Maybe a & s :-> s')-ifSome s n = ifNone n s--when_ :: (s :-> s) -> (Bool : s :-> s)-when_ i = if_ i nop--unless_ :: (s :-> s) -> (Bool : s :-> s)-unless_ i = if_ nop i--whenSome :: (a : s :-> s) -> (Maybe a : s :-> s)-whenSome i = ifSome i nop---- | Various convenient instructions on maps.-class MapInstrs map where-  -- | Specialized version of 'update'.-  mapUpdate :: IsComparable k => k : Maybe v : map k v : s :-> map k v : s--  -- | Insert given element into map.-  mapInsert :: IsComparable k => k : v : map k v : s :-> map k v : s-  mapInsert = dip some # mapUpdate--  -- | Insert given element into map, ensuring that it does not overwrite-  -- any existing entry.-  ---  -- As first argument accepts container name (for error message).-  mapInsertNew-    :: (IsComparable k, KnownValue e)-    => (forall s0. k : s0 :-> e : s0)-    -> k : v : map k v : s :-> map k v : s--  -- | Delete element from the map.-  deleteMap-    :: forall k v s. (IsComparable k, KnownValue k, KnownValue v)-    => k : map k v : s :-> map k v : s-  deleteMap = dip (none @v) # mapUpdate--instance MapInstrs Map where-  mapUpdate = update-  mapInsertNew mkErr = failingWhenPresent mkErr # mapInsert-instance MapInstrs BigMap where-  mapUpdate = update-  mapInsertNew mkErr = failingWhenPresent mkErr # mapInsert---- | Insert given element into set.------ This is a separate function from 'updateMap' because stacks they operate with--- differ in length.-setInsert :: IsComparable e => e & Set e & s :-> Set e & s-setInsert = dip (push True) # update---- | Insert given element into set, ensuring that it does not overwrite--- any existing entry.------ As first argument accepts container name.-setInsertNew-  :: (IsComparable e, KnownValue err)-  => (forall s0. e : s0 :-> err : s0)-  -> e & Set e & s :-> Set e & s-setInsertNew desc = dip (push True) # failingWhenPresent desc # update---- | Delete given element from the set.-setDelete :: IsComparable e => e & Set e & s :-> Set e & s-setDelete = dip (push False) # update--------------------------------------------------------------------------------- Additional Morley macros--------------------------------------------------------------------------------- | @view@ type synonym as described in A1.-data View (a :: Kind.Type) (r :: Kind.Type) = View-  { viewParam :: a-  , viewCallbackTo :: ContractRef r-  } deriving stock (Eq, Show, Generic)-    deriving anyclass IsoValue--instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (View a r) where-  typeDocMdDescription =-    "`View a r` accepts an argument of type `a` and callback contract \-    \which accepts `r` and returns result via calling that contract.\n\-    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/-/blob/c42e3f0f5e73669e84e615d69bee73281572eb0a/proposals/tzip-4/tzip-4.md#view-entrypoints)."-  typeDocMdReference = poly2TypeDocMdReference-  typeDocDependencies p =-    genericTypeDocDependencies p <>-    [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]-  typeDocHaskellRep =-    haskellRepNoFields $ concreteTypeDocHaskellRep @(View () Integer)-  typeDocMichelsonRep =-    concreteTypeDocMichelsonRep @(View () Integer)--instance {-# OVERLAPPABLE #-} Buildable a => Buildable (View a r) where-  build = buildView build--instance {-# OVERLAPPING  #-} Buildable (View () r) where-  build = buildView $ const "()"--buildViewTuple :: TupleF a => View a r -> Builder-buildViewTuple = buildView tupleF--buildView :: (a -> Builder) -> View a r -> Builder-buildView bfp (View {..}) =-  "(View param: " +| bfp viewParam |+ " callbackTo: " +| viewCallbackTo|+ ")"---- | Polymorphic version of 'View' constructor.-mkView :: ToContractRef r contract => a -> contract -> View a r-mkView a c = View a (toContractRef c)---- | Wrap internal representation of view into 'View' itself.------ 'View' is part of public standard and should not change often.-wrapView :: (a, ContractRef r) : s :-> View a r : s-wrapView = forcedCoerce_---- | Unwrap 'View' into its internal representation.------ 'View' is part of public standard and should not change often.-unwrapView :: View a r : s :-> (a, ContractRef r) : s-unwrapView = forcedCoerce_--view_ ::-     (NiceParameter r)-  => (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 #-  transferTokens # nil # swap # cons # pair---- | @void@ type synonym as described in A1.-data Void_ (a :: Kind.Type) (b :: Kind.Type) = Void_-  { voidParam :: a-    -- ^ Entry point argument.-  , voidResProxy :: Lambda b b-    -- ^ Type of result reported via 'failWith'.-  } deriving stock (Generic, Show)-    deriving anyclass IsoValue--instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (Void_ a r) where-  typeDocName _ = "Void"-  typeDocMdDescription =-    "`Void a r` accepts an argument of type `a` and returns a value of type \-    \`r` as contract error. To comply with general mechanism of contracts \-    \custom errors, void entrypoints execute `FAILWITH` instruction on \-    \`(\"VoidResult\", r)` value, where `r` is the actual return value of the \-    \entrypoint.\n\-    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/-/blob/c42e3f0f5e73669e84e615d69bee73281572eb0a/proposals/tzip-4/tzip-4.md#void-entrypoints)."-  typeDocMdReference tp =-    -- Avoiding trailing underscore-    customTypeDocMdReference-      ("Void", DType tp)-      [ DType (Proxy @a)-      , DType (Proxy @r)-      ]-  typeDocDependencies p =-    genericTypeDocDependencies p <>-    [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]-  typeDocHaskellRep p = do-    (_, rhs) <- haskellRepNoFields (concreteTypeDocHaskellRep @(Void_ () Integer)) p-    return (Just "Void () Integer", rhs)-  typeDocMichelsonRep p =-    let (_, rhs) = concreteTypeDocMichelsonRep @(Void_ () Integer) p-    in (Just "Void () Integer", rhs)--instance Buildable a => Buildable (Void_ a b) where-  build Void_ {..} = "(Void param: " +| voidParam |+ ")"---- | Newtype over void result type used in tests to--- distinguish successful void result from other errors.------ Usage example:--- lExpectFailWith (== VoidResult roleMaster)`------ This error is special - it can contain arguments of different types--- depending on entrypoint which raises it.-newtype VoidResult r = VoidResult { unVoidResult :: r }-  deriving stock (Generic)-  deriving newtype (Eq)--voidResultTag :: MText-voidResultTag = [mt|VoidResult|]--type VoidResultRep r = (MText, r)--instance (TypeHasDoc r, IsError (VoidResult r)) => TypeHasDoc (VoidResult r) where-  typeDocMdDescription = typeDocMdDescriptionReferToError @(VoidResult r)-  typeDocMdReference = poly1TypeDocMdReference-  typeDocHaskellRep = concreteTypeDocHaskellRepUnsafe @(VoidResultRep Integer)-  typeDocMichelsonRep = concreteTypeDocMichelsonRepUnsafe @(VoidResultRep Integer)--instance (Typeable r, NiceConstant r, ErrorHasDoc (VoidResult r)) =>-         IsError (VoidResult r) where-  errorToVal (VoidResult e) cont =-    withDict (niceConstantEvi @r) $-    isoErrorToVal @(VoidResultRep r) (voidResultTag, e) cont-  errorFromVal fullErr =-    isoErrorFromVal fullErr >>= \((tag, e) :: VoidResultRep r) ->-      if tag == voidResultTag-      then pure $ VoidResult e-      else Left $ "Error mismatch, expected VoidResult, got " <> pretty tag--instance TypeHasDoc r => ErrorHasDoc (VoidResult r) where-  errorDocName = "VoidResult"-  errorDocMdCause =-    "Call to entrypoint has succeeded, reporting returned value as error.\n\-    \As Tezos contracts normally do not produce any output (not counting storage \-    \update), this is the simplest way to return something to the caller in \-    \read-only entrypoints."-  errorDocHaskellRep =-    mdTicked ("(\"" <> pretty (voidResultTag) <> "\", " <> "<return value>" <> ")")-  errorDocDependencies =-    typeDocDependencies' (Proxy @MText) <> typeDocDependencies' (Proxy @r)--instance CustomErrorNoIsoValue (VoidResult r) => IsoValue (VoidResult r) where-  type ToT (VoidResult r) = CustomErrorNoIsoValue (VoidResult r)-  toVal = error "impossible"-  fromVal = error "impossible"--mkVoid :: forall b a. a -> Void_ a b-mkVoid a = Void_ a nop--void_-  :: forall a b s s' anything.-      (IsError (VoidResult b), KnownValue b)-  => a & s :-> b & s' -> Void_ a b & s :-> anything-void_ code =-  doc (DThrows (Proxy @(VoidResult b))) #-  forcedCoerce_ @_ @(_, Lambda b b) #-  unpair # swap # dip code # swap # exec #-  push voidResultTag # pair # failWith @(MText, b)--addressToEpAddress :: Address : s :-> EpAddress : s-addressToEpAddress = forcedCoerce_---- | Push a value of @contract@ type.------ Doing this via 'push' instruction is not possible, so we need to perform--- extra actions here.------ Aside from @contract@ value itself you will need to specify which error to--- throw in case this value is not valid.-pushContractRef-  :: NiceParameter arg-  => (forall s0. FutureContract arg : s :-> s0)-  -> ContractRef arg-  -> (s :-> ContractRef arg : s)-pushContractRef onContractNotFound (contractRef :: ContractRef arg) =-  withDict (niceParameterEvi @arg) $-    push (FutureContract contractRef) # dup #-    runFutureContract # ifNone onContractNotFound (dip drop)