diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,13 @@ ========== +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 ===== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 - - - -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. diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -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 diff --git a/src/Lorentz.hs b/src/Lorentz.hs deleted file mode 100644 --- a/src/Lorentz.hs +++ /dev/null @@ -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 () diff --git a/src/Lorentz/ADT.hs b/src/Lorentz/ADT.hs deleted file mode 100644 --- a/src/Lorentz/ADT.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Arith.hs b/src/Lorentz/Arith.hs deleted file mode 100644 --- a/src/Lorentz/Arith.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Base.hs b/src/Lorentz/Base.hs deleted file mode 100644 --- a/src/Lorentz/Base.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Coercions.hs b/src/Lorentz/Coercions.hs deleted file mode 100644 --- a/src/Lorentz/Coercions.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Common.hs b/src/Lorentz/Common.hs deleted file mode 100644 --- a/src/Lorentz/Common.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Constraints.hs b/src/Lorentz/Constraints.hs deleted file mode 100644 --- a/src/Lorentz/Constraints.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lorentz.Constraints - ( module Exports - ) where - -import Lorentz.Constraints.Derivative as Exports -import Lorentz.Constraints.Scopes as Exports diff --git a/src/Lorentz/Constraints/Derivative.hs b/src/Lorentz/Constraints/Derivative.hs deleted file mode 100644 --- a/src/Lorentz/Constraints/Derivative.hs +++ /dev/null @@ -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) diff --git a/src/Lorentz/Constraints/Scopes.hs b/src/Lorentz/Constraints/Scopes.hs deleted file mode 100644 --- a/src/Lorentz/Constraints/Scopes.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/ContractRegistry.hs b/src/Lorentz/ContractRegistry.hs deleted file mode 100644 --- a/src/Lorentz/ContractRegistry.hs +++ /dev/null @@ -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") diff --git a/src/Lorentz/Doc.hs b/src/Lorentz/Doc.hs deleted file mode 100644 --- a/src/Lorentz/Doc.hs +++ /dev/null @@ -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])) - ) diff --git a/src/Lorentz/Empty.hs b/src/Lorentz/Empty.hs deleted file mode 100644 --- a/src/Lorentz/Empty.hs +++ /dev/null @@ -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") diff --git a/src/Lorentz/EntryPoints.hs b/src/Lorentz/EntryPoints.hs deleted file mode 100644 --- a/src/Lorentz/EntryPoints.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/EntryPoints/Core.hs b/src/Lorentz/EntryPoints/Core.hs deleted file mode 100644 --- a/src/Lorentz/EntryPoints/Core.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/EntryPoints/Doc.hs b/src/Lorentz/EntryPoints/Doc.hs deleted file mode 100644 --- a/src/Lorentz/EntryPoints/Doc.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/EntryPoints/Helpers.hs b/src/Lorentz/EntryPoints/Helpers.hs deleted file mode 100644 --- a/src/Lorentz/EntryPoints/Helpers.hs +++ /dev/null @@ -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")) diff --git a/src/Lorentz/EntryPoints/Impl.hs b/src/Lorentz/EntryPoints/Impl.hs deleted file mode 100644 --- a/src/Lorentz/EntryPoints/Impl.hs +++ /dev/null @@ -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 = () diff --git a/src/Lorentz/EntryPoints/Manual.hs b/src/Lorentz/EntryPoints/Manual.hs deleted file mode 100644 --- a/src/Lorentz/EntryPoints/Manual.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Errors.hs b/src/Lorentz/Errors.hs deleted file mode 100644 --- a/src/Lorentz/Errors.hs +++ /dev/null @@ -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 <> "\", " <> "" <> ")") - 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" #-} diff --git a/src/Lorentz/Errors/Common.hs b/src/Lorentz/Errors/Common.hs deleted file mode 100644 --- a/src/Lorentz/Errors/Common.hs +++ /dev/null @@ -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." diff --git a/src/Lorentz/Errors/Numeric.hs b/src/Lorentz/Errors/Numeric.hs deleted file mode 100644 --- a/src/Lorentz/Errors/Numeric.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Ext.hs b/src/Lorentz/Ext.hs deleted file mode 100644 --- a/src/Lorentz/Ext.hs +++ /dev/null @@ -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 & _) diff --git a/src/Lorentz/Extensible.hs b/src/Lorentz/Extensible.hs deleted file mode 100644 --- a/src/Lorentz/Extensible.hs +++ /dev/null @@ -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 - ] diff --git a/src/Lorentz/Instr.hs b/src/Lorentz/Instr.hs deleted file mode 100644 --- a/src/Lorentz/Instr.hs +++ /dev/null @@ -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 diff --git a/src/Lorentz/Macro.hs b/src/Lorentz/Macro.hs deleted file mode 100644 --- a/src/Lorentz/Macro.hs +++ /dev/null @@ -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) <> "\", " <> "" <> ")") - 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) diff --git a/src/Lorentz/Pack.hs b/src/Lorentz/Pack.hs deleted file mode 100644 --- a/src/Lorentz/Pack.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | Packing utilities. -module Lorentz.Pack - ( lPackValue - , lUnpackValue - ) where - -import Data.Constraint ((\\)) - -import Lorentz.Constraints -import Michelson.Interpret.Pack -import Michelson.Interpret.Unpack -import Michelson.Typed - -lPackValue - :: forall a. - (NicePackedValue a) - => a -> ByteString -lPackValue = - packValue' . toVal \\ nicePackedValueEvi @a - -lUnpackValue - :: forall a. - (NiceUnpackedValue a) - => ByteString -> Either UnpackError a -lUnpackValue = - fmap fromVal . unpackValue' \\ niceUnpackedValueEvi @a diff --git a/src/Lorentz/Polymorphic.hs b/src/Lorentz/Polymorphic.hs deleted file mode 100644 --- a/src/Lorentz/Polymorphic.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE QuantifiedConstraints #-} - --- | Type families from 'Michelson.Typed.Polymorphic' lifted to Haskell types. -module Lorentz.Polymorphic - ( MemOpHs (..) - , MapOpHs (..) - , IterOpHs (..) - , SizeOpHs - , UpdOpHs (..) - , GetOpHs (..) - , ConcatOpHs - , SliceOpHs - , EDivOpHs (..) - - , IsoMapOpRes - ) where - -import qualified Data.Kind as Kind - -import Michelson.Text -import Michelson.Typed -import Tezos.Core (Mutez) - ----------------------------------------------------------------------------- --- Mirrored from Michelson ----------------------------------------------------------------------------- - --- | Lifted 'MemOpKey'. -class ( MemOp (ToT c) - , ToT (MemOpKeyHs c) ~ 'Tc (MemOpKey (ToT c)) - ) => MemOpHs c where - type MemOpKeyHs c :: Kind.Type - -instance IsComparable e => MemOpHs (Set e) where - type MemOpKeyHs (Set e) = e - -instance IsComparable k => MemOpHs (Map k v) where - type MemOpKeyHs (Map k v) = k - -instance IsComparable k => MemOpHs (BigMap k v) where - type MemOpKeyHs (BigMap k v) = k - --- | A useful property which holds for reasonable 'MapOp' instances. --- --- It's a separate thing from 'MapOpHs' because it mentions @b@ type parameter. -type family IsoMapOpRes c b where - IsoMapOpRes c b = ToT (MapOpResHs c b) ~ MapOpRes (ToT c) (ToT b) - --- | Lifted 'MapOp'. -class ( MapOp (ToT c) - , ToT (MapOpInpHs c) ~ MapOpInp (ToT c) - , ToT (MapOpResHs c ()) ~ MapOpRes (ToT c) (ToT ()) - ) => MapOpHs c where - type MapOpInpHs c :: Kind.Type - type MapOpResHs c :: Kind.Type -> Kind.Type - -instance IsComparable k => MapOpHs (Map k v) where - type MapOpInpHs (Map k v) = (k, v) - type MapOpResHs (Map k v) = Map k - -instance MapOpHs [e] where - type MapOpInpHs [e] = e - type MapOpResHs [e] = [] - --- | Lifted 'IterOp'. -class ( IterOp (ToT c) - , ToT (IterOpElHs c) ~ IterOpEl (ToT c) - ) => IterOpHs c where - type IterOpElHs c :: Kind.Type - -instance IsComparable k => IterOpHs (Map k v) where - type IterOpElHs (Map k v) = (k, v) - -instance IterOpHs [e] where - type IterOpElHs [e] = e - -instance IsComparable e => IterOpHs (Set e) where - type IterOpElHs (Set e) = e - --- | Lifted 'SizeOp'. --- --- This could be just a constraint alias, but to avoid 'T' types appearance in --- error messages we make a full type class with concrete instances. -class SizeOp (ToT c) => SizeOpHs c - -instance SizeOpHs MText -instance SizeOpHs ByteString -instance SizeOpHs (Set a) -instance SizeOpHs [a] -instance SizeOpHs (Map k v) - --- | Lifted 'UpdOp'. -class ( UpdOp (ToT c) - , ToT (UpdOpKeyHs c) ~ 'Tc (UpdOpKey (ToT c)) - , ToT (UpdOpParamsHs c) ~ UpdOpParams (ToT c) - ) => UpdOpHs c where - type UpdOpKeyHs c :: Kind.Type - type UpdOpParamsHs c :: Kind.Type - -instance IsComparable k => UpdOpHs (Map k v) where - type UpdOpKeyHs (Map k v) = k - type UpdOpParamsHs (Map k v) = Maybe v - -instance IsComparable k => UpdOpHs (BigMap k v) where - type UpdOpKeyHs (BigMap k v) = k - type UpdOpParamsHs (BigMap k v) = Maybe v - -instance IsComparable a => UpdOpHs (Set a) where - type UpdOpKeyHs (Set a) = a - type UpdOpParamsHs (Set a) = Bool - --- | Lifted 'GetOp'. -class ( GetOp (ToT c) - , ToT (GetOpKeyHs c) ~ 'Tc (GetOpKey (ToT c)) - , ToT (GetOpValHs c) ~ GetOpVal (ToT c) - ) => GetOpHs c where - type GetOpKeyHs c :: Kind.Type - type GetOpValHs c :: Kind.Type - -instance IsComparable k => GetOpHs (Map k v) where - type GetOpKeyHs (Map k v) = k - type GetOpValHs (Map k v) = v - -instance IsComparable k => GetOpHs (BigMap k v) where - type GetOpKeyHs (BigMap k v) = k - type GetOpValHs (BigMap k v) = v - --- | Lifted 'ConcatOp'. -class ConcatOp (ToT c) => ConcatOpHs c - -instance ConcatOpHs MText -instance ConcatOpHs ByteString - --- | Lifted 'SliceOp'. -class SliceOp (ToT c) => SliceOpHs c - -instance SliceOpHs MText -instance SliceOpHs ByteString - --- | Lifted 'EDivOp'. -class ( EDivOp (ToCT n) (ToCT m) - , IsComparable n, IsComparable m - , ToT (EDivOpResHs n m) ~ 'Tc (EDivOpRes (ToCT n) (ToCT m)) - , ToT (EModOpResHs n m) ~ 'Tc (EModOpRes (ToCT n) (ToCT m)) - ) => EDivOpHs n m where - type EDivOpResHs n m :: Kind.Type - type EModOpResHs n m :: Kind.Type - -instance EDivOpHs Integer Integer where - type EDivOpResHs Integer Integer = Integer - type EModOpResHs Integer Integer = Natural - -instance EDivOpHs Integer Natural where - type EDivOpResHs Integer Natural = Integer - type EModOpResHs Integer Natural = Natural - -instance EDivOpHs Natural Integer where - type EDivOpResHs Natural Integer = Integer - type EModOpResHs Natural Integer = Natural - -instance EDivOpHs Natural Natural where - type EDivOpResHs Natural Natural = Natural - type EModOpResHs Natural Natural = Natural - -instance EDivOpHs Mutez Mutez where - type EDivOpResHs Mutez Mutez = Natural - type EModOpResHs Mutez Mutez = Mutez - -instance EDivOpHs Mutez Natural where - type EDivOpResHs Mutez Natural = Mutez - type EModOpResHs Mutez Natural = Mutez diff --git a/src/Lorentz/Prelude.hs b/src/Lorentz/Prelude.hs deleted file mode 100644 --- a/src/Lorentz/Prelude.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | Commonly used parts of regular Prelude. -module Lorentz.Prelude - ( ($) - , (.) - , type ($) - , Eq - , Ord - , Bounded (..) - , Semigroup (..) - , Monoid (..) - , Generic - , Text - , Either (..) - , Maybe (..) - , Proxy (..) - , fromString - , undefined - , error - ) where diff --git a/src/Lorentz/Print.hs b/src/Lorentz/Print.hs deleted file mode 100644 --- a/src/Lorentz/Print.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- | Printing lorentz contracts. -module Lorentz.Print - ( printLorentzValue - , printLorentzContract - ) where - - -import Lorentz.Base -import Lorentz.Constraints -import Lorentz.Run -import Michelson.Printer (printTypedFullContract, printTypedValue) -import Michelson.Typed (toVal) - --- | Pretty-print a Haskell value as Michelson one. -printLorentzValue - :: forall v. - (NicePrintedValue v) - => Bool -> v -> LText -printLorentzValue forceSingleLine = - withDict (nicePrintedValueEvi @v) $ - printTypedValue forceSingleLine . toVal - --- | Pretty-print a Lorentz contract into Michelson code. -printLorentzContract - :: forall cp st. - (NiceParameterFull cp, NiceStorage st) - => Bool -> Contract cp st -> LText -printLorentzContract forceSingleLine = - printTypedFullContract forceSingleLine . compileLorentzContract diff --git a/src/Lorentz/Rebinded.hs b/src/Lorentz/Rebinded.hs deleted file mode 100644 --- a/src/Lorentz/Rebinded.hs +++ /dev/null @@ -1,179 +0,0 @@ -{- | Reimplementation of some syntax sugar. - -You need the following module pragmas to make it work smoothly: - -{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} - --} -module Lorentz.Rebinded - ( (>>) - , pure - , return - , ifThenElse - , Condition (..) - , (<.) - , (>.) - , (<=.) - , (>=.) - , (==.) - , (/=.) - , keepIfArgs - - -- * Re-exports required for RebindableSyntax - , fromInteger - , fromString - , fromLabel - ) where - - -import Prelude hiding (drop, swap, (>>), (>>=)) - -import Data.Vinyl.Derived (Label) -import Named ((:!)) - -import Lorentz.Arith -import Lorentz.Base -import Lorentz.Coercions -import Lorentz.Instr -import Lorentz.Macro -import Michelson.Typed.Arith - --- | Aliases for '(#)' used by do-blocks. -(>>) :: (a :-> b) -> (b :-> c) -> (a :-> c) -(>>) = (#) - --- | Predicate for @if ... then .. else ...@ construction, --- defines a kind of operation applied to the top elements of the current stack. --- --- Type arguments mean: --- 1. Input of @if@ --- 2. Left branch input --- 3. Right branch input --- 4. Output of branches --- 5. Output of @if@ -data Condition arg argl argr outb out where - Holds :: Condition (Bool ': s) s s o o - IsSome :: Condition (Maybe a ': s) (a ': s) s o o - IsNone :: Condition (Maybe a ': s) s (a ': s) o o - IsLeft :: Condition (Either l r ': s) (l ': s) (r ': s) o o - IsRight :: Condition (Either l r ': s) (r ': s) (l ': s) o o - IsCons :: Condition ([a] ': s) (a ': [a] ': s) s o o - IsNil :: Condition ([a] ': s) s (a ': [a] ': s) o o - - IsZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool) - => Condition (a ': s) s s o o - IsNotZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool) - => Condition (a ': s) s s o o - - IsEq :: NiceComparable a => Condition (a ': a ': s) s s o o - IsNeq :: NiceComparable a => Condition (a ': a ': s) s s o o - IsLt :: NiceComparable a => Condition (a ': a ': s) s s o o - IsGt :: NiceComparable a => Condition (a ': a ': s) s s o o - IsLe :: NiceComparable a => Condition (a ': a ': s) s s o o - IsGe :: NiceComparable a => Condition (a ': a ': s) s s o o - - -- | Explicitly named binary condition, to ensure proper order of - -- stack arguments. - NamedBinCondition :: - Condition (a ': a ': s) s s o o -> - Label n1 -> Label n2 -> - Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o - - -- | Provide the compared arguments to @if@ branches. - PreserveArgsBinCondition :: - (forall st o. Condition (a ': b ': st) st st o o) -> - Condition (a ': b ': s) (a ': b ': s) (a ': b ': s) (a ': b ': s) s - --- | Defines semantics of @if ... then ... else ...@ construction. -ifThenElse - :: Condition arg argl argr outb out - -> (argl :-> outb) -> (argr :-> outb) -> (arg :-> out) -ifThenElse = \case - Holds -> if_ - IsSome -> flip ifNone - IsNone -> ifNone - IsLeft -> ifLeft - IsRight -> flip ifLeft - IsCons -> ifCons - IsNil -> flip ifCons - - IsZero -> \l r -> eq0 # if_ l r - IsNotZero -> \l r -> eq0 # if_ r l - - IsEq -> ifEq - IsNeq -> ifNeq - IsLt -> ifLt - IsGt -> ifGt - IsLe -> ifLe - IsGe -> ifGe - - NamedBinCondition condition l1 l2 -> \l r -> - fromNamed l1 # dip (fromNamed l2) # ifThenElse condition l r - - PreserveArgsBinCondition condition -> \l r -> - dip dup # swap # dip dup # swap # - ifThenElse condition - -- since this pattern is commonly used when one of the branches fails, - -- it's essential to @drop@ within branches, not after @if@ - @drop@s - -- appearing to be dead code will be cut off - (l # drop # drop) - (r # drop # drop) - --- | Named version of 'IsLt'. --- --- In this and similar operators you provide names of accepted stack operands as --- a safety measure of that they go in the expected order. -infix 4 <. -(<.) - :: NiceComparable a - => Label n1 -> Label n2 - -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o -(<.) = NamedBinCondition IsLt - --- | Named version of 'IsGt'. -infix 4 >. -(>.) - :: NiceComparable a - => Label n1 -> Label n2 - -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o -(>.) = NamedBinCondition IsGt - --- | Named version of 'IsLe'. -infix 4 <=. -(<=.) - :: NiceComparable a - => Label n1 -> Label n2 - -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o -(<=.) = NamedBinCondition IsLe - --- | Named version of 'IsGe'. -infix 4 >=. -(>=.) - :: NiceComparable a - => Label n1 -> Label n2 - -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o -(>=.) = NamedBinCondition IsGe - --- | Named version of 'IsEq'. -infix 4 ==. -(==.) - :: NiceComparable a - => Label n1 -> Label n2 - -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o -(==.) = NamedBinCondition IsEq - --- | Named version of 'IsNeq'. -infix 4 /=. -(/=.) - :: NiceComparable a - => Label n1 -> Label n2 - -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o -(/=.) = NamedBinCondition IsNeq - --- | Condition modifier, makes stack operands of binary comparison to be --- available within @if@ branches. -keepIfArgs - :: (forall st o. Condition (a ': b ': st) st st o o) - -> Condition (a ': b ': s) (a ': b ': s) (a ': b ': s) (a ': b ': s) s -keepIfArgs = PreserveArgsBinCondition diff --git a/src/Lorentz/Referenced.hs b/src/Lorentz/Referenced.hs deleted file mode 100644 --- a/src/Lorentz/Referenced.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} - --- | Referenced-by-type versions of some instructions. --- --- They allow to "dip" into stack or copy elements of stack referring them --- by type. Their use is justified, because in most cases there is only --- one element of each type of stack, and in cases when this does not hold --- (e.g. entrypoint with multiple parameters of the same type), it might be --- a good idea to wrap those types into a newtype or to use primitives from --- 'named' package. --- --- This module is experimental, i.e. everything here should work but may be --- removed in favor of better development practices. --- --- Each instruction is followed with usage example. -module Lorentz.Referenced - ( dupT - , dipT - , dropT - ) where - -import Prelude hiding (drop, swap) - -import qualified Data.Kind as Kind -import Data.Type.Bool (If) -import GHC.TypeLits (ErrorMessage(..), TypeError) - -import Lorentz.Base -import Lorentz.Instr -import Util.Type - --- Errors ----------------------------------------------------------------------------- - -type family StackElemNotFound st a :: ErrorMessage where - StackElemNotFound st a = - 'Text "Element of type `" ':<>: 'ShowType a ':<>: - 'Text "` is not present on stack" ':$$: 'ShowType st - -type family StackElemAmbiguous st a :: ErrorMessage where - StackElemAmbiguous st a = - 'Text "Ambigous reference to element of type `" ':<>: 'ShowType a ':<>: - 'Text "` for stack" ':$$: 'ShowType st - --- Dup ----------------------------------------------------------------------------- - --- | Allows duplicating stack elements referring them by type. -class DupT (origSt :: [Kind.Type]) (a :: Kind.Type) (st :: [Kind.Type]) where - dupTImpl :: st :-> a : st - -instance TypeError (StackElemNotFound origSt a) => - DupT origSt a '[] where - dupTImpl = error "impossible" - -instance {-# OVERLAPPING #-} - If (a `IsElem` st) - (TypeError (StackElemAmbiguous origSt a)) - (() :: Constraint) => - DupT origSt a (a : st) where - dupTImpl = dup - -instance {-# OVERLAPPABLE #-} - DupT origSt a st => - DupT origSt a (b : st) where - dupTImpl = dip (dupTImpl @origSt) # swap - --- | Duplicate an element of stack referring it by type. --- --- If stack contains multiple entries of this type, compile error is raised. -dupT :: forall a st. DupT st a st => st :-> a : st -dupT = dupTImpl @st @a @st - -_dupSample1 :: [Integer, Text, ()] :-> [Text, Integer, Text, ()] -_dupSample1 = dupT @Text - --- Dip ----------------------------------------------------------------------------- - --- | Allows diving into stack referring expected new tip by type. --- --- Implemented with fun deps for conciseness; we can replace them --- with a type family anytime, but that would probably require more declarations. -class DipT (origInp :: [Kind.Type]) (a :: Kind.Type) - (inp :: [Kind.Type]) (dipInp :: [Kind.Type]) - (dipOut :: [Kind.Type]) (out :: [Kind.Type]) - | inp a -> dipInp, dipOut inp a -> out where - dipTImpl :: (dipInp :-> dipOut) -> (inp :-> out) - -instance ( TypeError (StackElemNotFound origSt a) - , dipInp ~ TypeError ('Text "Undefined type (see next error)") - , out ~ TypeError ('Text "Undefined type (see next error)") - ) => - DipT origSt a '[] dipInp dipOut out where - dipTImpl = error "impossible" - -instance {-# OVERLAPPING #-} - ( If (a `IsElem` st) - (TypeError (StackElemAmbiguous origSt a)) - (() :: Constraint) - , dipInp ~ (a : st) - , dipOut ~ out - ) => - DipT origSt a (a : st) dipInp dipOut out where - dipTImpl = id - -instance {-# OVERLAPPABLE #-} - ( DipT origSt a st dipInp dipOut out - , out1 ~ (b : out) - ) => - DipT origSt a (b : st) dipInp dipOut out1 where - dipTImpl = dip . dipTImpl @origSt @a @st - --- | Dip repeatedly until element of the given type is on top of the stack. --- --- If stack contains multiple entries of this type, compile error is raised. -dipT - :: forall a inp dinp dout out. - DipT inp a inp dinp dout out - => (dinp :-> dout) -> (inp :-> out) -dipT = dipTImpl @inp @a @inp @dinp - -_dipSample1 - :: [Natural, ()] - :-> '[ByteString] - -> [Integer, Text, Natural, ()] - :-> [Integer, Text, ByteString] -_dipSample1 = dipT @Natural - --- Drop ----------------------------------------------------------------------------- - --- | Remove element with the given type from the stack. -dropT - :: forall a inp dinp dout out. - ( DipT inp a inp dinp dout out - , dinp ~ (a ': dout) - ) - => inp :-> out -dropT = dipT @a drop - -_dropSample1 :: [Integer, (), Natural] :-> [Integer, Natural] -_dropSample1 = dropT @() - --- Framing ----------------------------------------------------------------------------- - -{- Note that there instructions are only usable for concrete stacks. - -When you know your stack only partially, and you try to refer to element of -type "X", then with the current approach compiler will require the unknown -part of stack to contain no elements of type "X", and this is annoying -at least because it ruins modularity. - -This issue can be resolved with using 'framed' instruction wrapper and family. - --} diff --git a/src/Lorentz/Run.hs b/src/Lorentz/Run.hs deleted file mode 100644 --- a/src/Lorentz/Run.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Lorentz.Run - ( CompilationOptions(..) - , compileLorentz - , compileLorentzContract - , compileLorentzContractWithOptions - , interpretLorentzInstr - , interpretLorentzLambda - , analyzeLorentz - ) where - -import Data.Constraint ((\\)) -import Data.Vinyl.Core (Rec(..)) - -import Lorentz.Base -import Lorentz.Constraints -import Lorentz.EntryPoints -import Michelson.Analyzer (AnalyzerRes, analyze) -import Michelson.Interpret -import Michelson.Typed - (FullContract(..), Instr(..), IsoValue, IsoValuesStack(..), ParamNotes(..), ToT, ToTs, isStar, - starNotes, unParamNotes) - --- | For use outside of Lorentz. -compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out) -compileLorentz = iAnyCode - --- | Version of 'compileLorentz' specialized to instruction corresponding to --- contract code. -compileLorentzContract - :: forall cp st. - (NiceParameterFull cp, NiceStorage st) - => Contract cp st -> FullContract (ToT cp) (ToT st) -compileLorentzContract = - compileLorentzContractWithOptions defaultCompilationOptions - -data CompilationOptions = CompilationOptions - { coDisableInitialCast :: Bool - -- ^ Flag which defines, whether compiled Michelson contract - -- will have @CAST@ (which drops parameter annotations) - -- as a first instruction. Note, that when - -- flag is false, there still can be no @CAST@ (in case - -- when parameter type has no annotations). - } - -defaultCompilationOptions :: CompilationOptions -defaultCompilationOptions = CompilationOptions { coDisableInitialCast = False } - --- | Version on 'compileLorentzContract' which accepts @CompilationOptions@. --- --- Note that compiled contract can be ill-typed in terms of Michelson code --- when some of the compilation options are used (e.g. when coDoInitialCast --- is False, resulted contract can be ill-typed). --- However, compilation with @defaultCompilationOptions@ should be valid. -compileLorentzContractWithOptions - :: forall cp st. - (NiceParameterFull cp, NiceStorage st) - => CompilationOptions -> Contract cp st -> FullContract (ToT cp) (ToT st) -compileLorentzContractWithOptions CompilationOptions{..} contract = - FullContract - { fcCode = if (isStar (unParamNotes cpNotes) || coDisableInitialCast) - then -- If contract parameter type has no annotations or explicitly asked, we drop CAST. - compileLorentz contract - else -- Perform CAST otherwise. - compileLorentz (I CAST # contract :: Contract cp st) - , fcParamNotesSafe = cpNotes - , fcStoreNotes = starNotes - } \\ niceParameterEvi @cp - \\ niceStorageEvi @st - where - cpNotes = parameterEntryPointsToNotes @cp - --- | Interpret a Lorentz instruction, for test purposes. -interpretLorentzInstr - :: (IsoValuesStack inp, IsoValuesStack out) - => ContractEnv - -> inp :-> out - -> Rec Identity inp - -> Either MichelsonFailed (Rec Identity out) -interpretLorentzInstr env (compileLorentz -> instr) inp = - fromValStack <$> interpretInstr env instr (toValStack inp) - --- | Like 'interpretLorentzInstr', but works on lambda rather than --- arbitrary instruction. -interpretLorentzLambda - :: (IsoValue inp, IsoValue out) - => ContractEnv - -> Lambda inp out - -> inp - -> Either MichelsonFailed out -interpretLorentzLambda env instr inp = do - res <- interpretLorentzInstr env instr (Identity inp :& RNil) - let Identity out :& RNil = res - return out - --- | Lorentz version of analyzer. -analyzeLorentz :: inp :-> out -> AnalyzerRes -analyzeLorentz = analyze . compileLorentz diff --git a/src/Lorentz/Store.hs b/src/Lorentz/Store.hs deleted file mode 100644 --- a/src/Lorentz/Store.hs +++ /dev/null @@ -1,701 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- | Impementation of @Store@ - object incapsulating multiple 'BigMap's. --- --- This module also provides template for the contract storage - --- 'StorageSkeleton'. --- --- We represent 'Store' as @big_map bytes (a | b | ...)@. --- --- Key of this map is formed as @(index, orig_key)@, where @index@ is --- zero-based index of emulated map, @orig_key@ is key of this emulated map. --- --- Value of this map is just a union of emulated map's values. - -{- Note on store inner representation (@martoon) - -I see an alternative approach - representing store as -@big_map bytes (option a, option b, ...)@. - -This would allow for saner implementation and more convenient interface. -An obvious shortcoming here is gas consumption. But this overhead seems -insignificant against the background of some other instructions. - --} -module Lorentz.Store - {-# DEPRECATED "Contract storage can contain multiple big_maps starting from Michelson 005" #-} - ( -- * Store and related type definitions - Store (..) - , type (|->) - - -- ** Type-lookup-by-name - , GetStoreKey - , GetStoreValue - - -- ** Instructions - , storeMem - , storeGet - , storeUpdate - , storeInsert - , storeInsertNew - , storeDelete - - -- ** Instruction constraints - , StoreMemC - , StoreGetC - , StoreUpdateC - , StoreInsertC - , StoreDeleteC - , HasStore - , HasStoreForAllIn - - -- * Storage skeleton - , StorageSkeleton (..) - , storageUnpack - , storagePack - , storageMem - , storageGet - , storageInsert - , storageInsertNew - , storageDelete - - -- * Store management from Haskell - , storePiece - , storeKeyValueList - , storeLookup - - -- ** Function constraints - , StorePieceC - ) where - -import Data.Constraint (Dict(..)) -import Data.Default (Default) -import qualified Data.Kind as Kind -import qualified Data.Map as Map -import Data.Type.Bool (If, type (||)) -import Data.Type.Equality (type (==)) -import Data.Vinyl.Derived (Label) -import GHC.Generics ((:+:)) -import qualified GHC.Generics as G -import GHC.TypeLits (AppendSymbol, ErrorMessage(..), KnownSymbol, Symbol, TypeError) -import GHC.TypeNats (type (+), Nat) -import Type.Reflection ((:~:)(Refl)) - -import Lorentz.ADT -import Lorentz.Base -import Lorentz.Coercions -import Lorentz.Constraints -import Lorentz.Instr as L -import Lorentz.Macro -import Lorentz.Pack -import Lorentz.StoreClass -import Michelson.Typed.Haskell.Instr.Sum -import Michelson.Typed.Haskell.Value -import Michelson.Typed.Instr - -{-# ANN module ("HLint: ignore Use 'natVal' from Universum" :: Text) #-} - ----------------------------------------------------------------------------- --- Store ----------------------------------------------------------------------------- - --- | Gathers multple 'BigMap's under one object. --- --- Type argument of this datatype stands for a "map template" - --- a datatype with multiple constructors, each containing an object of --- type '|->' and corresponding to single virtual 'BigMap'. --- It's also possible to parameterize it with a larger type which is --- a sum of types satisfying the above property. --- --- Inside it keeps only one 'BigMap' thus not violating Michelson limitations. --- --- See examples below. -newtype Store a = Store { unStore :: BigMap ByteString a } - deriving stock (Eq, Show) - deriving newtype (Default, Semigroup, Monoid, IsoValue) - --- | Describes one virtual big map. -data k |-> v = BigMapImage v - deriving stock Generic - deriving anyclass IsoValue - -{- Again we use generic magic to implement methods for 'Store' -(and thus 'Store' type constructor accepts a datatype, not a type-level list). - -There are two reasons for this: - -1. This gives us expected balanced tree of 'Or's for free. - -2. This allows us selecting a map by constructor name, not by -e.g. type of map value. This is subjective, but looks like a good thing -for me (@martoon). On the other hand, it prevents us from sharing the -same interface between maps and 'Store'. - --} - --- | Position of a constructor in the corresponding datatype declaration. -type CtorIdx = Nat - --- | Number of datatype constructors. -type CtorsNum = Nat - --- | Type arguments of '|->'. -data MapSignature = MapSignature Kind.Type Kind.Type CtorIdx - --- Again, we will use these getters instead of binding types within --- 'MapSignature' using type equality because getters does not produce extra --- compile errors on "field not found" cases. -type family MSKey ms where - MSKey ('MapSignature k _ _) = k -type family MSValue ms where - MSValue ('MapSignature _ v _) = v -type family MSCtorIdx ms where - MSCtorIdx ('MapSignature _ _ ci) = ci - --- | Get map signature from the constructor with a given name. -type GetStore name a = MSRequireFound name a (GLookupStore name (G.Rep a)) - -data MapLookupRes - = MapFound MapSignature - | MapAbsent CtorsNum - -type family MSRequireFound - (name :: Symbol) - (a :: Kind.Type) - (mlr :: MapLookupRes) - :: MapSignature where - MSRequireFound _ _ ('MapFound ms) = ms - MSRequireFound name a ('MapAbsent _) = TypeError - ('Text "Failed to find store template: datatype " ':<>: 'ShowType a ':<>: - 'Text " has no constructor " ':<>: 'ShowType name) - --- | Prepend a constructor name with a lower-case character so that you --- could make a label with @OverloadedLabels@ extension matching --- resulting thing. -type CtorNameToLabel name = "c" `AppendSymbol` name - -type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type) - :: MapLookupRes where - GLookupStore name (G.D1 _ x) = GLookupStore name x - GLookupStore name (x :+: y) = LSMergeFound name (GLookupStore name x) - (GLookupStore name y) - -- When we encounter a constructor there are two cases we are interested in: - -- 1. This constructor has one field with type `|->`. Then we check its name - -- and return 'MapFound' if it matches and 'MapAbsent' otherwise (storing - -- information that we've found one constructor). - -- 2. This constructor has one field with a different type. Then we expect - -- this field to store '|->' somewhere deeper and try to find it there. - GLookupStore name (G.C1 ('G.MetaCons ctorName _ _) x) = - If (IsLeafCtor x) - (If (name == ctorName || name == CtorNameToLabel ctorName) - ('MapFound $ GExtractMapSignature ctorName x) - ('MapAbsent 1) - ) - (GLookupStoreDeeper name x) - GLookupStore _ G.V1 = 'MapAbsent 0 - --- Helper type family to check whether ADT constructor has one field --- with type `|->`. -type family IsLeafCtor (x :: Kind.Type -> Kind.Type) :: Bool where - IsLeafCtor (G.S1 _ (G.Rec0 (_ |-> _))) = 'True - IsLeafCtor _ = 'False - --- Helper type family to go deeper during type-level store lookup. -type family GLookupStoreDeeper (name :: Symbol) (x :: Kind.Type -> Kind.Type) - :: MapLookupRes where - GLookupStoreDeeper name (G.S1 _ (G.Rec0 y)) = GLookupStore name (G.Rep y) - GLookupStoreDeeper name _ = TypeError - ('Text "Attempt to go deeper failed while looking for" ':<>: 'ShowType name - ':$$: - 'Text "Make sure that all constructors have exactly one field inside.") - -type family LSMergeFound (name :: Symbol) - (f1 :: MapLookupRes) (f2 :: MapLookupRes) - :: MapLookupRes where - LSMergeFound _ ('MapAbsent n1) ('MapAbsent n2) = 'MapAbsent (n1 + n2) - LSMergeFound _ ('MapFound ms) ('MapAbsent _) = 'MapFound ms - LSMergeFound _ ('MapAbsent n) ('MapFound ('MapSignature k v i)) = - 'MapFound ('MapSignature k v (n + i)) - -- It's possible that there are two constructors with the same name, - -- because main template pattern may be a sum of smaller template - -- patterns with same constructor names. - LSMergeFound ctor ('MapFound _) ('MapFound _) = TypeError - ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor) - -type family GExtractMapSignature (ctor :: Symbol) (x :: Kind.Type -> Kind.Type) - :: MapSignature where - GExtractMapSignature _ (G.S1 _ (G.Rec0 (k |-> v))) = 'MapSignature k v 0 - GExtractMapSignature ctor _ = TypeError - ('Text "Expected exactly one field of type `k |-> v`" ':$$: - 'Text "In constructor " ':<>: 'ShowType ctor) - -type GetStoreKey store name = MSKey (GetStore name store) -type GetStoreValue store name = MSValue (GetStore name store) - -packKey - :: forall (idx :: CtorIdx) a s. - (KnownNat idx, NicePackedValue a) - => (a : s) :-> (ByteString : s) -packKey = - withDict (nicePackedValueEvi @a) $ - push (natVal $ Proxy @idx) # - pair @Natural @a # - pack - -wrapBigMapImage :: (v : s) :-> ((k |-> v) : s) -wrapBigMapImage = forcedCoerce_ - -unwrapBigMapImage :: ((k |-> v) : s) :-> (v : s) -unwrapBigMapImage = forcedCoerce_ - -type StoreOpC store name = - ( NicePackedValue (MSKey (GetStore name store)) - , KnownNat (MSCtorIdx (GetStore name store)) - ) - -{- Note on store initialization: - -It's not possible to create an empty store, because Michelson provides no way -to create a new empty @big_map@. --} - -storeMem - :: forall store name s. - (StoreMemC store name) - => Label name - -> GetStoreKey store name : Store store : s :-> Bool : s -storeMem _ = - packKey @(MSCtorIdx (GetStore name store)) # - I MEM - -type StoreMemC store name = StoreOpC store name - -storeGet - :: forall store name s. - StoreGetC store name - => Label name - -> GetStoreKey store name : Store store : s - :-> Maybe (GetStoreValue store name) : s -storeGet label = - packKey @(MSCtorIdx (GetStore name store)) # - I GET # - ifNone none (unwrapUnsafe_ @store label # unwrapBigMapImage # L.some) - -type StoreGetC store name = - ( StoreOpC store name - , InstrUnwrapC store name - , KnownValue (GetStoreValue store name) - , CtorHasOnlyField name store - (GetStoreKey store name |-> GetStoreValue store name) - ) - -storeUpdate - :: forall store name s. - StoreUpdateC store name - => Label name - -> GetStoreKey store name - : Maybe (GetStoreValue store name) - : Store store - : s - :-> Store store : s -storeUpdate label = - packKey @(MSCtorIdx (GetStore name store)) # - dip (ifNone none (wrapBigMapImage # wrap_ @store label # L.some)) # - I UPDATE - -type StoreUpdateC store name = - ( KnownValue store - , StoreOpC store name - , InstrWrapC store name - , CtorHasOnlyField name store - (GetStoreKey store name |-> GetStoreValue store name) - ) - -storeInsert - :: forall store name s. - StoreInsertC store name - => Label name - -> GetStoreKey store name - : GetStoreValue store name - : Store store - : s - :-> Store store : s -storeInsert label = - packKey @(MSCtorIdx (GetStore name store)) # - dip (wrapBigMapImage # wrap_ @store label # L.some) # - I UPDATE - -type StoreInsertC store name = - ( StoreOpC store name - , InstrWrapC store name - , CtorHasOnlyField name store - (GetStoreKey store name |-> GetStoreValue store name) - ) - --- | Insert a key-value pair, but fail if it will overwrite some existing entry. -storeInsertNew - :: forall store name s. - (StoreInsertC store name, KnownSymbol name) - => Label name - -> (forall s0 any. GetStoreKey store name : s0 :-> any) - -> GetStoreKey store name - : GetStoreValue store name - : Store store - : s - :-> Store store : s -storeInsertNew label doFail = - duupX @3 # duupX @2 # storeMem label # - if_ doFail - (storeInsert label) - -storeDelete - :: forall store name s. - ( StoreDeleteC store name - ) - => Label name - -> GetStoreKey store name : Store store : s - :-> Store store : s -storeDelete _ = - packKey @(MSCtorIdx (GetStore name store)) # - dip (none @store) # - I UPDATE - -type StoreDeleteC store name = - ( StoreOpC store name - , KnownValue store - ) - --- | This constraint can be used if a function needs to work with --- /big/ store, but needs to know only about some part(s) of it. --- --- It can use all Store operations for a particular name, key and --- value without knowing whole template. -type HasStore name key value store = - ( StoreGetC store name - , StoreInsertC store name - , StoreDeleteC store name - , GetStoreKey store name ~ key - , GetStoreValue store name ~ value - , StorePieceC store name key value - ) - --- | Write down all sensisble constraints which given @store@ satisfies --- and apply them to @constrained@. --- --- This store should have '|->' datatype in its immediate fields, --- no deep inspection is performed. -type HasStoreForAllIn store constrained = - GForAllHasStore constrained (G.Rep store) - -type family GForAllHasStore (store :: Kind.Type) (x :: Kind.Type -> Kind.Type) - :: Constraint where - GForAllHasStore store (G.D1 _ x) = GForAllHasStore store x - GForAllHasStore store (x :+: y) = ( GForAllHasStore store x - , GForAllHasStore store y ) - GForAllHasStore store (G.C1 ('G.MetaCons ctorName _ _) - (G.S1 _ (G.Rec0 (key |-> value)))) = - HasStore (CtorNameToLabel ctorName) key value store - GForAllHasStore _ (G.C1 _ _) = () - GForAllHasStore _ G.V1 = () - --- Instances ----------------------------------------------------------------------------- - -instance ( StoreMemC store name, StoreGetC store name - , StoreUpdateC store name - , key ~ GetStoreKey store name, value ~ GetStoreValue store name - ) => - StoreHasSubmap (Store store) name key value where - storeSubmapOps = StoreSubmapOps - { sopMem = storeMem - , sopGet = storeGet - , sopUpdate = storeUpdate - , sopDelete = Just storeDelete - , sopInsert = Just storeInsert - } - --- Examples ----------------------------------------------------------------------------- - -data MyStoreTemplate - = IntsStore (Integer |-> ()) - | BytesStore (ByteString |-> ByteString) - deriving stock Generic - deriving anyclass IsoValue - -type MyStore = Store MyStoreTemplate - -_sample1 :: Integer : MyStore : s :-> MyStore : s -_sample1 = storeDelete @MyStoreTemplate #cIntsStore - -_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s -_sample2 = storeInsert @MyStoreTemplate #cBytesStore - -data MyStoreTemplate2 - = BoolsStore (Bool |-> Bool) - | IntsStore2 (Integer |-> Integer) - | IntsStore3 (Integer |-> Bool) - deriving stock Generic - deriving anyclass IsoValue - --- You must derive 'Generic' instance for all custom types, even --- newtypes. -newtype MyNatural = MyNatural Natural - deriving stock Generic - deriving newtype (IsoCValue, IsoValue) - -data MyStoreTemplate3 = MyStoreTemplate3 (Natural |-> MyNatural) - deriving stock Generic - deriving anyclass IsoValue - -data MyStoreTemplateBig - = BigTemplatePart1 MyStoreTemplate - | BigTemplatePart2 MyStoreTemplate2 - | BigTemplatePart3 MyStoreTemplate3 - deriving stock Generic - deriving anyclass IsoValue - -_MyStoreTemplateBigTextsStore :: - GetStore "cBytesStore" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString 1 -_MyStoreTemplateBigTextsStore = Refl - -_MyStoreTemplateBigBoolsStore :: - GetStore "cBoolsStore" MyStoreTemplateBig :~: 'MapSignature Bool Bool 2 -_MyStoreTemplateBigBoolsStore = Refl - -_MyStoreTemplateBigMyStoreTemplate3 :: - GetStore "cMyStoreTemplate3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural 5 -_MyStoreTemplateBigMyStoreTemplate3 = Refl - -_MyStoreBigHasAllStores - :: HasStoreForAllIn MyStoreTemplate store - => Dict ( HasStore "cIntsStore" Integer () store - , HasStore "cBytesStore" ByteString ByteString store - ) -_MyStoreBigHasAllStores = Dict - -type MyStoreBig = Store MyStoreTemplateBig - -_sample3 :: Integer : MyStoreBig : s :-> MyStoreBig : s -_sample3 = storeDelete @MyStoreTemplateBig #cIntsStore2 - -_sample4 :: ByteString : MyStoreBig : s :-> Bool : s -_sample4 = storeMem @MyStoreTemplateBig #cBytesStore - -_sample5 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s -_sample5 = storeInsert @MyStoreTemplateBig #cMyStoreTemplate3 - --- Example of 'HasStoreForAllIn' use. --- This function will work with any @store@ which has 'MyStoreTemplate3' inside. -_sample6 - :: forall store s. - HasStoreForAllIn MyStoreTemplate3 store - => Natural : MyNatural : Store store : s :-> Store store : s -_sample6 = storeInsert @store #cMyStoreTemplate3 - --- For instance, 'sample6' works for 'MyStoreBig'. -_sample6' :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s -_sample6' = _sample6 - ----------------------------------------------------------------------------- --- Storage skeleton ----------------------------------------------------------------------------- - --- | Contract storage with @big_map@. --- --- Due to Michelson constraints it is the only possible layout containing --- @big_map@. -data StorageSkeleton storeTemplate other = StorageSkeleton - { sMap :: Store storeTemplate - , sFields :: other - } deriving stock (Eq, Show, Generic) - deriving anyclass (Default, IsoValue) - --- | Unpack 'StorageSkeleton' into a pair. -storageUnpack :: StorageSkeleton store fields : s :-> (Store store, fields) : s -storageUnpack = forcedCoerce_ - --- | Pack a pair into 'StorageSkeleton'. -storagePack :: (Store store, fields) : s :-> StorageSkeleton store fields : s -storagePack = forcedCoerce_ - -storageMem - :: forall store name fields s. - (StoreMemC store name) - => Label name - -> GetStoreKey store name : StorageSkeleton store fields : s :-> Bool : s -storageMem label = dip (storageUnpack # car) # storeMem label - -storageGet - :: forall store name fields s. - StoreGetC store name - => Label name - -> GetStoreKey store name : StorageSkeleton store fields : s - :-> Maybe (GetStoreValue store name) : s -storageGet label = dip (storageUnpack # car) # storeGet label - -storageInsert - :: forall store name fields s. - StoreInsertC store name - => Label name - -> GetStoreKey store name - : GetStoreValue store name - : StorageSkeleton store fields - : s - :-> StorageSkeleton store fields : s -storageInsert label = - dip (dip (storageUnpack # dup # car # dip cdr)) # - storeInsert label # - pair # storagePack - --- | Insert a key-value pair, but fail if it will overwrite some existing entry. -storageInsertNew - :: forall store name fields s. - (StoreInsertC store name, KnownSymbol name) - => Label name - -> (forall s0 any. GetStoreKey store name : s0 :-> any) - -> GetStoreKey store name - : GetStoreValue store name - : StorageSkeleton store fields - : s - :-> StorageSkeleton store fields : s -storageInsertNew label doFail = - dip (dip (storageUnpack # dup # car # dip cdr)) # - storeInsertNew label doFail # - pair # storagePack - -storageDelete - :: forall store name fields s. - ( StoreDeleteC store name - ) - => Label name - -> GetStoreKey store name : StorageSkeleton store fields : s - :-> StorageSkeleton store fields : s -storageDelete label = - dip (storageUnpack # dup # car # dip cdr) # - storeDelete label # - pair # storagePack - --- Instances ----------------------------------------------------------------------------- - -instance (StoreHasField other fname ftype, IsoValue store, IsoValue other) => - StoreHasField (StorageSkeleton store other) fname ftype where - storeFieldOps = storeFieldOpsDeeper #sFields - -instance ( StoreMemC store name, StoreGetC store name - , StoreUpdateC store name - , key ~ GetStoreKey store name, value ~ GetStoreValue store name - , IsoValue other - ) => - StoreHasSubmap (StorageSkeleton store other) name key value where - storeSubmapOps = storeSubmapOpsDeeper #sMap - --- Examples ----------------------------------------------------------------------------- - -type MyStorage = StorageSkeleton MyStoreTemplate (Integer, ByteString) - --- You can access both Store... -_storageSample1 :: Integer : MyStorage : s :-> MyStorage : s -_storageSample1 = storageDelete @MyStoreTemplate #cIntsStore - --- and other fields of the storage created with 'StorageSkeleton'. -_storageSample2 :: MyStorage : s :-> Integer : s -_storageSample2 = toField #sFields # car - ----------------------------------------------------------------------------- --- Store construction from Haskell ----------------------------------------------------------------------------- - -packHsKey - :: forall ctorIdx key. - (NicePackedValue key, KnownNat ctorIdx) - => key -> ByteString -packHsKey key = - lPackValue (natVal (Proxy @ctorIdx), key) - --- | Lift a key-value pair to 'Store'. --- --- Further you can use 'Monoid' instance of @Store@ to make up large stores. -storePiece - :: forall name store key value. - StorePieceC store name key value - => Label name - -> key - -> value - -> Store store -storePiece label key val = - Store . BigMap $ one - ( packHsKey @(MSCtorIdx (GetStore name store)) key - , hsWrap @store label (BigMapImage val) - ) - -storeKeyValueList - :: forall name store key value. - StorePieceC store name key value - => Label name - -> [(key, value)] - -> Store store -storeKeyValueList label keyValues = - Store . BigMap . Map.fromList $ - Prelude.map (\(key, val) -> - ( packHsKey @(MSCtorIdx (GetStore name store)) key - , hsWrap @store label (BigMapImage val) - )) keyValues - -type StorePieceC store name key value = - ( key ~ GetStoreKey store name - , value ~ GetStoreValue store name - , NicePackedValue key - , KnownNat (MSCtorIdx (GetStore name store)) - , InstrWrapC store name, Generic store - , ExtractCtorField (GetCtorField store name) ~ (key |-> value) - ) - --- | Get a value from store by key. --- --- It expects map to be consistent, otherwise call to this function fails --- with error. -storeLookup - :: forall name store key value ctorIdx. - ( key ~ GetStoreKey store name - , value ~ GetStoreValue store name - , ctorIdx ~ MSCtorIdx (GetStore name store) - , NicePackedValue key - , KnownNat ctorIdx - , InstrUnwrapC store name, Generic store - , CtorOnlyField name store ~ (key |-> value) - ) - => Label name - -> key - -> Store store - -> Maybe value -storeLookup label key (Store (BigMap m)) = - Map.lookup (packHsKey @ctorIdx key) m <&> \val -> - case hsUnwrap label val of - Nothing -> error "Invalid store, keys and values types \ - \correspondence is violated" - Just (BigMapImage x) -> x - --- Examples ----------------------------------------------------------------------------- - -_storeSample :: Store MyStoreTemplate -_storeSample = mconcat - [ storePiece #cIntsStore 1 () - , storePiece #cBytesStore "a" "b" - ] - -_lookupSample :: Maybe ByteString -_lookupSample = storeLookup #cBytesStore "a" _storeSample - -_storeSampleBig :: Store MyStoreTemplateBig -_storeSampleBig = mconcat - [ storePiece #cIntsStore 1 () - , storePiece #cBoolsStore True True - , storePiece #cIntsStore3 2 False - ] - -_lookupSampleBig :: Maybe Bool -_lookupSampleBig = storeLookup #cIntsStore3 2 _storeSampleBig diff --git a/src/Lorentz/StoreClass.hs b/src/Lorentz/StoreClass.hs deleted file mode 100644 --- a/src/Lorentz/StoreClass.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} - --- | This module provides storage interfaces. -module Lorentz.StoreClass - ( -- * Class - StoreHasField (..) - , StoreFieldOps (..) - , StoreHasSubmap (..) - , StoreSubmapOps (..) - - -- * Expressing constraints on storage - , type (~>) - , StorageContains - - -- * Methods to work with storage - , stToField - , stGetField - , stSetField - , stMem - , stGet - , stUpdate - , stDelete - , stInsert - , stInsertNew - - -- * Implementations - , storeFieldOpsADT - , storeFieldOpsDeeper - , storeSubmapOpsDeeper - , storeFieldOpsReferTo - , storeSubmapOpsReferTo - , composeStoreFieldOps - , composeStoreSubmapOps - ) where - -import Data.Vinyl.Derived (Label) - -import Lorentz.ADT -import Lorentz.Base -import Lorentz.Constraints -import qualified Lorentz.Instr as L -import qualified Lorentz.Macro as L -import Lorentz.Value -import Michelson.Typed.Haskell - ----------------------------------------------------------------------------- --- Fields ----------------------------------------------------------------------------- - --- | Datatype containing the full implementation of 'StoreHasField' typeclass. --- --- We use this grouping because in most cases implementation will be chosen --- among the default ones, and initializing all methods at once is simpler --- and more consistent. --- (One can say that we are trying to emulate benefits of @DerivingVia@ extension.) -data StoreFieldOps store fname ftype = StoreFieldOps - { sopToField - :: forall s. - Label fname -> store : s :-> ftype : s - , sopSetField - :: forall s. - Label fname -> ftype : store : s :-> store : s - } - --- Using fundeps here for the sake of less amount of boilerplate on user side, --- switch to type families if having any issues with that. --- | Provides operations on fields for storage. -class StoreHasField store fname ftype | store fname -> ftype where - storeFieldOps :: StoreFieldOps store fname ftype - --- | Pick storage field. -stToField - :: StoreHasField store fname ftype - => Label fname -> store : s :-> ftype : s -stToField = sopToField storeFieldOps - --- | Get storage field, preserving the storage itself on stack. -stGetField - :: StoreHasField store fname ftype - => Label fname -> store : s :-> ftype : store : s -stGetField l = L.dup # sopToField storeFieldOps l - --- | Update storage field. -stSetField - :: StoreHasField store fname ftype - => Label fname -> ftype : store : s :-> store : s -stSetField = sopSetField storeFieldOps - ----------------------------------------------------------------------------- --- Virtual big maps ----------------------------------------------------------------------------- - --- | Datatype containing the full implementation of 'StoreHasField' typeclass. --- --- We use this grouping because in most cases implementation will be chosen --- among the default ones, and initializing all methods at once is simpler --- and more consistent. --- (One can say that we are trying to emulate @DerivingVia@ extension.) -data StoreSubmapOps store mname key value = StoreSubmapOps - { sopMem - :: forall s. - Label mname -> key : store : s :-> Bool : s - , sopGet - :: forall s. - Label mname -> key : store : s :-> Maybe value : s - , sopUpdate - :: forall s. - Label mname -> key : Maybe value : store : s :-> store : s - - -- Methods below are derivatives of methods above, they can be provided - -- if for given specific storage type more efficient implementation is - -- available. - , sopDelete - :: forall s. - Maybe (Label mname -> key : store : s :-> store : s) - , sopInsert - :: forall s. - Maybe (Label mname -> key : value : store : s :-> store : s) - } - --- | Provides operations on fields for storage. -class StoreHasSubmap store mname key value | store mname -> key value where - storeSubmapOps :: StoreSubmapOps store mname key value - --- | Check value presence in storage. -stMem - :: StoreHasSubmap store mname key value - => Label mname -> key : store : s :-> Bool : s -stMem = sopMem storeSubmapOps - --- | Get value in storage. -stGet - :: StoreHasSubmap store mname key value - => Label mname -> key : store : s :-> Maybe value : s -stGet = sopGet storeSubmapOps - --- | Update a value in storage. -stUpdate - :: StoreHasSubmap store mname key value - => Label mname -> key : Maybe value : store : s :-> store : s -stUpdate = sopUpdate storeSubmapOps - --- | Delete a value in storage. -stDelete - :: forall store mname key value s. - (StoreHasSubmap store mname key value, KnownValue value) - => Label mname -> key : store : s :-> store : s -stDelete l = case sopDelete storeSubmapOps of - Just delOp -> delOp l - Nothing -> L.dip L.none # stUpdate l - --- | Add a value in storage. -stInsert - :: StoreHasSubmap store mname key value - => Label mname -> key : value : store : s :-> store : s -stInsert l = case sopInsert storeSubmapOps of - Just insOp -> insOp l - Nothing -> L.dip L.some # stUpdate l - --- | Add a value in storage, but fail if it will overwrite some existing entry. -stInsertNew - :: StoreHasSubmap store mname key value - => Label mname - -> (forall s0 any. key : s0 :-> any) - -> key : value : store : s - :-> store : s -stInsertNew l doFail = - L.duupX @3 # L.duupX @2 # stMem l # - L.if_ doFail (stInsert l) - --- Instances ----------------------------------------------------------------------------- - --- | 'BigMap' can be used as standalone key-value storage, --- name of submap is not accounted in this case. -instance (key ~ key', value ~ value', IsComparable key) => - StoreHasSubmap (BigMap key' value') name key value where - storeSubmapOps = StoreSubmapOps - { sopMem = \_label -> L.mem - , sopGet = \_label -> L.get - , sopUpdate = \_label -> L.update - , sopDelete = Nothing - , sopInsert = Nothing - } - --- | 'Map' can be used as standalone key-value storage if very needed. -instance (key ~ key', value ~ value', IsComparable key) => - StoreHasSubmap (Map key' value') name key value where - storeSubmapOps = StoreSubmapOps - { sopMem = \_label -> L.mem - , sopGet = \_label -> L.get - , sopUpdate = \_label -> L.update - , sopDelete = Nothing - , sopInsert = Nothing - } - - --- Implementations ----------------------------------------------------------------------------- - --- | Implementation of 'StoreHasField' for case of datatype --- keeping a pack of fields. -storeFieldOpsADT - :: HasFieldOfType dt fname ftype - => StoreFieldOps dt fname ftype -storeFieldOpsADT = StoreFieldOps - { sopToField = toField - , sopSetField = setField - } - --- | Implementation of 'StoreHasField' for a data type which has an --- instance of 'StoreHasField' inside. --- For instance, it can be used for top-level storage. -storeFieldOpsDeeper - :: ( HasFieldOfType storage fieldsPartName fields - , StoreHasField fields fname ftype - ) - => Label fieldsPartName - -> StoreFieldOps storage fname ftype -storeFieldOpsDeeper fieldsLabel = - composeStoreFieldOps fieldsLabel storeFieldOpsADT storeFieldOps - --- | Implementation of 'StoreHasSubmap' for a data type which has an --- instance of 'StoreHasSubmap' inside. --- For instance, it can be used for top-level storage. -storeSubmapOpsDeeper - :: ( HasFieldOfType storage bigMapPartName fields - , StoreHasSubmap fields mname key value - ) - => Label bigMapPartName - -> StoreSubmapOps storage mname key value -storeSubmapOpsDeeper submapLabel = - composeStoreSubmapOps submapLabel storeFieldOpsADT storeSubmapOps - -{- | Pretend that given 'StoreSubmapOps' implementation is made up -for submap with name @desiredName@, not its actual name. -Logic of the implementation remains the same. - -Use case: imagine that your code requires access to submap named @X@, -but in your storage that submap is called @Y@. -Then you implement the instance which makes @X@ refer to @Y@: - -@ -instance StoreHasSubmap Store X Key Value where - storeSubmapOps = storeSubmapOpsReferTo #Y storeSubmapOpsForY -@ --} -storeSubmapOpsReferTo - :: Label name - -> StoreSubmapOps storage name key value - -> StoreSubmapOps storage desiredName key value -storeSubmapOpsReferTo l StoreSubmapOps{..} = - StoreSubmapOps - { sopMem = \_l -> sopMem l - , sopGet = \_l -> sopGet l - , sopUpdate = \_l -> sopUpdate l - , sopDelete = (\op _l -> op l) <$> sopDelete - , sopInsert = (\op _l -> op l) <$> sopInsert - } - --- | Pretend that given 'StoreSubmapOps' implementation is made up --- for submap with name @desiredName@, not its actual name. --- Logic of the implementation remains the same. --- --- See also 'storeSubmapOpsReferTo'. -storeFieldOpsReferTo - :: Label name - -> StoreFieldOps storage name field - -> StoreFieldOps storage desiredName field -storeFieldOpsReferTo l StoreFieldOps{..} = - StoreFieldOps - { sopToField = \_l -> sopToField l - , sopSetField = \_l -> sopSetField l - } - --- | Chain two implementations of field operations. --- --- Suits for a case when your store does not contain its fields directly --- rather has a nested structure. -composeStoreFieldOps - :: Label nameInStore - -> StoreFieldOps store nameInStore substore - -> StoreFieldOps substore nameInSubstore field - -> StoreFieldOps store nameInSubstore field -composeStoreFieldOps l1 ops1 ops2 = - StoreFieldOps - { sopToField = \l2 -> - sopToField ops1 l1 # sopToField ops2 l2 - , sopSetField = \l2 -> - L.dip (L.dup # sopToField ops1 l1) # - sopSetField ops2 l2 # - sopSetField ops1 l1 - } - --- | Chain implementations of field and submap operations. -composeStoreSubmapOps - :: Label nameInStore - -> StoreFieldOps store nameInStore substore - -> StoreSubmapOps substore mname key value - -> StoreSubmapOps store mname key value -composeStoreSubmapOps l1 ops1 ops2 = - StoreSubmapOps - { sopMem = \l2 -> - L.dip (sopToField ops1 l1) # sopMem ops2 l2 - , sopGet = \l2 -> - L.dip (sopToField ops1 l1) # sopGet ops2 l2 - , sopUpdate = \l2 -> - L.dip (L.dip (L.dup # sopToField ops1 l1)) # - sopUpdate ops2 l2 # - sopSetField ops1 l1 - , sopDelete = case sopDelete ops2 of - Nothing -> Nothing - Just delOp -> Just $ \l2 -> - L.dip (L.dup # sopToField ops1 l1) # - delOp l2 # - sopSetField ops1 l1 - , sopInsert = case sopInsert ops2 of - Nothing -> Nothing - Just insOp -> Just $ \l2 -> - L.dip (L.dip (L.dup # sopToField ops1 l1)) # - insOp l2 # - sopSetField ops1 l1 - } - ----------------------------------------------------------------------------- --- Utilities ----------------------------------------------------------------------------- - --- | Indicates a submap with given key and value types. -data k ~> v -infix 9 ~> - -{- | Concise way to write down constraints with expected content of a storage. - -Use it like follows: - -@ -type StorageConstraint = StorageContains - [ "fieldInt" := Int - , "fieldNat" := Nat - , "balances" := Address ~> Int - ] -@ - --} -type family StorageContains store (content :: [NamedField]) :: Constraint where - StorageContains _ '[] = () - StorageContains store ((n := k ~> v) ': ct) = - (StoreHasSubmap store n k v, StorageContains store ct) - StorageContains store ((n := ty) ': ct) = - (StoreHasField store n ty, StorageContains store ct) diff --git a/src/Lorentz/Test.hs b/src/Lorentz/Test.hs deleted file mode 100644 --- a/src/Lorentz/Test.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Lorentz.Test - ( -- * Importing a contract - specWithContract - , specWithTypedContract - , specWithUntypedContract - - -- * Unit testing - , ContractReturn - , ContractPropValidator - , contractProp - , contractPropVal - , expectContractEntrypoints - - -- * Integrational testing - -- ** Testing engine - , IntegrationalValidator - , SuccessValidator - , IntegrationalScenario - , IntegrationalScenarioM - , ValidationError (..) - , integrationalTestExpectation - , integrationalTestProperty - , lOriginate - , lOriginateEmpty - , lTransfer - , lCall - , lCallEP - , EntryPointRef (..) - , lCallDef - , validate - , integrationalFail - , setMaxSteps - , setNow - , rewindTime - , withSender - , setChainId - , branchout - , (?-) - , offshoot - - -- ** Validators - , composeValidators - , composeValidatorsList - , expectAnySuccess - , expectNoUpdates - , expectNoStorageUpdates - , lExpectStorageUpdate - , lExpectBalance - , lExpectStorage - , lExpectStorageConst - , lExpectMichelsonFailed - , lExpectFailWith - , lExpectError - , lExpectErrorNumeric - , lExpectCustomError - , lExpectCustomErrorNumeric - , lExpectCustomError_ - , lExpectCustomErrorNumeric_ - , lExpectConsumerStorage - , lExpectViewConsumerStorage - - -- ** Various - , TxData (..) - , genesisAddresses - , genesisAddress - , genesisAddress1 - , genesisAddress2 - , genesisAddress3 - , genesisAddress4 - , genesisAddress5 - , genesisAddress6 - - -- * Autodoc testing - , runDocTests - , testLorentzDoc - , excludeDocTests - - -- * General utilities - , failedProp - , succeededProp - , qcIsLeft - , qcIsRight - - -- * Dummy values - , dummyContractEnv - - -- * Arbitrary data - , minTimestamp - , maxTimestamp - , midTimestamp - - -- * Special contracts for testing - , contractConsumer - ) where - -import Michelson.Doc.Test -import Michelson.Test.Dummy -import Michelson.Test.Gen -import Michelson.Test.Import -import Michelson.Test.Unit -import Michelson.Test.Util - -import Lorentz.Test.Consumer -import Lorentz.Test.Doc -import Lorentz.Test.Integrational -import Lorentz.Test.Unit diff --git a/src/Lorentz/Test/Consumer.hs b/src/Lorentz/Test/Consumer.hs deleted file mode 100644 --- a/src/Lorentz/Test/Consumer.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | Contract which remembers all parameters it has been called with. --- --- Useful to save return values of @View@ entry points. -module Lorentz.Test.Consumer - ( contractConsumer - ) where - -import Lorentz.Base -import Lorentz.Instr -import Lorentz.Macro - --- | Remembers parameters it was called with, last goes first. -contractConsumer :: Contract cp [cp] -contractConsumer = unpair # cons # nil # pair diff --git a/src/Lorentz/Test/Doc.hs b/src/Lorentz/Test/Doc.hs deleted file mode 100644 --- a/src/Lorentz/Test/Doc.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | Testing predicates for documentation of Lorentz contracts. -module Lorentz.Test.Doc - ( -- * Test predicates - testLorentzDoc - - -- * Individual test predicates - , testDeclaresParameter - , testEachEntrypointIsDescribed - - , module Michelson.Doc.Test - ) where - -import Fmt (pretty) -import Test.HUnit (assertBool, assertFailure) - -import Lorentz.EntryPoints.Doc -import Michelson.Doc -import Michelson.Doc.Test -import Util.Typeable - --- | Check that contract documents its parameter. -testDeclaresParameter :: DocTest -testDeclaresParameter = - mkDocTest "Contract parameter is documented" $ - \contractDoc -> - assertBool "No doc items describing contract parameter found" $ - or $ forEachContractLayer contractDoc check - where - check Nothing _ = False - check (Just sdi) _ = - -- Currently the only way to document parameter (mentioning type of each arm) - -- is using 'entryCase'. This may not suit for small contracts, then - -- someone needs to invent another way to document parameter and also mention - -- it below. - case sdi of - SomeDocItem (castIgnoringPhantom -> Just DEntryPoint{}) -> True - _ -> False - --- | It's a common issue to forget to describe an entrypoint. -testEachEntrypointIsDescribed :: DocTest -testEachEntrypointIsDescribed = - mkDocTest "Each entrypoint has 'DDescription'" $ - \contractDoc -> - sequence_ . forEachContractLayer contractDoc $ \mDocItem block -> - runMaybeT $ do - SomeDocItem docItem <- MaybeT . pure $ mDocItem - dep@DEntryPoint{} <- MaybeT . pure $ castIgnoringPhantom docItem - Nothing <- pure $ lookupDocBlockSection @DDescription block - MaybeT . assertFailure $ - "Entrypoint '" <> pretty (depName dep) <> "' does not contain \ - \description.\n\ - \Put `doc $ DDescription \"text\"` in the entrypoint logic to fix this." - --- | Tests all properties. -testLorentzDoc :: [DocTest] -testLorentzDoc = mconcat - [ testDocBasic - , [ testDeclaresParameter - , testEachEntrypointIsDescribed - ] - ] diff --git a/src/Lorentz/Test/Integrational.hs b/src/Lorentz/Test/Integrational.hs deleted file mode 100644 --- a/src/Lorentz/Test/Integrational.hs +++ /dev/null @@ -1,392 +0,0 @@ --- | Mirrors 'Michelson.Test.Integrational' module in a Lorentz way. -module Lorentz.Test.Integrational - ( - -- * Re-exports - TxData (..) - , genesisAddresses - , genesisAddress - -- * More genesis addresses which can be used in tests - , genesisAddress1 - , genesisAddress2 - , genesisAddress3 - , genesisAddress4 - , genesisAddress5 - , genesisAddress6 - - -- * Testing engine for bare Typed primitives - , tOriginate - , tTransfer - , tExpectStorageConst - - -- * Testing engine - , I.IntegrationalValidator - , SuccessValidator - , IntegrationalScenarioM - , I.IntegrationalScenario - , I.ValidationError (..) - , I.integrationalTestExpectation - , I.integrationalTestProperty - , lOriginate - , lOriginateEmpty - , lTransfer - , lCall - , lCallEP - , EntryPointRef (..) - , lCallDef - , I.validate - , I.integrationalFail - , I.setMaxSteps - , I.setNow - , I.rewindTime - , I.withSender - , I.setChainId - , I.branchout - , (I.?-) - , I.offshoot - - -- * Validators - , I.composeValidators - , I.composeValidatorsList - , I.expectAnySuccess - , I.expectNoUpdates - , I.expectNoStorageUpdates - , lExpectStorageUpdate - , lExpectBalance - , lExpectStorage - , lExpectStorageConst - -- * Errors - , lExpectMichelsonFailed - , lExpectFailWith - , lExpectError - , lExpectErrorNumeric - , lExpectCustomError - , lExpectCustomErrorNumeric - , lExpectCustomError_ - , lExpectCustomErrorNumeric_ - - -- ** Consumer - , lExpectConsumerStorage - , lExpectViewConsumerStorage - ) where - -import Data.Constraint (Dict(..)) -import Data.Default (Default(..)) -import Data.Singletons (SingI) -import Data.Typeable (gcast) -import Data.Vinyl.Derived (Label) -import Fmt (Buildable, listF, (+|), (|+)) -import Named ((:!), arg) - -import qualified Lorentz as L -import Lorentz.Constraints -import Lorentz.EntryPoints -import Lorentz.Run -import Lorentz.Value -import Michelson.Interpret (InterpretError(..), MichelsonFailed(..)) -import Michelson.Runtime -import Michelson.Runtime.GState -import Michelson.Test.Integrational -import qualified Michelson.Test.Integrational as I -import Michelson.TypeCheck (typeVerifyValue) -import qualified Michelson.Typed as T -import Michelson.Typed.Scope -import qualified Michelson.Untyped as U -import Tezos.Core -import Util.Named ((.!)) - ----------------------------------------------------------------------------- --- Interface ----------------------------------------------------------------------------- - --- TODO: how to call they normally? :thinking: --- Preserving just the same names like @transfer@ or @originate@ --- looks very bad because no one will import this or --- 'Michelson.Test.Integrational' module qualified --- and thus finding which exact function is used would become too painful. - --- | Like 'originate', but for typed contract and value. -tOriginate - :: (ParameterScope cp, StorageScope st) - => T.FullContract cp st -> Text -> T.Value st -> Mutez -> IntegrationalScenarioM Address -tOriginate contract name value balance = - I.originate (T.convertFullContract contract) name (T.untypeValue value) balance - --- | Like 'originate', but for Lorentz contracts. -lOriginate - :: forall cp st. - (L.NiceParameterFull cp, NiceStorage st) - => L.Contract cp st - -> Text - -> st - -> Mutez - -> IntegrationalScenarioM (TAddress cp) -lOriginate contract name value balance = - withDict (niceParameterEvi @cp) $ - withDict (niceStorageEvi @st) $ do - addr <- tOriginate (compileLorentzContract contract) name (T.toVal value) balance - return (L.TAddress addr) - --- | Originate a contract with empty balance and default storage. -lOriginateEmpty - :: (L.NiceParameterFull cp, NiceStorage st, Default st) - => L.Contract cp st - -> Text - -> IntegrationalScenarioM (TAddress cp) -lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0) - --- | Similar to 'transfer', for typed values. --- Note that it works with untyped 'Address' and does not check that --- entrypoint with given name is present and has the expected type. --- Passed value must correspond to the entrypoint argument type, not --- the parameter type of the contract (and must be unit for implicit --- accounts). -tTransfer - :: forall arg. - (ParameterScope arg) - => "from" :! Address - -> "to" :! Address - -> Mutez - -> EpName - -> T.Value arg - -> IntegrationalScenarioM () -tTransfer (arg #from -> from) (arg #to -> to) money epName param = - let txData = TxData - { tdSenderAddress = from - , tdParameter = - withDict (properParameterEvi @arg) $ - T.untypeValue param - , tdEntrypoint = epName - , tdAmount = money - } - in I.transfer txData to - --- | Similar to 'transfer', for Lorentz values. -lTransfer - :: forall cp epRef epArg addr. - (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr) - => "from" :! Address - -> "to" :! addr - -> Mutez - -> epRef - -> epArg - -> IntegrationalScenarioM () -lTransfer from (toTAddress @cp . arg #to -> TAddress to) money epRef param = - case useHasEntryPointArg @cp @epRef @epArg epRef of - (Dict, epName) -> tTransfer from (#to .! to) money epName (T.toVal param) - -{-# DEPRECATED lCall "'lCall' will likely be replaced with 'lCallEP' in future version" #-} --- | Legacy version of 'lCallEP' function. Calls default entrypoint of --- a contract assuming its argument is the same as contract parameter --- (which is equivalent to absence of explicit default entrypoint). --- --- This function is DEPRECATED and exists only for backwards compatibility. -lCall - :: forall cp defEpName addr. - ( HasDefEntryPointArg cp defEpName cp - , IsoValue cp - , ToTAddress cp addr - ) - => addr -> cp -> IntegrationalScenarioM () -lCall = lCallDef @cp @defEpName @cp @addr - --- | Call an entrypoint of a contract without caring about the source --- address. Transfers 0 mutez. -lCallEP - :: forall cp epRef epArg addr. - (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr) - => addr -> epRef -> epArg -> IntegrationalScenarioM () -lCallEP addr epRef param = - lTransfer @cp @epRef @epArg - (#from .! genesisAddress) (#to .! addr) - (unsafeMkMutez 0) epRef param - --- | 'lCallEP' for default entrypoint. -lCallDef - :: forall cp defEpName defArg addr. - ( HasDefEntryPointArg cp defEpName defArg - , IsoValue defArg - , ToTAddress cp addr - ) - => addr -> defArg -> IntegrationalScenarioM () -lCallDef addr = - lCallEP @cp @defEpName @defArg addr CallDefault - ----------------------------------------------------------------------------- --- Validators to be used within 'IntegrationalValidator' ----------------------------------------------------------------------------- - --- Expect something successful - --- | Internal function that proceeds storage validation from by untyping --- the value passed to callback. -validateStorageCb - :: forall st addr. - (NiceStorage st, ToAddress addr, HasCallStack) - => (Address -> (U.Value -> Either ValidationError ()) -> SuccessValidator) - -> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator -validateStorageCb validator (toAddress -> addr) predicate = - validator addr $ \got -> do - val <- first I.UnexpectedTypeCheckError $ typeCheck got - predicate $ T.fromVal val - where - typeCheck uval = - evaluatingState initSt . runExceptT $ - usingReaderT def $ - typeVerifyValue uval - initSt = error "Typechecker state unavailable" - --- | Similar to 'expectStorage', but for Lorentz values. -lExpectStorage - :: forall st addr. - (NiceStorage st, ToAddress addr, HasCallStack) - => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator -lExpectStorage = validateStorageCb I.expectStorage - --- | Similar to 'expectStorageUpdate', but for Lorentz values. -lExpectStorageUpdate - :: forall st addr. - (NiceStorage st, ToAddress addr, HasCallStack) - => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator -lExpectStorageUpdate = validateStorageCb I.expectStorageUpdate - --- | Like 'expectBalance', for Lorentz values. -lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator -lExpectBalance (toAddress -> addr) money = I.expectBalance addr money - --- | Similar to 'expectStorageConst', for typed stuff. -tExpectStorageConst - :: forall st. - (StorageScope st) - => Address -> T.Value st -> SuccessValidator -tExpectStorageConst addr expected = - expectStorageConst addr (T.untypeValue expected) - --- | Similar to 'expectStorageConst', for Lorentz values. -lExpectStorageConst - :: forall st addr. - (NiceStorage st, ToAddress addr) - => addr -> st -> SuccessValidator -lExpectStorageConst (toAddress -> addr) expected = - withDict (niceStorageEvi @st) $ - tExpectStorageConst addr (T.toVal expected) - --- Expect errors - --- | Expect that interpretation of contract with given address ended --- with [FAILED]. -lExpectMichelsonFailed - :: forall addr. (ToAddress addr) - => (MichelsonFailed -> Bool) -> addr -> ExecutorError -> Bool -lExpectMichelsonFailed predicate (toAddress -> addr) = - I.expectMichelsonFailed predicate addr - --- | Expect contract to fail with "FAILWITH" instruction and provided value --- to match against the given predicate. -lExpectFailWith - :: forall e. - (Typeable (T.ToT e), T.IsoValue e) - => (e -> Bool) -> ExecutorError -> Bool -lExpectFailWith predicate = - \case - EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) -> - case gcast err of - Just errT -> predicate $ T.fromVal @e errT - Nothing -> False - _ -> False - --- | Expect contract to fail with given error. -lExpectError - :: forall e. - (L.IsError e) - => (e -> Bool) -> ExecutorError -> Bool -lExpectError = lExpectError' L.errorFromVal - --- | Version of 'lExpectError' for the case when numeric --- representation of errors is used. -lExpectErrorNumeric - :: forall e. - (L.IsError e) - => L.ErrorTagMap -> (e -> Bool) -> ExecutorError -> Bool -lExpectErrorNumeric errorTagMap = - lExpectError' (L.errorFromValNumeric errorTagMap) - -lExpectError' :: - forall e. - (forall t. (Typeable t, SingI t) => - Value t -> Either Text e) - -> (e -> Bool) - -> ExecutorError - -> Bool -lExpectError' errorFromValImpl predicate = - \case - EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) -> - case errorFromValImpl err of - Right err' -> predicate err' - Left _ -> False - _ -> False - --- | Expect contract to fail with given 'CustomError'. -lExpectCustomError - :: forall tag arg. - (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg) - => Label tag -> arg -> ExecutorError -> Bool -lExpectCustomError l a = - lExpectError (== L.CustomError l a) - --- | Version of 'lExpectCustomError' for the case when numeric --- representation of errors is used. -lExpectCustomErrorNumeric - :: forall tag arg. - (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg) - => L.ErrorTagMap -> Label tag -> arg -> ExecutorError -> Bool -lExpectCustomErrorNumeric errorTagMap l a = - lExpectErrorNumeric errorTagMap (== L.CustomError l a) - --- | Specialization of 'lExpectCustomError' for non-arg error case. -lExpectCustomError_ - :: forall tag. - (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ()) - => Label tag -> ExecutorError -> Bool -lExpectCustomError_ l = - lExpectCustomError l () - --- | Version of 'lExpectCustomError_' for the case when numeric --- representation of errors is used. -lExpectCustomErrorNumeric_ - :: forall tag. - (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ()) - => L.ErrorTagMap -> Label tag -> ExecutorError -> Bool -lExpectCustomErrorNumeric_ errorTagMap l = - lExpectCustomErrorNumeric errorTagMap l () - --- Consumer - --- | Version of 'lExpectStorageUpdate' specialized to "consumer" contract --- (see 'Lorentz.Contracts.Consumer.contractConsumer'). -lExpectConsumerStorage - :: forall cp st addr. - (st ~ [cp], NiceStorage st, ToTAddress cp addr) - => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator -lExpectConsumerStorage addr = lExpectStorageUpdate (toTAddress @cp addr) - --- | Assuming that "consumer" contract receives a value from 'View', expect --- this view return value to be the given one. --- --- Despite consumer stores parameters it was called with in reversed order, --- this function cares about it, so you should provide a list of expected values --- in the same order in which the corresponding events were happenning. -lExpectViewConsumerStorage - :: ( st ~ [cp] - , Eq cp, Buildable cp - , NiceStorage st - , ToTAddress cp addr - ) - => addr -> [cp] -> SuccessValidator -lExpectViewConsumerStorage addr expected = - lExpectConsumerStorage addr (matchExpected . reverse) - where - mkError = Left . I.CustomValidationError - matchExpected got - | got == expected = pass - | otherwise = mkError $ "Expected " +| listF expected |+ - ", but got " +| listF got |+ "" diff --git a/src/Lorentz/Test/Unit.hs b/src/Lorentz/Test/Unit.hs deleted file mode 100644 --- a/src/Lorentz/Test/Unit.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Unit tests for Lorentz. -module Lorentz.Test.Unit - ( expectContractEntrypoints - ) where - -import Test.HUnit (Assertion, assertFailure) - -import Lorentz hiding (contract) -import Michelson.Test.Unit (matchContractEntryPoints) -import Michelson.Typed (convertFullContract) - --- | Expect the given contract to have some specific entrypoints. -expectContractEntrypoints - :: forall expectedEps contractEps st. - ( NiceParameterFull expectedEps - , NiceParameterFull contractEps - , NiceStorage st - ) - => Contract contractEps st -> Assertion -expectContractEntrypoints contract = - withDict (niceParameterEvi @expectedEps) $ - withDict (niceParameterEvi @contractEps) $ - withDict (niceStorageEvi @st) $ do - let entrypoints = flattenEntryPoints $ parameterEntryPointsToNotes @expectedEps - contract' = convertFullContract . compileLorentzContract $ contract - case matchContractEntryPoints contract' entrypoints of - Left eps -> assertFailure $ "Some entrypoints were not found " <> show eps - Right _ -> pass diff --git a/src/Lorentz/TestScenario.hs b/src/Lorentz/TestScenario.hs deleted file mode 100644 --- a/src/Lorentz/TestScenario.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Lorentz.TestScenario - {-# DEPRECATED "Use morley-nettest instead" #-} - ( TestScenario - , showTestScenario - ) where - -import Fmt (Buildable, Builder, fmt, (+|), (|+)) - -import Lorentz.Constraints (KnownValue, NicePrintedValue, NoOperation) -import Lorentz.Print (printLorentzValue) -import Michelson.Typed.Haskell.Value (IsoValue) -import Tezos.Address (Address) - --- | Type that represents test scenario for Lorentz contract. --- Simply put, it is sequence of pairs (`sender`, `parameter`). --- Using this sequence we can perform transfers to the desired contract. -type TestScenario param = [(Address, param)] - --- | Function to get textual representation of @TestScenario@, each Parameter --- is printed as a raw Michelson value. --- This representation can later be used in order to run test scenario --- on real network. --- --- The format for a single contract call is the following: --- # `printed Lorentz parameter` (actually comment) --- `sender address` --- `printed raw Michelson parameter` -showTestScenario - :: (Buildable param, NicePrintedValue param) - => TestScenario param -> Text -showTestScenario = fmt . foldMap formatParam - where - formatParam - :: (Buildable param, KnownValue param, NoOperation param) - => (Address, param) -> Builder - formatParam (addr, param) = - "# " +| param |+ "\n" +| - addr |+ "\n" +| - printLorentzValue True param |+ "\n" - -data Parameter - = Param1 Integer Bool - | Param2 - | Param3 Natural Natural - deriving stock Generic - deriving anyclass IsoValue - -_mkTestScenarioExample :: Address -> TestScenario Parameter -_mkTestScenarioExample owner = - [ (owner, Param1 5 False) - , (owner, Param2) - , (owner, Param3 2 2) - ] diff --git a/src/Lorentz/TypeAnns.hs b/src/Lorentz/TypeAnns.hs deleted file mode 100644 --- a/src/Lorentz/TypeAnns.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE UndecidableSuperClasses #-} - --- | Type annotations for Lorentz types. -module Lorentz.TypeAnns - ( HasTypeAnn (..) - , GHasTypeAnn (..) - ) where - -import Data.Singletons (SingI) -import qualified GHC.Generics as G -import Named (NamedF) - -import Lorentz.Base ((:->)) -import Lorentz.Zip -import Michelson.Text -import Michelson.Typed - (BigMap, ContractRef(..), EpAddress, Notes(..), Operation, T(..), ToCT, ToT, starNotes) -import Michelson.Typed.Haskell.Value (GValueType) -import Michelson.Untyped (TypeAnn, ann, noAnn) -import Tezos.Address -import Tezos.Core -import Tezos.Crypto -import Util.TypeLits - --- For supporting type annotations of entrypoint arguments. --- ---At the botton of this infra is the HasTypeAnn class, which defines the type ---annotations for a given type. Right now the type annotations can only come ---from names in a named field. That is, we are not deriving names from, for ---example, record field names. - -class HasTypeAnn a where - getTypeAnn :: Notes (ToT a) - -instance {-# OVERLAPPABLE #-} (GHasTypeAnn (G.Rep a), GValueType (G.Rep a) ~ ToT a) - => HasTypeAnn a where - getTypeAnn = gGetTypeAnn @(G.Rep a) - -instance (HasTypeAnn a, KnownSymbol name) - => HasTypeAnn (NamedF Identity a name) where - getTypeAnn = insertNote (symbolAnn @name) $ getTypeAnn @a - where - symbolAnn :: forall s. KnownSymbol s => TypeAnn - symbolAnn = ann $ symbolValT' @s - -- Insert the provided type annotation into the provided note. - insertNote :: forall (b :: T). TypeAnn -> Notes b -> Notes b - insertNote nt s = case s of - NTc _ -> NTc nt - NTKey _ -> NTKey nt - NTUnit _ -> NTUnit nt - NTSignature _ -> NTSignature nt - NTOption _ n1 -> NTOption nt n1 - NTList _ n1 -> NTList nt n1 - NTSet _ n1 -> NTSet nt n1 - NTOperation _ -> NTOperation nt - NTContract _ n1 -> NTContract nt n1 - NTPair _ n1 n2 n3 n4 -> NTPair nt n1 n2 n3 n4 - NTOr _ n1 n2 n3 n4 -> NTOr nt n1 n2 n3 n4 - NTLambda _ n1 n2 -> NTLambda nt n1 n2 - NTMap _ n1 n2 -> NTMap nt n1 n2 - NTBigMap _ n1 n2 -> NTBigMap nt n1 n2 - NTChainId _ -> NTChainId nt - -instance (HasTypeAnn (Maybe a), KnownSymbol name) - => HasTypeAnn (NamedF Maybe a name) where - getTypeAnn = getTypeAnn @(NamedF Identity (Maybe a) name) - --- Primitive instances -instance (HasTypeAnn a) => HasTypeAnn (Maybe a) where - getTypeAnn = NTOption noAnn (getTypeAnn @a) - -instance HasTypeAnn Integer where - getTypeAnn = starNotes - -instance HasTypeAnn Natural where - getTypeAnn = starNotes - -instance HasTypeAnn MText where - getTypeAnn = starNotes - -instance HasTypeAnn Bool where - getTypeAnn = starNotes - -instance HasTypeAnn ByteString where - getTypeAnn = starNotes - -instance HasTypeAnn Mutez where - getTypeAnn = starNotes - -instance HasTypeAnn Address where - getTypeAnn = starNotes - -instance HasTypeAnn EpAddress where - getTypeAnn = starNotes - -instance HasTypeAnn KeyHash where - getTypeAnn = starNotes - -instance HasTypeAnn Timestamp where - getTypeAnn = starNotes - -instance HasTypeAnn PublicKey where - getTypeAnn = starNotes - -instance HasTypeAnn Signature where - getTypeAnn = starNotes - -instance (HasTypeAnn a) => HasTypeAnn (ContractRef a) where - getTypeAnn = NTContract noAnn (getTypeAnn @a) - -instance (HasTypeAnn v) => HasTypeAnn (Map k v) where - getTypeAnn = NTMap noAnn noAnn (getTypeAnn @v) - -instance (HasTypeAnn v) => HasTypeAnn (BigMap k v) where - getTypeAnn = NTBigMap noAnn noAnn (getTypeAnn @v) - -instance (SingI (ToCT v), Typeable (ToCT v)) => HasTypeAnn (Set v) where - getTypeAnn = starNotes - -instance (HasTypeAnn a) => HasTypeAnn [a] where - getTypeAnn = NTList noAnn (getTypeAnn @a) - -instance HasTypeAnn Operation where - getTypeAnn = starNotes - -instance - ( HasTypeAnn (ZippedStack i) - , HasTypeAnn (ZippedStack o) - ) - => - HasTypeAnn (i :-> o) - where - getTypeAnn = NTLambda noAnn - (getTypeAnn @(ZippedStack i)) - (getTypeAnn @(ZippedStack o)) - --- A Generic HasTypeAnn implementation -class GHasTypeAnn a where - gGetTypeAnn :: Notes (GValueType a) - -instance GHasTypeAnn G.U1 where - gGetTypeAnn = starNotes - -instance (GHasTypeAnn x) => GHasTypeAnn (G.M1 i0 i1 x) where - gGetTypeAnn = gGetTypeAnn @x - -instance - ( GHasTypeAnn x - , GHasTypeAnn y - ) - => - GHasTypeAnn (x G.:+: y) - where - gGetTypeAnn = NTOr noAnn noAnn noAnn - (gGetTypeAnn @x) - (gGetTypeAnn @y) - -instance - ( GHasTypeAnn x - , GHasTypeAnn y - ) - => - GHasTypeAnn (x G.:*: y) - where - gGetTypeAnn = NTPair noAnn noAnn noAnn - (gGetTypeAnn @x) - (gGetTypeAnn @y) - -instance (HasTypeAnn x) => GHasTypeAnn (G.Rec0 x) where - gGetTypeAnn = getTypeAnn @x diff --git a/src/Lorentz/UParam.hs b/src/Lorentz/UParam.hs deleted file mode 100644 --- a/src/Lorentz/UParam.hs +++ /dev/null @@ -1,417 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Lorentz.UParam - ( UParam (..) - , EntryPointKind - , type (?:) - - -- * Construction - , mkUParam - - -- * Deconstruction - , ConstrainedSome (..) - , UnpackUParam - , unpackUParam - - -- * Casting to homomorphic value - , SomeInterface - , UParam_ - - -- * Pattern-matching - , EntryPointsImpl - , UParamFallback - , EntryPointLookupError (..) - , CaseUParam - , caseUParam - , caseUParamT - , uparamFallbackFail - - -- * Constraints - , LookupEntryPoint - , RequireUniqueEntryPoints - - -- * Conversion from ADT - , uparamFromAdt - , UParamLinearize - , UParamLinearized - - -- * Documentation - , pbsUParam - - -- * Internals used for entrypoint-wise migrations - , unwrapUParam - ) where - -import Data.Constraint ((\\)) -import qualified Data.Kind as Kind -import Data.Vinyl.Core (Rec(..)) -import Data.Vinyl.Derived (Label) -import Data.Vinyl.TypeLevel (type (++)) -import qualified Fcf -import Fmt (Buildable(..)) -import GHC.Generics ((:*:)(..), (:+:)(..)) -import qualified GHC.Generics as G -import GHC.TypeLits (KnownSymbol, Symbol) -import qualified Text.Show - -import Lorentz.ADT -import Lorentz.Base -import Lorentz.Coercions -import Lorentz.EntryPoints.Doc -import Lorentz.Constraints -import Lorentz.Errors -import Lorentz.Instr as L -import Lorentz.Macro -import Lorentz.Pack -import Michelson.Text -import Michelson.Typed -import Util.Type -import Util.TypeLits -import Util.TypeTuple -import Util.Markdown - --- | An entrypoint is described by two types: its name and type of argument. -type EntryPointKind = (Symbol, Kind.Type) - --- | A convenient alias for type-level name-something pair. -type (n :: Symbol) ?: (a :: k) = '(n, a) - --- | Encapsulates parameter for one of entry points. --- It keeps entrypoint name and corresponding argument serialized. --- --- In Haskell world, we keep an invariant of that contained value relates --- to one of entry points from @entries@ list. -newtype UParam (entries :: [EntryPointKind]) = UParamUnsafe (MText, ByteString) - deriving stock (Generic, Eq, Show) - deriving anyclass (IsoValue) - -instance Wrapped (UParam entries) - --- Casting to homomorphic value ----------------------------------------------------------------------------- - --- | Pseudo value for 'UParam' type variable. -type SomeInterface = '[ '("SomeEntrypoints", Void) ] - --- | Homomorphic version of 'UParam', forgets the exact interface. -type UParam_ = UParam SomeInterface - --- | Allows casts only between 'UParam_' and 'UParam'. -instance SameEntries entries1 entries2 => - UParam entries1 `CanCastTo` UParam entries2 - -type family SameEntries (es1 :: [EntryPointKind]) (es :: [EntryPointKind]) - :: Constraint where - SameEntries e e = () - SameEntries SomeInterface _ = () - SameEntries _ SomeInterface = () - SameEntries e1 e2 = (e1 ~ e2) - ----------------------------------------------------------------------------- --- Common type-level stuff ----------------------------------------------------------------------------- - --- | Get type of entrypoint argument by its name. -type family LookupEntryPoint (name :: Symbol) (entries :: [EntryPointKind]) - :: Kind.Type where - LookupEntryPoint name ('(name, a) ': _) = a - LookupEntryPoint name (_ ': entries) = LookupEntryPoint name entries - LookupEntryPoint name '[] = - TypeError ('Text "Entry point " ':<>: 'ShowType name ':<>: - 'Text " in not in the entry points list") - --- | Ensure that given entry points do no contain duplicated names. -type family RequireUniqueEntryPoints (entries :: [EntryPointKind]) - :: Constraint where - RequireUniqueEntryPoints entries = - RequireAllUnique "entrypoint" (Fcf.Eval (Fcf.Map Fcf.Fst entries)) - ----------------------------------------------------------------------------- --- Construction ----------------------------------------------------------------------------- - --- | Construct a 'UParam' safely. -mkUParam - :: ( KnownSymbol name, NicePackedValue a - , LookupEntryPoint name entries ~ a - , RequireUniqueEntryPoints entries - ) - => Label name -> a -> UParam entries -mkUParam label (a :: a) = - UParamUnsafe (labelToMText label, lPackValue a) - \\ nicePackedValueEvi @a - --- Example ----------------------------------------------------------------------------- - -type MyEntryPoints = - [ "add" ?: Integer - , "reset" ?: () - ] - -_mkParamSample1 :: UParam MyEntryPoints -_mkParamSample1 = mkUParam #add 5 - ----------------------------------------------------------------------------- --- Deconstruction ----------------------------------------------------------------------------- - --- | This type can store any value that satisfies a certain constraint. -data ConstrainedSome (c :: Kind.Type -> Constraint) where - ConstrainedSome :: c a => a -> ConstrainedSome c - -instance Show (ConstrainedSome Show) where - show (ConstrainedSome a) = show a - -instance Buildable (ConstrainedSome Buildable) where - build (ConstrainedSome a) = build a - --- | This class is needed to implement `unpackUParam`. -class UnpackUParam (c :: Kind.Type -> Constraint) entries where - -- | Turn 'UParam' into a Haskell value. - -- Since we don't know its type in compile time, we have to erase it using - -- 'ConstrainedSome'. The user of this function can require arbitrary - -- constraint to hold (depending on how they want to use the result). - unpackUParam :: - UParam entries -> Either EntryPointLookupError (MText, ConstrainedSome c) - -instance UnpackUParam c '[] where - unpackUParam (UParamUnsafe (name, _)) = Left (NoSuchEntryPoint name) - -instance - ( KnownSymbol name - , UnpackUParam c entries - , NiceUnpackedValue arg - , c arg - ) => UnpackUParam c ((name ?: arg) ': entries) where - unpackUParam (UParamUnsafe (name, bytes)) - | name == symbolToMText @name = - fmap (name,) . - first (const ArgumentUnpackFailed) . - fmap ConstrainedSome . - lUnpackValue @arg $ - bytes - | otherwise = unpackUParam @c @entries (UParamUnsafe (name, bytes)) - ----------------------------------------------------------------------------- --- Pattern-matching ----------------------------------------------------------------------------- - --- | Helper instruction which extracts content of 'UParam'. -unwrapUParam :: UParam entries : s :-> (MText, ByteString) : s -unwrapUParam = coerceUnwrap - --- | Wrapper for a single "case" branch. -data CaseClauseU inp out (entry :: EntryPointKind) where - CaseClauseU :: (arg : inp) :-> out -> CaseClauseU inp out '(name, arg) - -instance (name ~ name', body ~ ((arg : inp) :-> out)) => - CaseArrow name' body (CaseClauseU inp out '(name, arg)) where - (/->) _ = CaseClauseU - -data EntryPointLookupError - = NoSuchEntryPoint MText - | ArgumentUnpackFailed - deriving stock (Generic, Eq, Show) - -instance Buildable EntryPointLookupError where - build = - \case - NoSuchEntryPoint name -> "No such entrypoint: " <> build name - ArgumentUnpackFailed -> "UNPACK failed" - -type instance ErrorArg "uparamNoSuchEntryPoint" = MText -type instance ErrorArg "uparamArgumentUnpackFailed" = () - -instance Buildable (CustomError "uparamNoSuchEntryPoint") where - build (CustomError _ name) = "No such entrypoint: " <> build name - -instance Buildable (CustomError "uparamArgumentUnpackFailed") where - build (CustomError _ ()) = "UNPACK failed" - -instance CustomErrorHasDoc "uparamNoSuchEntryPoint" where - customErrClass = ErrClassBadArgument - customErrDocMdCause = "Entrypoint with given name does not exist." - -instance CustomErrorHasDoc "uparamArgumentUnpackFailed" where - customErrClass = ErrClassBadArgument - customErrDocMdCause = "Argument of wrong type is provided to the entrypoint." - --- | Implementations of some entry points. --- --- Note that this thing inherits properties of 'Rec', e.g. you can --- @Data.Vinyl.Core.rappend@ implementations for two entrypoint sets --- when assembling scattered parts of a contract. -type EntryPointsImpl inp out entries = - Rec (CaseClauseU inp out) entries - --- | An action invoked when user-provided entrypoint is not found. -type UParamFallback inp out = ((MText, ByteString) : inp) :-> out - --- | Default implementation for 'UParamFallback', simply reports an error. -uparamFallbackFail :: UParamFallback inp out -uparamFallbackFail = - car # failCustom #uparamNoSuchEntryPoint - --- | Make up a "case" over entry points. -class CaseUParam (entries :: [EntryPointKind]) where - -- | Pattern-match on given @UParam entries@. - -- - -- You have to provide all case branches and a fallback action on case - -- when entrypoint is not found. - -- - -- This function is unsafe because it does not make sure at type-level - -- that entry points' names do not repeat. - caseUParamUnsafe - :: Rec (CaseClauseU inp out) entries - -> UParamFallback inp out - -> (UParam entries : inp) :-> out - -instance CaseUParam '[] where - caseUParamUnsafe RNil fallback = unwrapUParam # fallback - -instance ( KnownSymbol name - , CaseUParam entries - , NiceUnpackedValue arg - ) => - CaseUParam ((name ?: arg) ': entries) where - caseUParamUnsafe (CaseClauseU clause :& clauses) fallback = - dup # unwrapUParam # car # - push (mkMTextUnsafe $ symbolValT' @name) # eq # - if_ (unwrapUParam # cdr # unpack # - ifSome nop (failCustom_ #uparamArgumentUnpackFailed) # clause) - (cutUParamEntry # caseUParamUnsafe clauses fallback) - where - cutUParamEntry :: UParam (e : es) : s :-> UParam es : s - cutUParamEntry = forcedCoerce_ - --- | Pattern-match on given @UParam entries@. --- --- You have to provide all case branches and a fallback action on case --- when entrypoint is not found. -caseUParam - :: (CaseUParam entries, RequireUniqueEntryPoints entries) - => Rec (CaseClauseU inp out) entries - -> UParamFallback inp out - -> (UParam entries : inp) :-> out -caseUParam = caseUParamUnsafe - --- | Like 'caseUParam', but accepts a tuple of clauses, not a 'Rec'. -caseUParamT - :: forall entries inp out clauses. - ( clauses ~ Rec (CaseClauseU inp out) entries - , RecFromTuple clauses - , CaseUParam entries - ) - => IsoRecTuple clauses - -> UParamFallback inp out - -> (UParam entries : inp) :-> out -caseUParamT clauses fallback = caseUParamUnsafe (recFromTuple clauses) fallback - --- Example ----------------------------------------------------------------------------- - -_caseSample :: UParam MyEntryPoints : s :-> Integer : s -_caseSample = caseUParamT - ( #add /-> nop - , #reset /-> L.drop @() # push 0 - ) uparamFallbackFail - ----------------------------------------------------------------------------- --- ADT conversion ----------------------------------------------------------------------------- - -{- @martoon: I actually hope no one will use this capability, - it's here primarily because in other places we also use Generic stuff. - - Representation with type-level list and a datatype made polymorhpic over - it seems more powerful than Generics. - 1. It's simpler to implement features for it. No extra boilerplate. - 2. 'Data.Vinyl' provides many useful utilities to work with such things. - 3. You are not such constrained in selecting names of entry points as when - they come from constructor names. --} - --- | Make up 'UParam' from ADT sum. --- --- Entry points template will consist of --- @(constructorName, constructorFieldType)@ pairs. --- Each constructor is expected to have exactly one field. -uparamFromAdt - :: UParamLinearize up - => up -> UParam (UParamLinearized up) -uparamFromAdt = adtToRec . G.from - --- | Constraint required by 'uparamFromAdt'. -type UParamLinearize p = (Generic p, GUParamLinearize (G.Rep p)) - --- | Entry points template derived from given ADT sum. -type UParamLinearized p = GUParamLinearized (G.Rep p) - --- | Generic traversal for conversion between ADT sum and 'UParam'. -class GUParamLinearize (x :: Kind.Type -> Kind.Type) where - type GUParamLinearized x :: [(Symbol, Kind.Type)] - adtToRec :: x p -> UParam (GUParamLinearized x) - -instance GUParamLinearize x => GUParamLinearize (G.D1 i x) where - type GUParamLinearized (G.D1 i x) = GUParamLinearized x - adtToRec = adtToRec . G.unM1 - -instance (GUParamLinearize x, GUParamLinearize y) => GUParamLinearize (x :+: y) where - type GUParamLinearized (x :+: y) = GUParamLinearized x ++ GUParamLinearized y - adtToRec = \case - G.L1 x -> let UParamUnsafe up = adtToRec x in UParamUnsafe up - G.R1 y -> let UParamUnsafe up = adtToRec y in UParamUnsafe up - -instance (KnownSymbol name, NicePackedValue a) => - GUParamLinearize (G.C1 ('G.MetaCons name _1 _2) (G.S1 si (G.Rec0 a))) where - type GUParamLinearized (G.C1 ('G.MetaCons name _1 _2) (G.S1 si (G.Rec0 a))) = - '[ '(name, a) ] - - adtToRec (G.M1 (G.M1 (G.K1 a))) = UParamUnsafe - ( symbolToMText @name - , lPackValue a - ) - -instance - TypeError ('Text "UParam linearization requires exactly one field \ - \in each constructor") => - GUParamLinearize (G.C1 i G.U1) where - type GUParamLinearized (G.C1 i G.U1) = - TypeError ('Text "Bad linearized ADT") - adtToRec = error "impossible" - -instance - TypeError ('Text "UParam linearization requires exactly one field \ - \in each constructor") => - GUParamLinearize (G.C1 i (x :*: y)) where - type GUParamLinearized (G.C1 i (x :*: y)) = - TypeError ('Text "Bad linearized ADT") - adtToRec = error "impossible" - ----------------------------------------------------------------------------- --- Documentation ----------------------------------------------------------------------------- - -instance Typeable interface => TypeHasDoc (UParam interface) where - typeDocName _ = "Upgradable parameter" - typeDocMdReference p = customTypeDocMdReference ("UParam", DType p) [] - typeDocMdDescription = - "This type encapsulates parameter for one of entry points. \ - \It keeps entry point name and corresponding argument serialized." - typeDocHaskellRep = homomorphicTypeDocHaskellRep - typeDocMichelsonRep = homomorphicTypeDocMichelsonRep - --- | Note that calling given entrypoints involves constructing 'UParam'. -pbsUParam :: forall ctorName. KnownSymbol ctorName => ParamBuildingStep -pbsUParam = - let ctor = build $ symbolValT' @ctorName - in ParamBuildingStep - { pbsEnglish = - "Wrap into *UParam* as " <> mdTicked ctor <> " entrypoint." - , pbsHaskell = - \a -> "mkUParam #" <> ctor <> " (" <> a <> ")" - , pbsMichelson = - \a -> "Pair \"" <> ctor <> "\" (pack (" <> a <> "))" - } diff --git a/src/Lorentz/UStore.hs b/src/Lorentz/UStore.hs deleted file mode 100644 --- a/src/Lorentz/UStore.hs +++ /dev/null @@ -1,93 +0,0 @@ -{- | This module contains implementation of 'UStore'. - -@UStore@ is essentially 'Lorentz.Store.Store' modified for the sake of -upgradeability. - -In API it differs from @Store@ in the following ways: -1. It keeps both virtual @big_map@s and plain fields; -2. Neat conversion between Michelson and Haskell values -is implemented; -3. Regarding composabililty, one can operate with one @UStore@ -and then lift it to a bigger one which includes the former. -This allows for simpler management of stores and clearer error messages. -In spite of this, operations with 'UStore's over deeply nested templates will -still work as before. - -We represent 'UStore' as @big_map bytes bytes@. - -* Plain fields are stored as -@key = pack fieldName; value = pack originalValue@. - -* Virtual @big_map@s are kept as -@key = pack (bigMapName, originalKey); value = pack originalValue@. - --} -module Lorentz.UStore - ( -- * UStore and related type definitions - UStore - , type (|~>)(..) - , UStoreFieldExt (..) - , UStoreField - , UStoreMarkerType - , KnownUStoreMarker (..) - - -- ** Type-lookup-by-name - , GetUStoreKey - , GetUStoreValue - , GetUStoreField - , GetUStoreFieldMarker - - -- ** Instructions - , ustoreMem - , ustoreGet - , ustoreUpdate - , ustoreInsert - , ustoreInsertNew - , ustoreDelete - - , ustoreToField - , ustoreGetField - , ustoreSetField - - -- ** Instruction constraints - , HasUStore - , HasUField - , HasUStoreForAllIn - - -- * UStore composability - , liftUStore - , unliftUStore - - -- * UStore management from Haskell - , UStoreConversible - , mkUStore - , ustoreDecompose - , ustoreDecomposeFull - , fillUStore - - -- * Migrations - , MigrationScript (..) - , MigrationScript_ - , UStoreMigration - , migrationToScript - , migrationToScriptI - , migrationToLambda - , mkUStoreMigration - , mustoreToOld - , migrateGetField - , migrateAddField - , migrateRemoveField - , migrateExtractField - , migrateOverwriteField - , migrateModifyField - - -- * Extras - , PickMarkedFields - ) where - -import Lorentz.UStore.Types -import Lorentz.UStore.Instr -import Lorentz.UStore.Instances () -import Lorentz.UStore.Haskell -import Lorentz.UStore.Lift -import Lorentz.UStore.Migration diff --git a/src/Lorentz/UStore/Common.hs b/src/Lorentz/UStore/Common.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Common.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Lorentz.UStore.Common - ( fieldNameToMText - ) where - -import GHC.TypeLits (KnownSymbol, symbolVal) - -import Michelson.Text - -fieldNameToMText :: forall field. KnownSymbol field => MText -fieldNameToMText = - -- Using 'mkMTextUnsafe' because our coding practices does not allow - -- weird characters (like unicode) in field names - mkMTextUnsafe . toText . symbolVal $ Proxy @field diff --git a/src/Lorentz/UStore/Haskell.hs b/src/Lorentz/UStore/Haskell.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Haskell.hs +++ /dev/null @@ -1,335 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- | Conversion between 'UStore' in Haskell and Michelson representation. -module Lorentz.UStore.Haskell - ( UStoreContent - , UStoreConversible - , mkUStore - , ustoreDecompose - , ustoreDecomposeFull - , fillUStore - , migrateFillUStore - , fillUStoreMigrationBlock - ) where - -import qualified Data.Kind as Kind -import qualified Data.List as L -import qualified Data.Map as Map -import Data.Singletons (demote) -import Fcf (type (=<<), Eval, Pure2) -import qualified Fcf -import Fmt ((+|), (+||), (|+), (||+)) -import GHC.Generics ((:*:)(..), (:+:)(..)) -import qualified GHC.Generics as G -import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal) - -import Lorentz.Base -import Lorentz.Coercions -import Lorentz.Constraints -import qualified Lorentz.Instr as L -import Lorentz.Pack -import Lorentz.UStore.Common -import Lorentz.UStore.Migration -import Lorentz.UStore.Migration.Diff -import Lorentz.UStore.Types -import Michelson.Interpret.Pack -import Michelson.Text -import Michelson.Typed.Haskell.Value -import Util.Type - --- | 'UStore' content represented as key-value pairs. -type UStoreContent = [(ByteString, ByteString)] - --- | Make 'UStore' from separate @big_map@s and fields. -mkUStore - :: (UStoreConversible template) - => template -> UStore template -mkUStore = UStore . BigMap . mkUStoreRec - --- | Decompose 'UStore' into separate @big_map@s and fields. --- --- Since this function needs to @UNPACK@ content of @UStore@ to actual --- keys and values, you have to provide 'UnpackEnv'. --- --- Along with resulting value, you get a list of @UStore@ entries which --- were not recognized as belonging to any submap or field according to --- @UStore@'s template - this should be empty unless @UStore@ invariants --- were violated. -ustoreDecompose - :: forall template. - (UStoreConversible template) - => UStore template -> Either Text (UStoreContent, template) -ustoreDecompose = storeDecomposeRec . Map.toList . unBigMap . unUStore - --- | Make migration script which initializes 'UStore' from scratch. -fillUStore - :: (UStoreConversible template) - => template -> UStoreMigration () template -fillUStore v = UStoreMigration $ appEndo (fillUStoreRec v) [] - --- | Version of 'migrateFillUStore' for batched migrations. --- --- Each field write will be placed to a separate batch. -fillUStoreMigrationBlock - :: ( UStoreConversible template - , allFieldsExp ~ AllUStoreFieldsF template - , newDiff ~ FillingNewDiff template diff - , newTouched ~ FillingNewTouched template touched - , PatternMatchL newDiff, PatternMatchL newTouched - ) - => template - -> MigrationBlocks oldTempl newTempl diff touched newDiff newTouched -fillUStoreMigrationBlock v = MigrationBlocks $ appEndo (fillUStoreRec v) [] - --- | Fill 'UStore' with entries from the given template as part of simple --- migration. --- --- Sometimes you already have some fields initialized and 'fillUStore' does not --- suit, then in case if your UStore template is a nested structure you can use --- sub-templates to initialize the corresponding parts of UStore. --- --- For batched migrations see 'fillUStoreMigrationBlock'. -migrateFillUStore - :: ( UStoreConversible template - , allFieldsExp ~ AllUStoreFieldsF template - , newDiff ~ FillingNewDiff template diff - , newTouched ~ FillingNewTouched template touched - , PatternMatchL newDiff, PatternMatchL newTouched - ) - => template - -> Lambda - (MUStore oldTempl newTempl diff touched) - (MUStore oldTempl newTempl newDiff newTouched) -migrateFillUStore v = - let atoms = appEndo (fillUStoreRec v) [] - script = foldMap (unMigrationScript . maScript) atoms - in forcedCoerce_ # script # forcedCoerce_ - -type FillingNewDiff template diff = - CoverDiffMany diff - (Eval (Fcf.Map (Pure2 '(,) 'DcAdd) =<< LinearizeUStoreF template)) - -type FillingNewTouched template touched = - Eval (AllUStoreFieldsF template) ++ touched - --- Implementation ----------------------------------------------------------------------------- - --- | Like 'ustoreDecompose', but requires all entries from @UStore@ to be --- recognized. -ustoreDecomposeFull - :: forall template. - (UStoreConversible template) - => UStore template -> Either Text template -ustoreDecomposeFull ustore = do - (remained, res) <- ustoreDecompose ustore - unless (null remained) $ - Left $ "Unrecognized entries in UStore: " +|| remained ||+ "" - return res - --- | Recursive template traversal for 'mkUStore'. -mkUStoreRec - :: (UStoreConversible template) - => template -> Map ByteString ByteString -mkUStoreRec = gUstoreToVal . G.from - --- | Recursive template traversal for 'ustoreDecompose'. -storeDecomposeRec - :: forall template. - (UStoreConversible template) - => UStoreContent -> Either Text (UStoreContent, template) -storeDecomposeRec = fmap (second G.to) ... gUstoreFromVal - --- | Recursive template traversal for 'fillUStore'. -fillUStoreRec - :: (UStoreConversible template) - => template - -> Endo [MigrationAtom] -fillUStoreRec = gUstoreToScript . G.from - --- | Given template can be converted to 'UStore' value. -class (Generic template, GUStoreConversible (G.Rep template)) => - UStoreConversible template -instance (Generic template, GUStoreConversible (G.Rep template)) => - UStoreConversible template - --- | Generic traversal for 'mkUStore' and 'ustoreDecompose'. -class GUStoreConversible (template :: Kind.Type -> Kind.Type) where - -- | Convert generic value to internal 'UStore' representation. - gUstoreToVal :: template p -> Map ByteString ByteString - - -- | Parse internal 'UStore' representation into generic Haskell value of - -- 'UStore', also returning unparsed entries. - gUstoreFromVal - :: UStoreContent - -> Either Text (UStoreContent, template p) - - -- | Convert generic value to a script filling the corresponding 'UStore'. - gUstoreToScript - :: template p - -> Endo [MigrationAtom] - -instance GUStoreConversible x => GUStoreConversible (G.D1 i x) where - gUstoreToVal = gUstoreToVal . G.unM1 - gUstoreFromVal = fmap (second G.M1) ... gUstoreFromVal - gUstoreToScript = gUstoreToScript . G.unM1 - -instance GUStoreConversible x => GUStoreConversible (G.C1 i x) where - gUstoreToVal = gUstoreToVal . G.unM1 - gUstoreFromVal = fmap (second G.M1) ... gUstoreFromVal - gUstoreToScript = gUstoreToScript . G.unM1 - -instance TypeError ('Text "Unexpected sum type in UStore template") => - GUStoreConversible (x :+: y) where - gUstoreToVal = error "impossible" - gUstoreFromVal = error "impossible" - gUstoreToScript = error "impossible" - -instance TypeError ('Text "UStore template should have one constructor") => - GUStoreConversible G.V1 where - gUstoreToVal = error "impossible" - gUstoreFromVal = error "impossible" - gUstoreToScript = error "impossible" - -instance (GUStoreConversible x, GUStoreConversible y) => - GUStoreConversible (x :*: y) where - gUstoreToVal (x :*: y) = gUstoreToVal x <> gUstoreToVal y - gUstoreFromVal entries = do - (entries', res1) <- gUstoreFromVal entries - (entries'', res2) <- gUstoreFromVal entries' - return (entries'', res1 :*: res2) - gUstoreToScript (x :*: y) = gUstoreToScript x <> gUstoreToScript y - -instance GUStoreConversible G.U1 where - gUstoreToVal G.U1 = mempty - gUstoreFromVal entries = pure (entries, G.U1) - gUstoreToScript G.U1 = mempty - --- | Case of nested template. -instance {-# OVERLAPPABLE #-} - (UStoreConversible template) => - GUStoreConversible (G.S1 i (G.Rec0 template)) where - gUstoreToVal = mkUStoreRec . G.unK1 . G.unM1 - gUstoreFromVal = fmap (second $ G.M1 . G.K1) ... storeDecomposeRec - gUstoreToScript = fillUStoreRec . G.unK1 . G.unM1 - --- | Case of '|~>'. -instance ( NiceFullPackedValue k, NiceFullPackedValue v - , KnownSymbol fieldName, Ord k - ) => - GUStoreConversible (G.S1 ('G.MetaSel ('Just fieldName) _1 _2 _3) - (G.Rec0 (k |~> v))) where - gUstoreToVal (G.M1 (G.K1 (UStoreSubMap m))) = - mconcat - [ one ( lPackValue (fieldNameToMText @fieldName, k) - , lPackValue v - ) - | (k, v) <- Map.toList m - ] - - gUstoreFromVal allEntries = do - (unrecognized, res) <- foldM parseEntry (mempty, mempty) allEntries - return (unrecognized, G.M1 . G.K1 $ UStoreSubMap res) - where - parseEntry - :: (UStoreContent, Map k v) - -> (ByteString, ByteString) - -> Either Text (UStoreContent, Map k v) - parseEntry (entries, !acc) entry@(key, val) = - case lUnpackValue @(UStoreSubmapKey _) key of - Left _ -> Right (entry : entries, acc) - Right (name :: MText, keyValue :: k) - | toText name /= toText (symbolVal $ Proxy @fieldName) -> - Right (entry : entries, acc) - | otherwise -> - case lUnpackValue val of - Left err -> - Left $ "Failed to parse UStore value for " +| - demote @(ToT k) |+ " |~> " +| demote @(ToT v) |+ - ": " +| err |+ "" - Right valValue -> - Right (entries, Map.insert keyValue valValue acc) - - gUstoreToScript (G.M1 (G.K1 (UStoreSubMap m))) = Endo . (<>) $ - Map.toList m <&> \(k, v) -> - formMigrationAtom Nothing $ - attachMigrationActionName (DAddAction "init submap") (fromLabel @fieldName) (Proxy @v) # - -- @PUSH + PACK@ will be merged by optimizer, but there is still place - -- for further improvement both or value and key pushing. - -- We cannot push already packed value because that would break code - -- analyzers and transformers, consider adding necessary rules to - -- optimizer. - -- TODO [TM-379]: consider improving this case - -- or - -- TODO: add necessary rules to optimizer - L.push v # L.pack # L.some # - L.push k # L.push (fieldNameToMText @fieldName) # L.pair # - L.pack @(UStoreSubmapKey _) # - L.update - --- | Case of 'UStoreField'. -instance (NiceFullPackedValue v, KnownUStoreMarker m, KnownSymbol fieldName) => - GUStoreConversible (G.S1 ('G.MetaSel ('Just fieldName) _1 _2 _3) - (G.Rec0 (UStoreFieldExt m v))) where - gUstoreToVal (G.M1 (G.K1 (UStoreField val))) = - one ( mkFieldMarkerUKeyL @m (fromLabel @fieldName) - , lPackValue val - ) - - gUstoreFromVal entries = - let key = packValue' $ toVal (fieldNameToMText @fieldName) - in case L.partition ((== key) . fst) entries of - ([], _) -> - Left $ "Failed to find field in UStore: " +| - fieldNameToMText @fieldName |+ "" - ([(_, val)], otherEntries) -> - case lUnpackValue val of - Left err -> - Left $ "Failed to parse UStore value for field " +| - demote @(ToT v) |+ ": " +| err |+ "" - Right valValue -> - Right (otherEntries, G.M1 . G.K1 $ UStoreField valValue) - (_ : _ : _, _) -> - error "UStore content contained multiple entries with the same key" - - gUstoreToScript (G.M1 (G.K1 (UStoreField val))) = - Endo . (:) . formMigrationAtom Nothing $ - attachMigrationActionName (DAddAction "init field") (fromLabel @fieldName) (Proxy @v) # - -- Not pushing already packed value (which would be more efficient) because - -- analyzers cannot work with packed values. - -- TODO: make optimizer compress this to @push (Just $ lPackValue val)@ - L.push val # L.pack # L.some # - - L.push (mkFieldMarkerUKeyL @m (fromLabel @fieldName)) # - L.update - --- Examples ----------------------------------------------------------------------------- - -data MyStoreTemplate = MyStoreTemplate - { ints :: Integer |~> () - , flag :: UStoreField Bool - } - deriving stock (Generic) - -data MyStoreTemplateBig = MyStoreTemplateBig - { templ :: MyStoreTemplate - , bytes :: ByteString |~> ByteString - } - deriving stock (Generic) - -_storeSample :: UStore MyStoreTemplate -_storeSample = mkUStore - MyStoreTemplate - { ints = UStoreSubMap $ one (1, ()) - , flag = UStoreField False - } - -_storeSampleBig :: UStore MyStoreTemplateBig -_storeSampleBig = mkUStore $ - MyStoreTemplateBig - MyStoreTemplate - { ints = UStoreSubMap $ one (1, ()) - , flag = UStoreField False - } - (UStoreSubMap $ one ("a", "b")) diff --git a/src/Lorentz/UStore/Instances.hs b/src/Lorentz/UStore/Instances.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Instances.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -module Lorentz.UStore.Instances () where - -import Lorentz.StoreClass -import Lorentz.UStore.Instr -import Lorentz.UStore.Types - -instance HasUField fname ftype templ => - StoreHasField (UStore templ) fname ftype where - storeFieldOps = StoreFieldOps - { sopToField = ustoreToField - , sopSetField = ustoreSetField - } - -instance HasUStore mname key value templ => - StoreHasSubmap (UStore templ) mname key value where - storeSubmapOps = StoreSubmapOps - { sopMem = ustoreMem - , sopGet = ustoreGet - , sopUpdate = ustoreUpdate - , sopDelete = Just ustoreDelete - , sopInsert = Just ustoreInsert - } diff --git a/src/Lorentz/UStore/Instr.hs b/src/Lorentz/UStore/Instr.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Instr.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- | Instructions to work with 'UStore'. -module Lorentz.UStore.Instr - ( unsafeEmptyUStore - , ustoreMem - , ustoreGet - , ustoreUpdate - , ustoreInsert - , ustoreInsertNew - , ustoreDelete - - , ustoreToField - , ustoreGetField - , ustoreSetField - , ustoreRemoveFieldUnsafe - - -- ** Instruction constraints - , HasUStore - , HasUField - , HasUStoreForAllIn - - -- ** Internals - , packSubMapUKey - ) where - -import qualified Data.Kind as Kind -import GHC.Generics ((:*:), (:+:)) -import qualified GHC.Generics as G -import Data.Vinyl.Derived (Label) -import GHC.TypeLits (KnownSymbol, Symbol) -import Type.Reflection ((:~:)(Refl)) - -import Lorentz.Base -import Lorentz.Coercions (coerceWrap) -import Lorentz.Errors -import Lorentz.Instr as L -import Lorentz.Macro -import Lorentz.Constraints -import Lorentz.UStore.Types -import Lorentz.UStore.Common -import Michelson.Text -import Michelson.Typed.Haskell.Value - --- Helpers ----------------------------------------------------------------------------- - -type KeyAccessC store name = - ( NiceFullPackedValue (GetUStoreKey store name) - , KnownSymbol name - ) - -type ValueAccessC store name = - ( NiceFullPackedValue (GetUStoreValue store name) - , KnownSymbol name - ) - -type FieldAccessC store name = - ( NiceFullPackedValue (GetUStoreField store name) - , KnownUStoreMarker (GetUStoreFieldMarker store name) - , KnownSymbol name - ) - -packSubMapUKey - :: forall (field :: Symbol) k s. - (KnownSymbol field, NicePackedValue k) - => (k : s) :-> (ByteString : s) -packSubMapUKey = push submapName # pair # pack @(UStoreSubmapKey _) - where - submapName = fieldNameToMText @field - -unpackUValueUnsafe - :: forall (field :: Symbol) val s. - (KnownSymbol field, NiceUnpackedValue val) - => (ByteString : s) :-> (val : s) -unpackUValueUnsafe = unpack @val # ifSome nop (failUsing failErr) - where - failErr = mconcat - [ [mt|UStore: failed to unpack |] - , fieldNameToMText @field - ] - --- Main instructions ----------------------------------------------------------------------------- - --- | Put an empty 'UStore' onto the stack. This function is generally unsafe: --- if store template contains a 'UStoreField', the resulting 'UStore' is not --- immediately usable. --- If you are sure that 'UStore' contains only submaps, feel free to just use --- the result of this function. Otherwise you must set all fields. -unsafeEmptyUStore :: forall store s. s :-> UStore store ': s -unsafeEmptyUStore = emptyBigMap # coerceWrap - -ustoreMem - :: forall store name s. - (KeyAccessC store name) - => Label name - -> GetUStoreKey store name : UStore store : s :-> Bool : s -ustoreMem _ = packSubMapUKey @name # mem - -ustoreGet - :: forall store name s. - (KeyAccessC store name, ValueAccessC store name) - => Label name - -> GetUStoreKey store name : UStore store : s - :-> Maybe (GetUStoreValue store name) : s -ustoreGet _ = - packSubMapUKey @name # - L.get # - lmap (unpackUValueUnsafe @name @(GetUStoreValue store name)) - -ustoreUpdate - :: forall store name s. - (KeyAccessC store name, ValueAccessC store name) - => Label name - -> GetUStoreKey store name - : Maybe (GetUStoreValue store name) - : UStore store - : s - :-> UStore store : s -ustoreUpdate _ = - packSubMapUKey @name # - dip (lmap pack) # - update - -ustoreInsert - :: forall store name s. - (KeyAccessC store name, ValueAccessC store name) - => Label name - -> GetUStoreKey store name - : GetUStoreValue store name - : UStore store - : s - :-> UStore store : s -ustoreInsert _ = - packSubMapUKey @name # - dip (pack # L.some) # - update - --- | Insert a key-value pair, but fail if it will overwrite some existing entry. -ustoreInsertNew - :: forall store name s. - (KeyAccessC store name, ValueAccessC store name) - => Label name - -> (forall s0 any. GetUStoreKey store name : s0 :-> any) - -> GetUStoreKey store name - : GetUStoreValue store name - : UStore store - : s - :-> UStore store : s -ustoreInsertNew label doFail = - duupX @3 # duupX @2 # ustoreMem label # - if_ doFail (ustoreInsert label) - -ustoreDelete - :: forall store name s. - (KeyAccessC store name) - => Label name - -> GetUStoreKey store name : UStore store : s - :-> UStore store : s -ustoreDelete _ = - packSubMapUKey @name # - dip none # - update - --- | Like 'toField', but for 'UStore'. --- --- This may fail only if 'UStore' was made up incorrectly during contract --- initialization. -ustoreToField - :: forall store name s. - (FieldAccessC store name) - => Label name - -> UStore store : s - :-> GetUStoreField store name : s -ustoreToField l = - push (mkFieldUKey @store l) # - L.get # - ensureFieldIsPresent # - unpackUValueUnsafe @name @(GetUStoreField store name) - where - ensureFieldIsPresent = - ifSome nop $ failUsing $ mconcat - [ [mt|UStore: no field |] - , fieldNameToMText @name - ] - --- | Like 'getField', but for 'UStore'. --- --- This may fail only if 'UStore' was made up incorrectly during contract --- initialization. -ustoreGetField - :: forall store name s. - (FieldAccessC store name) - => Label name - -> UStore store : s - :-> GetUStoreField store name : UStore store : s -ustoreGetField label = dup # ustoreToField label - --- | Like 'setField', but for 'UStore'. -ustoreSetField - :: forall store name s. - (FieldAccessC store name) - => Label name - -> GetUStoreField store name : UStore store : s - :-> UStore store : s -ustoreSetField l = - pack # L.some # - push (mkFieldUKey @store l) # - L.update - --- | Remove a field from 'UStore', for internal purposes only. -ustoreRemoveFieldUnsafe - :: forall store name s. - (FieldAccessC store name) - => Label name - -> UStore store : s - :-> UStore store : s -ustoreRemoveFieldUnsafe l = - L.none # - push (mkFieldUKey @store l) # - L.update - --- | This constraint can be used if a function needs to work with --- /big/ store, but needs to know only about some submap(s) of it. --- --- It can use all UStore operations for a particular name, key and --- value without knowing whole template. -type HasUStore name key value store = - ( KeyAccessC store name, ValueAccessC store name - , GetUStoreKey store name ~ key - , GetUStoreValue store name ~ value - ) - --- | This constraint can be used if a function needs to work with --- /big/ store, but needs to know only about some field of it. -type HasUField name ty store = - ( FieldAccessC store name - , GetUStoreField store name ~ ty - ) - --- | Write down all sensisble constraints which given @store@ satisfies --- and apply them to @constrained@. --- --- This store should have '|~>' and 'UStoreField' fields in its immediate fields, --- no deep inspection is performed. -type HasUStoreForAllIn store constrained = - (Generic store, GHasStoreForAllIn constrained (G.Rep store)) - -type family GHasStoreForAllIn (store :: Kind.Type) (x :: Kind.Type -> Kind.Type) - :: Constraint where - GHasStoreForAllIn store (G.D1 _ x) = GHasStoreForAllIn store x - GHasStoreForAllIn store (x :+: y) = - (GHasStoreForAllIn store x, GHasStoreForAllIn store y) - GHasStoreForAllIn store (x :*: y) = - (GHasStoreForAllIn store x, GHasStoreForAllIn store y) - GHasStoreForAllIn store (G.C1 _ x) = GHasStoreForAllIn store x - GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _) - (G.Rec0 (key |~> value))) = - HasUStore name key value store - GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _) - (G.Rec0 (UStoreFieldExt _ value))) = - HasUField name value store - GHasStoreForAllIn _ G.V1 = () - GHasStoreForAllIn _ G.U1 = () - ----------------------------------------------------------------------------- --- Examples ----------------------------------------------------------------------------- - -data MyStoreTemplate = MyStoreTemplate - { ints :: Integer |~> () - , bytes :: ByteString |~> ByteString - , flag :: UStoreField Bool - , entrypoint :: UStoreFieldExt Marker1 Integer - } - deriving stock (Generic) - -type MyStore = UStore MyStoreTemplate - -data Marker1 :: UStoreMarkerType - deriving anyclass KnownUStoreMarker - -_sample1 :: Integer : MyStore : s :-> MyStore : s -_sample1 = ustoreDelete @MyStoreTemplate #ints - -_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s -_sample2 = ustoreInsert @MyStoreTemplate #bytes - -_sample3 :: MyStore : s :-> Bool : s -_sample3 = ustoreToField @MyStoreTemplate #flag - -_sample3'5 :: MyStore : s :-> Integer : s -_sample3'5 = ustoreToField @MyStoreTemplate #entrypoint - -data MyStoreTemplate2 = MyStoreTemplate2 - { bools :: Bool |~> Bool - , ints2 :: Integer |~> Integer - , ints3 :: Integer |~> Bool - } - deriving stock (Generic) - -newtype MyNatural = MyNatural Natural - deriving newtype (IsoCValue, IsoValue) - -data MyStoreTemplate3 = MyStoreTemplate3 { store3 :: Natural |~> MyNatural } - deriving stock Generic - -data MyStoreTemplateBig = MyStoreTemplateBig - MyStoreTemplate - MyStoreTemplate2 - MyStoreTemplate3 - deriving stock Generic - -_MyStoreTemplateBigTextsStore :: - GetUStore "bytes" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString -_MyStoreTemplateBigTextsStore = Refl - -_MyStoreTemplateBigBoolsStore :: - GetUStore "bools" MyStoreTemplateBig :~: 'MapSignature Bool Bool -_MyStoreTemplateBigBoolsStore = Refl - -_MyStoreTemplateBigMyStoreTemplate3 :: - GetUStore "store3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural -_MyStoreTemplateBigMyStoreTemplate3 = Refl - -type MyStoreBig = UStore MyStoreTemplateBig - -_sample4 :: Integer : MyStoreBig : s :-> MyStoreBig : s -_sample4 = ustoreDelete #ints2 - -_sample5 :: ByteString : MyStoreBig : s :-> Bool : s -_sample5 = ustoreMem #bytes - -_sample6 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s -_sample6 = ustoreInsert #store3 - --- | When you want to express a constraint like --- "given big store contains all elements present in given small concrete store", --- you can use 'HasUStoreForAllIn'. --- --- Here @store@ is a big store, and we expect it to contain 'MyStoreTemplate' --- entirely. -_sample7 - :: HasUStoreForAllIn MyStoreTemplate store - => UStore store : s :-> Bool : Maybe ByteString : s -_sample7 = ustoreGetField #flag # dip (push "x" # ustoreGet #bytes) - --- | '_sample7' with @store@ instantiated to 'MyStoreTemplateBig'. -_sample7' :: UStore MyStoreTemplateBig : s :-> Bool : Maybe ByteString : s -_sample7' = _sample7 diff --git a/src/Lorentz/UStore/Lift.hs b/src/Lorentz/UStore/Lift.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Lift.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- | Composability helper for 'UStore'. -module Lorentz.UStore.Lift - ( liftUStore - , unliftUStore - - -- * Internals - , UStoreFieldsAreUnique - ) where - -import Data.Vinyl.Derived (Label) -import Data.Type.Bool (If) -import qualified Data.Kind as Kind -import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..)) -import Data.Vinyl.TypeLevel (type (++)) -import GHC.Generics (type (:+:), type (:*:)) -import qualified GHC.Generics as G - -import Lorentz.Base -import Lorentz.Coercions -import Lorentz.Instr -import Lorentz.UStore.Types -import Michelson.Typed.Haskell -import Util.Type - --- | Get all fields names accessible in given 'UStore' template. -type UStoreFields (template :: Kind.Type) = GUStoreFields (G.Rep template) - -type family GUStoreFields (x :: Kind.Type -> Kind.Type) :: [Symbol] where - -- We are not oblidged to fail in case of bad template - this will be handled - -- in other operations with 'UStore' anyway. - GUStoreFields (G.D1 _ x) = GUStoreFields x - GUStoreFields (_ :+: _) = '[] - GUStoreFields G.V1 = '[] - GUStoreFields (G.C1 _ x) = GUStoreFields x - GUStoreFields (x :*: y) = GUStoreFields x ++ GUStoreFields y - GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (_ |~> _))) = - '[fieldName] - GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt _ _))) = - '[fieldName] - GUStoreFields (G.S1 _ (G.Rec0 a)) = - UStoreFields a - -type UStoreFieldsAreUnique template = AllUnique (UStoreFields template) - -type family RequireAllUniqueFields (template :: Kind.Type) :: Constraint where - RequireAllUniqueFields template = - If (UStoreFieldsAreUnique template) - (() :: Constraint) - (TypeError ('Text "Some field in template is duplicated")) - -- TODO: if this ever fires for you and it's not clear which exact field - -- is duplicated, please create a ticket to implement the corresponding - -- logic. - --- | Lift an 'UStore' to another 'UStore' which contains all the entries --- of the former under given field. --- --- This function is not intended for use in migrations, only in normal --- entry points. --- --- Note that this function ensures that template of resulting store --- does not contain inner nested templates with duplicated fields, --- otherwise 'UStore' invariants could get broken. -liftUStore - :: (Generic template, RequireAllUniqueFields template) - => Label name - -> UStore (GetFieldType template name) : s :-> UStore template : s -liftUStore _ = forcedCoerce_ - --- | Unlift an 'UStore' to a smaller 'UStore' which is part of the former. --- --- This function is not intended for use in migrations, only in normal --- entry points. --- --- Surprisingly, despite smaller 'UStore' may have extra entries, --- this function is safe when used in contract code. --- Truly, all getters and setters are still safe to use. --- Also, there is no way for the resulting small @UStore@ to leak outside --- of the contract since the only place where 'big_map' can appear --- is contract storage, so this small @UStore@ can be either dropped --- or lifted back via 'liftUStore' to appear as part of the new contract's state. --- --- When this function is run as part of standalone instructions sequence, --- not as part of contract code (e.g. in tests), you may get an @UStore@ --- with entries not inherent to it. -unliftUStore - :: (Generic template) - => Label name - -> UStore template : s :-> UStore (GetFieldType template name) : s -unliftUStore _ = forcedCoerce_ - --- Examples ----------------------------------------------------------------------------- - -data MyStoreTemplate = MyStoreTemplate - { ints :: Integer |~> Integer - } deriving stock Generic - -data MyStoreTemplateBig = MyStoreTemplateBig - { bool :: UStoreField Bool - , substore :: MyStoreTemplate - } deriving stock Generic - --- | This example demostrates a way to run an instruction, operating on small --- 'UStore', so that it works on a larger 'UStore'. -_sampleWithMyStore - :: ('[param, UStore MyStoreTemplate] :-> '[UStore MyStoreTemplate]) - -> ('[param, UStore MyStoreTemplateBig] :-> '[UStore MyStoreTemplateBig]) -_sampleWithMyStore instr = - dip (unliftUStore #substore) # instr # liftUStore #substore diff --git a/src/Lorentz/UStore/Migration.hs b/src/Lorentz/UStore/Migration.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Migration.hs +++ /dev/null @@ -1,89 +0,0 @@ -{- | Type-safe migrations of UStore. - -This implements imperative approach to migration when we make user -write a code of migration and track whether all new fields were indeed added -and all unnecessary fields were removed. - -You can find migration examples in tests. - -== How to write your simple migration - -1. Start with migration template: - - @ - migration :: 'UStoreMigration' V1.Storage V2.Storage - migration = 'mkUStoreMigration' $ do - -- migration code to be put here - 'migrationFinish' - @ - - You will be prompted with a list of fields which should be added or removed. - -2. Add/remove necessary fields using 'migrateAddField', 'migrateExtractField' -and other instructions. -They allow you to operate with 'MUStore' — it is similar to 'UStore' -but used within 'mkUStoreMigration' to track migration progress. - -3. Use 'migrationToScript' or 'migrationToTestScript' to turn 'UStoreMigration' -into something useful. - -Note that here you will get a solid 'MigrationScript', thus migration has -to fit into single Tezos transaction. If that's an issue, see the next section. - -== How to write batched migration - -1. Insert migration template. - - It looks like: - - @ - migration :: 'UStoreMigration' V1.Storage V2.Storage - migration = 'mkUStoreBatchedMigration' $ - -- place for migration blocks - 'migrationFinish' - @ - -2. Fill migration code with blocks like - - @ - 'mkUStoreBatchedMigration' $ - 'muBlock' '$:' do - -- code for block 1 - '<-->' - 'muBlock' '$:' do - -- code for block 2 - '<-->' - 'migrationFinish' - @ - - Migration blocks have to be the smallest actions which can safely be mixed - and splitted accross migration stages. - -3. Compile migration with 'compileBatchedMigration'. - - Here you have to supply batching implementation. Alternatives include - - * 'mbNoBatching'; - * 'mbBatchesAsIs'; - * Functions from 'Lorentz.UStore.Migration.Batching' module. - -4. Get the required information about migration. - - * 'migrationToScripts' picks the migration scripts, each has to be put - in a separate Tezos transaction. - - * 'buildMigrationPlan' - dump description of each migration stage. - -== Manual migrations - -If for some reasons you need to define migration manually, you can use -functions from @Manual migrations@ section of "Lorentz.UStore.Migration.Base". - --} -module Lorentz.UStore.Migration - ( module Exports - ) where - -import Lorentz.UStore.Migration.Base as Exports -import Lorentz.UStore.Migration.Batching as Exports -import Lorentz.UStore.Migration.Blocks as Exports diff --git a/src/Lorentz/UStore/Migration/Base.hs b/src/Lorentz/UStore/Migration/Base.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Migration/Base.hs +++ /dev/null @@ -1,497 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -{- | Basic migration primitives. - -All primitives in one scheme: - - - MigrationBlocks - (batched migrations writing) - /| || - muBlock // || mkUStoreBatchedMigration - // || - // || - MUStore || UStore template value - (simple migration writing) || (storage initialization) - \\ || // - \\ || // - mkUStoreMigration \\ || // fillUStore - \| \/ |/ - UStoreMigration - (whole migration) - || \\ - || \\ - migrationToScript || \\ compileMigration - || \\ MigrationBatching - || \\ (way to slice migration) - || \\ // - || \\ // - || \| |/ - || UStoreMigrationCompiled - || (sliced migration) - || // \\ - || migrationToScripts \\ buildMigrationPlan - || // \\ migrationStagesNum - || // \\ ... - \/ |/ \| - MigrationScript Information about migration - (part of migration which (migration plan, stages number...) - fits into Tezos transaction) - --} -module Lorentz.UStore.Migration.Base - ( -- * 'UStore' utilities - SomeUTemplate - , UStore_ - - -- * Basic migration primitives - , MigrationScript (..) - , maNameL - , maScriptL - , maActionsDescL - , MigrationScriptFrom - , MigrationScriptTo - , MigrationScript_ - , MigrationAtom (..) - , UStoreMigration (..) - , MigrationBlocks (..) - , MUStore (..) - , migrationToLambda - , mapMigrationCode - - -- ** Simple migrations - , mkUStoreMigration - , migrationToScript - , migrationToScriptI - - -- ** Batched migrations - , MigrationBatching (..) - , mbBatchesAsIs - , mbNoBatching - , compileMigration - , UStoreMigrationCompiled (..) - , mkUStoreBatchedMigration - , migrationToScripts - , migrationToScriptsList - , migrationToInfo - , migrationStagesNum - , buildMigrationPlan - - -- * Manual migrations - , manualWithOldUStore - , manualWithNewUStore - , manualConcatMigrationScripts - , manualMapMigrationScript - - -- * Extras - , DMigrationActionType (..) - , DMigrationActionDesc (..) - , attachMigrationActionName - - -- * Internals - , formMigrationAtom - ) where - -import Control.Lens (traversed, _Wrapped') -import Data.Default (def) -import qualified Data.Foldable as Foldable -import qualified Data.Kind as Kind -import Data.Singletons (SingI(..), demote) -import qualified Data.Typeable as Typeable -import Data.Vinyl.Derived (Label) -import Fmt (Buildable(..), Builder, fmt) - -import Lorentz.Base -import Lorentz.Coercions -import Lorentz.Doc -import Lorentz.Instr (nop) -import Lorentz.Run -import Lorentz.UStore.Types -import Lorentz.Value -import Michelson.Typed (ExtInstr(..), Instr(..), T(..)) -import Michelson.Typed.Util -import Util.Lens -import Util.TypeLits - -import Lorentz.UStore.Migration.Diff - ----------------------------------------------------------------------------- --- UStore utilities ----------------------------------------------------------------------------- - --- | Dummy template for 'UStore', use this when you want to forget exact template --- and make type of store homomorphic. -data SomeUTemplate - --- | UStore with hidden template. -type UStore_ = UStore SomeUTemplate - --- | We allow casting between 'UStore_' and 'UStore' freely. -instance SameUStoreTemplate template1 template2 => - UStore template1 `CanCastTo` UStore template2 - -type family SameUStoreTemplate (template1 :: Kind.Type) (template2 :: Kind.Type) - :: Constraint where - SameUStoreTemplate t t = () -- case for undeducible but equal types - SameUStoreTemplate SomeUTemplate _ = () - SameUStoreTemplate _ SomeUTemplate = () - SameUStoreTemplate t1 t2 = (t1 ~ t2) - ----------------------------------------------------------------------------- --- Migration primitives ----------------------------------------------------------------------------- - --- | Code of migration for 'UStore'. --- --- Invariant: preferably should fit into op size / gas limits (quite obvious). --- Often this stands for exactly one stage of migration (one Tezos transaction). -newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) = - MigrationScript - { unMigrationScript :: Lambda UStore_ UStore_ - } deriving stock (Show, Generic) - deriving anyclass IsoValue - -instance Wrapped (MigrationScript oldStore newStore) - -instance (Typeable oldStore, Typeable newStore) => - TypeHasDoc (MigrationScript oldStore newStore) where - typeDocMdDescription = - "A code which updates storage in order to make it compliant with the \ - \new version of the contract." - typeDocMdReference tp = customTypeDocMdReference ("MigrationScript", DType tp) [] - typeDocHaskellRep = homomorphicTypeDocHaskellRep - typeDocMichelsonRep = homomorphicTypeDocMichelsonRep - -instance Lambda (UStore ot1) (UStore nt1) `CanCastTo` Lambda (UStore ot2) (UStore nt2) => - MigrationScript ot1 nt1 `CanCastTo` MigrationScript ot2 nt2 - --- | Corner case of 'MigrationScript' with some type argument unknown. --- --- You can turn this into 'MigrationScript' using 'checkedCoerce'. -type MigrationScriptFrom oldStore = MigrationScript oldStore SomeUTemplate -type MigrationScriptTo newStore = MigrationScript SomeUTemplate newStore -type MigrationScript_ = MigrationScript SomeUTemplate SomeUTemplate - --- | Manually perform a piece of migration. -manualWithUStore - :: forall ustore template oldStore newStore. - (ustore ~ UStore template) - => ('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore -manualWithUStore action = MigrationScript $ checkedCoercing_ action - -manualWithOldUStore - :: ('[UStore oldStore] :-> '[UStore oldStore]) -> MigrationScript oldStore newStore -manualWithOldUStore = manualWithUStore - -manualWithNewUStore - :: ('[UStore newStore] :-> '[UStore newStore]) -> MigrationScript oldStore newStore -manualWithNewUStore = manualWithUStore - -manualMapMigrationScript - :: (('[UStore_] :-> '[UStore_]) -> ('[UStore_] :-> '[UStore_])) - -> MigrationScript oldStore newStore - -> MigrationScript oldStore newStore -manualMapMigrationScript f = MigrationScript . f . unMigrationScript - --- | Merge several migration scripts. Used in manual migrations. --- --- This function is generally unsafe because resulting migration script can fail --- to fit into operation size limit. -manualConcatMigrationScripts :: [MigrationScript os ns] -> MigrationScript os ns -manualConcatMigrationScripts = - MigrationScript . foldl' (#) nop . fmap unMigrationScript - --- | An action on storage entry. -data DMigrationActionType - = DAddAction Text - -- ^ Some sort of addition: "init", "set", "overwrite", e.t.c. - | DDelAction - -- ^ Removal. - deriving stock (Show) - -instance Buildable DMigrationActionType where - build = \case - DAddAction a -> build a - DDelAction -> "remove" - --- | Describes single migration action. --- --- In most cases it is possible to derive reasonable description for migration --- atom automatically, this datatype exactly carries this information. -data DMigrationActionDesc = DMigrationActionDesc - { manAction :: DMigrationActionType - -- ^ Action on field, e.g. "set", "remove", "overwrite". - , manField :: Text - -- ^ Name of affected field of 'UStore'. - , manFieldType :: T - -- ^ Type of affected field of 'UStore' in new storage version. - } deriving stock (Show) - --- Sad that we need to write this useless documentation instance, probably it's --- worth generalizing @doc_group@ and @doc_item@ instructions so that they --- could serve as multi-purpose markers. -instance DocItem DMigrationActionDesc where - type DocItemPosition DMigrationActionDesc = 105010 - docItemSectionName = Nothing - docItemToMarkdown _ _ = "Migration action" - --- | Add description of action, it will be used in rendering migration plan and --- some batching implementations. -attachMigrationActionName - :: (KnownSymbol fieldName, SingI (ToT fieldTy)) - => DMigrationActionType - -> Label fieldName - -> Proxy fieldTy - -> s :-> s -attachMigrationActionName action (_ :: Label fieldName) (_ :: Proxy fieldTy) = - doc $ DMigrationActionDesc - { manAction = action - , manField = symbolValT' @fieldName - , manFieldType = demote @(ToT fieldTy) - } - --- | Minimal possible piece of migration script. --- --- Different atoms can be arbitrarily reordered and separated across migration --- stages, but each single atom is treated as a whole. --- --- Splitting migration into atoms is responsibility of migration writer. -data MigrationAtom = MigrationAtom - { maName :: Text - , maScript :: MigrationScript_ - , maActionsDesc :: [DMigrationActionDesc] - } deriving stock (Show) - -makeLensesWith postfixLFields ''MigrationAtom - --- | Keeps information about migration between 'UStore's with two given --- templates. -data UStoreMigration (oldTempl :: Kind.Type) (newTempl :: Kind.Type) where - UStoreMigration - :: [MigrationAtom] - -> UStoreMigration oldTempl newTempl - --- | Turn 'Migration' into a whole piece of code for transforming storage. --- --- This is not want you'd want to use for contract deployment because of --- gas and operation size limits that Tezos applies to transactions. -migrationToLambda - :: UStoreMigration oldTemplate newTemplate - -> Lambda (UStore oldTemplate) (UStore newTemplate) -migrationToLambda (UStoreMigration atoms) = - checkedCoerce_ # foldMap (unMigrationScript . maScript) atoms # checkedCoerce_ - --- | Modify all code in migration. -mapMigrationCode - :: (forall i o. (i :-> o) -> (i :-> o)) - -> UStoreMigration os ns - -> UStoreMigration os ns -mapMigrationCode f (UStoreMigration atoms) = - UStoreMigration $ - atoms & traversed . maScriptL . _Wrapped' %~ f - --- | A bunch of migration atoms produced by migration writer. -newtype MigrationBlocks (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type) - (preRemDiff :: [DiffItem]) (preTouched :: [Symbol]) - (postRemDiff :: [DiffItem]) (postTouched :: [Symbol]) = - MigrationBlocks [MigrationAtom] - -{- | Wrapper over 'UStore' which is currently being migrated. - -In type-level arguments it keeps - -* Old and new 'UStore' templates - mostly for convenience of the implementation. - -* Remaining diff which yet should be covered. Here we track migration progress. -Once remaining diff is empty, migration is finished. - -* Names of fields which have already been touched by migration. -Required to make getters safe. --} -newtype MUStore (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type) - (remDiff :: [DiffItem]) (touched :: [Symbol]) = - MUStoreUnsafe (UStore oldTemplate) - deriving stock Generic - deriving anyclass IsoValue - --- | Create migration atom from code. --- --- This is an internal function, should not be used for writing migrations. -formMigrationAtom - :: Maybe Text - -> Lambda UStore_ UStore_ - -> MigrationAtom -formMigrationAtom mname code = - MigrationAtom - { maName = name - , maScript = MigrationScript (checkedCoercing_ code) - , maActionsDesc = actionsDescs - } - where - name = case mname of - Just n -> n - Nothing -> - fmt . mconcat $ intersperse ", " - [ build action <> " \"" <> build field <> "\"" - | DMigrationActionDesc action field _type <- actionsDescs - ] - - actionsDescs = - let instr = compileLorentz code - (_, actions) = dfsInstr def (\i -> (i, pickActionDescs i)) instr - in actions - - pickActionDescs :: Instr i o -> [DMigrationActionDesc] - pickActionDescs i = case i of - Ext (DOC_ITEM (SomeDocItem di)) -> - [ d - | Just d@DMigrationActionDesc{} <- pure $ Typeable.cast di - ] - _ -> [] - --- | Way of distributing migration atoms among batches. --- --- This also participates in describing migration plan and should contain --- information which would clarify to a user why migration is splitted --- such a way. Objects of type @batchInfo@ stand for information corresponding to --- a batch and may include e.g. names of taken actions and gas consumption. --- --- Type argument @structure@ stands for container where batches will be put to --- and is usually a list ('[]'). --- --- When writing an instance of this datatype, you should tend to produce --- as few batches as possible because Tezos transaction execution overhead --- is quite high; though these batches should still preferably fit into gas limit. --- --- Note that we never fail here because reaching perfect consistency with Tezos --- gas model is beyond dreams for now, even if our model predicts that some --- migration atom cannot be fit into gas limit, Tezos node can think differently --- and accept the migration. --- If your batching function can make predictions about fitting into gas limit, --- consider including this information in @batchInfo@ type. --- --- See batching implementations in "Lorentz.UStore.Migration.Batching" module. -data MigrationBatching (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) = - MigrationBatching ([MigrationAtom] -> structure (batchInfo, MigrationScript_)) - --- | Put each migration atom to a separate batch. --- --- In most cases this is not what you want, but may be useful if e.g. you write --- your migration manually. -mbBatchesAsIs :: MigrationBatching [] Text -mbBatchesAsIs = MigrationBatching $ - map (maName &&& maScript) - --- | Put the whole migration into one batch. -mbNoBatching :: MigrationBatching Identity Text -mbNoBatching = MigrationBatching $ - Identity . \atoms -> - ( mconcat . intersperse ", " $ maName <$> atoms - , manualConcatMigrationScripts (maScript <$> atoms) - ) - --- | Version of 'mkUStoreMigration' which allows splitting migration in batches. --- --- Here you supply a sequence of migration blocks which then are automatically --- distributed among migration stages. -mkUStoreBatchedMigration - :: MigrationBlocks oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1 - -> UStoreMigration oldTempl newTempl -mkUStoreBatchedMigration (MigrationBlocks blocks) = UStoreMigration blocks - --- | Safe way to create migration scripts for 'UStore'. --- --- You have to supply a code which would transform 'MUStore', --- coverring required diff step-by-step. --- All basic instructions work, also use @migrate*@ functions --- from this module to operate with 'MUStore'. --- --- This method produces a whole migration, it cannot be splitted in batches. --- In case if your migration is too big to be applied within a single --- transaction, use 'mkUStoreBatchedMigration'. -mkUStoreMigration - :: Lambda - (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[]) - (MUStore oldTempl newTempl '[] _1) - -> UStoreMigration oldTempl newTempl -mkUStoreMigration code = - mkUStoreBatchedMigration $ - MigrationBlocks . one . formMigrationAtom (Just "Migration") $ - forcedCoerce_ # code # forcedCoerce_ - --- | Migration script splitted in batches. --- --- This is an intermediate form of migration content and needed because --- compiling 'UStoreMigration' is a potentially heavyweight operation, --- and after compilation is performed you may need to get various information like --- number of migration steps, migration script, migration plan and other. -newtype UStoreMigrationCompiled - (oldStore :: Kind.Type) (newStore :: Kind.Type) - (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) = - UStoreMigrationCompiled - { compiledMigrationContent - :: structure (batchInfo, MigrationScript oldStore newStore) - } - --- | Compile migration for use in production. -compileMigration - :: (Functor t) - => MigrationBatching t batchInfo - -> UStoreMigration ot nt - -> UStoreMigrationCompiled ot nt t batchInfo -compileMigration (MigrationBatching toBatches) (UStoreMigration blks) = - UStoreMigrationCompiled (second forcedCoerce <$> toBatches blks) - --- | Get migration scripts, each to be executed in separate Tezos transaction. -migrationToScripts - :: Traversable t - => UStoreMigrationCompiled os ns t batchInfo - -> t (MigrationScript os ns) -migrationToScripts = map snd . compiledMigrationContent - --- | Get migration scripts as list. -migrationToScriptsList - :: Traversable t - => UStoreMigrationCompiled os ns t batchInfo - -> [MigrationScript os ns] -migrationToScriptsList = Foldable.toList . migrationToScripts - --- | Get migration script in case of simple (non-batched) migration. -migrationToScriptI - :: UStoreMigration os ns - -> Identity (MigrationScript os ns) -migrationToScriptI = - migrationToScripts . compileMigration mbNoBatching - --- | Get migration script in case of simple (non-batched) migration. -migrationToScript - :: UStoreMigration os ns - -> MigrationScript os ns -migrationToScript = - runIdentity . migrationToScriptI - --- | Get information about each batch. -migrationToInfo - :: Traversable t - => UStoreMigrationCompiled ot nt t batchInfo - -> t batchInfo -migrationToInfo = map fst . compiledMigrationContent - --- | Number of stages in migration. -migrationStagesNum - :: Traversable t - => UStoreMigrationCompiled ot nt t batchInfo -> Int -migrationStagesNum = Foldable.length . migrationToScripts - --- | Render migration plan. -buildMigrationPlan - :: (Traversable t, Buildable batchInfo) - => UStoreMigrationCompiled ot nt t batchInfo -> Builder -buildMigrationPlan content = - let infos = Foldable.toList $ migrationToInfo content - in mconcat - [ "Migration stages:\n" - , mconcat $ zip [1..] infos <&> \(i :: Int, info) -> - build i <> ") " <> build info <> "\n" - ] diff --git a/src/Lorentz/UStore/Migration/Batching.hs b/src/Lorentz/UStore/Migration/Batching.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Migration/Batching.hs +++ /dev/null @@ -1,113 +0,0 @@ --- | Different approaches to batching. --- --- For now we do not support perfect batching because operation size evaluation --- (as well as gas consumption evaluation) is not implemented yet. --- The only non-trivial batching implementation we provide is --- 'mbSeparateLambdas'. -module Lorentz.UStore.Migration.Batching - ( -- * Separate-lambdas batching - SlBatchType (..) - , SlBatchInfo (..) - , mbSeparateLambdas - ) where - -import qualified Data.List as L -import Fmt (Buildable(..)) -import System.Console.Pretty (Color(..), color) - -import Lorentz.UStore.Migration.Base -import Michelson.Typed - ----------------------------------------------------------------------------- --- Separating lambdas ----------------------------------------------------------------------------- - --- | Type of batch. -data SlBatchType - = SlbtData - -- ^ Addition of any type of data. - | SlbtLambda - -- ^ Addition of code. - | SlbtCustom - -- ^ Several joined actions of different types. - | SlbtUnknown - -- ^ No information to chooseType about batching. - -- This means that the given action does not contain 'DMigrationActionDesc'. - deriving stock (Show, Eq) - -slbtIsData :: SlBatchType -> Bool -slbtIsData = \case { SlbtData -> True; _ -> False } - -data SlBatchInfo = SlBatchInfo - { slbiType :: SlBatchType - , slbiActions :: [Text] - } - -instance Buildable SlBatchInfo where - build (SlBatchInfo ty actions) = mconcat - [ build @Text $ case ty of - SlbtData -> color Blue "[data]" - SlbtLambda -> color Green "[code]" - SlbtCustom -> color Yellow "[custom]" - SlbtUnknown -> color Red "[unknown]" - , " " - , case actions of - [] -> "-" - [a] -> build a - as -> foldMap (\a -> "\n * " <> build a) as - ] - --- | Puts all data updates in one batch, and all lambdas in separate batches, --- one per batch. --- --- The reason for such behaviour is that in production contracts amount of --- changed data (be it in contract initialization or contract upgrade) is small, --- while stored entrypoints are huge and addition of even one entrypoint often --- barely fits into gas limit. -mbSeparateLambdas :: MigrationBatching [] SlBatchInfo -mbSeparateLambdas = MigrationBatching $ \atoms -> - let - atomsWithType = atoms <&> \a -> (atomType a, a) - (dataAtoms, otherAtoms) = L.partition (slbtIsData . fst) atomsWithType - dataMigration = - ( SlBatchInfo SlbtData (nubCounting $ maName . snd <$> dataAtoms) - , manualConcatMigrationScripts (maScript . snd <$> dataAtoms) - ) - otherMigrations = - [ (SlBatchInfo ty [maName atom], maScript atom) - | (ty, atom) <- otherAtoms - ] - in dataMigration : otherMigrations - where - atomType :: MigrationAtom -> SlBatchType - atomType = chooseType . maActionsDesc - - chooseType :: [DMigrationActionDesc] -> SlBatchType - chooseType = \case - [] -> SlbtUnknown - xs | all isLambda xs -> SlbtLambda - xs | all (not . isAddLambda) xs -> SlbtData - | otherwise -> SlbtCustom - - isLambda :: DMigrationActionDesc -> Bool - isLambda = \case { TLambda{} -> True; _ -> False } . manFieldType - - isAddLambda :: DMigrationActionDesc -> Bool - isAddLambda a = and - [ isLambda a - , case manAction a of { DAddAction _ -> True; _ -> False } - ] - --- | Similar to 'nub', counts number of invocations and attaches to text entry. --- --- >>> nubCounting ["a", "b", "a"] --- ["a (x2)", "b"] -nubCounting :: [Text] -> [Text] -nubCounting = \case - [] -> [] - x : xs -> - let ((length -> repetitions), others) = L.partition (== x) xs - x' = if repetitions == 0 - then x - else x <> " (x" <> show (repetitions + 1) <> ")" - in x' : nubCounting others diff --git a/src/Lorentz/UStore/Migration/Blocks.hs b/src/Lorentz/UStore/Migration/Blocks.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Migration/Blocks.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- | Elemental building blocks for migrations. -module Lorentz.UStore.Migration.Blocks - ( -- * General - mustoreToOld - , MigrationFinishCheckPosition (..) - - -- * Elemental steps - , migrateCoerceUnsafe - , migrateGetField - , migrateAddField - , migrateRemoveField - , migrateExtractField - , migrateOverwriteField - , migrateModifyField - - -- * Migration batches - , muBlock - , muBlockNamed - , (<-->) - , ($:) - ) where - -import Data.Vinyl.Derived (Label) - -import Lorentz.Base -import Lorentz.Coercions -import Lorentz.Instr (dip) -import Lorentz.UStore.Instr -import Lorentz.UStore.Migration.Base -import Lorentz.UStore.Migration.Diff -import Lorentz.UStore.Types -import Util.Type -import Util.TypeLits - --- | Helper for 'mustoreToOld' which ensures that given store hasn't been --- (partially) migrated yet. -type family RequireBeInitial (touched :: [Symbol]) :: Constraint where - RequireBeInitial '[] = () - RequireBeInitial _ = - TypeError ('Text "Migration has already been started over this store") - -type family RequireUntouched (field :: Symbol) (wasTouched :: Bool) - :: Constraint where - RequireUntouched _ 'False = () - RequireUntouched field 'True = TypeError - ('Text ("Field `" `AppendSymbol` field `AppendSymbol` "` has already been \ - \migrated and cannot be read") - ) - --- | Cast field or submap pretending that its value fits to the new type. --- --- Useful when type of field, e.g. lambda or set of lambdas, is polymorphic --- over storage type. -migrateCoerceUnsafe - :: forall field oldTempl newTempl diff touched newDiff newDiff0 _1 _2 s. - ( '(_1, newDiff0) ~ CoverDiff 'DcRemove field diff - , '(_2, newDiff) ~ CoverDiff 'DcAdd field newDiff0 - ) - => Label field - -> MUStore oldTempl newTempl diff touched : s - :-> MUStore oldTempl newTempl newDiff touched : s -migrateCoerceUnsafe _ = - forcedCoerce_ - --- Migrating fields ----------------------------------------------------------------------------- - --- | Get a field present in old version of 'UStore'. -migrateGetField - :: forall field oldTempl newTempl diff touched fieldTy s. - ( HasUField field fieldTy oldTempl - , RequireUntouched field (field `IsElem` touched) - ) - => Label field - -> MUStore oldTempl newTempl diff touched : s - :-> fieldTy : MUStore oldTempl newTempl diff touched : s -migrateGetField label = - forcedCoerce_ @_ @(UStore oldTempl) # ustoreGetField label # dip forcedCoerce_ - --- | Add a field which was not present before. --- This covers one addition from the diff and any removals of field with given --- name. --- --- This function cannot overwrite existing field with the same name, if this --- is necessary use 'migrateOverwriteField' which would declare removal --- explicitly. -migrateAddField - :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s. - ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field diff - , HasUField field fieldTy newTempl - ) - => Label field - -> fieldTy : MUStore oldTempl newTempl diff touched : s - :-> MUStore oldTempl newTempl newDiff (field ': touched) : s -migrateAddField label = - attachMigrationActionName (DAddAction "add") label (Proxy @fieldTy) # - dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_ - --- | Remove a field which should not be present in new version of storage. --- This covers one removal from the diff. --- --- In fact, this action could be performed automatically, but since --- removal is a destructive operation, being explicit about it seems --- like a good thing. -migrateRemoveField - :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s. - ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff - , HasUField field fieldTy oldTempl - ) - => Label field - -> MUStore oldTempl newTempl diff touched : s - :-> MUStore oldTempl newTempl newDiff (field ': touched) : s -migrateRemoveField label = - attachMigrationActionName DDelAction label (Proxy @fieldTy) # - forcedCoerce_ @_ @(UStore oldTempl) # ustoreRemoveFieldUnsafe label # forcedCoerce_ - --- | Get and remove a field from old version of 'UStore'. --- --- You probably want to use this more often than plain 'migrateRemoveField'. -migrateExtractField - :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s. - ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff - , HasUField field fieldTy oldTempl - , RequireUntouched field (field `IsElem` touched) - ) - => Label field - -> MUStore oldTempl newTempl diff touched : s - :-> fieldTy : MUStore oldTempl newTempl newDiff (field ': touched) : s -migrateExtractField label = - attachMigrationActionName DDelAction label (Proxy @fieldTy) # - migrateGetField label # dip (migrateRemoveField label) - --- | Remove field and write new one in place of it. --- --- This is semantically equivalent to --- @dip (migrateRemoveField label) >> migrateAddField label@, --- but is cheaper. -migrateOverwriteField - :: forall field oldTempl newTempl diff touched fieldTy oldFieldTy - marker oldMarker newDiff newDiff0 s. - ( '(UStoreFieldExt oldMarker oldFieldTy, newDiff0) ~ CoverDiff 'DcRemove field diff - , '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field newDiff0 - , HasUField field fieldTy newTempl - ) - => Label field - -> fieldTy : MUStore oldTempl newTempl diff touched : s - :-> MUStore oldTempl newTempl newDiff (field ': touched) : s -migrateOverwriteField label = - attachMigrationActionName (DAddAction "overwrite") label (Proxy @fieldTy) # - dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_ - --- | Modify field which should stay in new version of storage. --- This does not affect remaining diff. -migrateModifyField - :: forall field oldTempl newTempl diff touched fieldTy s. - ( HasUField field fieldTy oldTempl - , HasUField field fieldTy newTempl - ) - => Label field - -> fieldTy : MUStore oldTempl newTempl diff touched : s - :-> MUStore oldTempl newTempl diff touched : s -migrateModifyField label = - attachMigrationActionName (DAddAction "modify") label (Proxy @fieldTy) # - dip (forcedCoerce_ @_ @(UStore oldTempl)) # ustoreSetField label # forcedCoerce_ - --- Migrating virtual submaps (strict migration) ----------------------------------------------------------------------------- - -{- For now we do not support this kind of migration. - -"Strict" means that we want to modify maps right here rather than signal to -do modification of each entry on first access to it (which would be simpler -in some sense). - -Implementing this is slightly less trivial than migrating individial fields. -1. One needs current value of UStore picked from the contract, because it's -not possible to iterate over big_map from within a contract in the current mainnet. -Even if it was, we can't assume that iteration of the whole submap would fit -into gas limit of single transaction, thus iteration should be performed -from outside of the contract by someone who knows the current storage. - -2. We need to split migration in batches smartly. Too big batches would hit -operation size limit, while small ones would cause high overhead of -contract/storage deserialization. -Will be resolved in TM-330. --} - ----------------------------------------------------------------------------- --- Blocks for batched migrations ----------------------------------------------------------------------------- - --- | Define a migration atom. --- --- It will be named automatically according to the set of actions it performs --- (via 'DMigrationActionDesc's). --- This may be want you want for small sequences of actions, but for complex ones --- consider using 'muBlockNamed'. --- Names are used in rendering migration plan. -muBlock - :: ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2]) - -> MigrationBlocks o n d1 t1 d2 t2 -muBlock code = - MigrationBlocks . one . formMigrationAtom Nothing $ - forcedCoerce_ # code # forcedCoerce_ - --- | Define a migration atom with given name. --- --- Name will be used when rendering migration plan. -muBlockNamed - :: Text - -> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2]) - -> MigrationBlocks o n d1 t1 d2 t2 -muBlockNamed name code = - MigrationBlocks . one . formMigrationAtom (Just name) $ - forcedCoerce_ # code # forcedCoerce_ - --- | Composition of migration blocks. -(<-->) - :: MigrationBlocks o n d1 t1 d2 t2 - -> MigrationBlocks o n d2 t2 d3 t3 - -> MigrationBlocks o n d1 t1 d3 t3 -MigrationBlocks blocks1 <--> MigrationBlocks blocks2 = - MigrationBlocks (blocks1 <> blocks2) -infixl 2 <--> - -{- | This is '$' operator with priority higher than '<-->'. - -It allows you writing - -@ -mkUStoreBatchedMigration = - muBlock $: do - migrateAddField ... - <--> - muBlock $: do - migrateRemoveField ... -@ - -Alternatively, @BlockArguments@ extension can be used. --} -($:) :: (a -> b) -> a -> b -($:) = ($) -infixr 7 $: - ----------------------------------------------------------------------------- --- Common ----------------------------------------------------------------------------- - --- | Get the old version of storage. --- --- This can be applied only in the beginning of migration. --- --- In fact this function is not very useful, all required operations should --- be available for 'MUStore', but leaving it here just in case. -mustoreToOld - :: RequireBeInitial touched - => MUStore oldTemplate newTemplate remDiff touched : s - :-> UStore oldTemplate : s -mustoreToOld = forcedCoerce_ - -class MigrationFinishCheckPosition a where - -- | Put this in the end of migration script to get a human-readable message - -- about remaining diff which yet should be covered. - -- Use of this function in migration is fully optional. - -- - -- This function is not part of 'mkUStoreMigration' for the sake of - -- proper error messages ordering, during development - -- you probably want errors in migration script to be located earlier - -- in code than errors about not fully covered diff (if you used - -- to fix errors in the same order in which they appear). - migrationFinish :: a - --- | This version can be used in 'mkUStoreMigration'. -instance ( i ~ (MUStore oldTempl newTempl diff touched : s) - , o ~ (MUStore oldTempl newTempl '[] touched : s) - , RequireEmptyDiff diff - ) => - MigrationFinishCheckPosition (i :-> o) where - migrationFinish = forcedCoerce_ - --- | This version can be used in 'mkUStoreMultiMigration' as the last migration --- block. -instance (RequireEmptyDiff d1, t1 ~ t2) => - MigrationFinishCheckPosition (MigrationBlocks o n d1 t1 '[] t2) where - migrationFinish = MigrationBlocks [] diff --git a/src/Lorentz/UStore/Migration/Diff.hs b/src/Lorentz/UStore/Migration/Diff.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Migration/Diff.hs +++ /dev/null @@ -1,196 +0,0 @@ -module Lorentz.UStore.Migration.Diff - ( FieldInfo - , DiffKind (..) - , DiffItem - , BuildDiff - , ShowDiff - , RequireEmptyDiff - - , LinearizeUStore - , LinearizeUStoreF - , AllUStoreFieldsF - - , DiffCoverage (..) - , CoverDiff - , CoverDiffMany - ) where - -import qualified Data.Kind as Kind -import GHC.Generics ((:*:), (:+:)) -import Fcf (Eval, Exp, Pure, Fst, type (=<<), type (***)) -import qualified Fcf -import Fcf.Data.List (Cons) -import Fcf.Utils (TError) -import qualified GHC.Generics as G - -import Lorentz.UStore.Types -import Util.Type -import Util.TypeLits - --- Diff definition ----------------------------------------------------------------------------- - --- | Information about single field of UStore. -type FieldInfo = (Symbol, Kind.Type) - --- | What should happen with a particular 'UStoreItem'. -data DiffKind = ToAdd | ToDel - --- | Single piece of a diff. -type DiffItem = (DiffKind, FieldInfo) - --- Building diff ----------------------------------------------------------------------------- - --- | Get information about all fields of UStore template in a list. --- --- In particular, this recursivelly traverses template and retrives --- names and types of fields. Semantic wrappers like 'UStoreField' --- and '|~>' in field types are returned as-is. -type LinearizeUStore a = GLinearizeUStore (G.Rep a) - -data LinearizeUStoreF (template :: Kind.Type) :: Exp [FieldInfo] -type instance Eval (LinearizeUStoreF template) = LinearizeUStore template - --- | Get only field names of UStore template. -type family AllUStoreFieldsF (template :: Kind.Type) :: Exp [Symbol] where - AllUStoreFieldsF template = Fcf.Map Fst =<< LinearizeUStoreF template - -type family GLinearizeUStore (template :: Kind.Type -> Kind.Type) - :: [FieldInfo] where - GLinearizeUStore (G.D1 _ x) = GLinearizeUStore x - GLinearizeUStore (G.C1 _ x) = GLinearizeUStore x - GLinearizeUStore (_ :+: _) = TypeError - ('Text "Unexpected sum type in UStore template") - GLinearizeUStore G.V1 = TypeError - ('Text "Unexpected void-like type in UStore template") - GLinearizeUStore G.U1 = '[] - GLinearizeUStore (x :*: y) = GLinearizeUStore x ++ GLinearizeUStore y - - GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (k |~> v))) = - '[ '(RequireFieldName mfield, k |~> v) ] - GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (UStoreFieldExt m v))) = - '[ '(RequireFieldName mfield, UStoreFieldExt m v) ] - GLinearizeUStore (G.S1 _ (G.Rec0 a)) = - LinearizeUStore a - --- | Helper to make sure that datatype field is named and then extract this name. -type family RequireFieldName (mfield :: Maybe Symbol) :: Symbol where - RequireFieldName ('Just field) = field - RequireFieldName 'Nothing = TypeError ('Text "Unnamed field in UStore template") - --- | Lift a list of 'FieldInfo' to 'DiffItem's via attaching given 'DiffKind'. -type family LiftToDiff (kind :: DiffKind) (items :: [FieldInfo]) :: [DiffItem] where - LiftToDiff _ '[] = '[] - LiftToDiff kind (item ': items) = '(kind, item) ': LiftToDiff kind items - --- | Make up a migration diff between given old and new 'UStore' templates. -type BuildDiff oldTemplate newTemplate = - LiftToDiff 'ToAdd (LinearizeUStore newTemplate // LinearizeUStore oldTemplate) - ++ - LiftToDiff 'ToDel (LinearizeUStore oldTemplate // LinearizeUStore newTemplate) - --- Pretty-printing diff ----------------------------------------------------------------------------- - --- | Renders human-readable message describing given diff. -type ShowDiff diff = - 'Text "Migration is incomplete, remaining diff:" ':$$: ShowDiffItems diff - -type family ShowDiffItems (diff :: [DiffItem]) :: ErrorMessage where - ShowDiffItems '[d] = ShowDiffItem d - ShowDiffItems (d : ds) = ShowDiffItem d ':$$: ShowDiffItems ds - -type family ShowDiffKind (kind :: DiffKind) :: Symbol where - ShowDiffKind 'ToAdd = "+" - ShowDiffKind 'ToDel = "-" - -type family ShowUStoreElement (ty :: Kind.Type) :: ErrorMessage where - ShowUStoreElement (UStoreFieldExt m f) = - ShowUStoreField m f - ShowUStoreElement (k |~> v) = - 'Text "submap " ':<>: 'ShowType k ':<>: 'Text " -> " ':<>: 'ShowType v - -type family ShowDiffItem (diff :: DiffItem) :: ErrorMessage where - ShowDiffItem '(kind, '(field, ty)) = - 'Text (ShowDiffKind kind `AppendSymbol` - " `" `AppendSymbol` - field `AppendSymbol` - "`") ':<>: - 'Text ": " ':<>: ShowUStoreElement ty - --- | Helper type family which dumps error message about remaining diff --- if such is present. -type family RequireEmptyDiff (diff :: [DiffItem]) :: Constraint where - RequireEmptyDiff '[] = () - RequireEmptyDiff diff = TypeError (ShowDiff diff) - --- Diff coverage ----------------------------------------------------------------------------- - --- | Cover the respective part of diff. --- Maybe fail if such action is not required. --- --- This type is very similar to 'DiffKind', but we still use another type as --- 1. Their kinds will differ - no chance to mix up anything. --- 2. One day there might appear more complex actions. -data DiffCoverage - = DcAdd - | DcRemove - -type family PrefixSecond (a :: k2) (r :: (k1, [k2])) :: (k1, [k2]) where - PrefixSecond a '(t, l) = '(t, (a ': l)) - --- | Apply given diff coverage, returning type of affected field and modified --- diff. -type family CoverDiff (cover :: DiffCoverage) (field :: Symbol) (diff :: [DiffItem]) - :: (Kind.Type, [DiffItem]) where - CoverDiff cover field diff = Eval (CoverDiffF '(cover, field) diff) - -type family CoverDiffF (arg :: (DiffCoverage, Symbol)) (diff :: [DiffItem]) - :: Exp (Kind.Type, [DiffItem]) where - CoverDiffF '( 'DcAdd, field) diff = RemoveDiffF 'ToAdd field diff - CoverDiffF '( 'DcRemove, field) diff = RemoveDiffF 'ToDel field diff - -type family RemoveDiffF (kind :: DiffKind) (field :: Symbol) (diff :: [DiffItem]) - :: Exp (Kind.Type, [DiffItem]) where - RemoveDiffF kind field ('(kind, '(field, ty)) ': diff) = Pure '(ty, diff) - RemoveDiffF kind field (d ': diff) = (Pure *** Cons d) =<< RemoveDiffF kind field diff - RemoveDiffF kind field '[] = - TError ('Text (ShowDiffKindWord kind) ':<>: 'Text " field " ':<>: - 'ShowType field ':<>: 'Text " is not required") - -type family ShowDiffKindWord (kind :: DiffKind) :: Symbol where - ShowDiffKindWord 'ToAdd = "Adding" - ShowDiffKindWord 'ToDel = "Removing" - --- | Single piece of a coverage. -type DiffCoverageItem = (DiffCoverage, FieldInfo) - --- | Apply multiple coverage steps. -type family CoverDiffMany (diff :: [DiffItem]) (covers :: [DiffCoverageItem]) - :: [DiffItem] where - CoverDiffMany diff '[] = diff - CoverDiffMany diff ('(dc, '(field, ty)) ': cs) = - CoverDiffMany (HandleCoverRes field ty (CoverDiff dc field diff)) cs - -type family HandleCoverRes (field :: Symbol) (ty :: Kind.Type) (res :: (Kind.Type, [DiffItem])) - :: [DiffItem] where - HandleCoverRes _ ty '(ty, diff) = diff - HandleCoverRes field tyCover '(tyDiff, _) = TypeError - ('Text "Type mismatch when covering diff for field " ':<>: 'ShowType field - ':$$: - 'Text "Expected type `" ':<>: 'ShowType tyDiff ':<>: 'Text "` (in requested diff)" - ':$$: - 'Text "but covered with value of type `" ':<>: 'ShowType tyCover ':<>: 'Text "`" - ) - -type family EnsureDiffHasNoRemovalF (field :: Symbol) (diff :: [DiffItem]) - :: Exp [DiffItem] where - EnsureDiffHasNoRemovalF _ '[] = Pure '[] - EnsureDiffHasNoRemovalF field ('( 'ToDel, '(field, _)) ': _) = - TError ('Text "Field with name " ':<>: 'ShowType field ':<>: - 'Text " is present in old version of storage" - ) - EnsureDiffHasNoRemovalF field (d ': diff) = - Cons d =<< EnsureDiffHasNoRemovalF field diff diff --git a/src/Lorentz/UStore/Types.hs b/src/Lorentz/UStore/Types.hs deleted file mode 100644 --- a/src/Lorentz/UStore/Types.hs +++ /dev/null @@ -1,282 +0,0 @@ --- | 'UStore' definition and common type-level stuff. -module Lorentz.UStore.Types - ( -- * UStore and related type definitions - UStore (..) - , type (|~>)(..) - , UStoreFieldExt (..) - , UStoreField - , UStoreMarkerType - , UMarkerPlainField - - -- ** Extras - , KnownUStoreMarker (..) - , mkFieldMarkerUKeyL - , mkFieldUKey - , UStoreSubmapKey - , UStoreSubmapKeyT - - -- ** Type-lookup-by-name - , GetUStoreKey - , GetUStoreValue - , GetUStoreField - , GetUStoreFieldMarker - - -- ** Marked fields - , PickMarkedFields - - -- * Internals - , ElemSignature (..) - , GetUStore - , MSKey - , MSValue - , FSValue - , FSMarker - ) where - -import Data.Default (Default) -import Control.Lens (Wrapped) -import Data.Vinyl.Derived (Label) -import qualified Data.Kind as Kind -import Data.Type.Equality (type (==)) -import GHC.Generics ((:*:)(..), (:+:)(..)) -import qualified GHC.Generics as G -import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError, KnownSymbol) - -import Lorentz.Pack -import Lorentz.Doc -import Lorentz.Polymorphic -import Michelson.Typed.T -import Michelson.Typed.Haskell.Value -import Lorentz.UStore.Common -import Lorentz.Value -import Util.Type - --- | Gathers multple fields and 'BigMap's under one object. --- --- Type argument of this datatype stands for a "store template" - --- a datatype with one constructor and multiple fields, each containing --- an object of type 'UStoreField' or '|~>' and corresponding to single --- virtual field or 'BigMap' respectively. --- It's also possible to parameterize it with a larger type which is --- a product of types satisfying the above property. -newtype UStore (a :: Kind.Type) = UStore - { unUStore :: BigMap ByteString ByteString - } deriving stock (Eq, Show, Generic) - deriving newtype (Default, Semigroup, Monoid, IsoValue, - MemOpHs, GetOpHs, UpdOpHs) - -instance Wrapped (UStore a) - --- | Describes one virtual big map in the storage. -newtype k |~> v = UStoreSubMap { unUStoreSubMap :: Map k v } - deriving stock (Show, Eq) - deriving newtype (Default) - --- | Describes plain field in the storage. -newtype UStoreFieldExt (m :: UStoreMarkerType) (v :: Kind.Type) = UStoreField { unUStoreField :: v } - deriving stock (Show, Eq) - --- | Just a servant type. -data UStoreMarker - --- | Specific kind used to designate markers for 'UStoreFieldExt'. --- --- We suggest that fields may serve different purposes and so annotated with --- special markers accordingly. See example below. --- --- This kind is implemented like that because we want markers to differ from all --- other types in kind; herewith 'UStoreMarkerType' is still an open kind --- (has potentially infinite number of inhabitants). -type UStoreMarkerType = UStoreMarker -> Kind.Type - --- | Just a plain field used as data. -type UStoreField = UStoreFieldExt UMarkerPlainField -data UMarkerPlainField :: UStoreMarkerType - -instance Typeable template => TypeHasDoc (UStore template) where - typeDocName _ = "Upgradeable storage" - typeDocMdDescription = - "Storage with not hardcoded structure, which allows upgrading the contract \ - \in place. UStore is capable of storing simple fields and multiple submaps. \ - \For simple fields key is serialized field name. For submap element big_map \ - \key is serialized `(submapName, keyValue)`." - typeDocMdReference tp = - customTypeDocMdReference ("UStore", DType tp) [] - typeDocHaskellRep = homomorphicTypeDocHaskellRep - typeDocMichelsonRep = homomorphicTypeDocMichelsonRep - --- | What do we serialize when constructing big_map key for accessing --- an UStore submap. -type UStoreSubmapKey k = (MText, k) -type UStoreSubmapKeyT k = 'TPair (ToT MText) k - --- Extra attributes of fields ----------------------------------------------------------------------------- - --- | Allows to specify format of key under which fields of this type are stored. --- Useful to avoid collisions. -class KnownUStoreMarker (marker :: UStoreMarkerType) where - -- | By field name derive key under which field should be stored. - mkFieldMarkerUKey :: MText -> ByteString - default mkFieldMarkerUKey :: MText -> ByteString - mkFieldMarkerUKey = lPackValue - - -- | Display type-level information about UStore field with given marker and - -- field value type. - -- Used for error messages. - type ShowUStoreField marker v :: ErrorMessage - type ShowUStoreField marker v = 'Text "field of type " ':<>: 'ShowType v - --- | Version of 'mkFieldMarkerUKey' which accepts label. -mkFieldMarkerUKeyL - :: forall marker field. - (KnownUStoreMarker marker, KnownSymbol field) - => Label field -> ByteString -mkFieldMarkerUKeyL _ = - mkFieldMarkerUKey @marker (fieldNameToMText @field) - --- | Shortcut for 'mkFieldMarkerUKey' which accepts not marker but store template --- and name of entry. -mkFieldUKey - :: forall (store :: Kind.Type) field. - (KnownSymbol field, KnownUStoreMarker (GetUStoreFieldMarker store field)) - => Label field -> ByteString -mkFieldUKey = mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field) - -instance KnownUStoreMarker UMarkerPlainField where - ----------------------------------------------------------------------------- --- Type-safe lookup magic ----------------------------------------------------------------------------- - -{- Again we use generic magic to implement methods for 'Store' -(and thus 'Store' type constructor accepts a datatype, not a type-level list). - -There are two reasons for this: - -1. This gives us expected balanced tree of 'Or's for free. - -2. This allows us selecting a map by field name, not by -e.g. type of map value. This is subjective, but looks like a good thing -for me (@martoon). On the other hand, it prevents us from sharing the -same interface between maps and 'Store'. - --} - --- | What was found on lookup by constructor name. --- --- This keeps either type arguments of '|~>' or 'UStoreField'. -data ElemSignature - = MapSignature Kind.Type Kind.Type - | FieldSignature UStoreMarkerType Kind.Type - --- Again, we will use these getters instead of binding types within --- 'MapSignature' using type equality because getters does not produce extra --- compile errors on "field not found" cases. -type family MSKey (ms :: ElemSignature) :: Kind.Type where - MSKey ('MapSignature k _) = k - MSKey ('FieldSignature _ _) = - TypeError ('Text "Expected UStore submap, but field was referred") -type family MSValue (ms :: ElemSignature) :: Kind.Type where - MSValue ('MapSignature _ v) = v - MSValue ('FieldSignature _ _) = - TypeError ('Text "Expected UStore submap, but field was referred") -type family FSValue (ms :: ElemSignature) :: Kind.Type where - FSValue ('FieldSignature _ v) = v - FSValue ('MapSignature _ _) = - TypeError ('Text "Expected UStore field, but submap was referred") -type family FSMarker (ms :: ElemSignature) :: UStoreMarkerType where - FSValue ('FieldSignature m _) = m - FSValue ('MapSignature _ _) = - TypeError ('Text "Expected UStore field, but submap was referred") - --- | Get map signature from the constructor with a given name. -type GetUStore name a = MERequireFound name a (GLookupStore name (G.Rep a)) - -type family MERequireFound - (name :: Symbol) - (a :: Kind.Type) - (mlr :: Maybe ElemSignature) - :: ElemSignature where - MERequireFound _ _ ('Just ms) = ms - MERequireFound name a 'Nothing = TypeError - ('Text "Failed to find plain field or submap in store template: datatype `" - ':<>: 'ShowType a ':<>: 'Text "` has no field " ':<>: 'ShowType name) - -type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type) - :: Maybe ElemSignature where - GLookupStore name (G.D1 _ x) = GLookupStore name x - GLookupStore _ (_ :+: _) = - TypeError ('Text "Templates used in UStore should have only one constructor") - GLookupStore _ G.V1 = - TypeError ('Text "No constructors in UStore template") - - GLookupStore name (G.C1 _ x) = GLookupStore name x - - GLookupStore name (x :*: y) = LSMergeFound name (GLookupStore name x) - (GLookupStore name y) - - -- When we encounter a field there are three cases we are interested in: - -- 1. This field has type '|~>'. Then we check its name and return 'Just' - -- with all required info on match, and 'Nothing' otherwise. - -- 2. This field has type 'UStoreField'. We act in the same way - -- as for '|~>', attaching 'ThePlainFieldKey' as key. - -- 3. This field type is a different one. Then we expect this field to store - -- '|~>' or 'UStoreField' somewhere deeper and try to find it there. - GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (k |~> v))) = - Guard ('Just name == mFieldName) ('MapSignature k v) - GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (UStoreFieldExt m v))) = - Guard ('Just name == mFieldName) ('FieldSignature m v) - - GLookupStore name (G.S1 _ (G.Rec0 a)) = - GLookupStore name (G.Rep a) - - GLookupStore _ G.U1 = 'Nothing - -type family LSMergeFound (name :: Symbol) - (f1 :: Maybe ElemSignature) (f2 :: Maybe ElemSignature) - :: Maybe ElemSignature where - LSMergeFound _ 'Nothing 'Nothing = 'Nothing - LSMergeFound _ ('Just ms) 'Nothing = 'Just ms - LSMergeFound _ 'Nothing ('Just ms) = 'Just ms - -- It's possible that there are two constructors with the same name, - -- because main template pattern may be a sum of smaller template - -- patterns with same constructor names. - LSMergeFound ctor ('Just _) ('Just _) = TypeError - ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor) - - --- | Get type of submap key. -type GetUStoreKey store name = MSKey (GetUStore name store) - --- | Get type of submap value. -type GetUStoreValue store name = MSValue (GetUStore name store) - --- | Get type of plain field. --- This ignores marker with field type. -type GetUStoreField store name = FSValue (GetUStore name store) - --- | Get kind of field. -type GetUStoreFieldMarker store name = FSMarker (GetUStore name store) - --- One more magic ----------------------------------------------------------------------------- - --- | Collect all fields with the given marker. -type PickMarkedFields marker template = GPickMarkedFields marker (G.Rep template) - -type family GPickMarkedFields (marker :: UStoreMarkerType) (x :: Kind.Type -> Kind.Type) - :: [(Symbol, Kind.Type)] where - GPickMarkedFields m (G.D1 _ x) = GPickMarkedFields m x - GPickMarkedFields m (G.C1 _ x) = GPickMarkedFields m x - GPickMarkedFields m (x :*: y) = GPickMarkedFields m x ++ GPickMarkedFields m y - GPickMarkedFields _ G.U1 = '[] - - GPickMarkedFields m (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt m v))) = - '[ '(fieldName, v) ] - GPickMarkedFields _ (G.S1 _ (G.Rec0 (UStoreFieldExt _ _))) = - '[] - GPickMarkedFields _ (G.S1 _ (G.Rec0 (_ |~> _))) = - '[] - GPickMarkedFields m (G.S1 _ (G.Rec0 a)) = - PickMarkedFields m a diff --git a/src/Lorentz/Value.hs b/src/Lorentz/Value.hs deleted file mode 100644 --- a/src/Lorentz/Value.hs +++ /dev/null @@ -1,247 +0,0 @@ --- | Re-exports typed Value, CValue, some core types, some helpers and --- defines aliases for constructors of typed values. --- - -{- -TODO [TM-280]: Move this mess somewhere (in the last MR) - -This module also introduces several types for safe work with @address@ and -@contract@ types, all available types for that are represented in the following -table: - -+------------------------+------------+-------------------+----------------------+ -| Type | Type safe? | What it refers to | Michelson reflection | -+========================+============+===================+======================+ -| Address | No | Whole contract | address | -+------------------------+------------+-------------------+----------------------+ -| EpAddress | No | Entrypoint | address | -+------------------------+------------+-------------------+----------------------+ -| TAddress | Yes | Whole contract | address | -+------------------------+------------+-------------------+----------------------+ -| FutureContract | Yes | Entrypoint | address | -+------------------------+------------+-------------------+----------------------+ -| ContractRef | Yes | Entrypoint | contract | -+------------------------+------------+-------------------+----------------------+ - -This module also provides functions for converting between this types in Haskell -world. -In Michelson world, you can use coercions and dedicated instructions from -"Lorentz.Instr". --} -module Lorentz.Value - ( Value - , IsoValue (..) - , IsoCValue (..) - , CValue (..) - - -- * Primitive types - , Integer - , Natural - , MText - , Bool (..) - , ByteString - , Address - , EpAddress (..) - , Mutez - , Timestamp - , ChainId - , KeyHash - , PublicKey - , Signature - , Set - , Map - , M.BigMap (..) - , M.Operation - , Maybe (..) - , List - , ContractRef (..) - , TAddress (..) - , FutureContract (..) - - , M.EpName - , pattern M.DefEpName - , EntryPointCall - , SomeEntryPointCall - - -- * Constructors - , toMutez - , mt - , timestampFromSeconds - , timestampFromUTCTime - , timestampQuote - - -- * Conversions - , M.coerceContractRef - , callingTAddress - , callingDefTAddress - , ToAddress (..) - , ToTAddress (..) - , ToContractRef (..) - , FromContractRef (..) - , convertContractRef - - -- * Misc - , Default (..) - , Label (..) - ) where - -import Data.Default (Default(..)) -import Data.Type.Bool (type (&&), Not) -import Data.Kind as Kind -import Data.Vinyl.Derived (Label(..)) - -import Lorentz.Constraints -import Michelson.Text -import Michelson.Typed - (ContractRef(..), EntryPointCall, IsoCValue(..), IsoValue(..), SomeEntryPointCall, Value) -import qualified Michelson.Typed as M -import Michelson.Typed.CValue (CValue(..)) -import qualified Lorentz.EntryPoints.Core as Ep -import Michelson.Typed.EntryPoints (EpAddress(..)) -import Tezos.Address (Address) -import Tezos.Core - (ChainId, Mutez, Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampQuote, toMutez) -import Tezos.Crypto (KeyHash, PublicKey, Signature) -import Util.TypeLits -import Util.Type - -type List = [] - --- TODO (this MR): Add appropriate 'CanCastTo' instances - --- | Address which remembers the parameter type of the contract it refers to. --- --- It differs from Michelson's @contract@ type because it cannot contain --- entrypoint, and it always refers to entire contract parameter even if this --- contract has explicit default entrypoint. -newtype TAddress p = TAddress { unTAddress :: Address } - deriving stock Generic - deriving anyclass IsoValue - --- | Turn 'TAddress' to 'ContractRef' in /Haskell/ world. --- --- This is an analogy of @address@ to @contract@ convertion in Michelson world, --- thus you have to supply an entrypoint (or call the default one explicitly). -callingTAddress - :: forall cp mname. - (NiceParameterFull cp) - => TAddress cp - -> Ep.EntryPointRef mname - -> ContractRef (Ep.GetEntryPointArgCustom cp mname) -callingTAddress (TAddress addr) epRef = - withDict (niceParameterEvi @cp) $ - case Ep.parameterEntryPointCallCustom @cp epRef of - epc@M.EntryPointCall{} -> ContractRef addr (M.SomeEpc epc) - --- | Specification of 'callTAddress' to call the default entrypoint. -callingDefTAddress - :: forall cp. - (NiceParameterFull cp) - => TAddress cp - -> ContractRef (Ep.GetDefaultEntryPointArg cp) -callingDefTAddress taddr = callingTAddress taddr Ep.CallDefault - --- | Address associated with value of @contract arg@ type. --- --- Places where 'ContractRef' can appear are now severely limited, --- this type gives you type-safety of 'ContractRef' but still can be used --- everywhere. --- This type is not a full-featured one rather a helper; in particular, once --- pushing it on stack, you cannot return it back to Haskell world. --- --- Note that it refers to an entrypoint of the contract, not just the contract --- as a whole. In this sense this type differs from 'TAddress'. --- --- Unlike with 'ContractRef', having this type you still cannot be sure that --- the referred contract exists and need to perform a lookup before calling it. -newtype FutureContract arg = FutureContract { unFutureContract :: ContractRef arg } - -instance IsoValue (FutureContract arg) where - type ToT (FutureContract arg) = ToT EpAddress - toVal (FutureContract contract) = toVal $ M.contractRefToAddr contract - fromVal = error "Fetching 'FutureContract' back from Michelson is impossible" - --- | Convert something to 'Address' in /Haskell/ world. --- --- Use this when you want to access state of the contract and are not interested --- in calling it. -class ToAddress a where - toAddress :: a -> Address - -instance ToAddress Address where - toAddress = id - -instance ToAddress EpAddress where - toAddress = eaAddress - -instance ToAddress (TAddress cp) where - toAddress = unTAddress - -instance ToAddress (FutureContract cp) where - toAddress = toAddress . unFutureContract - -instance ToAddress (ContractRef cp) where - toAddress = crAddress - --- | Convert something referring to a contract (not specific entrypoint) --- to 'TAddress' in /Haskell/ world. -class ToTAddress (cp :: Kind.Type) (a :: Kind.Type) where - toTAddress :: a -> TAddress cp - -instance ToTAddress cp Address where - toTAddress = TAddress - -instance (cp ~ cp') => ToTAddress cp (TAddress cp') where - toTAddress = id - --- | Convert something to 'ContractRef' in /Haskell/ world. -class ToContractRef (cp :: Kind.Type) (contract :: Kind.Type) where - toContractRef :: HasCallStack => contract -> ContractRef cp - -instance (cp ~ cp') => ToContractRef cp (ContractRef cp') where - toContractRef = id - -instance (NiceParameter cp, cp ~ cp') => ToContractRef cp (FutureContract cp') where - toContractRef = unFutureContract - -instance ( FailWhen cond msg - , cond ~ - ( Ep.CanHaveEntryPoints cp && - Not (Ep.ParameterEntryPointsDerivation cp == Ep.EpdNone) - ) - , msg ~ - ( 'Text "Cannot apply `ToContractRef` to `TAddress`" ':$$: - 'Text "Consider using call(Def)TAddress first`" ':$$: - 'Text "(or if you know your parameter type is primitive," ':$$: - 'Text " make sure typechecker also knows about that)" ':$$: - 'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`" - ) - , cp ~ arg, NiceParameter arg - -- These constraints should naturally derive from ones above, - -- but prooving that does not worth the effort - , NiceParameterFull cp, Ep.GetDefaultEntryPointArg cp ~ cp - ) => - ToContractRef arg (TAddress cp) where - toContractRef = callingDefTAddress - --- | Convert something from 'ContractAddr' in /Haskell/ world. -class FromContractRef (cp :: Kind.Type) (contract :: Kind.Type) where - fromContractRef :: ContractRef cp -> contract - -instance (cp ~ cp') => FromContractRef cp (ContractRef cp') where - fromContractRef = id - -instance (cp ~ cp') => FromContractRef cp (FutureContract cp') where - fromContractRef = FutureContract . fromContractRef - -instance FromContractRef cp EpAddress where - fromContractRef = M.contractRefToAddr - -instance FromContractRef cp Address where - fromContractRef = crAddress - -convertContractRef - :: forall cp contract2 contract1. - (ToContractRef cp contract1, FromContractRef cp contract2) - => contract1 -> contract2 -convertContractRef = fromContractRef @cp . toContractRef diff --git a/src/Lorentz/Zip.hs b/src/Lorentz/Zip.hs deleted file mode 100644 --- a/src/Lorentz/Zip.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Stack zipping. --- --- This module provides functions for flattening stacks into tuples. --- --- Also here we define an instance which turns any instruction, --- not only lambdas, into a valid value. -module Lorentz.Zip - ( ZipInstr (..) - , ZipInstrs - , zippingStack - , unzippingStack - ) where - -import Prelude hiding (drop) - -import qualified Data.Kind as Kind - -import Lorentz.Base -import Michelson.Typed - --- | Zipping stack into tuple and back. -class ZipInstr (s :: [Kind.Type]) where - -- | A type which contains the whole stack zipped. - type ZippedStack s :: Kind.Type - - -- | Fold given stack into single value. - zipInstr :: s :-> '[ZippedStack s] - - -- | Unfold given stack from a single value. - unzipInstr :: '[ZippedStack s] :-> s - -{- Further we have to work on low level because even "Lorentz.Instr" depends - on this module. --} - -instance ZipInstr '[] where - type ZippedStack '[] = () - zipInstr = I UNIT - unzipInstr = I DROP - -instance ZipInstr '[a] where - type ZippedStack '[a] = a - zipInstr = I Nop - unzipInstr = I Nop - --- | Such definition seems the only possible one we can support --- efficiently. -instance ZipInstr ((a, b) ': s) => ZipInstr (a ': b ': s) where - type ZippedStack (a ': b ': s) = ZippedStack ((a, b) ': s) - zipInstr = I PAIR ## zipInstr @((a, b) ': s) - unzipInstr = unzipInstr @((a, b) ': s) ## I (DUP `Seq` CAR `Seq` DIP CDR) - --- | Require several stacks to comply 'ZipInstr' constraint. -type ZipInstrs ss = Each '[ZipInstr] ss - --- | Flatten both ends of instruction stack. -zippingStack - :: ZipInstrs [inp, out] - => inp :-> out -> Lambda (ZippedStack inp) (ZippedStack out) -zippingStack code = unzipInstr ## code ## zipInstr - --- | Unflatten both ends of instruction stack. -unzippingStack - :: ZipInstrs [inp, out] - => Lambda (ZippedStack inp) (ZippedStack out) -> inp :-> out -unzippingStack code = zipInstr ## code ## unzipInstr - -instance (ZipInstr inp, ZipInstr out) => IsoValue (inp :-> out) where - type ToT (inp :-> out) = 'TLambda (ToT (ZippedStack inp)) (ToT (ZippedStack out)) - toVal i = VLam . unLorentzInstr $ zippingStack i - fromVal (VLam i) = zipInstr ## LorentzInstr i ## unzipInstr diff --git a/src/Michelson/Test.hs b/src/Michelson/Test.hs --- a/src/Michelson/Test.hs +++ b/src/Michelson/Test.hs @@ -5,14 +5,13 @@ module Michelson.Test ( -- * Importing a contract specWithContract - , specWithContractL , specWithTypedContract , specWithUntypedContract , testTreesWithContract - , testTreesWithContractL , testTreesWithUntypedContract , testTreesWithTypedContract , concatTestTrees + , importContract , importUntypedContract -- * Unit testing @@ -20,6 +19,7 @@ , ContractPropValidator , contractProp , contractPropVal + , validateStorageIs -- * Integrational testing -- ** Testing engine @@ -30,11 +30,16 @@ , integrationalTestExpectation , integrationalTestProperty , originate + , tOriginate , transfer + , tTransfer , validate , integrationalFail , setMaxSteps , setNow + , rewindTime + , withSender + , setChainId , branchout , (?-) @@ -49,6 +54,7 @@ , expectBalance , expectStorage , expectStorageConst + , tExpectStorageConst , expectGasExhaustion , expectMichelsonFailed diff --git a/src/Michelson/Test/Import.hs b/src/Michelson/Test/Import.hs --- a/src/Michelson/Test/Import.hs +++ b/src/Michelson/Test/Import.hs @@ -10,14 +10,12 @@ -- * Tasty helpers , testTreesWithContract - , testTreesWithContractL , testTreesWithTypedContract , testTreesWithUntypedContract , concatTestTrees -- * HSpec helpers , specWithContract - , specWithContractL , specWithTypedContract , specWithUntypedContract ) where @@ -31,11 +29,10 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L import Michelson.Parser.Error (ParserException(..)) import Michelson.Runtime (parseExpandContract, prepareContract) import Michelson.TypeCheck (SomeContract(..), TCError, typeCheckContract) -import Michelson.Typed (Contract, FullContract(..), ToT, toUType) +import Michelson.Typed (Contract, FullContract(..), toUType) import qualified Michelson.Untyped as U import Util.IO @@ -54,12 +51,6 @@ => FilePath -> ((U.Contract, Contract cp st) -> IO [TestTree]) -> IO [TestTree] testTreesWithContract = testTreesWithContractImpl importContract --- | Like 'testTreesWithContract' but for Lorentz types. -testTreesWithContractL - :: (Each [Typeable, SingI] [ToT cp, ToT st], HasCallStack) - => FilePath -> ((U.Contract, L.Contract cp st) -> IO [TestTree]) -> IO [TestTree] -testTreesWithContractL file testImpl = testTreesWithContract file (testImpl . second L.I) - -- | Like 'testTreesWithContract' but supplies only untyped contract. testTreesWithUntypedContract :: HasCallStack @@ -105,12 +96,6 @@ :: (Each [Typeable, SingI] [cp, st], HasCallStack) => FilePath -> ((U.Contract, Contract cp st) -> Spec) -> Spec specWithContract = specWithContractImpl importContract - --- | Like 'specWithContract', but for Lorentz types. -specWithContractL - :: (Each [Typeable, SingI] [ToT cp, ToT st], HasCallStack) - => FilePath -> ((U.Contract, L.Contract cp st) -> Spec) -> Spec -specWithContractL file mkSpec = specWithContract file (mkSpec . second L.I) -- | A version of 'specWithContract' which passes only the typed -- representation of the contract. diff --git a/src/Michelson/Test/Integrational.hs b/src/Michelson/Test/Integrational.hs --- a/src/Michelson/Test/Integrational.hs +++ b/src/Michelson/Test/Integrational.hs @@ -23,7 +23,9 @@ , integrationalTestExpectation , integrationalTestProperty , originate + , tOriginate , transfer + , tTransfer , validate , integrationalFail , setMaxSteps @@ -47,6 +49,7 @@ , expectBalance , expectStorage , expectStorageConst + , tExpectStorageConst , expectGasExhaustion , expectMichelsonFailed ) where @@ -56,6 +59,7 @@ import qualified Data.List as List import Data.Map as Map (empty, insert, lookup) import Fmt (Buildable(..), blockListF, listF, pretty, (+|), (|+)) +import Named ((:!), arg) import Test.Hspec (Expectation, expectationFailure) import Test.QuickCheck (Property) @@ -67,7 +71,9 @@ import Michelson.Test.Dummy import Michelson.Test.Util (failedProp, succeededProp) import Michelson.TypeCheck (TCError) -import Michelson.Untyped (Contract, OriginationOperation(..), Value, mkContractAddress) +import qualified Michelson.Typed as Typed +import Michelson.Typed.Scope (ParameterScope, StorageScope, properParameterEvi, withDict) +import Michelson.Untyped (Contract, EpName, OriginationOperation(..), Value, mkContractAddress) import Tezos.Address (Address) import Tezos.Core (ChainId, Mutez, Timestamp, timestampPlusSeconds, unsafeMkMutez) @@ -242,6 +248,18 @@ where origination = (dummyOrigination value contract) {ooBalance = balance} +-- | Like 'originate', but for typed contract and value. +tOriginate :: + (ParameterScope cp, StorageScope st) + => Typed.FullContract cp st + -> Text + -> Typed.Value st + -> Mutez + -> IntegrationalScenarioM Address +tOriginate contract name value balance = + originate (Typed.convertFullContract contract) name + (Typed.untypeValue value) balance + -- | Transfer tokens to a given address. transfer :: TxData -> Address -> IntegrationalScenarioM () transfer txData destination = do @@ -249,6 +267,32 @@ let unwrappedData = maybe id (set tdSenderAddressL) mSender txData registerInterpretationIfNeeded [TransferOp destination unwrappedData] +-- | Similar to 'transfer', for typed values. +-- Note that it works with untyped 'Address' and does not check that +-- entrypoint with given name is present and has the expected type. +-- Passed value must correspond to the entrypoint argument type, not +-- the parameter type of the contract (and must be unit for implicit +-- accounts). +tTransfer + :: forall arg. + (ParameterScope arg) + => "from" :! Address + -> "to" :! Address + -> Mutez + -> EpName + -> Typed.Value arg + -> IntegrationalScenarioM () +tTransfer (arg #from -> from) (arg #to -> to) money epName param = + let txData = TxData + { tdSenderAddress = from + , tdParameter = + withDict (properParameterEvi @arg) $ + Typed.untypeValue param + , tdEntrypoint = epName + , tdAmount = money + } + in transfer txData to + -- | Validate the execution result. validate :: IntegrationalValidator -> IntegrationalScenario validate validator = Validated <$ do @@ -435,6 +479,14 @@ | val == expected = pass | otherwise = Left $ InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected) (pretty val) + +-- | Similar to 'expectStorageConst', for typed stuff. +tExpectStorageConst + :: forall st. + (StorageScope st) + => Address -> Typed.Value st -> SuccessValidator +tExpectStorageConst addr expected = + expectStorageConst addr (Typed.untypeValue expected) -- | Check that eventually address has some particular balance. expectBalance :: Address -> Mutez -> SuccessValidator diff --git a/src/Michelson/Test/Unit.hs b/src/Michelson/Test/Unit.hs --- a/src/Michelson/Test/Unit.hs +++ b/src/Michelson/Test/Unit.hs @@ -8,10 +8,13 @@ , contractHasEntryPoints , matchContractEntryPoints , hasEp + , validateStorageIs ) where import Data.List.NonEmpty (fromList) import qualified Data.Map as Map +import Fmt ((+|), (|+)) +import Test.HUnit (Assertion, assertFailure, (@?=)) import Michelson.Interpret (ContractEnv, ContractReturn, interpret) import Michelson.Printer (printUntypedContract) @@ -96,3 +99,15 @@ phi (para -> Type t _) = conv $ filter (\ep -> not (hasEp t ep)) (Map.toList eps) conv l | null l = Right () | otherwise = Left $ fromList l + +-- | 'ContractPropValidator' that expects contract execution to +-- succeed and update storage to a particular constant value. +validateStorageIs + :: IsoValue st + => st -> ContractPropValidator (ToT st) Assertion +validateStorageIs expected (res, _) = + case res of + Left err -> + assertFailure $ "Unexpected interpretation failure: " +| err |+ "" + Right (_ops, got) -> + got @?= toVal expected diff --git a/src/Michelson/Test/Util.hs b/src/Michelson/Test/Util.hs --- a/src/Michelson/Test/Util.hs +++ b/src/Michelson/Test/Util.hs @@ -8,10 +8,15 @@ , succeededProp , qcIsLeft , qcIsRight + , roundtripTest ) where +import Data.Typeable (typeRep) import Fmt (Buildable, pretty) -import Test.QuickCheck.Property (Property, Result(..), failed, property) +import Test.QuickCheck (Arbitrary) +import Test.QuickCheck.Property (Property, Result(..), failed, property, (===)) +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) leftToShowPanic :: (Show e, HasCallStack) => Either e a -> a leftToShowPanic = either (error . show) id @@ -42,3 +47,28 @@ qcIsRight = \case Right _ -> property True Left x -> failedProp $ "expected Right, got Left (" <> show x <> ")" + +---------------------------------------------------------------------------- +-- Roundtrip +---------------------------------------------------------------------------- + +-- | This 'TestTree' contains a property based test for conversion from +-- some @x@ to some @y@ and back to @x@ (it should successfully return +-- the initial @x@). +roundtripTest :: + forall x y err. + ( Show x + , Show err + , Typeable x + , Arbitrary x + , Eq x + , Eq err + ) + => (x -> y) + -> (y -> Either err x) + -> TestTree +roundtripTest xToY yToX = testProperty typeName check + where + typeName = show $ typeRep (Proxy @x) + check :: x -> Property + check x = yToX (xToY x) === Right x diff --git a/src/Util/Test/Arbitrary.hs b/src/Util/Test/Arbitrary.hs --- a/src/Util/Test/Arbitrary.hs +++ b/src/Util/Test/Arbitrary.hs @@ -16,13 +16,12 @@ import Test.QuickCheck.Instances.Text () import Test.QuickCheck.Random (mkQCGen) -import Lorentz.UStore import Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..)) import Michelson.Test () import Michelson.Untyped - (Annotation, CT(..), Comparable(..), Contract'(..), Elt(..), ExpandedExtInstr, - ExpandedOp(..), ExtInstrAbstract(..), InstrAbstract(..), InternalByteString(..), - StackTypePattern(..), T(..), TyVar(..), Type(..), Value'(..), Var(..), mkAnnotation) + (Annotation, CT(..), Comparable(..), Contract'(..), Elt(..), ExpandedExtInstr, ExpandedOp(..), + ExtInstrAbstract(..), InstrAbstract(..), InternalByteString(..), StackTypePattern(..), T(..), + TyVar(..), Type(..), Value'(..), Var(..), mkAnnotation) import Tezos.Core (Mutez(..)) instance Arbitrary InternalByteString where @@ -235,13 +234,6 @@ instance ToADTArbitrary Comparable instance Arbitrary Comparable where arbitrary = Comparable <$> arbitrary <*> arbitrary - -instance (Ord k, Arbitrary k, Arbitrary v) => - Arbitrary (k |~> v) where - arbitrary = UStoreSubMap <$> arbitrary - -instance Arbitrary v => Arbitrary (UStoreFieldExt m v) where - arbitrary = UStoreField <$> arbitrary -- | Run given generator deterministically. runGen :: Int -> Gen a -> a diff --git a/test/Test/Doc.hs b/test/Test/Doc.hs deleted file mode 100644 --- a/test/Test/Doc.hs +++ /dev/null @@ -1,156 +0,0 @@ --- | Tests on automatic documentation generation. - -module Test.Doc - ( test_General_doc_scan - , test_Dependencies_loops - , test_Cutting_all_except_doc - , test_fakeCoerce - ) where - -import qualified Data.Set as Set -import Fmt (build) -import Test.HUnit (assertBool, assertFailure, (@?=)) -import Test.QuickCheck (total) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) - -import Lorentz (( # )) -import qualified Lorentz as L -import Michelson.Doc -import Michelson.Typed -import Util.Named - --- General tests on contract doc scan ----------------------------------------------------------------------------- - -newtype MyType = MyType Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyType where - typeDocMdDescription = "" - -data MyGroup = MyGroup Text SubDoc - -instance DocItem MyGroup where - type DocItemPosition MyGroup = 91232 - docItemSectionName = Nothing - docItemToMarkdown lvl (MyGroup name subDoc) = - build name <> subDocToMarkdown lvl subDoc - -test_General_doc_scan :: [TestTree] -test_General_doc_scan = - [ testCase "Type declaration is found" $ - let contract = L.doc $ DType (Proxy @MyType) - doc = L.buildLorentzDoc contract - in case lookupDocBlockSection @DType $ cdDefinitions doc of - Just (toList -> ds) -> - sort ds @?= sort [DType (Proxy @MyType), DType (Proxy @Integer)] - Nothing -> - assertFailure "DTypes not found" - - , testCase "Dependencies of polymorphic types are found" $ - -- There once was a bug which caused, in the following scenario, - -- 'Integer' type to be found while 'Natural' to be not, doc items - -- discovery thought that ":!" has already been traversed and didn't - -- pick its dependencies the second time. - let contract = L.doc $ L.mkDEntryPointArgSimple @("a" :! Integer, "b" :! Natural) - doc = L.buildLorentzDoc contract - defs = cdDefinitionsSet doc - in do - assertBool "'Integer' declaration is present" $ - Set.member (SomeDocDefinitionItem $ DType (Proxy @Integer)) defs - assertBool "'Natural' declaration is present" $ - Set.member (SomeDocDefinitionItem $ DType (Proxy @Natural)) defs - - , testCase "Doc group is handled correctly" $ - let contract = L.docGroup (SomeDocItem . MyGroup "a") $ - L.doc $ DDescription "a" - doc = L.buildLorentzDoc contract - contents = cdContents doc - in case lookupDocBlockSection contents of - Just (MyGroup "a" (SubDoc subcontents) :| []) -> - case lookupDocBlockSection subcontents of - Just (DDescription "a" :| []) -> - pass - _ -> assertFailure $ "Unexpected subcontents: " <> show subcontents - _ -> assertFailure $ "Unexpected contents: " <> show contents - ] - --- Test on loops on dependency graph of doc items ----------------------------------------------------------------------------- - --- | Type, documentation for which somehow depends on itself. -newtype MyLoopedType = MyLoopedType Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyLoopedType where - typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyLoopedType)] - typeDocMdDescription = "" - -newtype MyMutuallyDependentType1 = MyMutuallyDependentType1 Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -newtype MyMutuallyDependentType2 = MyMutuallyDependentType2 Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyMutuallyDependentType1 where - typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType2)] - typeDocMdDescription = "" - -instance TypeHasDoc MyMutuallyDependentType2 where - typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType1)] - typeDocMdDescription = "" - -test_Dependencies_loops :: [TestTree] -test_Dependencies_loops = - [ testProperty "Type depending on itself" $ - let contract = L.doc $ DType (Proxy @MyLoopedType) - in total . contractDocToMarkdown $ L.buildLorentzDoc contract - , testProperty "Mutually dependent types" $ - let contract = L.doc $ DType (Proxy @MyMutuallyDependentType1) - in total . contractDocToMarkdown $ L.buildLorentzDoc contract - ] - --- Functions semantics ----------------------------------------------------------------------------- - -test_Cutting_all_except_doc :: [TestTree] -test_Cutting_all_except_doc = - [ testCase "Cleaning simple code" $ - let contract = - L.doc (DDescription "a") # - L.push True # - L.if_ (L.contractName "aaa" $ L.doc $ DDescription "b") (L.sender # L.drop) - :: '[] L.:-> '[] - cutContract = - L.doc (DDescription "a") # - L.contractName "aaa" (L.doc $ DDescription "b") - in L.renderLorentzDoc (L.cutLorentzNonDoc contract) - @?= - L.renderLorentzDoc cutContract - - , testCase "DocGroup is handled correctly" $ - let contract = - L.docGroup (SomeDocItem . MyGroup "b") $ - L.doc (DDescription "a") # L.nop - cutContract = - L.docGroup (SomeDocItem . MyGroup "b") $ - L.doc (DDescription "a") - in L.renderLorentzDoc (L.cutLorentzNonDoc contract) - @?= - L.renderLorentzDoc cutContract - ] - -test_fakeCoerce :: [TestTree] -test_fakeCoerce = - [ testCase "Does not truncate the following documentation" $ - let contract = L.doc (DDescription "a") :: '[] L.:-> '[] - in L.renderLorentzDoc (L.fakeCoerce # contract) - @?= - L.renderLorentzDoc contract - ] diff --git a/test/Test/DocTest.hs b/test/Test/DocTest.hs deleted file mode 100644 --- a/test/Test/DocTest.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | Tests on doc test framework. -module Test.DocTest - ( test_Predicates_work - , test_Exclusion_works - ) where - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz (( # ), (/->)) -import qualified Lorentz as L -import Lorentz.EntryPoints.Doc -import Lorentz.Test.Doc -import Michelson.Doc - --- A bad contract because it uses 'caseT' instead of 'entryCase' -contract1 :: L.Contract (Either Integer Natural) Integer -contract1 = L.car # L.caseT - ( #cLeft /-> - L.doc (DDescription "Handles left") # - L.nop - , #cRight /-> - L.doc (DDescription "Handles right") # - L.int - ) # L.nil # L.pair - -contractDoc1 :: ContractDoc -contractDoc1 = L.buildLorentzDoc contract1 - -contract2 :: L.Contract (Either Integer Natural) Integer -contract2 = L.car # L.entryCase (Proxy @PlainEntryPointsKind) - ( #cLeft /-> L.nop - , #cRight /-> L.int - ) # L.nil # L.pair - -contractDoc2 :: ContractDoc -contractDoc2 = L.buildLorentzDoc contract2 - -test_Predicates_work :: [TestTree] -test_Predicates_work = - [ testCase "Name at top absence is detected" $ - expectDocTestFailure testContractNameAtTop contractDoc1 - , testCase "Multiple adjacent descriptions are detected" $ - expectDocTestFailure testNoAdjacentDescriptions contractDoc1 - , testCase "Absence of parameter description is detected" $ - expectDocTestFailure testDeclaresParameter contractDoc1 - , testCase "Absence of entrypoint description is detected" $ - expectDocTestFailure testEachEntrypointIsDescribed contractDoc2 - ] - --- Normally doc test suites should not be declared with 'HasCallStack', but --- this may potentially break 'excludeDocTests' so we try this here. -testDummyWithCallStack :: HasCallStack => DocTest -testDummyWithCallStack = mkDocTest "dummy" $ \_ -> pass - -test_Exclusion_works :: [TestTree] -test_Exclusion_works = - [ testCase "Exclusion removes only expected things" $ - [ testContractNameAtTop - , testDocNotEmpty - , testNoAdjacentDescriptions - , testDummyWithCallStack - ] - `excludeDocTests` - [ testDocNotEmpty - , testDummyWithCallStack - ] - @?= - [ testContractNameAtTop - , testNoAdjacentDescriptions - ] - ] diff --git a/test/Test/Integrational.hs b/test/Test/Integrational.hs --- a/test/Test/Integrational.hs +++ b/test/Test/Integrational.hs @@ -5,22 +5,29 @@ import Test.Hspec (Spec, it) -import Lorentz (( # )) -import qualified Lorentz as L -import Lorentz.Test +import Michelson.Test +import Michelson.Typed import Tezos.Core +import Util.Named spec_Chain_id :: Spec spec_Chain_id = do it "Chain id can be set" $ integrationalTestExpectation $ do - let code = L.drop # L.chainId # L.nil # L.pair + let code = DROP `Seq` CHAIN_ID `Seq` NIL `Seq` PAIR + let contract = FullContract + { fcCode = code + , fcParamNotesSafe = ParamNotesUnsafe (starNotes @'TUnit) + , fcStoreNotes = starNotes + } let chainId = mkChainIdUnsafe "aaaa" - contract <- lOriginate code "" dummyChainId (toMutez 50) + contractAddr <- + tOriginate contract "" (toVal dummyChainId) (toMutez 50) setChainId chainId - lCallDef @() contract () + tTransfer (#from .! genesisAddress) (#to .! contractAddr) + minBound DefEpName (toVal ()) validate . Right $ - lExpectStorageConst contract chainId + tExpectStorageConst contractAddr (toVal chainId) diff --git a/test/Test/Interpreter.hs b/test/Test/Interpreter.hs --- a/test/Test/Interpreter.hs +++ b/test/Test/Interpreter.hs @@ -11,43 +11,30 @@ , test_STEPS_TO_QUOTA , test_gas_exhaustion , test_add1_list - , test_mkStackRef , test_Sum_types , test_Product_types , test_split_bytes , test_split_string_simple , test_complex_strings , test_contract_instr_on_implicit - , test_APPLY , test_Entry_points_lookup , test_Entry_points_calling ) where import qualified Data.Map as Map import Data.Singletons (SingI) -import Fmt (pretty, (+|), (|+)) +import Fmt (pretty) import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy) -import Test.HUnit (Assertion, assertFailure, (@?=)) +import Test.HUnit (assertFailure) import Test.QuickCheck (Property, label, (.&&.), (===)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Test.Tasty.QuickCheck (testProperty) -import Text.Hex (decodeHex) import Util.Named ((.!)) -import Lorentz (Lambda, ( # )) -import qualified Lorentz as L -import Lorentz.Run -import Lorentz.Test.Integrational (tExpectStorageConst, tTransfer) import Michelson.Interpret (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps, interpret) import Michelson.Test - (ContractPropValidator, concatTestTrees, contractProp, testTreesWithTypedContract, - testTreesWithUntypedContract) -import Michelson.Test.Dummy (dummyContractEnv) -import Michelson.Test.Integrational (originate) -import Michelson.Test.Integrational (genesisAddress, integrationalTestExpectation, validate) -import Michelson.Test.Util (failedProp) import Michelson.Text import Michelson.Typed (CT(..), CValue(..), IsoValue(..), T(..), epcPrimitive) import qualified Michelson.Typed as T @@ -192,14 +179,6 @@ contractProp contract (doValidate param) dummyContractEnv param param ] -test_mkStackRef :: TestTree -test_mkStackRef = - testCase "does not segfault" $ do - let contract = L.drop # L.push () # L.dup # L.printComment (L.stackRef @1) - # L.drop # L.nil @T.Operation # L.pair - contractProp (T.fcCode $ compileLorentzContract @() contract) - (flip shouldSatisfy isRight . fst) dummyContractEnv () () - test_Sum_types :: IO [TestTree] test_Sum_types = concatTestTrees [ testTreesWithTypedContract "contracts/union.mtz" $ \contract -> pure @@ -325,23 +304,6 @@ where addr = mkKeyAddress . toPublic $ detSecretKey "sfsdfsdf" -test_APPLY :: IO [TestTree] -test_APPLY = - testTreesWithTypedContract "contracts/apply.tz" $ \applyContract -> - testTreesWithTypedContract "contracts/partially-applied-lambda-packed.tz" $ \partApplyContract -> - pure - [ testCase "Basic test" $ - contractProp @(Lambda (Integer, Integer) Integer) @Integer - applyContract (validateStorageIs @Integer 2) - dummyContractEnv (L.unpair # L.sub) 0 - , testCase "Partially applied lambda packed" $ - let expected = decodeHex "05020000000f0743035b0005034202000000020316" - ?: error "Bad bytes" - in contractProp @() @ByteString - partApplyContract (validateStorageIs @ByteString expected) - dummyContractEnv () "" - ] - -- TODO [TM-280] Move to separate module test_Entry_points_lookup :: IO [TestTree] test_Entry_points_lookup = @@ -441,16 +403,6 @@ validateSuccess :: HasCallStack => ContractPropValidator st Expectation validateSuccess (res, _) = res `shouldSatisfy` isRight - -validateStorageIs - :: IsoValue st - => st -> ContractPropValidator (ToT st) Assertion -validateStorageIs expected (res, _) = - case res of - Left err -> - assertFailure $ "Unexpected interpretation failure: " +| err |+ "" - Right (_ops, got) -> - got @?= toVal expected validateBasic1 :: [Integer] -> ContractPropValidator ('TList ('Tc 'CInt)) Property diff --git a/test/Test/Interpreter/Apply.hs b/test/Test/Interpreter/Apply.hs new file mode 100644 --- /dev/null +++ b/test/Test/Interpreter/Apply.hs @@ -0,0 +1,33 @@ +-- | Tests for the 'APPLY' instruction. + +module Test.Interpreter.Apply + ( unit_Basic + , unit_Partially_applied_lambda_packed + ) where + +import Test.HUnit (Assertion) +import Text.Hex (decodeHex) + +import Michelson.Test +import Michelson.Typed + +unit_Basic :: Assertion +unit_Basic = do + (_, applyContract) <- importContract "contracts/apply.tz" + let + lam :: Instr '[ ToT (Integer, Integer) ] '[ ToT Integer ] + lam = DUP `Seq` CAR `Seq` DIP CDR `Seq` SUB + + contractPropVal + applyContract (validateStorageIs @Integer 2) + dummyContractEnv (VLam $ RfNormal lam) (VC $ CvInt 0) + +unit_Partially_applied_lambda_packed :: Assertion +unit_Partially_applied_lambda_packed = do + (_, partApplyContract) <- + importContract "contracts/partially-applied-lambda-packed.tz" + let expected = decodeHex "05020000000f0743035b0005034202000000020316" + ?: error "Bad bytes" + contractProp @() @ByteString + partApplyContract (validateStorageIs @ByteString expected) + dummyContractEnv () "" diff --git a/test/Test/Interpreter/StackRef.hs b/test/Test/Interpreter/StackRef.hs new file mode 100644 --- /dev/null +++ b/test/Test/Interpreter/StackRef.hs @@ -0,0 +1,26 @@ +-- | Interpreter tests involving 'StackRef'. + +module Test.Interpreter.StackRef + ( test_mkStackRef + ) where + +import Test.Hspec.Expectations (shouldSatisfy) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase) + +import Michelson.Test (contractProp) +import Michelson.Test.Dummy (dummyContractEnv) +import Michelson.Typed + +test_mkStackRef :: TestTree +test_mkStackRef = + testCase "does not segfault" $ + contractProp contract (flip shouldSatisfy isRight . fst) + dummyContractEnv () () + where + stackRef = PrintComment . one . Right $ mkStackRef @1 + + contract :: Contract 'TUnit 'TUnit + contract = + CAR `Seq` DUP `Seq` Ext (PRINT stackRef) `Seq` + DROP `Seq` NIL `Seq` PAIR diff --git a/test/Test/Lorentz/Base.hs b/test/Test/Lorentz/Base.hs deleted file mode 100644 --- a/test/Test/Lorentz/Base.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | Tests for basic Lorentz functionality. - -module Test.Lorentz.Base - ( unit_parseLorentzValue - ) where - -import Test.HUnit (Assertion, (@?=)) - -import Lorentz.Base (parseLorentzValue) -import Michelson.Typed (IsoValue) - --- Sum type. -data S - = S1 Bool - | S2 - | S3 Integer - deriving stock (Generic, Eq, Show) - deriving anyclass (IsoValue) - --- Product type. -type P = (Bool, Integer, S, S) - -unit_parseLorentzValue :: Assertion -unit_parseLorentzValue = do - parseLorentzValue "Left True" @?= Right (S1 True) - parseLorentzValue @P "Pair (Pair False 20) (Pair (Right (Left Unit)) (Right (Right 15)))" @?= - Right (False, 20, S2, S3 15) diff --git a/test/Test/Lorentz/Conditionals.hs b/test/Test/Lorentz/Conditionals.hs deleted file mode 100644 --- a/test/Test/Lorentz/Conditionals.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} - --- | Tests (and examples) on Lorentz' @if .. then .. else ..@. -module Test.Lorentz.Conditionals - ( test_Named - ) where - -import Michelson.Test.Dummy -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz - -test_Named :: [TestTree] -test_Named = - [ testCase "Named compare works good" $ - interpretLorentzLambda dummyContractEnv myContract (5 :: Natural) - @?= Right True - ] - where - myContract = do - toNamed #x - push @Natural 3; toNamed #y - if #y >=. #x - then push False - else push True diff --git a/test/Test/Lorentz/DeadCode.hs b/test/Test/Lorentz/DeadCode.hs deleted file mode 100644 --- a/test/Test/Lorentz/DeadCode.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | Tests checking dead code avoidance in Lorentz. - -module Test.Lorentz.DeadCode - ( test_Test - ) where - -import Control.Spoon (spoon) -import Test.HUnit (assertBool, (@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import qualified Lorentz as L -import Lorentz.Base -import Lorentz.Run -import Michelson.Typed (Instr(Seq)) -import qualified Michelson.Typed as T - -test_Test :: [TestTree] -test_Test = - [ testCase "Can construct normal instructions" $ - L.push @Integer 5 # L.drop - `compilesTo` (T.PUSH (T.toVal @Integer 5) `Seq` T.DROP) - - , testCase "Dead code is cut off" $ - (L.unit # L.failWith) # L.drop - `compilesTo` (T.UNIT `Seq` T.FAILWITH) - - , testCase "Dead code after all failing if branches is cut off" $ - (L.push True # L.if_ L.failWith L.failWith) # L.drop - `compilesTo` (T.PUSH (T.toVal True) `Seq` T.IF T.FAILWITH T.FAILWITH) - - , testCase "Always failing DIP body is error" $ - L.dip (L.unit # L.failWith) - & fails - ] - where - compilesTo linstr instr = - compileLorentz @'[()] linstr @?= instr - infixr 0 `compilesTo` - - fails instr = - assertBool "instruction construction didn't fail" . isNothing . spoon $ - compileLorentz instr diff --git a/test/Test/Lorentz/EntryPoints.hs b/test/Test/Lorentz/EntryPoints.hs deleted file mode 100644 --- a/test/Test/Lorentz/EntryPoints.hs +++ /dev/null @@ -1,447 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - --- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'. -module Test.Lorentz.EntryPoints - ( test_FieldAnnotations - , test_TypeAnnotations - , test_Entrypoints_lookup - , test_Contract_call - , test_Self_call - ) where - -import Fcf (Eval) -import Unsafe.Coerce (unsafeCoerce) -import Data.Constraint (Dict (..)) -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.TypeSpec (typeTest) -import Test.TypeSpec (Is, TypeSpec(..)) -import Test.Util.TypeSpec (ExactlyIs) - -import Lorentz ((:!), ( # ), (/->)) -import qualified Lorentz as L -import Lorentz.Constraints -import Lorentz.EntryPoints -import Lorentz.Run -import Lorentz.Test -import Lorentz.Value -import Michelson.Typed -import Michelson.Untyped (FieldAnn, TypeAnn, ann, noAnn) - ----------------------------------------------------------------------------- --- Entrypoints declarations ----------------------------------------------------------------------------- - -data MyEntryPoints1 - = Do1 Integer - | Do2 (Integer, Integer) - | Do3 MyEntryPoints2 - | Do4 MyParams - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints1a - = Do1a Integer - | Do2a (Integer, Integer) - | Do3a MyEntryPoints2 - | Do4a MyParams - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints2 - = Do10 - | Do11 Natural - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints3 - = Do12 ("tuplearg" :! ("TL" :! Integer, "TR" :! Natural), "boolarg" :! Bool) - | Do13 ("integerarg" :! Integer, "boolarg" :! Bool) - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints4 - = Do14 ("viewarg1" :! L.View ("owner" :! L.Address) Natural) - | Do15 () - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints5 - = Do16 ("maybearg" :! Maybe ("maybeinner" :! Natural)) - | Do17 () - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints6 - = Do18 ("lambdaarg" :! L.Lambda Natural Natural) - | Do19 () - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints7 - = Do20 ("listarg" :! [("balance" :! Natural , "address" :! L.Address)]) - | Do21 () - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints8 - = Do22 ("maparg" :! (Map Natural ("balance" :! Natural , "address" :! L.Address))) - | Do23 () - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints9 - = Do24 ("maybearg" L.:? ("maybeinner" :! Natural)) - | Do25 () - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPoints10 - = Do26 ("bigmaparg" :! L.Lambda (BigMap Natural ("balance" :! Natural , "address" :! L.Address)) ()) - | Do27 () - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPointsWithDef - = Default Integer - | NonDefault Natural - deriving stock Generic - deriving anyclass IsoValue - -data MyParams = MyParams - { param1 :: () - , param2 :: ByteString - } - deriving stock Generic - deriving anyclass IsoValue - --- Normally this cannot declare entrypoints because this is not a sum type. --- But we will declare them forcibly -data MySingleEntryPoint = Dos1 Integer - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPointsDelegated - = Dod1 - | Dod2 MyEntryPointsSubDelegated - deriving stock Generic - deriving anyclass IsoValue - -data MyEntryPointsSubDelegated - = Dosd1 - | Dosd2 - deriving stock Generic - deriving anyclass IsoValue - -instance ParameterHasEntryPoints MyEntryPoints1 where - type ParameterEntryPointsDerivation MyEntryPoints1 = EpdRecursive - -instance ParameterHasEntryPoints MyEntryPoints1a where - type ParameterEntryPointsDerivation MyEntryPoints1a = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints2 where - type ParameterEntryPointsDerivation MyEntryPoints2 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints3 where - type ParameterEntryPointsDerivation MyEntryPoints3 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints4 where - type ParameterEntryPointsDerivation MyEntryPoints4 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints5 where - type ParameterEntryPointsDerivation MyEntryPoints5 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints6 where - type ParameterEntryPointsDerivation MyEntryPoints6 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints7 where - type ParameterEntryPointsDerivation MyEntryPoints7 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints8 where - type ParameterEntryPointsDerivation MyEntryPoints8 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints9 where - type ParameterEntryPointsDerivation MyEntryPoints9 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPoints10 where - type ParameterEntryPointsDerivation MyEntryPoints10 = EpdPlain - -instance ParameterHasEntryPoints MyEntryPointsWithDef where - type ParameterEntryPointsDerivation MyEntryPointsWithDef = EpdPlain - -instance ParameterHasEntryPoints (ShouldHaveEntryPoints MySingleEntryPoint) where - type ParameterEntryPointsDerivation (ShouldHaveEntryPoints MySingleEntryPoint) = EpdPlain - -instance ParameterHasEntryPoints MyEntryPointsDelegated where - type ParameterEntryPointsDerivation MyEntryPointsDelegated = EpdDelegate - -instance ParameterHasEntryPoints MyEntryPointsSubDelegated where - type ParameterEntryPointsDerivation MyEntryPointsSubDelegated = EpdNone - -dummyContract :: L.Contract param () -dummyContract = L.drop L.# L.unit L.# L.nil L.# L.pair - --- | Helper datatype which contains field annotations from 'NTOr'. -data FieldAnnTree t where - Leaf :: ForbidOr t => FieldAnnTree t - Node :: FieldAnn -> FieldAnnTree a - -> FieldAnn -> FieldAnnTree b - -> FieldAnnTree ('TOr a b) - -deriving stock instance Eq (FieldAnnTree t) -deriving stock instance Show (FieldAnnTree t) - -data TypeAnnTree t where - TALeaf :: TypeAnn -> TypeAnnTree t - TANodeOption :: TypeAnn -> TypeAnnTree a -> TypeAnnTree ('TOption a) - TANodePair :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TPair a b) - TANodeOr :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TOr a b) - TANodeLambda :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TLambda a b) - TANodeList :: TypeAnn -> TypeAnnTree a -> TypeAnnTree ('TList a) - TANodeMap :: TypeAnn -> TypeAnnTree b -> TypeAnnTree ('TMap a b) - TANodeBigMap :: TypeAnn -> TypeAnnTree b -> TypeAnnTree ('TBigMap a b) - -deriving stock instance Eq (TypeAnnTree t) -deriving stock instance Show (TypeAnnTree t) - -extractTypeAnnTres :: Notes t -> TypeAnnTree t -extractTypeAnnTres = \case - NTc ta -> TALeaf ta - NTKey ta -> TALeaf ta - NTUnit ta -> TALeaf ta - NTSignature ta -> TALeaf ta - NTOption ta n1 -> TANodeOption ta (extractTypeAnnTres n1) - NTList ta n1 -> TANodeList ta (extractTypeAnnTres n1) - NTSet ta _ -> TALeaf ta - NTOperation ta -> TALeaf ta - NTContract ta _ -> TALeaf ta - NTPair ta _ _ n1 n2 -> TANodePair ta (extractTypeAnnTres n1) (extractTypeAnnTres n2) - NTOr ta _ _ n1 n2 -> TANodeOr ta (extractTypeAnnTres n1) (extractTypeAnnTres n2) - NTLambda ta n1 n2 -> TANodeLambda ta (extractTypeAnnTres n1) (extractTypeAnnTres n2) - NTMap ta _ n1 -> TANodeMap ta (extractTypeAnnTres n1) - NTBigMap ta _ n1 -> TANodeBigMap ta (extractTypeAnnTres n1) - NTChainId ta -> TALeaf ta - -extractFieldAnnTree :: Notes t -> FieldAnnTree t -extractFieldAnnTree = \case - NTOr _ lann rann lnotes rnotes -> - Node lann (extractFieldAnnTree lnotes) rann (extractFieldAnnTree rnotes) - (_ :: Notes t) -> - -- Here we know that type is not 'TOr', - -- and tests don't require high-quality code - case unsafeCoerce @(Dict ()) @(Dict (ForbidOr t)) Dict of - Dict -> Leaf - -test_FieldAnnotations :: [TestTree] -test_FieldAnnotations = - [ testCase "Simple parameter" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints2)) - @?= - Node - (ann "do10") Leaf - (ann "do11") Leaf - - , testGroup "Complex parameter" - [ testCase "Interpreting as direct list of entrypoints" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints1a)) - @?= - Node - noAnn (Node (ann "do1a") Leaf (ann "do2a") Leaf) - noAnn (Node (ann "do3a") (Node noAnn Leaf noAnn Leaf) (ann "do4a") Leaf) - - , testCase "Recursive entrypoints traversal" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints1)) - @?= - Node - noAnn (Node (ann "do1") Leaf (ann "do2") Leaf) - noAnn (Node - noAnn (Node (ann "do10") Leaf (ann "do11") Leaf) - (ann "do4") Leaf - ) - - , testCase "Delegating entrypoints traversal" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPointsDelegated)) - @?= - Node (ann "dod1") Leaf - (ann "dod2") (Node noAnn Leaf noAnn Leaf) - ] - ] - where - paramAnnTree :: FullContract cp st -> FieldAnnTree cp - paramAnnTree = extractFieldAnnTree . fcParamNotes - -test_TypeAnnotations :: [TestTree] -test_TypeAnnotations = - [ testCase "Named field parameter" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints3)) - @?= - (TANodeOr noAnn - (TANodePair noAnn (TANodePair (ann "tuplearg") (TALeaf (ann "TL")) (TALeaf (ann "TR"))) (TALeaf (ann "boolarg"))) - (TANodePair noAnn (TALeaf (ann "integerarg")) (TALeaf (ann "boolarg"))) - ) - , testCase "Named field parameter for views" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints4)) - @?= - (TANodeOr noAnn - (TANodePair (ann "viewarg1") (TALeaf (ann "owner")) (TALeaf noAnn)) (TALeaf noAnn)) - - , testCase "Maybe field parameter" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints5)) - @?= - (TANodeOr noAnn - (TANodeOption (ann "maybearg") (TALeaf (ann "maybeinner"))) (TALeaf noAnn)) - - , testCase "Lambda field parameter" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints6)) - @?= - (TANodeOr noAnn - (TANodeLambda (ann "lambdaarg") (TALeaf noAnn) (TALeaf noAnn)) (TALeaf noAnn)) - - , testCase "List field parameter" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints7)) - @?= - (TANodeOr noAnn - (TANodeList (ann "listarg") (TANodePair noAnn (TALeaf (ann "balance")) (TALeaf (ann "address")))) (TALeaf noAnn)) - - , testCase "Map field parameter" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints8)) - @?= - (TANodeOr noAnn - (TANodeMap (ann "maparg") (TANodePair noAnn (TALeaf (ann "balance")) (TALeaf (ann "address")))) (TALeaf noAnn)) - - , testCase "Maybe field parameter 2" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints9)) - @?= - (TANodeOr noAnn - (TANodeOption (ann "maybearg") (TALeaf (ann "maybeinner"))) (TALeaf noAnn)) - - , testCase "Big map field parameter" $ - (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints10)) - @?= - (TANodeOr noAnn - (TANodeLambda (ann "bigmaparg") (TANodeBigMap noAnn (TANodePair noAnn (TALeaf (ann "balance")) (TALeaf (ann "address")))) (TALeaf noAnn)) (TALeaf noAnn)) - - , testCase "Newtype" $ - (paramAnnTree $ compileLorentzContract (dummyContract @(ShouldHaveEntryPoints MySingleEntryPoint))) - @?= - TALeaf noAnn - - , testGroup "Primitive type parameter" - -- Parameters used in these test cases should not require any instances - [ testCase "Address" $ - (paramAnnTree $ compileLorentzContract (dummyContract @Address)) - @?= - TALeaf noAnn - , testCase "Void" $ - (paramAnnTree $ compileLorentzContract (dummyContract @(L.Void_ Integer Natural))) - @?= - TANodePair noAnn (TALeaf noAnn) (TANodeLambda noAnn (TALeaf noAnn) (TALeaf noAnn)) - ] - ] - where - paramAnnTree :: FullContract cp st -> TypeAnnTree cp - paramAnnTree = extractTypeAnnTres . fcParamNotes - ----------------------------------------------------------------------------- --- @contract@ instruction ----------------------------------------------------------------------------- - -test_Entrypoints_lookup :: [TestTree] -test_Entrypoints_lookup = - [ testGroup "Flat parameter type" - [ typeTest "Default entrypoint arg" $ Valid @ - (GetDefaultEntryPointArg MyEntryPoints1a `Is` MyEntryPoints1a) - , typeTest "Can get entrypoint on surface" $ Valid @ - (GetEntryPointArg MyEntryPoints1a "Do1a" `Is` Integer) - , typeTest "Cannot get entrypoint in deep" $ Valid @ - (Eval (LookupParameterEntryPoint MyEntryPoints1a "Do11") - `ExactlyIs` 'Nothing - ) - ] - , testGroup "Nested parameter type" - [ typeTest "Default entrypoint arg" $ Valid @ - (GetDefaultEntryPointArg MyEntryPoints1 `Is` MyEntryPoints1) - , typeTest "Can get entrypoint on surface" $ Valid @ - (GetEntryPointArg MyEntryPoints1 "Do1" `Is` Integer) - , typeTest "Can get entrypoint in deep" $ Valid @ - (GetEntryPointArg MyEntryPoints1 "Do11" `Is` Natural) - , typeTest "Can get entrypoint without arg" $ Valid @ - (GetEntryPointArg MyEntryPoints1 "Do10" `Is` ()) - ] - , testGroup "Parameter type with default entrypoint" - [ typeTest "Default entrypoint arg" $ Valid @ - (GetDefaultEntryPointArg MyEntryPointsWithDef `Is` Integer) - , typeTest "Can get non-default entrypoint" $ Valid @ - (GetEntryPointArg MyEntryPointsWithDef "NonDefault" `Is` Natural) - ] - , testGroup "Delegation" - [ typeTest "Calling immediate entrypoint works" $ Valid @ - (GetEntryPointArg MyEntryPointsDelegated "Dod1" `Is` ()) - ] - ] - --- | A contract which accepts 'Address' as parameter and calls specific --- entrypoint of another contract. -callerContract - :: forall cp mname arg. - ( arg ~ GetEntryPointArgCustom cp mname - , NiceConstant arg, NiceParameter arg, NiceParameterFull cp - ) - => EntryPointRef mname - -> arg - -> L.Contract (TAddress cp) () -callerContract epRef arg = - L.car # L.contractCalling @cp epRef # - L.assertSome [mt|Contract lookup failed|] # - L.push (toMutez 1) # L.push arg # L.transferTokens # - L.dip (L.unit # L.nil) # L.cons # L.pair - -test_Contract_call :: [TestTree] -test_Contract_call = - [ testCase "Calling entrypoint" $ - integrationalTestExpectation $ do - let myCallerContract = callerContract (Call @"Do11") 5 - let myTargetContract = L.car # L.caseT @MyEntryPoints2 - ( #cDo10 /-> L.push 0 - , #cDo11 /-> L.nop - ) # L.nil # L.pair - - caller <- lOriginate myCallerContract "Caller" () (toMutez 10) - target <- lOriginateEmpty myTargetContract "Call target" - lCallDef caller target - validate . Right $ - lExpectStorageConst target (5 :: Natural) - - , testCase "Calling default entrypoint" $ - integrationalTestExpectation $ do - let myCallerContract = callerContract CallDefault 3 - let myTargetContract = L.car # L.caseT @MyEntryPointsWithDef - ( #cDefault /-> L.nop - , #cNonDefault /-> L.neg - ) # L.nil # L.pair - - caller <- lOriginate myCallerContract "Caller" () (toMutez 10) - target <- lOriginateEmpty myTargetContract "Call target" - lCallDef caller target - validate . Right $ - lExpectStorageConst target (3 :: Natural) - ] - -test_Self_call :: [TestTree] -test_Self_call = - [ testCase "Calling entrypoint" $ - integrationalTestExpectation $ do - let myContract = L.car # L.caseT @MyEntryPoints2 - ( #cDo10 /-> - L.selfCalling @MyEntryPoints2 (Call @"Do11") # - L.push (toMutez 1) # L.push 5 # L.transferTokens # - L.dip (L.push @Integer 1 # L.nil) # L.cons # L.pair - , #cDo11 /-> L.push @Integer 10 # L.add # L.nil # L.pair - ) - - contractRef <- lOriginate myContract "Contract" 0 (toMutez 10) - lCallDef contractRef Do10 - validate . Right $ - lExpectStorageConst contractRef (15 :: Natural) - ] diff --git a/test/Test/Lorentz/Errors.hs b/test/Test/Lorentz/Errors.hs deleted file mode 100644 --- a/test/Test/Lorentz/Errors.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Test.Lorentz.Errors - ( unit_Errors - , unit_gatherErrorTags - , unit_Numeric_simple - , unit_Numeric_append - , unit_errorFromValNumeric - ) where - -import qualified Data.Bimap as Bimap -import qualified Data.HashSet as HS -import Test.HUnit (Assertion, (@?=)) - -import Lorentz as L -import Lorentz.Test.Integrational -import Michelson.Text (mt) - -{- Checking that errors of old format still can be used fine -} - -data ErrorOfOldFormat - = ErrorCase1 - | ErrorCase2 Integer - deriving stock Generic - -deriveCustomError ''ErrorOfOldFormat - -_canFailUsing :: s :-> s' -_canFailUsing = failUsing ErrorCase1 - -_canFailUsingArg :: Integer : s :-> s' -_canFailUsingArg = failUsingArg @ErrorOfOldFormat #cErrorCase2 - --- Needed to make this module compile -unit_Errors :: IO () -unit_Errors = pass - ----------------------------------------------------------------------------- --- Numeric representation ----------------------------------------------------------------------------- - -unit_gatherErrorTags :: Assertion -unit_gatherErrorTags = sampleGatheredTags @?= HS.fromList [str1, str2] - -unit_Numeric_simple :: Assertion -unit_Numeric_simple = - useNumericErrors sample @?= - (sampleNumericErrors (0, 1), Bimap.fromList [(0, str1), (1, str2)]) - -unit_Numeric_append :: Assertion -unit_Numeric_append = - applyErrorTagMap newMap sample @?= - sampleNumericErrors (5, 4) - where - existingMap :: ErrorTagMap - existingMap = Bimap.fromList [(4, str2)] - - newMap = existingMap `addNewErrorTags` sampleGatheredTags - -type instance ErrorArg "aa" = Bool -instance CustomErrorHasDoc "aa" where - customErrClass = ErrClassActionException - customErrDocMdCause = "patak" - -sample :: '[ MText] :-> '[ MText] -sample = - pushTrue # - -- FailWithString - if_ - (push str1 # failWith) - pushTrue # - -- Non-typical fail - if_ - (push str1 # push str1 # pair # pair # failWith) - pushTrue # - -- FailWithStackValue - if_ - (push str1 # pair # failWith) - (pushTrue) # - -- FailWithStackValue via 'failCustom' - if_ - (pushTrue # failCustom #aa) - (none @()) # - -- Deeper FailWithString - ifNone - (unit # pushTrue # if_ (push str2 # failWith) nop) - nop # - -- FailWithConstantPair - push (str2, ()) # failWith - --- Arguments are numeric codes for 'str1' and 'str2'. -sampleNumericErrors :: (Natural, Natural) -> '[ MText] :-> '[ MText] -sampleNumericErrors (code1, code2) = - pushTrue # - if_ - (push code1 # failWith) - pushTrue # - - if_ - (push str1 # push str1 # pair # pair # failWith) - pushTrue # - - if_ - (push code1 # pair # failWith) - pushTrue # - - -- Here we lose doc item and rely on the fact that instructions are - -- compared by transpiling them to Michelson. - if_ - (pushTrue # push code1 # pair # failWith) - (none @()) # - - ifNone - (unit # pushTrue # if_ (push code2 # failWith) nop) - nop # - - push (code2, ()) # failWith - -sampleGatheredTags :: HashSet MText -sampleGatheredTags = gatherErrorTags sample - -pushTrue :: forall s. s :-> Bool ': s -pushTrue = push True - -str1, str2 :: MText -str1 = [mt|Aa|] -str2 = [mt|Qq|] - -unit_errorFromValNumeric :: Assertion -unit_errorFromValNumeric = integrationalTestExpectation $ do - let - (voidSample', errorTagMap) = useNumericErrors voidSample - ref <- lOriginate voidSample' "voidSample" () minBound - lCall ref (mkVoid True) - validate . Left $ - lExpectErrorNumeric errorTagMap (== VoidResult False) - -voidSample :: Contract (Void_ Bool Bool) () -voidSample = car # void_ L.not diff --git a/test/Test/Lorentz/Extensible.hs b/test/Test/Lorentz/Extensible.hs deleted file mode 100644 --- a/test/Test/Lorentz/Extensible.hs +++ /dev/null @@ -1,71 +0,0 @@ -module Test.Lorentz.Extensible - ( test_Extensible - ) where - -import Data.Vinyl.Core (Rec(..)) -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz (toVal) -import Lorentz.Base -import Lorentz.Extensible -import Lorentz.Run -import Michelson.Interpret.Pack -import Michelson.Test.Dummy - -data SumType - = Ctor0 Natural - | Ctor1 - | Ctor2 (Integer, Integer) - deriving stock (Generic, Eq, Show) - -values :: [SumType] -values = - [ Ctor0 42 - , Ctor1 - , Ctor2 (-100, 500) - ] - -test_Extensible :: [TestTree] -test_Extensible = - [ testCase "toExtVal conversion" $ do - fmap toExtVal values @?= - [ Extensible (0, packValue' $ toVal @Natural 42) - , Extensible (1, packValue' $ toVal ()) - , Extensible (2, packValue' $ toVal ints) - ] - , testCase "fromExtVal conversion" $ do - let extValues = [ Extensible (0, packValue' $ toVal @Natural 42) - , Extensible (1, packValue' $ toVal ()) - , Extensible (2, packValue' $ toVal ints) - ] - fmap fromExtVal extValues @?= fmap Right values - , testCase "fromExtVal failure" $ do - let invalidCtor = Extensible (3, packValue' $ toVal ()) - let invalidArg = Extensible (2, packValue' $ toVal ()) - fromExtVal @SumType invalidCtor - @?= Left (ConstructorIndexNotFound 3) - fromExtVal @SumType invalidArg - @?= Left ArgumentUnpackFailed - , testCase "wrapExt" $ do - wrapIntoCtor2 ints @?= (Right $ Extensible (2, packValue' $ toVal ints)) - , testCase "Roundtrip" $ do - fmap roundtrip values @?= fmap Right values - ] - where - wrapIntoCtor2 initVal = do - let initStack = (Identity initVal :& RNil) - resStack <- interpretLorentzInstr dummyContractEnv wrapCode initStack - let Identity res :& RNil = resStack - return res - -ints :: (Integer, Integer) -ints = (-100, 500) - -wrapCode :: '[(Integer, Integer)] :-> '[Extensible SumType] -wrapCode = wrapExt #cCtor2 - -roundtrip :: (ExtVal value) => value -> Either ExtConversionError value -roundtrip value = - fromExtVal $ toExtVal value diff --git a/test/Test/Lorentz/Macro.hs b/test/Test/Lorentz/Macro.hs deleted file mode 100644 --- a/test/Test/Lorentz/Macro.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | Tests for Lorentz macros. --- --- They test logic of macros and type-level logic. Also they serve as --- examples of using complex macros (e. g. parameterized with --- type-level numbers) - -module Test.Lorentz.Macro - ( unit_duupX - , test_execute - ) where - -import Prelude hiding (drop, swap) -import Test.HUnit (Assertion, (@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz - -import Michelson.Test.Dummy - -unit_duupX :: Assertion -unit_duupX = do - duupX @1 @?= dup - duupX @2 @?= (dip dup # swap) - duupX @3 @?= duupX3 - where - duupX3 :: [Bool, Integer, (), Bool] :-> [(), Bool, Integer, (), Bool] - duupX3 = dipN @2 dup # dig @2 - -test_execute :: [TestTree] -test_execute = - [ testCase "Two arguments lambda" $ - let lam :: [Integer, Integer] :-> [(), Integer] - lam = add # unit - code = push 3 # push lam # execute # drop @() - in interpretLorentzLambda dummyContractEnv code 5 - @?= Right 8 - - , testCase "Zero arguments lambda" $ - let lam :: '[] :-> '[Integer] - lam = push 5 - code = drop # push lam # execute - in interpretLorentzLambda dummyContractEnv code (0 :: Integer) - @?= Right 5 - ] diff --git a/test/Test/Lorentz/Pack.hs b/test/Test/Lorentz/Pack.hs deleted file mode 100644 --- a/test/Test/Lorentz/Pack.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | Tests for Lorentz packing/unpacking - -module Test.Lorentz.Pack - ( test_lambda_roundtrip - ) where - -import Prelude hiding (drop, swap) -import Test.HUnit (Assertion, (@?=), assertFailure) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz -import Michelson.Typed.Instr (Instr (..)) -import Michelson.Typed.Util (DfsSettings (..), dfsFoldInstr) - -test_lambda_roundtrip :: [TestTree] -test_lambda_roundtrip = - [ testCase "Packing and then unpacking a Lambda does not add empty annotations" $ - lambdaRoundtripWithoutNotes lam - ] - where - lam :: Lambda () () - lam = push @Natural 5 # drop - --- | Checks that packing and unpacking a lambda made of instructions without --- Annotations will produce the same lambda, still without annotations. -lambdaRoundtripWithoutNotes - :: forall i o. NiceUnpackedValue (Lambda i o) - => Lambda i o - -> Assertion -lambdaRoundtripWithoutNotes l = case lUnpackValue @(Lambda i o) $ lPackValue l of - Left err -> assertFailure $ "Unpacking error: " <> show err - Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of - [] -> ul @?= l - notes -> assertFailure $ "Lambda has annotations: " <> show notes - where - dfsSettings :: DfsSettings [Text] - dfsSettings = def { dsGoToValues = True} - - instrNotes :: Instr inp out -> [Text] - instrNotes = \case - InstrWithNotes n _ -> [show n] - _ -> [] diff --git a/test/Test/Lorentz/Print.hs b/test/Test/Lorentz/Print.hs deleted file mode 100644 --- a/test/Test/Lorentz/Print.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - --- | Tests on Lorentz contracts pretty-printing. -module Test.Lorentz.Print - ( test_Print_parameter_annotations - , test_Print_lambda - ) where - -import Prelude hiding (drop, swap) -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz hiding (contract, unpack) -import Michelson.Printer.Util (buildRenderDoc) -import Michelson.Typed hiding (Contract) -import Michelson.Untyped (para) - -data MyEntryPoints1 - = Do1 Integer - | Do2 (Integer, Integer) - | Do3 - deriving stock Generic - deriving anyclass IsoValue - -instance ParameterHasEntryPoints MyEntryPoints1 where - type ParameterEntryPointsDerivation MyEntryPoints1 = EpdPlain - -contract :: Contract MyEntryPoints1 () -contract = drop # unit # nil # pair - -test_Print_parameter_annotations :: [TestTree] -test_Print_parameter_annotations = - [ testCase "Simple parameter" $ - let typedContract = compileLorentzContract contract - untypedContract = convertFullContract typedContract - in buildRenderDoc (para untypedContract) - @?= - "or (int %do1) (or (pair %do2 int int) (unit %do3))" - ] - -test_Print_lambda :: [TestTree] -test_Print_lambda = - [ testCase "Prints correct lambda instruction" $ - let - code :: '[Integer] :-> '[('[Integer] :-> '[()])] - code = drop # lambda (drop # unit) - in printLorentzValue True code - @?= - "{ DROP; LAMBDA int unit { DROP;UNIT } }" - ] diff --git a/test/Test/Lorentz/UParam.hs b/test/Test/Lorentz/UParam.hs deleted file mode 100644 --- a/test/Test/Lorentz/UParam.hs +++ /dev/null @@ -1,96 +0,0 @@ --- | Tests for Lorentz 'UParam'. -module Test.Lorentz.UParam - ( test_Simple_contract - , test_ADT_conversion - , unit_unpackUParam - ) where - -import Data.Vinyl.Core (Rec(..)) -import Data.Constraint (Dict (..)) -import Test.HUnit ((@?=), assertBool, Assertion) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Michelson.Text -import Michelson.Interpret.Pack -import Lorentz ((/->)) -import qualified Lorentz as L -import Lorentz.Base -import Lorentz.UParam -import Lorentz.Run -import Michelson.Test.Dummy - --- Test on simple contract ----------------------------------------------------------------------------- - -type Entries = ["add" ?: Natural, "id" ?: ()] - -simpleCode :: '[UParam Entries, Integer] :-> '[Integer] -simpleCode = caseUParamT - ( #add /-> L.add - , #id /-> L.drop @() - ) uparamFallbackFail - -test_Simple_contract :: [TestTree] -test_Simple_contract = - [ testCase "Passing parameter 1" $ - runSimpleCode 5 (mkUParam #add 3) @?= Right 8 - , testCase "Passing parameter 2" $ - runSimpleCode 5 (mkUParam #id ()) @?= Right 5 - , testCase "Passing illegal parameter" $ - assertBool "Expected failure" $ - isLeft $ - runSimpleCode 5 (UParamUnsafe ([mt|Nyan|], "")) - ] - where - runSimpleCode initVal uparam = do - let initStack = (Identity uparam :& initVal :& RNil) - resStack <- interpretLorentzInstr dummyContractEnv simpleCode initStack - let Identity res :& RNil = resStack - return res - --- Test deconstruction ----------------------------------------------------------------------------- - -unit_unpackUParam :: Assertion -unit_unpackUParam = do - unpk (mkUParam #add 3) @?= - Right ([mt|add|], "3") - unpk (mkUParam #id ()) @?= - Right ([mt|id|], "()") - unpk (UParamUnsafe ([mt|gy|], mempty)) @?= - Left (NoSuchEntryPoint [mt|gy|]) - unpk (UParamUnsafe ([mt|add|], mempty)) @?= - Left ArgumentUnpackFailed - where - unpk :: - UParam Entries -> - Either EntryPointLookupError (MText, String) - unpk = fmap (second show) . unpackUParam @Show - --- Test ADT conversion ----------------------------------------------------------------------------- - -data Parameter1 - = MyEntryPoint1 Integer - | MyEntryPoint2 () - deriving stock (Generic) - -type ExpectedLinearization1 = - [ "MyEntryPoint1" ?: Integer - , "MyEntryPoint2" ?: () - ] - -_checkLinearizedType - :: Dict (UParamLinearized Parameter1 ~ ExpectedLinearization1) -_checkLinearizedType = Dict - -test_ADT_conversion :: [TestTree] -test_ADT_conversion = - [ testCase "Linearization 1.1" $ - uparamFromAdt (MyEntryPoint1 5) - @?= UParamUnsafe ([mt|MyEntryPoint1|], packValue' (L.toVal @Integer 5)) - , testCase "Linearization 1.2" $ - uparamFromAdt (MyEntryPoint2 ()) - @?= UParamUnsafe ([mt|MyEntryPoint2|], packValue' (L.toVal ())) - ] diff --git a/test/Test/Lorentz/UStore/Behaviour.hs b/test/Test/Lorentz/UStore/Behaviour.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Behaviour.hs +++ /dev/null @@ -1,175 +0,0 @@ --- | Tests for Lorentz 'UStore'. -module Test.Lorentz.UStore.Behaviour - ( test_Roundtrip - , test_Conversions - , test_Script - ) where - -import Data.Default (def) -import qualified Data.Map as M -import Test.HUnit (Assertion, assertFailure, (@?=)) -import Test.QuickCheck (Arbitrary(..)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Lorentz.Base -import Lorentz.Instr as L -import Lorentz.Run -import Lorentz.UStore -import Michelson.Test.Dummy -import Michelson.Test.Util -import Util.Test.Arbitrary () - -import Test.Util.QuickCheck (roundtripTest) - - -data MyTemplate = MyTemplate - { ints :: Integer |~> () - , bool :: UStoreField Bool - } deriving stock (Eq, Show, Generic) - -instance Arbitrary MyTemplate where - arbitrary = MyTemplate <$> arbitrary <*> arbitrary - -data MyTemplateBig = MyTemplateBig - { small :: MyTemplate - , bytes :: ByteString |~> Natural - , total :: UStoreField Integer - } deriving stock (Eq, Show, Generic) - -instance Arbitrary MyTemplateBig where - arbitrary = MyTemplateBig <$> arbitrary <*> arbitrary <*> arbitrary - -test_Roundtrip :: [TestTree] -test_Roundtrip = - [ roundtripTest (mkUStore @MyTemplate) ustoreDecomposeFull - , roundtripTest (mkUStore @MyTemplateBig) ustoreDecomposeFull - ] - -test_Conversions :: [TestTree] -test_Conversions = - [ testGroup "Simple store template" - [ testCase "No action" $ - ustoreChangeTest - ( nop - , MyTemplate (UStoreSubMap def) (UStoreField False) - , MyTemplate (UStoreSubMap def) (UStoreField False) - ) - , testCase "Insert into submap" $ - ustoreChangeTest - ( unit # push 5 # ustoreInsert #ints - , MyTemplate (UStoreSubMap def) (UStoreField False) - , MyTemplate (UStoreSubMap $ one (5, ())) (UStoreField False) - ) - , testCase "Delete from submap" $ - ustoreChangeTest - ( push 3 # ustoreDelete #ints - , MyTemplate (UStoreSubMap $ one (3, ())) (UStoreField False) - , MyTemplate (UStoreSubMap mempty) (UStoreField False) - ) - , testCase "Get from submap" $ - ustoreChangeTest - ( dup # push 0 # ustoreGet #ints # - ifNone (push 10) (L.drop # push 11) # dip unit # ustoreInsert #ints - , MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField False) - , MyTemplate (UStoreSubMap $ M.fromList [(0, ()), (11, ())]) (UStoreField False) - ) - , testCase "Set field" $ - ustoreChangeTest - ( push True # ustoreSetField #bool - , MyTemplate (UStoreSubMap mempty) (UStoreField False) - , MyTemplate (UStoreSubMap mempty) (UStoreField True) - ) - , testCase "Get field" $ - ustoreChangeTest - ( ustoreGetField #bool # - if_ (push 5) (push 0) # dip unit # ustoreInsert #ints - , MyTemplate (UStoreSubMap mempty) (UStoreField False) - , MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField False) - ) - , testCase "Leave some entries untouched" $ - ustoreChangeTest - ( push 0 # ustoreDelete #ints # - unit # push 2 # ustoreInsert #ints - , MyTemplate (UStoreSubMap $ M.fromList [(0, ()), (1, ())]) (UStoreField False) - , MyTemplate (UStoreSubMap $ M.fromList [(1, ()), (2, ())]) (UStoreField False) - ) - ] - - , testGroup "Non-flat store template" - [ testCase "Custom scenario 1" $ - ustoreChangeTest - ( push "a" # ustoreDelete #bytes # - push 2 # push "b" # ustoreInsert #bytes # - ustoreGetField #total # push @Integer 1 # add # ustoreSetField #total # - unliftUStore #small # - unit # push 0 # ustoreInsert #ints # - push True # ustoreSetField #bool # - liftUStore #small - , MyTemplateBig - { small = MyTemplate (UStoreSubMap def) (UStoreField False) - , bytes = UStoreSubMap $ one ("a", 1) - , total = UStoreField 10 - } - , MyTemplateBig - { small = MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField True) - , bytes = UStoreSubMap $ one ("b", 2) - , total = UStoreField 11 - } - ) - ] - ] - where - -- We accept a tuple as argument to avoid many parentheses - ustoreChangeTest - :: (Each [Eq, Show, Generic, UStoreConversible] '[template], HasCallStack) - => ( '[UStore template] :-> '[UStore template] - , template - , template - ) - -> Assertion - ustoreChangeTest (instr, initStoreHs, expectedNewStore) = - let - initStore = mkUStore initStoreHs - ustore = - leftToPrettyPanic $ - interpretLorentzLambda dummyContractEnv instr initStore - in case ustoreDecomposeFull ustore of - Left err -> assertFailure (toString err) - Right ustoreHs -> ustoreHs @?= expectedNewStore - -test_Script :: [TestTree] -test_Script = - [ testCase "Only fields" $ - ustoreScriptTest MyTemplate - { ints = UStoreSubMap mempty - , bool = UStoreField True - } - - , testCase "Fields and submaps" $ - ustoreScriptTest MyTemplate - { ints = UStoreSubMap $ one (5, ()) - , bool = UStoreField True - } - - , testCase "Complex" $ - ustoreScriptTest MyTemplateBig - { small = MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField True) - , bytes = UStoreSubMap $ one ("b", 2) - , total = UStoreField 11 - } - ] - where - ustoreScriptTest - :: (Each [Eq, Show, Generic, UStoreConversible] '[template], HasCallStack) - => template - -> Assertion - ustoreScriptTest store = - let - filling = migrationToLambda (fillUStore store) - ustoreFilled = - leftToPrettyPanic $ - interpretLorentzLambda dummyContractEnv filling (mkUStore ()) - in case ustoreDecomposeFull ustoreFilled of - Left err -> assertFailure (toString err) - Right ustoreHs -> ustoreHs @?= store diff --git a/test/Test/Lorentz/UStore/Migration/Batched.hs b/test/Test/Lorentz/UStore/Migration/Batched.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Migration/Batched.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Test.Lorentz.UStore.Migration.Batched - ( test_Separated_lambdas - ) where - -import qualified Data.Map as M -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import qualified Lorentz as L -import Lorentz.UStore -import Lorentz.UStore.Migration - -import qualified Test.Lorentz.UStore.Migration.Batched.V1 as V1 -import qualified Test.Lorentz.UStore.Migration.Batched.V2 as V2 - -initMigration :: UStoreMigration () V1.MyTemplate -initMigration = fillUStore V1.MyTemplate - { bytes = UStoreSubMap $ M.fromList [(1, "a"), (2, "b")] - , int1 = UStoreField 1 - , int2 = UStoreField 2 - , code1 = UStoreField L.nop - , code2 = UStoreField L.int - , code3 = UStoreField L.nop - } - -v2migration :: UStoreMigration V1.MyTemplate V2.MyTemplate -v2migration = mkUStoreBatchedMigration $ - muBlock $: - L.push @Natural 1 L.# - migrateOverwriteField #int1 - <--> - muBlock $: - migrateRemoveField #int2 - <--> - muBlock $: - -- Normally such joined blocks should not be present, but we - -- want to test different scenarios - L.push L.nop L.# - migrateModifyField #code1 L.# - - migrateRemoveField #code2 - <--> - muBlock $: - migrateRemoveField #code3 - <--> - migrationFinish - -test_Separated_lambdas :: [TestTree] -test_Separated_lambdas = - [ testGroup "V0 -> V1" $ - let cmigration = compileMigration mbSeparateLambdas initMigration - in - [ testCase "Split is correct" $ - (slbiType <$> migrationToInfo cmigration) - @?= - [ SlbtData - , SlbtLambda - , SlbtLambda - , SlbtLambda - ] - ] - - , testGroup "V1 -> V2" $ - let cmigration = compileMigration mbSeparateLambdas v2migration - in - [ testCase "Split is correct" $ - (slbiType <$> migrationToInfo cmigration) - @?= - [ SlbtData - , SlbtLambda - , SlbtLambda - -- Lambda removals should not be put separatelly, so one lambda is gone - ] - ] - ] diff --git a/test/Test/Lorentz/UStore/Migration/Batched/V1.hs b/test/Test/Lorentz/UStore/Migration/Batched/V1.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Migration/Batched/V1.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Test.Lorentz.UStore.Migration.Batched.V1 - ( MyTemplate (..) - ) where - -import Lorentz.Base -import Lorentz.UStore - -data MyTemplate = MyTemplate - { bytes :: Integer |~> ByteString - , int1 :: UStoreField Integer - , int2 :: UStoreField Integer - , code1 :: UStoreField $ Lambda () () - , code2 :: UStoreField $ Lambda Natural Integer - , code3 :: UStoreField $ Lambda () () - } deriving stock Generic diff --git a/test/Test/Lorentz/UStore/Migration/Batched/V2.hs b/test/Test/Lorentz/UStore/Migration/Batched/V2.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Migration/Batched/V2.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Test.Lorentz.UStore.Migration.Batched.V2 - ( MyTemplate (..) - ) where - -import Lorentz.Base -import Lorentz.UStore - -data MyTemplate = MyTemplate - { bytes :: Integer |~> ByteString - , int1 :: UStoreField Natural - , code1 :: UStoreField $ Lambda () () - } deriving stock Generic diff --git a/test/Test/Lorentz/UStore/Migration/FillInParts.hs b/test/Test/Lorentz/UStore/Migration/FillInParts.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Migration/FillInParts.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Test.Lorentz.UStore.Migration.FillInParts - ( test_Migration_works - ) where - -import Fmt (pretty) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) -import Test.HUnit ((@?=), assertFailure) - -import qualified Lorentz as L -import Lorentz.UStore -import Lorentz.UStore.Migration -import Lorentz.UStore.Haskell -import Michelson.Text -import Michelson.Test.Dummy -import Lorentz.Run - -data MyTemplateWrapper substore = MyTemplateWrapper - { commonField :: UStoreField MText - , custom :: substore - } deriving stock (Eq, Show, Generic) - -data MySubTemplatePart1 = MySubTemplatePart1 - { int :: UStoreField Integer - , nat :: UStoreField Natural - } deriving stock (Eq, Show, Generic) - -part1Val :: MySubTemplatePart1 -part1Val = MySubTemplatePart1{ int = UStoreField -1, nat = UStoreField 1 } - -data MySubTemplatePart2 = MySubTemplatePart2 - { string :: UStoreField MText - } deriving stock (Eq, Show, Generic) - -part2Val :: MySubTemplatePart2 -part2Val = MySubTemplatePart2{ string = UStoreField [mt|bb|] } - -type MyTemplateV0 = MyTemplateWrapper () - -type MyTemplateV1 = MyTemplateWrapper (MySubTemplatePart1, MySubTemplatePart2) - -migrationBatched :: UStoreMigration MyTemplateV0 MyTemplateV1 -migrationBatched = mkUStoreBatchedMigration $ - muBlock $: - L.push [mt|bb|] L.# - migrateModifyField #commonField - <--> - fillUStoreMigrationBlock part1Val - <--> - fillUStoreMigrationBlock part2Val - <--> - migrationFinish - -migrationSimple :: UStoreMigration MyTemplateV0 MyTemplateV1 -migrationSimple = mkUStoreMigration $ - L.push [mt|bb|] L.# migrateModifyField #commonField L.# - migrateFillUStore part1Val L.# - migrateFillUStore part2Val L.# - migrationFinish - -test_Migration_works :: [TestTree] -test_Migration_works = - [ ("simple migration", migrationSimple) - , ("batched migration", migrationBatched) - ] <&> \(desc, migration) -> - testCase desc $ migratesToWith migration - MyTemplateWrapper - { commonField = UStoreField [mt|aa|] - , custom = () - } - MyTemplateWrapper - { commonField = UStoreField [mt|bb|] - , custom = (part1Val, part2Val) - } - where - migratesToWith migration storeV1 expectedStoreV2 = - either (assertFailure . toString) (@?= expectedStoreV2) $ do - storeV2 <- - first pretty $ - interpretLorentzLambda - dummyContractEnv - (migrationToLambda migration) - (mkUStore storeV1) - ustoreDecomposeFull storeV2 diff --git a/test/Test/Lorentz/UStore/Migration/Simple.hs b/test/Test/Lorentz/UStore/Migration/Simple.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Migration/Simple.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Test.Lorentz.UStore.Migration.Simple - ( test_Migration_works - ) where - -import Fmt (pretty) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) -import Test.HUnit ((@?=), assertFailure) - -import qualified Lorentz as L -import Lorentz.UStore -import Lorentz.UStore.Migration -import Lorentz.UStore.Migration.Diff -import Michelson.Text -import Michelson.Test.Dummy -import Lorentz.Run - -import qualified Test.Lorentz.UStore.Migration.Simple.V1 as V1 -import qualified Test.Lorentz.UStore.Migration.Simple.V2 as V2 - -_checkDiff :: Proxy (BuildDiff V1.MyTemplate V2.MyTemplate) -_checkDiff = Proxy @ - [ '( 'ToAdd, '("theName", UStoreField MText)) - , '( 'ToAdd, '("transformed", UStoreField Integer)) - , '( 'ToDel, '("useless", UStoreField MText)) - , '( 'ToDel, '("transformed", UStoreField Natural)) - ] - -migrationBatched :: UStoreMigration V1.MyTemplate V2.MyTemplate -migrationBatched = mkUStoreBatchedMigration $ - muBlock $: - migrateExtractField #useless L.# - L.push [mt|Token-|] L.# - L.concat L.# - migrateAddField #theName - <--> - muBlock $: - L.push 3 L.# - migrateOverwriteField #transformed - <--> - migrationFinish - -migrationSimple :: UStoreMigration V1.MyTemplate V2.MyTemplate -migrationSimple = mkUStoreMigration $ - migrateExtractField #useless L.# - L.push [mt|Token-|] L.# - L.concat L.# - migrateAddField #theName L.# - - L.push 3 L.# - migrateOverwriteField #transformed L.# - - migrationFinish - -test_Migration_works :: [TestTree] -test_Migration_works = - [ ("simple migration", migrationSimple) - , ("batched migration", migrationBatched) - ] <&> \(desc, migration) -> - testCase desc $ migratesWith migration - V1.MyTemplate - { V1.bytes = UStoreSubMap mempty - , V1.count = UStoreField 5 - , V1.useless = UStoreField [mt|pog|] - , V1.transformed = UStoreField 10 - } - V2.MyTemplate - { V2.theName = UStoreField [mt|Token-pog|] - , V2.bytes = UStoreSubMap mempty - , V2.count = UStoreField 5 - , V2.transformed = UStoreField 3 - } - where - migratesWith migration storeV1 expectedStoreV2 = - either (assertFailure . toString) (@?= expectedStoreV2) $ do - storeV2 <- - first pretty $ - interpretLorentzLambda - dummyContractEnv - (migrationToLambda migration) - (mkUStore storeV1) - ustoreDecomposeFull storeV2 diff --git a/test/Test/Lorentz/UStore/Migration/Simple/V1.hs b/test/Test/Lorentz/UStore/Migration/Simple/V1.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Migration/Simple/V1.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Test.Lorentz.UStore.Migration.Simple.V1 - ( MyTemplate (..) - ) where - -import Lorentz.UStore -import Lorentz.Value - -data MyTemplate = MyTemplate - { bytes :: Integer |~> ByteString - , count :: UStoreField Integer - , useless :: UStoreField MText - , transformed :: UStoreField Natural - } deriving stock Generic diff --git a/test/Test/Lorentz/UStore/Migration/Simple/V2.hs b/test/Test/Lorentz/UStore/Migration/Simple/V2.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/Migration/Simple/V2.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Test.Lorentz.UStore.Migration.Simple.V2 - ( MyTemplate (..) - ) where - -import Lorentz.UStore -import Lorentz.Value - -data MyTemplate = MyTemplate - { theName :: UStoreField MText - , bytes :: Integer |~> ByteString - , count :: UStoreField Integer - , transformed :: UStoreField Integer - } deriving stock (Eq, Show, Generic) diff --git a/test/Test/Lorentz/UStore/SafeLift.hs b/test/Test/Lorentz/UStore/SafeLift.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/SafeLift.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | We have a constraint in 'ustoreLift' which --- forbids nested store templates with duplicated fields. --- This module checks this constraint will work fine. -module Test.Lorentz.UStore.SafeLift - ( test_UStore_lift - ) where - -import Data.Typeable ((:~:)(..)) -import Test.Tasty (TestTree) - -import Lorentz.UStore -import Lorentz.UStore.Lift - -import Test.Lorentz.UStore.SafeLift.Helpers - --- Fake tests to deceive "weeder". --- All the check consist of typechecking some stuff, see below. -test_UStore_lift :: [TestTree] -test_UStore_lift = [] - -_checkDuplicates0 :: UStoreFieldsAreUnique MySimpleTemplate :~: 'True -_checkDuplicates0 = Refl - -data MyTemplateBig = MyTemplateBig - { ints :: Integer |~> Natural - , small :: MySimpleTemplate - } deriving stock (Generic) - -_checkDuplicates1 :: UStoreFieldsAreUnique MyTemplateBig :~: 'False -_checkDuplicates1 = Refl - -data MyTemplate2 = MyTemplate2 - { bool :: UStoreField Bool - } deriving stock (Generic) - -data MyTemplateSuperBig = MyTemplateSuperBig - { ssmall :: MySimpleTemplate - , ssmall2 :: MyTemplate2 - } deriving stock (Generic) - -_checkDuplicates2 :: UStoreFieldsAreUnique MyTemplateSuperBig :~: 'False -_checkDuplicates2 = Refl diff --git a/test/Test/Lorentz/UStore/SafeLift/Helpers.hs b/test/Test/Lorentz/UStore/SafeLift/Helpers.hs deleted file mode 100644 --- a/test/Test/Lorentz/UStore/SafeLift/Helpers.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | Contains a template for safe lifting check. --- --- We are going to define another template with the same field name, --- so putting this template in a separate module. -module Test.Lorentz.UStore.SafeLift.Helpers - ( MySimpleTemplate (..) - ) where - -import Lorentz.UStore - -data MySimpleTemplate = MySimpleTemplate - { ints :: Integer |~> () - , bool :: UStoreField Bool - } deriving stock (Generic) diff --git a/test/Test/Printer/Michelson.hs b/test/Test/Printer/Michelson.hs --- a/test/Test/Printer/Michelson.hs +++ b/test/Test/Printer/Michelson.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Test.Printer.Michelson - ( unit_Erase_annotations - , unit_Roundtrip + ( unit_Roundtrip , unit_let_macro , unit_PrettyPrint , unit_PrintTypedNotes @@ -15,7 +14,6 @@ import Generics.SYB (everywhere, mkT) import Test.HUnit (Assertion, assertEqual, assertFailure, (@?=)) -import qualified Lorentz as L import Michelson.Printer (printSomeContract, printUntypedContract) import Michelson.Runtime (parseExpandContract) import Michelson.TypeCheck.Instr (typeCheckContract) @@ -102,25 +100,6 @@ contract <- printAndParse filePath =<< importUntypedContract filePath let ops = concatMap U.flattenExpandedOp (U.code contract) ops @?= [U.CDR U.noAnn U.noAnn, U.UNIT U.noAnn U.noAnn, U.DROP] - -data TestParam - = TestCon1 ("a" L.:! Natural, "b" L.:! Bool) - | TestCon2 () - deriving stock Generic - deriving anyclass L.IsoValue - -instance L.ParameterHasEntryPoints TestParam where - type ParameterEntryPointsDerivation TestParam = L.EpdRecursive - -unit_Erase_annotations :: Assertion -unit_Erase_annotations = - let - contract :: L.Contract TestParam () - contract = L.cdr L.# L.nil L.# L.pair - expected = "parameter (or (pair %testCon1 (nat :a) (bool :b)) (unit %testCon2));storage unit;code { CAST (pair (or (pair nat bool) unit) unit);CDR;NIL operation;PAIR };" - in assertEqual - "Lorentz contract erases parameter annotations when printed" - expected (L.printLorentzContract True contract) printAndParse :: FilePath -> U.Contract -> IO U.Contract printAndParse fp contract1 = diff --git a/test/Test/Tasty/TypeSpec.hs b/test/Test/Tasty/TypeSpec.hs deleted file mode 100644 --- a/test/Test/Tasty/TypeSpec.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | Tasty integration for TypeSpec. -module Test.Tasty.TypeSpec - ( typeTest - ) where - -import Test.Tasty.Providers (IsTest(..), TestName, TestTree, singleTest, testPassed) -import Test.TypeSpec.Core (PrettyTypeSpec, TypeSpec(..)) - -data TypeTestCase = - forall expectation. PrettyTypeSpec expectation => - TypeTestCase (TypeSpec expectation) - -instance IsTest TypeTestCase where - -- Implementation here is similar to the one from HUnit integration - run _ (TypeTestCase spec) _ = - -- According to documentation of TypeSpec, the only sensible thing we can - -- do with spec value is to print it. - -- TypeSpec test suites are ensured at compile time. - return . testPassed $ show spec - - testOptions = pure [] - --- | Turn a 'TypeSpec' into tasty test case. -typeTest - :: PrettyTypeSpec expectation - => TestName -> TypeSpec expectation -> TestTree -typeTest name spec = singleTest name (TypeTestCase spec) diff --git a/test/Test/Util/QuickCheck.hs b/test/Test/Util/QuickCheck.hs --- a/test/Test/Util/QuickCheck.hs +++ b/test/Test/Util/QuickCheck.hs @@ -44,6 +44,8 @@ import Test.Tasty.QuickCheck (Property, testProperty, (.&&.), (===)) import qualified Text.Show (show) +import Michelson.Test.Util (roundtripTest) + ---------------------------------------------------------------------------- -- 'Show'ing a value though 'Buildable' type class. -- Useful because QuickCheck uses 'Show'. @@ -60,16 +62,14 @@ show = show . unSTB ---------------------------------------------------------------------------- --- Formatting +-- Roundtrip ---------------------------------------------------------------------------- --- | This 'TestTree' contains a property based test for conversion from --- some @x@ to some @y@ and back to @x@ (it should successfully return --- the initial @x@). -roundtripTest :: +-- | Version of 'roundtripTest' which shows values using 'Buildable' instance. +roundtripTestSTB :: forall x y err. - ( Show x - , Show err + ( Show (ShowThroughBuild x) + , Show (ShowThroughBuild err) , Typeable x , Arbitrary x , Eq x @@ -78,11 +78,7 @@ => (x -> y) -> (y -> Either err x) -> TestTree -roundtripTest xToY yToX = testProperty typeName check - where - typeName = show $ typeRep (Proxy @x) - check :: x -> Property - check x = yToX (xToY x) === Right x +roundtripTestSTB xToY yToX = roundtripTest (xToY . unSTB) (bimap STB STB . yToX) roundtripADTTest :: forall x y err. @@ -105,21 +101,6 @@ typeName = show $ typeRep (Proxy @x) check x = yToX (xToY x) === Right x z = True === True - --- | Version of 'roundtripTest' which shows values using 'Buildable' instance. -roundtripTestSTB :: - forall x y err. - ( Show (ShowThroughBuild x) - , Show (ShowThroughBuild err) - , Typeable x - , Arbitrary x - , Eq x - , Eq err - ) - => (x -> y) - -> (y -> Either err x) - -> TestTree -roundtripTestSTB xToY yToX = roundtripTest (xToY . unSTB) (bimap STB STB . yToX) aesonRoundtrip :: forall x. (Show (ShowThroughBuild x), ToJSON x, FromJSON x, Typeable x, Arbitrary x, Eq x) diff --git a/test/Test/Util/TypeSpec.hs b/test/Test/Util/TypeSpec.hs deleted file mode 100644 --- a/test/Test/Util/TypeSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Test.Util.TypeSpec - ( ExactlyIs - ) where - -import Test.TypeSpec.Core -import Data.Singletons.Prelude.Eq (DefaultEq) -import Util.Type (If) -import Util.TypeLits (ErrorMessage (..)) - --- | Like 'Is' but ensures that arguments match in kind. -data ExactlyIs (actual :: k) (expected :: k) -type instance EvalExpectation (ExactlyIs actual expected) = - If (DefaultEq actual expected) - (OK (ExactlyIs actual expected)) - (FAILED - ('Text "Expected type: " ':<>: 'ShowType expected - ':$$: 'Text "Actual type: " ':<>: 'ShowType actual)) - -instance PrettyTypeSpec (ExactlyIs a b) where - prettyTypeSpec _px = "Equal"