diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,20 @@ +0.6.0 +========== +* [!528](https://gitlab.com/morley-framework/morley/-/merge_requests/528) + The generated documentation now contains a sample value of each entrypoint. + + Allow modification of sample value via `mkDEntrypointExample`. +* [!493](https://gitlab.com/morley-framework/morley/-/merge_requests/493) + Add support for root entrypoint. + + A contract can now specify whether or not the root annotation should be generated + and which name it should use. + + `self` and `contract` instructions are able to call the root entrypoint. + 0.5.0 ===== +* [!530](https://gitlab.com/morley-framework/morley/-/merge_requests/530) + Field annotation are now generated for sum-type in `parameter` and `storage`. + + It also ensures that it will not generate field annotations that would introduce + extra entrypoints. * [!371](https://gitlab.com/morley-framework/morley/-/merge_requests/371) Make `view_` argument accept 2 arguments rather than a pair. * [!486](https://gitlab.com/morley-framework/morley/-/merge_requests/486) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,8 +24,8 @@ 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 that package's [README](/code/morley-ledgers/README.md). +Examples of using Lorentz eDSL reside in the [`morley-multisig`](../morley-multisig) package. +For more information, refer to that package's [README](/code/morley-multisig/README.md). Also, to get more information about Lorentz you can read our [blogpost](https://serokell.io/blog/lorentz-implementing-smart-contract-edsl-in-haskell). @@ -112,8 +112,7 @@ Lorentz provides primitives for embedding documentation in the contract code and functions to produce documentation in Markdown, they can be found in [`Lorentz.Doc`](./src/Lorentz/Doc.hs) and [`Michelson.Doc`](../morley/src/Michelson/Doc.hs) modules. - Documentation examples can be found [here](https://gitlab.com/morley-framework/morley/-/tree/autodoc/master/morley-ledgers/autodoc) - and [here](https://gitlab.com/morley-framework/morley/-/tree/autodoc/master/morley-multisig/autodoc). + Documentation examples can be found [here](https://gitlab.com/morley-framework/morley/-/tree/autodoc/master/morley-multisig/autodoc). ## Sample smart contract written in Lorentz diff --git a/lorentz.cabal b/lorentz.cabal --- a/lorentz.cabal +++ b/lorentz.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 16b347727d4e62a2940ac95ec51994350b8b857bcd82d1803c5f7684b86a81f3 +-- hash: 886d75999d5a74ca60336ce7e2df837ebf21b15e761a4cdf8d8ccaa07d9a67f1 name: lorentz -version: 0.5.0 +version: 0.6.0 synopsis: EDSL for the Michelson Language description: Lorentz is a powerful meta-programming tool which allows one to write Michelson contracts directly in Haskell. It has the same instructions as Michelson, but operates on Haskell values and allows one to use Haskell features. category: Language diff --git a/src/Lorentz/Address.hs b/src/Lorentz/Address.hs --- a/src/Lorentz/Address.hs +++ b/src/Lorentz/Address.hs @@ -127,7 +127,7 @@ fromVal = error "Fetching 'FutureContract' back from Michelson is impossible" instance HasAnnotation (FutureContract a) where - getAnnotation = M.starNotes + getAnnotation _ = M.starNotes -- | Convert something to 'Address' in /Haskell/ world. -- diff --git a/src/Lorentz/Annotation.hs b/src/Lorentz/Annotation.hs --- a/src/Lorentz/Annotation.hs +++ b/src/Lorentz/Annotation.hs @@ -6,7 +6,9 @@ -- | Type and field annotations for Lorentz types. module Lorentz.Annotation - ( HasAnnotation (..) + ( FollowEntrypointFlag (..) + , GenerateFieldAnnFlag (..) + , HasAnnotation (..) , GHasAnnotation (..) , gGetAnnotationNoField , insertTypeAnn @@ -27,91 +29,104 @@ import Tezos.Crypto import Util.TypeLits +-- | Used in `GHasAnnotation` and `HasAnnotation` as a flag to track +-- whether or not it directly follows an entrypoint to avoid introducing +-- extra entrypoints. +data FollowEntrypointFlag = FollowEntrypoint | NotFollowEntrypoint + +-- | Used in `GHasAnnotation` as a flag to track whether or not field/constructor +-- annotations should be generated. +data GenerateFieldAnnFlag = GenerateFieldAnn | NotGenerateFieldAnn + -- | Use this in the instance of @HasAnnotation@ when field annotations -- should not be generated. gGetAnnotationNoField - :: forall a. (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) => Notes (ToT a) -gGetAnnotationNoField = fst $ gGetAnnotation @(G.Rep a) False + :: forall a. (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) + => FollowEntrypointFlag -> Notes (ToT a) +gGetAnnotationNoField = \_ -> fst $ gGetAnnotation @(G.Rep a) NotFollowEntrypoint NotGenerateFieldAnn -- | This class defines the type and field annotations for a given type. Right now -- the type annotations come from names in a named field, and field annotations are -- generated from the record fields. class HasAnnotation a where - getAnnotation :: Notes (ToT a) + getAnnotation :: FollowEntrypointFlag -> Notes (ToT a) default getAnnotation - :: (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) => Notes (ToT a) - getAnnotation = fst $ gGetAnnotation @(G.Rep a) True + :: (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) + => FollowEntrypointFlag + -> Notes (ToT a) + getAnnotation b = fst $ gGetAnnotation @(G.Rep a) b GenerateFieldAnn instance (HasAnnotation a, KnownSymbol name) => HasAnnotation (NamedF Identity a name) where - getAnnotation = insertTypeAnn (symbolAnn @name) $ getAnnotation @a + getAnnotation b = insertTypeAnn (symbolAnn @name) $ + getAnnotation @a b where symbolAnn :: forall s. KnownSymbol s => TypeAnn symbolAnn = ann $ symbolValT' @s instance (HasAnnotation (Maybe a), KnownSymbol name) => HasAnnotation (NamedF Maybe a name) where - getAnnotation = getAnnotation @(NamedF Identity (Maybe a) name) + getAnnotation b = getAnnotation @(NamedF Identity (Maybe a) name) b -- Primitive instances instance (HasAnnotation a) => HasAnnotation (Maybe a) where - getAnnotation = NTOption noAnn (getAnnotation @a) + getAnnotation _ = NTOption noAnn (getAnnotation @a NotFollowEntrypoint) instance HasAnnotation () instance HasAnnotation Integer where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation Natural where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation MText where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation Bool where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation ByteString where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation Mutez where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation Address where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation EpAddress where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation KeyHash where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation Timestamp where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation PublicKey where - getAnnotation = starNotes + getAnnotation _ = starNotes instance HasAnnotation Signature where - getAnnotation = starNotes + getAnnotation _ = starNotes instance (HasAnnotation a) => HasAnnotation (ContractRef a) where - getAnnotation = NTContract noAnn (getAnnotation @a) + getAnnotation _ = NTContract noAnn (getAnnotation @a NotFollowEntrypoint) instance (HasAnnotation k, HasAnnotation v) => HasAnnotation (Map k v) where - getAnnotation = NTMap noAnn (getAnnotation @k) (getAnnotation @v) + getAnnotation _ = NTMap noAnn (getAnnotation @k NotFollowEntrypoint) (getAnnotation @v NotFollowEntrypoint) instance (HasAnnotation k, HasAnnotation v) => HasAnnotation (BigMap k v) where - getAnnotation = NTBigMap noAnn (getAnnotation @k) (getAnnotation @v) + getAnnotation _ = NTBigMap noAnn (getAnnotation @k NotFollowEntrypoint) (getAnnotation @v NotFollowEntrypoint) instance (KnownIsoT v) => HasAnnotation (Set v) where - getAnnotation = starNotes + getAnnotation _ = starNotes instance (HasAnnotation a) => HasAnnotation [a] where - getAnnotation = NTList noAnn (getAnnotation @a) + getAnnotation _ = NTList noAnn (getAnnotation @a NotFollowEntrypoint) instance HasAnnotation Operation where - getAnnotation = starNotes + getAnnotation _ = starNotes instance (HasAnnotation a, HasAnnotation b) => HasAnnotation (a, b) instance (HasAnnotation a, HasAnnotation b, HasAnnotation c) => HasAnnotation (a, b, c) @@ -127,30 +142,28 @@ -- | A Generic @HasAnnotation@ implementation class GHasAnnotation a where - -- | @Bool@ acts as a flag to determine whether or not field annotations - -- should be set. - gGetAnnotation :: Bool -> (Notes (GValueType a), FieldAnn) + gGetAnnotation :: FollowEntrypointFlag -> GenerateFieldAnnFlag -> (Notes (GValueType a), FieldAnn) instance GHasAnnotation G.U1 where - gGetAnnotation _ = (starNotes, noAnn) + gGetAnnotation _ _ = (starNotes, noAnn) instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.S ('G.MetaSel 'Nothing b c d) x) where - gGetAnnotation b = gGetAnnotation @x b + gGetAnnotation b b2 = gGetAnnotation @x b b2 instance (GHasAnnotation x, KnownSymbol a) => GHasAnnotation (G.M1 G.S ('G.MetaSel ('Just a) b c d) x) where - gGetAnnotation b = case b of - True -> (fst $ gGetAnnotation @x b, ctorNameToAnn @a) - False -> (fst $ gGetAnnotation @x b, noAnn) + gGetAnnotation b b2 = case b2 of + GenerateFieldAnn -> (fst $ gGetAnnotation @x b b2, ctorNameToAnn @a) + NotGenerateFieldAnn -> (fst $ gGetAnnotation @x b b2, noAnn) -instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.C i1 x) where - gGetAnnotation b = gGetAnnotation @x b +instance (GHasAnnotation x, KnownSymbol a) => GHasAnnotation (G.M1 G.C ('G.MetaCons a _p _f) x) where + gGetAnnotation b b2 = (fst $ gGetAnnotation @x b b2, ctorNameToAnn @a) instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.D i1 x) where - gGetAnnotation b = gGetAnnotation @x b + gGetAnnotation b b2 = gGetAnnotation @x b b2 instance ( GHasAnnotation x @@ -159,13 +172,24 @@ => GHasAnnotation (x G.:+: y) where - gGetAnnotation b = - ( NTOr noAnn noAnn noAnn - (fst $ gGetAnnotation @x b) - (fst $ gGetAnnotation @y b ) - , noAnn - ) + gGetAnnotation followEntrypointFlag generateAnnFlag = + let (xTypeAnn, xFieldAnn) = gGetAnnotation @x followEntrypointFlag generateAnnFlag + (yTypeAnn, yFieldAnn) = gGetAnnotation @y followEntrypointFlag generateAnnFlag + in case (followEntrypointFlag, generateAnnFlag) of + (NotFollowEntrypoint, GenerateFieldAnn) -> + ( NTOr noAnn + xFieldAnn yFieldAnn + xTypeAnn yTypeAnn + , noAnn + ) + _ -> + ( NTOr noAnn + noAnn noAnn + xTypeAnn yTypeAnn + , noAnn + ) + instance ( GHasAnnotation x , GHasAnnotation y @@ -173,9 +197,9 @@ => GHasAnnotation (x G.:*: y) where - gGetAnnotation b = - let (xTypeAnn, xFieldAnn) = gGetAnnotation @x b - (yTypeAnn, yFieldAnn) = gGetAnnotation @y b + gGetAnnotation _ b2 = + let (xTypeAnn, xFieldAnn) = gGetAnnotation @x NotFollowEntrypoint b2 + (yTypeAnn, yFieldAnn) = gGetAnnotation @y NotFollowEntrypoint b2 in ( NTPair noAnn xFieldAnn yFieldAnn @@ -184,4 +208,4 @@ ) instance (HasAnnotation x) => GHasAnnotation (G.Rec0 x) where - gGetAnnotation _ = (getAnnotation @x, noAnn) + gGetAnnotation b _ = (getAnnotation @x b, noAnn) diff --git a/src/Lorentz/ContractRegistry.hs b/src/Lorentz/ContractRegistry.hs --- a/src/Lorentz/ContractRegistry.hs +++ b/src/Lorentz/ContractRegistry.hs @@ -3,8 +3,8 @@ -- SPDX-License-Identifier: LicenseRef-MIT-TQ -- | This module contains various datatypes and functions which are --- common for contract registry packages (e.g. @morley-ledgers@ and --- @morley-multisig@). +-- common for contract registry packages (e.g. +-- [morley-ledgers](https://gitlab.com/morley-framework/morley-ledgers/)). module Lorentz.ContractRegistry ( -- * Registry types diff --git a/src/Lorentz/Doc.hs b/src/Lorentz/Doc.hs --- a/src/Lorentz/Doc.hs +++ b/src/Lorentz/Doc.hs @@ -18,11 +18,14 @@ -- * Re-exports , Markdown + , DocElem(..) , DocItem (..) , docItemPosition , DocItemId (..) , DocItemPlacementKind (..) + , DocItemPos(..) , DocItemRef (..) + , DocSection(..) , DocSectionNameStyle (..) , SomeDocItem (..) , SomeDocDefinitionItem (..) @@ -30,6 +33,8 @@ , DocGrouping , ContractDoc (..) , DDescription (..) + , DEntrypointExample (..) + , mkDEntrypointExample , DGitRevision (..) , GitRepoSettings (..) , mkDGitRevision @@ -61,15 +66,19 @@ , homomorphicTypeDocMichelsonRep , concreteTypeDocMichelsonRep , concreteTypeDocMichelsonRepUnsafe + , mdTocFromRef ) where import Data.Singletons (demote) +import Fmt (build) import Lorentz.Base +import Lorentz.Constraints import Lorentz.Value import Lorentz.Zip () import Michelson.Doc import Michelson.Optimizer +import Michelson.Printer import Michelson.Typed import Util.Markdown import Util.Type @@ -106,7 +115,9 @@ -- Currently we only include git revision. It is unknown in the -- library code and is supposed to be updated in an executable. contractGeneralDefault :: s :-> s -contractGeneralDefault = contractGeneral $ doc DGitRevisionUnknown +contractGeneralDefault = + (contractGeneral $ doc DGitRevisionUnknown) # + doc (DToc "") buildLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> ContractDoc buildLorentzDocWithGitRev gitRev (iAnyCode -> code) = @@ -163,3 +174,17 @@ ( Just "Code [Integer, Natural, MText, ()] [ByteString]" , demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString])) ) + +-- | Modify the example value of an entrypoint +data DEntrypointExample = forall t . ParameterScope t => DEntrypointExample (Value t) + +instance DocItem DEntrypointExample where + docItemPos = 10000 + docItemSectionName = Nothing + docItemToMarkdown _ (DEntrypointExample val) = + build $ printUntypedValue True $ untypeValue val + +mkDEntrypointExample :: forall a. NiceParameter a => a -> DEntrypointExample +mkDEntrypointExample v = + withDict (niceParameterEvi @a) $ + DEntrypointExample $ toVal v diff --git a/src/Lorentz/Entrypoints.hs b/src/Lorentz/Entrypoints.hs --- a/src/Lorentz/Entrypoints.hs +++ b/src/Lorentz/Entrypoints.hs @@ -40,6 +40,7 @@ , EpdPlain , EpdRecursive , EpdDelegate + , EpdWithRoot -- * Behaviour modifiers , ParameterWrapper (..) diff --git a/src/Lorentz/Entrypoints/Core.hs b/src/Lorentz/Entrypoints/Core.hs --- a/src/Lorentz/Entrypoints/Core.hs +++ b/src/Lorentz/Entrypoints/Core.hs @@ -61,7 +61,7 @@ import Util.Type import Util.TypeLits -import Lorentz.Annotation (HasAnnotation, getAnnotation) +import Lorentz.Annotation (FollowEntrypointFlag(..), HasAnnotation, getAnnotation) import Lorentz.Constraints.Scopes import Lorentz.Entrypoints.Helpers @@ -95,9 +95,7 @@ -- -- This method is implementation detail, for actual notes construction -- use 'parameterEntrypointsToNotes'. - -- - -- TODO [#35]: Should also return field annotation - epdNotes :: Notes (ToT cp) + epdNotes :: (Notes (ToT cp), U.RootAnn) -- | Construct entrypoint caller. -- @@ -189,7 +187,7 @@ -- | 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 :: forall cp. ParameterDeclaresEntrypoints cp => (Notes (ToT cp), U.RootAnn) pepNotes = epdNotes @(GetParameterEpDerivation cp) @cp -- | Version of 'epdCall' which we actually use in code. @@ -258,8 +256,8 @@ :: forall cp. ParameterDeclaresEntrypoints cp => ParamNotes (ToT cp) parameterEntrypointsToNotes = - let notes = pepNotes @cp - in case mkParamNotes notes U.noAnn of + let (notes, ra) = pepNotes @cp + in case mkParamNotes notes ra of -- Normally this should be valid because -- 1. Constraint in superclass of 'ParameterHasEntrypoints' ensures that -- no entrypoint is duplicated. @@ -494,6 +492,6 @@ instance (HasAnnotation cp) => EntrypointsDerivation EpdNone cp where type EpdAllEntrypoints EpdNone cp = '[] type EpdLookupEntrypoint EpdNone cp = Fcf.ConstFn 'Nothing - epdNotes = getAnnotation @cp + epdNotes = (getAnnotation @cp FollowEntrypoint, U.noAnn) epdCall _ = EpConstructionFailed epdDescs = RNil diff --git a/src/Lorentz/Entrypoints/Doc.hs b/src/Lorentz/Entrypoints/Doc.hs --- a/src/Lorentz/Entrypoints/Doc.hs +++ b/src/Lorentz/Entrypoints/Doc.hs @@ -38,8 +38,10 @@ import Data.Char (toLower) import Data.Constraint (Dict(..)) import qualified Data.Kind as Kind +import qualified Data.Map as Map +import qualified Data.Text as T import Data.Vinyl.Core (RMap, rappend) -import Fmt (Buildable(..), listF) +import Fmt (Buildable(..), build, fmt, listF) import GHC.Generics ((:+:)) import qualified GHC.Generics as G import qualified Text.Show @@ -52,8 +54,9 @@ import Lorentz.Entrypoints.Core import Lorentz.Entrypoints.Helpers import Lorentz.Entrypoints.Impl +import Michelson.Printer (printUntypedValue) import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB) -import Michelson.Typed (pattern DefEpName, EpName, mkUType) +import Michelson.Typed (pattern DefEpName, EpName, mkUType, sampleValueFromUntype) import Michelson.Typed.Doc import Michelson.Typed.Haskell.Doc import Michelson.Typed.Haskell.Instr @@ -82,15 +85,58 @@ diEntrypointToMarkdown lvl (DEntrypoint name block) = mdSeparator <> mdHeader lvl (mdTicked . build . over _head toLower $ name) <> - subDocToMarkdown (nextHeaderLevel lvl) block + ( modifyExample block + $ subDocToMarkdown (nextHeaderLevel lvl) + $ filterDEntrypointExample block + ) + where + filterDEntrypointExample (SubDoc subdoc) = + SubDoc $ Map.delete (docItemPosition @DEntrypointExample) subdoc + -- | Modify 'SubDoc' of an entrypoint to replace its example value with the one defined in + -- 'DEntrypointExample' in an ad-hoc way. + modifyExample :: SubDoc -> Markdown -> Markdown + modifyExample (SubDoc sub) subDocMd = + case (Map.lookup (docItemPosition @DEntrypointExample) sub) of + Just (DocSection ((DocElem b _ ) :| _)) -> + mdFindExampleIdAndReplace + (docItemToMarkdown (HeaderLevel 0) $ b) + subDocMd + Nothing -> subDocMd + + mdFindExampleIdAndReplace :: Markdown -> Markdown -> Markdown + mdFindExampleIdAndReplace replaceTxt inputText = + build + $ unlines + $ (\w -> case T.isInfixOf ("id=\"" <> (fmt @Text exampleId) <> "\"") w of + True -> fmt @Text $ " + " <> + mdSubsection "Example" (mdAddId exampleId $ mdTicked replaceTxt) + False -> w + ) + <$> lines (fmt @Text inputText) + where + exampleId = "example-id" + -- | Default value for 'DEntrypoint' type argument. data PlainEntrypointsKind +instance Show (DEntrypoint PlainEntrypointsKind) where + show (DEntrypoint name _) = show name +instance Eq (DEntrypoint PlainEntrypointsKind) where + (DEntrypoint a1 _) == (DEntrypoint a2 _) = a1 == a2 +instance Ord (DEntrypoint PlainEntrypointsKind) where + (DEntrypoint a1 _) `compare` (DEntrypoint a2 _) = a1 `compare` a2 + instance DocItem (DEntrypoint PlainEntrypointsKind) where + type DocItemPlacement (DEntrypoint PlainEntrypointsKind) = 'DocItemInlined + type DocItemReferenced (DEntrypoint PlainEntrypointsKind) = 'True + docItemRef (DEntrypoint name _) = DocItemRefInlined $ + DocItemId ("entrypoints-" <> (over _head toLower $ name)) docItemPos = 1000 docItemSectionName = Just "Entrypoints" docItemToMarkdown = diEntrypointToMarkdown + docItemToToc lvl d@(DEntrypoint name _) = + mdTocFromRef lvl (build . over _head toLower $ name) d data DEntrypointReference = DEntrypointReference Text Anchor @@ -216,7 +262,7 @@ } mkDEpUType :: forall t. (KnownValue t, HasAnnotation t) => Untyped.Type -mkDEpUType = mkUType (getAnnotation @t) +mkDEpUType = mkUType (getAnnotation @t FollowEntrypoint) mkDEntrypointArgSimple :: forall t. @@ -266,6 +312,13 @@ , " + " <> mdSubsection "In Michelson" (mdTicked $ printDocB False . renderDoc needsParens $ et) + , " + " <> + mdSubsection "Example" + (mdAddId "example-id" + $ mdTicked + $ build $ printUntypedValue True + $ sampleValueFromUntype et + ) ], mdSpoiler "How to call this entrypoint" $ "\n0. Construct an argument for the entrypoint.\n" <> @@ -561,3 +614,11 @@ 'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`" ':$$: 'Text "With entrypoints derivation way `" ':<>: 'ShowType deriv ':<>: 'Text "`" ) + +--------------------------- +-- Helper +--------------------------- + +-- | Surrouned a markdown text in a span tag with given id. +mdAddId :: Markdown -> Markdown -> Markdown +mdAddId idTxt txt = " idTxt <> "\">" <> txt <> "" diff --git a/src/Lorentz/Entrypoints/Impl.hs b/src/Lorentz/Entrypoints/Impl.hs --- a/src/Lorentz/Entrypoints/Impl.hs +++ b/src/Lorentz/Entrypoints/Impl.hs @@ -8,6 +8,7 @@ EpdPlain , EpdRecursive , EpdDelegate + , EpdWithRoot -- * Implementation details , PlainEntrypointsC @@ -28,7 +29,7 @@ import Lorentz.Value import Michelson.Typed import Michelson.Typed.Haskell.Value (GValueType) -import Michelson.Untyped (FieldAnn, noAnn) +import Michelson.Untyped (FieldAnn, ann, noAnn) import Util.Fcf (type (<|>), Over2, TyEqSing) import Util.Type @@ -48,7 +49,7 @@ 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 + epdNotes = (plainEpdNotesExt @EpdPlain @cp, noAnn) epdCall = plainEpdCallExt @EpdPlain @cp epdDescs = plainEpdDescsExt @EpdPlain @cp @@ -69,7 +70,7 @@ 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 + epdNotes = (plainEpdNotesExt @EpdRecursive @cp, noAnn) epdCall = plainEpdCallExt @EpdRecursive @cp epdDescs = plainEpdDescsExt @EpdRecursive @cp @@ -92,10 +93,34 @@ 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 + epdNotes = (plainEpdNotesExt @EpdDelegate @cp, noAnn) epdCall = plainEpdCallExt @EpdDelegate @cp epdDescs = plainEpdDescsExt @EpdDelegate @cp +-- | Extension of 'EpdPlain', 'EpdRecursive', and 'EpdDelegate' which allow specifying root annotation +-- for the parameters. +data EpdWithRoot (r :: Symbol) epd +instance (KnownSymbol r, PlainEntrypointsC deriv cp) => EntrypointsDerivation (EpdWithRoot r deriv) cp where + type EpdAllEntrypoints (EpdWithRoot r deriv) cp = + '(r, cp) ': PlainAllEntrypointsExt deriv cp + type EpdLookupEntrypoint (EpdWithRoot r deriv) cp = + Fcf.Case + '[ Fcf.Is (TyEqSing r) ('Just cp) + , Fcf.Else (PlainLookupEntrypointExt deriv cp) + ] + epdNotes = (plainEpdNotesExt @deriv @cp, ann (symbolValT' @r)) + epdCall label@(Label :: Label name) = case sing @r %== sing @name of + STrue -> EpConstructed EplArgHere + SFalse -> plainEpdCallExt @deriv @cp label + epdDescs = + (addDescStep @r $ + EpCallingDesc + { epcdArg = Proxy + , epcdEntrypoint = ctorNameToEp @r + , epcdSteps = [] + } :& RNil + ) <+> plainEpdDescsExt @deriv @cp + type PlainAllEntrypointsExt mode cp = AllEntrypoints mode (BuildEPTree mode cp) cp type PlainLookupEntrypointExt mode cp = LookupEntrypoint mode (BuildEPTree mode cp) cp @@ -257,7 +282,7 @@ type GLookupEntrypoint mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) = JustOnEq ctor (GExtractField x) gMkEntrypointsNotes = - (fst $ gGetAnnotation @x False, ctorNameToAnn @ctor) + (fst $ gGetAnnotation @x FollowEntrypoint NotGenerateFieldAnn, ctorNameToAnn @ctor) gMkEpLiftSequence (Label :: Label name) = case sing @ctor %== sing @name of STrue -> EpConstructed EplArgHere @@ -320,8 +345,7 @@ 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' + gMkEntrypointsNotes = (fst (pepNotes @a), noAnn) gMkEpLiftSequence = pepCall @a gMkDescs = pepDescs @a diff --git a/src/Lorentz/Errors.hs b/src/Lorentz/Errors.hs --- a/src/Lorentz/Errors.hs +++ b/src/Lorentz/Errors.hs @@ -10,6 +10,7 @@ module Lorentz.Errors ( -- * Haskell to 'Value' conversion IsError (..) + , ErrorScope , isoErrorToVal , isoErrorFromVal , ErrorHasDoc (..) @@ -513,6 +514,8 @@ instance DocItem DError where type DocItemPlacement DError = 'DocItemInDefinitions + type DocItemReferenced DError = 'True + docItemPos = 5010 docItemSectionName = Just "Errors" docItemSectionDescription = Just errorsDocumentation @@ -528,6 +531,9 @@ , "\n\n" , mdSubsection "Representation" $ errorDocHaskellRep @e ] + docItemToToc lvl d@(DError (_ :: Proxy e)) = + mdTocFromRef lvl (build $ errorDocName @e) d + docItemDependencies (DError (_ :: Proxy e)) = errorDocDependencies @e errorDocMdReference :: forall e. ErrorHasDoc e => Markdown diff --git a/src/Lorentz/Errors/Numeric/Contract.hs b/src/Lorentz/Errors/Numeric/Contract.hs --- a/src/Lorentz/Errors/Numeric/Contract.hs +++ b/src/Lorentz/Errors/Numeric/Contract.hs @@ -27,6 +27,7 @@ , useNumericErrors , errorFromValNumeric + , errorToValNumeric ) where import Data.Bimap (Bimap) @@ -168,10 +169,30 @@ VNat tag | Just textualTag <- Bimap.lookup tag errorTagMap -> errorFromVal $ VString textualTag - VPair (VNat tag, something) - | Just textualTag <- Bimap.lookup tag errorTagMap - , _ :: Value pair <- v -> + (VPair (VNat tag, something) :: Value pair) + | Just textualTag <- Bimap.lookup tag errorTagMap -> case sing @pair of STPair {} -> errorFromVal $ VPair (VString textualTag, something) _ -> errorFromVal v + +-- | If you apply numeric error representation in your contract, 'errorToVal' +-- will stop working because it doesn't know about this +-- transformation. +-- This function takes this transformation into account. +-- If a string is used as a tag, but it is not found in the passed +-- map, we conservatively preserve that string (because this whole +-- approach is rather a heuristic). +errorToValNumeric :: + IsError e => ErrorTagMap -> e -> (forall t. ErrorScope t => Value t -> r) -> r +errorToValNumeric errorTagMap e cont = + errorToVal e $ \case + VString textualTag + | Just tag <- Bimap.lookupR textualTag errorTagMap -> cont (VNat tag) + + (VPair (VString textualTag, something) :: Value pair) + | Just tag <- Bimap.lookupR textualTag errorTagMap -> + case sing @pair of + STPair {} -> + cont (VPair (VNat tag, something)) + v -> cont v diff --git a/src/Lorentz/Errors/Numeric/Doc.hs b/src/Lorentz/Errors/Numeric/Doc.hs --- a/src/Lorentz/Errors/Numeric/Doc.hs +++ b/src/Lorentz/Errors/Numeric/Doc.hs @@ -43,6 +43,7 @@ instance DocItem DDescribeErrorTagMap where type DocItemPlacement DDescribeErrorTagMap = 'DocItemInDefinitions + type DocItemReferenced DDescribeErrorTagMap = 'True docItemPos = 4090 docItemSectionName = Just "About error tags mapping" docItemRef DDescribeErrorTagMap{..} = DocItemRef $ diff --git a/src/Lorentz/Instr.hs b/src/Lorentz/Instr.hs --- a/src/Lorentz/Instr.hs +++ b/src/Lorentz/Instr.hs @@ -125,7 +125,7 @@ import Michelson.Typed (pattern CAR, pattern CDR, CommentType(..), ConstraintDIG, ConstraintDIG', ConstraintDIPN, ConstraintDIPN', ConstraintDUG, ConstraintDUG', EntrypointCallT(..), ExtInstr(..), Instr(..), - RemFail(..), SomeEntrypointCallT(..), Value'(..), sepcName, starNotes) + RemFail(..), pattern PAIR, SomeEntrypointCallT(..), Value'(..), sepcName, starNotes) import Michelson.Typed.Arith import Michelson.Typed.Haskell.Value import Util.Peano diff --git a/src/Lorentz/Pack.hs b/src/Lorentz/Pack.hs --- a/src/Lorentz/Pack.hs +++ b/src/Lorentz/Pack.hs @@ -7,14 +7,19 @@ ( lPackValue , lUnpackValue , lEncodeValue + , valueToScriptExpr + , expressionToScriptExpr ) where +import qualified Data.ByteString as BS import Data.Constraint ((\\)) import Lorentz.Constraints import Michelson.Interpret.Pack import Michelson.Interpret.Unpack import Michelson.Typed +import Morley.Micheline (Expression, encodeExpression) +import Tezos.Crypto (blake2b) lPackValue :: forall a. @@ -34,3 +39,25 @@ :: forall a. (NicePrintedValue a) => a -> ByteString lEncodeValue = encodeValue' . toVal \\ nicePrintedValueEvi @a + +-- | This function transforms Lorentz values into @script_expr@. +-- +-- @script_expr@ is used in RPC as an argument in entrypoint +-- designed for getting value by key from the big_map in Babylon. +-- In order to convert value to the @script_expr@ we have to pack it, +-- take blake2b hash and add specific @expr@ prefix. Take a look at +-- +-- and +-- for more information. +valueToScriptExpr + :: forall t. (NicePackedValue t) + => t -> ByteString +valueToScriptExpr = addScriptExprPrefix . blake2b . lPackValue + +-- | Similar to 'valueToScriptExpr', but for values encoded as 'Expression's. +-- This is only used in tests. +expressionToScriptExpr :: Expression -> ByteString +expressionToScriptExpr = addScriptExprPrefix . blake2b . mappend packValuePrefix . encodeExpression + +addScriptExprPrefix :: ByteString -> ByteString +addScriptExprPrefix = (BS.pack [0x0D, 0x2C, 0x40, 0x1B] <>) diff --git a/src/Lorentz/Run.hs b/src/Lorentz/Run.hs --- a/src/Lorentz/Run.hs +++ b/src/Lorentz/Run.hs @@ -113,7 +113,7 @@ else -- Perform CAST otherwise. compileLorentzWithOptions cCompilationOptions (I CAST # cCode :: ContractCode cp st) , cParamNotes = cpNotes - , cStoreNotes = getAnnotation @st + , cStoreNotes = getAnnotation @st NotFollowEntrypoint , cEntriesOrder = U.canonicalEntriesOrder } \\ niceParameterEvi @cp \\ niceStorageEvi @st diff --git a/src/Lorentz/UStore/Doc.hs b/src/Lorentz/UStore/Doc.hs --- a/src/Lorentz/UStore/Doc.hs +++ b/src/Lorentz/UStore/Doc.hs @@ -97,6 +97,7 @@ instance DocItem DUStoreTemplate where type DocItemPlacement DUStoreTemplate = 'DocItemInDefinitions + type DocItemReferenced DUStoreTemplate = 'True docItemPos = 12700 docItemSectionName = Just "Used upgradeable storage formats" diff --git a/src/Lorentz/Zip.hs b/src/Lorentz/Zip.hs --- a/src/Lorentz/Zip.hs +++ b/src/Lorentz/Zip.hs @@ -85,6 +85,6 @@ => HasAnnotation (i :-> o) where - getAnnotation = NTLambda noAnn - (getAnnotation @(ZippedStack i)) - (getAnnotation @(ZippedStack o)) + getAnnotation b = NTLambda noAnn + (getAnnotation @(ZippedStack i) b) + (getAnnotation @(ZippedStack o) b)