lorentz 0.5.0 → 0.6.0

raw patch · 19 files changed

+288/−85 lines, 19 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.md +15/−0
• README.md +3/−4
• lorentz.cabal +2/−2
• src/Lorentz/Address.hs +1/−1
• src/Lorentz/Annotation.hs +72/−48
• src/Lorentz/ContractRegistry.hs +2/−2
• src/Lorentz/Doc.hs +26/−1
• src/Lorentz/Entrypoints.hs +1/−0
• src/Lorentz/Entrypoints/Core.hs +6/−8
• src/Lorentz/Entrypoints/Doc.hs +65/−4
• src/Lorentz/Entrypoints/Impl.hs +31/−7
• src/Lorentz/Errors.hs +6/−0
• src/Lorentz/Errors/Numeric/Contract.hs +24/−3
• src/Lorentz/Errors/Numeric/Doc.hs +1/−0
• src/Lorentz/Instr.hs +1/−1
• src/Lorentz/Pack.hs +27/−0
• src/Lorentz/Run.hs +1/−1
• src/Lorentz/UStore/Doc.hs +1/−0
• src/Lorentz/Zip.hs +3/−3

@@ -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)

@@ -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).  <a name="lorentz-example"></a> ## Sample smart contract written in Lorentz

@@ -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

@@ -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. --

@@ -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)

@@ -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

@@ -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

@@ -40,6 +40,7 @@   , EpdPlain   , EpdRecursive   , EpdDelegate+  , EpdWithRoot      -- * Behaviour modifiers   , ParameterWrapper (..)

@@ -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

@@ -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 = "<span id=\"" <> idTxt <> "\">" <> txt <> "</span>"

@@ -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 

@@ -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

@@ -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

@@ -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 $

@@ -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

@@ -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+-- <https://gitlab.com/tezos/tezos/blob/6e25ae8eb385d9975a30388c7a7aa2a9a65bf184/src/proto_005_PsBabyM1/lib_protocol/script_expr_hash.ml>+-- and <https://gitlab.com/tezos/tezos/blob/6e25ae8eb385d9975a30388c7a7aa2a9a65bf184/src/proto_005_PsBabyM1/lib_protocol/contract_services.ml#L136>+-- 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] <>)

@@ -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

@@ -97,6 +97,7 @@  instance DocItem DUStoreTemplate where   type DocItemPlacement DUStoreTemplate = 'DocItemInDefinitions+  type DocItemReferenced DUStoreTemplate = 'True    docItemPos = 12700   docItemSectionName = Just "Used upgradeable storage formats"

@@ -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)