lorentz 0.6.1 → 0.6.2

raw patch · 5 files changed

+94/−27 lines, 5 filesdep +text-manipulatePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: text-manipulate

API changes (from Hackage documentation)

Files

• CHANGES.md +9/−1
• lorentz.cabal +3/−4
• src/Lorentz/Annotation.hs +74/−19
• src/Lorentz/Entrypoints/Impl.hs +1/−1
• src/Lorentz/Macro.hs +7/−2

@@ -1,3 +1,12 @@+0.6.2+=====+* [!589](https://gitlab.com/morley-framework/morley/-/merge_requests/589)+  Add `annOptions` method in `HasAnnotation` which can be used to customize+  the generated annotations of a type.+  + Add helper functions to use with `annOptions`.+* [!591](https://gitlab.com/morley-framework/morley/-/merge_requests/591)+  Add `dupTop2`.+ 0.6.1 ===== * [!533](https://gitlab.com/morley-framework/morley/-/merge_requests/533)@@ -6,7 +15,6 @@  0.6.0 =====-<!-- Append new entries here --> * [!558](https://gitlab.com/morley-framework/morley/-/merge_requests/558)   Added a new `wrapOne` to wrap a value in a constructor with a single field,   because it has the advantage of having an input stack that does not depend on

@@ -1,13 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack------ hash: ab7ab680d9da4f86c259fce26537c6a0ef35fb4cefd1183adc942dec4efc3fa1  name:           lorentz-version:        0.6.1+version:        0.6.2 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@@ -116,6 +114,7 @@     , singletons     , template-haskell     , text+    , text-manipulate     , unordered-containers     , vinyl     , with-utf8

@@ -6,18 +6,30 @@  -- | Type and field annotations for Lorentz types. module Lorentz.Annotation-  ( FollowEntrypointFlag (..)+  ( AnnOptions (..)+  , defaultAnnOptions+  , dropPrefixThen+  , appendTo+  , toCamel+  , toPascal+  , toSnake++  , ctorNameToAnnWithOptions+  , FollowEntrypointFlag (..)   , GenerateFieldAnnFlag (..)+   , HasAnnotation (..)   , GHasAnnotation (..)   , gGetAnnotationNoField   , insertTypeAnn   ) where +import Data.Char (isUpper)+import qualified Data.Text as T+import Data.Text.Manipulate (toCamel, toPascal, toSnake) import qualified GHC.Generics as G import Named (NamedF) -import Lorentz.Entrypoints.Helpers (ctorNameToAnn) import Michelson.Text import Michelson.Typed   (BigMap, ContractRef(..), EpAddress, KnownIsoT, Notes(..), Operation, ToT, insertTypeAnn,@@ -27,8 +39,44 @@ import Tezos.Address import Tezos.Core import Tezos.Crypto+import Util.Text import Util.TypeLits +----------------------------------------------------------------------------+-- Annotation Customization+----------------------------------------------------------------------------++-- | Allow customization of field annotation generated for a type+-- when declaring its 'HasAnnotation' instance.+data AnnOptions = AnnOptions+  { fieldAnnModifier :: Text -> Text+  }++defaultAnnOptions :: AnnOptions+defaultAnnOptions = AnnOptions id++-- | Drops the field name prefix from a field.+-- We assume a convention of the prefix always being lower case,+-- and the first letter of the actual field name being uppercase.+-- It also accepts another function which will be applied directly+-- after dropping the prefix.+dropPrefixThen :: (Text -> Text) -> Text -> Text+dropPrefixThen f = f . T.dropWhile (Prelude.not . isUpper)++-- | @appendTo suffix fields field@ appends the given suffix to @field@+-- if the field exists in the @fields@ list.+appendTo :: Text -> [Text] -> Text -> Text+appendTo suffix fields field+  | field `elem` fields = field <> suffix+  | otherwise = field++----------------------------------------------------------------------------+-- Typeclasses related to Annotaiton Generation+----------------------------------------------------------------------------++ctorNameToAnnWithOptions :: forall ctor. (KnownSymbol ctor, HasCallStack) => AnnOptions -> FieldAnn+ctorNameToAnnWithOptions o = ann . fieldAnnModifier o $ headToLower $ (symbolValT' @ctor)+ -- | Used in `GHasAnnotation` and `HasAnnotation` as a flag to track -- whether or not it directly follows an entrypoint to avoid introducing -- extra entrypoints.@@ -43,7 +91,7 @@ gGetAnnotationNoField     :: forall a. (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a)     => FollowEntrypointFlag -> Notes (ToT a)-gGetAnnotationNoField = \_ -> fst $ gGetAnnotation @(G.Rep a) NotFollowEntrypoint NotGenerateFieldAnn+gGetAnnotationNoField = \_ -> fst $ gGetAnnotation @(G.Rep a) defaultAnnOptions 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@@ -54,8 +102,12 @@     :: (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a)     => FollowEntrypointFlag     -> Notes (ToT a)-  getAnnotation b = fst $ gGetAnnotation @(G.Rep a) b GenerateFieldAnn+  getAnnotation b = fst $ gGetAnnotation @(G.Rep a) (annOptions @a) b GenerateFieldAnn +  annOptions :: AnnOptions+  default annOptions :: AnnOptions+  annOptions = defaultAnnOptions+ instance (HasAnnotation a, KnownSymbol name)   => HasAnnotation (NamedF Identity a name) where   getAnnotation b = insertTypeAnn (symbolAnn @name) $@@ -142,28 +194,31 @@  -- | A Generic @HasAnnotation@ implementation class GHasAnnotation a where-  gGetAnnotation :: FollowEntrypointFlag -> GenerateFieldAnnFlag -> (Notes (GValueType a), FieldAnn)+  gGetAnnotation :: AnnOptions -> 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 b2 = gGetAnnotation @x b b2+  gGetAnnotation o b b2 = gGetAnnotation @x o b b2  instance (GHasAnnotation x, KnownSymbol a)   => GHasAnnotation (G.M1 G.S ('G.MetaSel ('Just a) b c d) x)   where-  gGetAnnotation b b2 = case b2 of-    GenerateFieldAnn -> (fst $ gGetAnnotation @x b b2, ctorNameToAnn @a)-    NotGenerateFieldAnn -> (fst $ gGetAnnotation @x b b2, noAnn)+  gGetAnnotation o b b2 = case b2 of+    GenerateFieldAnn -> (fst $ gGetAnnotation @x o b b2, ctorNameToAnnWithOptions @a o)+    NotGenerateFieldAnn -> (fst $ gGetAnnotation @x o b b2, noAnn)  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)+  gGetAnnotation o b b2 =+    ( fst $ gGetAnnotation @x o b b2+    , ctorNameToAnnWithOptions @a o+    )  instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.D i1 x) where-  gGetAnnotation b b2 = gGetAnnotation @x b b2+  gGetAnnotation o b b2 = gGetAnnotation @x o b b2  instance     ( GHasAnnotation x@@ -173,9 +228,9 @@     GHasAnnotation (x G.:+: y)   where -  gGetAnnotation followEntrypointFlag generateAnnFlag =-    let (xTypeAnn, xFieldAnn) = gGetAnnotation @x followEntrypointFlag generateAnnFlag-        (yTypeAnn, yFieldAnn) = gGetAnnotation @y followEntrypointFlag generateAnnFlag+  gGetAnnotation o followEntrypointFlag generateAnnFlag =+    let (xTypeAnn, xFieldAnn) = gGetAnnotation @x o followEntrypointFlag generateAnnFlag+        (yTypeAnn, yFieldAnn) = gGetAnnotation @y o followEntrypointFlag generateAnnFlag     in case (followEntrypointFlag, generateAnnFlag) of           (NotFollowEntrypoint, GenerateFieldAnn) ->             ( NTOr noAnn@@ -197,9 +252,9 @@   =>     GHasAnnotation (x G.:*: y)   where-  gGetAnnotation _ b2 =-    let  (xTypeAnn, xFieldAnn) = gGetAnnotation @x NotFollowEntrypoint b2-         (yTypeAnn, yFieldAnn) = gGetAnnotation @y NotFollowEntrypoint b2+  gGetAnnotation o _ b2 =+    let  (xTypeAnn, xFieldAnn) = gGetAnnotation @x o NotFollowEntrypoint b2+         (yTypeAnn, yFieldAnn) = gGetAnnotation @y o NotFollowEntrypoint b2     in       ( NTPair noAnn           xFieldAnn yFieldAnn@@ -208,4 +263,4 @@       )  instance (HasAnnotation x) => GHasAnnotation (G.Rec0 x) where-  gGetAnnotation b _ = (getAnnotation @x b, noAnn)+  gGetAnnotation _ b _ = (getAnnotation @x b, noAnn)

@@ -282,7 +282,7 @@   type GLookupEntrypoint mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =     JustOnEq ctor (GExtractField x)   gMkEntrypointsNotes =-    (fst $ gGetAnnotation @x FollowEntrypoint NotGenerateFieldAnn, ctorNameToAnn @ctor)+    (fst $ gGetAnnotation @x defaultAnnOptions FollowEntrypoint NotGenerateFieldAnn, ctorNameToAnn @ctor)   gMkEpLiftSequence (Label :: Label name) =     case sing @ctor %== sing @name of       STrue -> EpConstructed EplArgHere

@@ -107,6 +107,7 @@   , wrapVoid   , unwrapVoid   , voidResultTag+  , dupTop2    -- * Buildable utils for additional Morley macros   , buildView@@ -115,8 +116,6 @@   -- * Macros for working with @address@ and @contract@-like types   , addressToEpAddress   , pushContractRef--   ) where  import Prelude hiding (compare, drop, some, swap)@@ -837,3 +836,9 @@   withDict (niceParameterEvi @arg) $     push (FutureContract contractRef) # dup #     runFutureContract # ifNone onContractNotFound (dip drop)++-- | Duplicate two topmost items on top of the stack.+dupTop2 ::+  forall (a :: Kind.Type) (b :: Kind.Type) (s :: [Kind.Type]).+  a ': b ': s :-> a ': b ': a ': b ': s+dupTop2 = duupX @2 # duupX @2