packages feed

lorentz 0.13.0 → 0.13.1

raw patch · 24 files changed

+795/−191 lines, 24 files

Files

CHANGES.md view
@@ -1,5 +1,21 @@ <!-- Unreleased: append new entries here --> +0.13.1+======+* [!1016](https://gitlab.com/morley-framework/morley/-/merge_requests/1016)+  + Add support for on-chain views.+  + `Contract`, `TAddress` and similar types has gained a new type argument+    designating the views set exposed by the contract. By default, set it to `()`.+  + The old A1 (aka TZIP-4) views - `View` type and related methods - were renamed+    via adding a `_` suffix: `View_`, `mkView_`, `wrapView_`, e.t.c.+* [!1010](https://gitlab.com/morley-framework/morley/-/merge_requests/1010)+  Add timelock puzzle support.+  + Add Lorentz instruction `openChest`.+  + Add `OpenChest` type, isomorphic to `Either ByteString Bool`+  + Add Lorentz types `ChestT`, `OpenChestT`, abstracting working with any+  type representable as `ByteString` (defined in `Lorentz.Bytes`).+  + Add `openChestT` Lorentz instruction for working with `ChestT` (defined in+  `Lorentz.Bytes`)  0.13.0 ======
lorentz.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           lorentz-version:        0.13.0+version:        0.13.1 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@@ -77,6 +77,7 @@       Lorentz.UParam       Lorentz.Util.TH       Lorentz.Value+      Lorentz.ViewBase       Lorentz.Wrappable       Lorentz.Zip   other-modules:@@ -118,6 +119,7 @@       PatternSynonyms       PolyKinds       QuasiQuotes+      QuantifiedConstraints       RankNTypes       RecordWildCards       RecursiveDo
src/Lorentz.hs view
@@ -7,6 +7,7 @@   ) where  import Lorentz.ADT as Exports+import Lorentz.Address as Exports import Lorentz.Annotation as Exports import Lorentz.Arith as Exports import Lorentz.Base as Exports@@ -41,4 +42,5 @@ import Lorentz.UParam as Exports import Lorentz.Util.TH as Exports import Lorentz.Value as Exports+import Lorentz.ViewBase as Exports import Lorentz.Zip as Exports ()
src/Lorentz/Address.hs view
@@ -33,6 +33,8 @@   , FutureContract (..)      -- ** Conversions+  , asAddressOf+  , asAddressOf_   , callingAddress   , callingDefAddress   , callingTAddress@@ -66,66 +68,74 @@ import Morley.Util.Type import Morley.Util.TypeLits --- | Address which remembers the parameter type of the contract it refers to.+-- | Address which remembers the parameter and views types 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 :: Type) = TAddress { unTAddress :: Address }+newtype TAddress (p :: Type) (vd :: Type) = TAddress { unTAddress :: Address }   deriving stock (Generic, Show)   deriving newtype (Eq, Ord, Buildable)   deriving anyclass (IsoValue, HasAnnotation) +-- | For a contract and an address of its instance, construct a typed address.+asAddressOf :: contract cp st vd -> Address -> TAddress cp vd+asAddressOf _ = TAddress++asAddressOf_ :: contract cp st vd -> Address : s :-> TAddress cp vd : s+asAddressOf_ _ = I M.Nop+ -- | 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.+  :: forall cp vd mname.      (NiceParameterFull cp)-  => TAddress cp+  => TAddress cp vd   -> Ep.EntrypointRef mname   -> ContractRef (Ep.GetEntrypointArgCustom cp mname)-callingTAddress = callingAddress+callingTAddress = callingAddress @cp @vd {-# DEPRECATED callingTAddress "Use `callingAddress`" #-}  -- | Specification of 'callingTAddress' to call the default entrypoint. callingDefTAddress-  :: forall cp.+  :: forall cp vd.      (NiceParameterFull cp)-  => TAddress cp+  => TAddress cp vd   -> ContractRef (Ep.GetDefaultEntrypointArg cp) callingDefTAddress taddr = callingTAddress taddr Ep.CallDefault {-# DEPRECATED callingDefTAddress "Use `callingDefAddress`" #-}  -- | Generalization of 'callingTAddress' to any typed address. callingAddress-  :: forall cp addr mname.-     (ToTAddress cp addr, NiceParameterFull cp)+  :: forall cp vd addr mname.+     (ToTAddress cp vd addr, NiceParameterFull cp)   => addr   -> Ep.EntrypointRef mname   -> ContractRef (Ep.GetEntrypointArgCustom cp mname)-callingAddress (toTAddress @cp -> TAddress addr) epRef =+callingAddress (toTAddress @cp @vd -> TAddress addr) epRef =   withDict (niceParameterEvi @cp) $   case Ep.parameterEntrypointCallCustom @cp epRef of     epc@M.EntrypointCall{} -> ContractRef addr (M.SomeEpc epc)  -- | Generalization of 'callingDefTAddress' to any typed address. callingDefAddress-  :: forall cp addr.-     (ToTAddress cp addr, NiceParameterFull cp)+  :: forall cp vd addr.+     (ToTAddress cp vd addr, NiceParameterFull cp)   => addr   -> ContractRef (Ep.GetDefaultEntrypointArg cp)-callingDefAddress addr = callingAddress @cp addr Ep.CallDefault+callingDefAddress addr = callingAddress @cp @vd addr Ep.CallDefault  -- | Something coercible to 'TAddress cp'.-type ToTAddress_ cp addr = (ToTAddress cp addr, ToT addr ~ ToT Address)+type ToTAddress_ cp vd addr = (ToTAddress cp vd addr, ToT addr ~ ToT Address)  -- | Cast something appropriate to 'TAddress'. toTAddress_-  :: forall cp addr s.-     (ToTAddress_ cp addr)-  => addr : s :-> TAddress cp : s+  :: forall cp addr vd s.+     (ToTAddress_ cp vd addr)+  => addr : s :-> TAddress cp vd : s toTAddress_ = I M.Nop  -- | Address associated with value of @contract arg@ type.@@ -164,7 +174,7 @@ instance ToAddress EpAddress where   toAddress = eaAddress -instance ToAddress (TAddress cp) where+instance ToAddress (TAddress cp vd) where   toAddress = unTAddress  instance ToAddress (FutureContract cp) where@@ -175,13 +185,13 @@  -- | Convert something referring to a contract (not specific entrypoint) -- to 'TAddress' in /Haskell/ world.-class ToTAddress (cp :: Type) (a :: Type) where-  toTAddress :: a -> TAddress cp+class ToTAddress (cp :: Type) (vd :: Type) (a :: Type) where+  toTAddress :: a -> TAddress cp vd -instance ToTAddress cp Address where+instance ToTAddress cp vd Address where   toTAddress = TAddress -instance (cp ~ cp') => ToTAddress cp (TAddress cp') where+instance (cp ~ cp', vd ~ vd') => ToTAddress cp vd (TAddress cp' vd') where   toTAddress = id  -- | Convert something to 'ContractRef' in /Haskell/ world.@@ -211,7 +221,7 @@            -- but proving that is not worth the effort          , NiceParameterFull cp, Ep.GetDefaultEntrypointArg cp ~ cp          ) =>-         ToContractRef arg (TAddress cp) where+         ToContractRef arg (TAddress cp vd) where   toContractRef = callingDefTAddress  -- | Convert something from 'ContractRef' in /Haskell/ world.
src/Lorentz/Annotation.hs view
@@ -189,6 +189,12 @@ instance HasAnnotation Operation where   getAnnotation _ = starNotes +instance HasAnnotation Chest where+  getAnnotation _ = starNotes++instance HasAnnotation ChestKey where+  getAnnotation _ = starNotes+ instance (HasAnnotation a, HasAnnotation b) => HasAnnotation (Either a b)  instance (HasAnnotation a, HasAnnotation b) => HasAnnotation (a, b)
src/Lorentz/Base.hs view
@@ -29,6 +29,7 @@   , ContractOut   , ContractCode   , SomeContractCode (..)+  , ViewCode   , Contract (..)   , toMichelsonContract   , Lambda@@ -50,7 +51,7 @@ import Morley.Michelson.Typed   (Instr(..), IsoValue(..), Operation, RemFail(..), ToT, ToTs, Value, rfAnyInstr, rfMapAnyInstr,   rfMerge)-import qualified Morley.Michelson.Typed as M (Contract(..))+import qualified Morley.Michelson.Typed as M (Contract) import qualified Morley.Michelson.Untyped as U  -- | Alias for instruction which hides inner types representation via @T@.@@ -129,9 +130,15 @@     => ContractCode cp st     -> SomeContractCode +type ViewCode arg st ret = '[(arg, st)] :-> '[ret]+ -- | Compiled Lorentz contract.-data Contract cp st =-  (NiceParameterFull cp, NiceStorage st) =>+--+-- Note, that the views argument (views descriptor) is added comparing to the+-- Michelson. In Michelson, ability to call a view is fully checked at runtime,+-- but in Lorentz we want to make calls safer at compile-time.+data Contract cp st vd =+  (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd) =>   Contract   { -- | Ready contract code.     cMichelsonContract :: M.Contract (ToT cp) (ToT st)@@ -145,16 +152,16 @@   , cDocumentedCode :: ~(ContractCode cp st)   } -deriving stock instance Show (Contract cp st)-deriving stock instance Eq (Contract cp st)-instance NFData (Contract cp st) where+deriving stock instance Show (Contract cp st vd)+deriving stock instance Eq (Contract cp st vd)+instance NFData (Contract cp st vd) where   rnf (Contract c d) = rnf c `seq` rnf d -instance ToExpression (Contract cp st) where+instance ToExpression (Contract cp st vd) where   toExpression = toExpression . toMichelsonContract  -- | Demote Lorentz 'Contract' to Michelson typed 'M.Contract'.-toMichelsonContract :: Contract cp st -> M.Contract (ToT cp) (ToT st)+toMichelsonContract :: Contract cp st vd -> M.Contract (ToT cp) (ToT st) toMichelsonContract = cMichelsonContract  -- | An alias for @':@.
src/Lorentz/Bytes.hs view
@@ -8,11 +8,14 @@ module Lorentz.Bytes   ( BytesLike (..) +  -- * Packed   , Packed (..) +  -- * Signatures   , TSignature (..)   , lSign +  -- * Hashes   , Hash (..)   , DHashAlgorithm   , KnownHashAlgorithm (..)@@ -22,6 +25,11 @@   , Blake2b   , Sha3   , Keccak++  -- * Typed Chest+  , ChestT (..)+  , OpenChestT (..)+  , openChestT   ) where  import Crypto.Random (MonadRandom)@@ -225,3 +233,43 @@ instance KnownHashAlgorithm Keccak where   computeHash = Crypto.keccak   toHash = I T.KECCAK++----------------------------------------------------------------------------+-- Typed Chest+----------------------------------------------------------------------------++newtype ChestT a = ChestT { unChestT :: Chest }+  deriving newtype (IsoValue, HasAnnotation)+  deriving stock Generic++instance TypeHasDoc a => TypeHasDoc (ChestT a) where+  typeDocMdDescription = [md|+    Timelock puzzle chest containing a typed value.++    In Lorentz, use `openChestT` instead of `openChest` to open it.+    |]+  typeDocMdReference = poly1TypeDocMdReference+  typeDocDependencies p =+    genericTypeDocDependencies p <>+    [ dTypeDep @a+    , dTypeDep @MText, dTypeDep @Integer  -- for examples below+    ]+  typeDocHaskellRep = concreteTypeDocHaskellRep @(ChestT (Packed (MText, Integer)))+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(ChestT (Packed (MText, Integer)))++data OpenChestT a = ChestContentT a | ChestOpenFailedT Bool+  deriving stock (Generic, Show, Eq)+  deriving anyclass (T.IsoValue, HasAnnotation)++instance (TypeHasDoc a) => TypeHasDoc (OpenChestT a) where+  typeDocMdDescription = "Typed result of opening a typed timelocked chest."+  typeDocMdReference = poly1TypeDocMdReference+  typeDocDependencies _ =+    [ dTypeDep @a+    , dTypeDep @MText, dTypeDep @Integer  -- for examples below+    ]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(OpenChestT (Packed (MText, Integer)))++openChestT :: BytesLike a => ChestKey : ChestT a : Natural : s :-> OpenChestT a : s+openChestT = I T.OPEN_CHEST
src/Lorentz/Coercions.hs view
@@ -262,8 +262,8 @@ -- Coercions for some basic types ---------------------------------------------------------------------------- -instance TAddress p `CanCastTo` Address-instance Address `CanCastTo` TAddress p+instance TAddress p vd `CanCastTo` Address+instance Address `CanCastTo` TAddress p vd  instance FutureContract p `CanCastTo` EpAddress
src/Lorentz/Constraints/Derivative.hs view
@@ -10,12 +10,16 @@   ( NiceParameterFull   , DupableDecision (..)   , decideOnDupable+  , NiceViews+  , NiceViewsDescriptor   ) where  import Lorentz.Constraints.Scopes import Lorentz.Entrypoints.Core+import Lorentz.ViewBase import Morley.Michelson.Typed.Haskell.Value import Morley.Michelson.Typed.Scope+import Morley.Util.Type  -- | Constraint applied to a whole parameter type. type NiceParameterFull cp = (Typeable cp, ParameterDeclaresEntrypoints cp)@@ -46,3 +50,9 @@   case checkScope @(DupableScope (ToT a)) of     Right Dict -> IsDupable     Left _ -> IsNotDupable++-- | Require views set to be proper.+type NiceViews vs = RequireAllUnique "view" (ViewsNames vs)++-- | Require views set referred by the given views descriptor to be proper.+type NiceViewsDescriptor vd = NiceViews (RevealViews vd)
src/Lorentz/Constraints/Scopes.hs view
@@ -19,6 +19,7 @@   , NiceUntypedValue   , NiceStorage   , NiceUnpackedValue+  , NiceViewable   , NiceNoBigMap    , niceParameterEvi@@ -28,6 +29,7 @@   , nicePackedValueEvi   , niceUnpackedValueEvi   , niceUntypedValueEvi+  , niceViewableEvi      -- * Individual constraints (internals)   , CanHaveBigMap@@ -89,6 +91,8 @@  type NiceUntypedValue a = (ProperUntypedValBetterErrors (ToT a), KnownValue a) +type NiceViewable a = (ProperViewableBetterErrors (ToT a), KnownValue a)+ -- | Constraint applied to any type, to check if Michelson representation (if exists) of this -- type is Comparable. In case it is not prints human-readable error message type NiceComparable n = (ProperNonComparableValBetterErrors (ToT n), KnownValue n, Comparable (ToT n))@@ -122,3 +126,7 @@ niceUntypedValueEvi :: forall a. NiceUntypedValue a :- UntypedValScope (ToT a) niceUntypedValueEvi =   properUntypedValEvi @(ToT a) `trans` weaken1++niceViewableEvi :: forall a. NiceViewable a :- ViewableScope (ToT a)+niceViewableEvi =+  properViewableEvi @(ToT a) `trans` weaken1
src/Lorentz/ContractRegistry.hs view
@@ -38,14 +38,14 @@ import Morley.Michelson.Analyzer (analyze) import Morley.Michelson.Printer (printTypedContract) import Morley.Michelson.Typed (IsoValue(..), Notes)-import qualified Morley.Michelson.Typed as M (Contract(..))+import qualified Morley.Michelson.Typed as M import Morley.Util.CLI (mkCommandParser)  data ContractInfo =-  forall cp st.+  forall cp st vd.     (NiceStorage st) =>   ContractInfo-  { ciContract :: Contract cp st+  { ciContract :: Contract cp st vd   , ciIsDocumented :: Bool   , ciStorageParser :: Maybe (Opt.Parser st)   -- ^ Specifies how to parse initial storage value.
src/Lorentz/Doc.hs view
@@ -18,6 +18,13 @@   , contractGeneralDefault   , cutLorentzNonDoc +    -- * Views+  , DView (..)+  , DViewArg (..)+  , DViewRet (..)+  , DViewDesc (..)+  , ViewsDescriptorHasDoc (..)+     -- * Re-exports   , Markdown   , DocElem(..)@@ -62,6 +69,7 @@    , TypeHasDoc (..)   , SomeTypeWithDoc (..)+  , typeDocBuiltMichelsonRep    , HaveCommonTypeCtor   , IsHomomorphic@@ -83,18 +91,22 @@   ) where  import Data.Singletons (demote)-import Fmt (build)+import Data.Typeable (typeRep)+import Fmt (Buildable(..), Builder, pretty)  import Lorentz.Base import Lorentz.Constraints import Lorentz.Value+import Lorentz.ViewBase import Lorentz.Zip () import Morley.Michelson.Doc import Morley.Michelson.Optimizer import Morley.Michelson.Printer import Morley.Michelson.Typed hiding (Contract)+import Morley.Util.Generic import Morley.Util.Markdown import Morley.Util.Type+import Morley.Util.TypeLits  -- | Put a document item. doc :: DocItem di => di -> s :-> s@@ -148,10 +160,10 @@ instance ContainsUpdateableDoc (i :-> o) where   modifyDocEntirely how = iMapAnyCode $ modifyDocEntirely how -instance ContainsDoc (Contract cp st) where+instance ContainsDoc (Contract cp st vd) where   buildDocUnfinalized =     buildDocUnfinalized . cDocumentedCode-instance ContainsUpdateableDoc (Contract cp st) where+instance ContainsUpdateableDoc (Contract cp st vd) where   modifyDocEntirely how c =     c{ cDocumentedCode = modifyDocEntirely how (cDocumentedCode c) } @@ -220,7 +232,7 @@     , demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString]))     ) -instance TypeHasDoc p => TypeHasDoc (TAddress p) where+instance (TypeHasDoc p, ViewsDescriptorHasDoc vd) => TypeHasDoc (TAddress p vd) where   typeDocMdDescription = [md|     A typed version of address primitive. @@ -228,10 +240,19 @@      This is not assumed to carry an entrypoint name.     |]-  typeDocMdReference = poly1TypeDocMdReference-  typeDocDependencies _ = [dTypeDep @()]+  typeDocMdReference pa =+    customTypeDocMdReference' ("TAddress", DType pa)+      [ typeDocMdReference (Proxy @p)+      , \_wp -> docDefinitionRef+          (mdTicked . pretty $ viewsDescriptorName (Proxy @vd))+          (DViewDesc (Proxy @vd))+      ]+  typeDocDependencies _ =+    [ dTypeDep @()+    , SomeDocDefinitionItem $ DViewDesc (Proxy @vd)+    ]   typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(TAddress ())+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(TAddress () ())  instance TypeHasDoc p => TypeHasDoc (FutureContract p) where   typeDocName _ = "FutureContract"@@ -262,3 +283,128 @@ mkDEntrypointExample v =   withDict (niceParameterEvi @a) $     DEntrypointExample $ toVal v++----------------------------------------------------------------------------+-- Views documentation+----------------------------------------------------------------------------++-- View doc items+----------------------------------------------------------------------------++-- | Renders to a view section.+data DView = DView+  { dvName :: ViewName+  , dvSub :: SubDoc+  }++-- | Renders to a line mentioning the view's argument.+data DViewArg =+  forall a. (NiceViewable a, TypeHasDoc a) => DViewArg (Proxy a)++-- | Renders to a line mentioning the view's argument.+data DViewRet =+  forall a. (NiceViewable a, TypeHasDoc a) => DViewRet (Proxy a)++instance DocItem DViewArg where+  docItemPos = 20+  docItemSectionName = Nothing+  docItemDependencies (DViewArg p) =+    [ SomeDocDefinitionItem (DType p) ]+  docItemToMarkdown _ (DViewArg p) =+    "Argument type: " <> typeDocMdReference p (WithinParens False) <> "\n\n"++instance DocItem DViewRet where+  docItemPos = 21+  docItemSectionName = Nothing+  docItemDependencies (DViewRet p) =+    [ SomeDocDefinitionItem (DType p) ]+  docItemToMarkdown _ (DViewRet p) =+    "Return type: " <> typeDocMdReference p (WithinParens False) <> "\n\n"++instance DocItem DView where+  type DocItemPlacement DView = 'DocItemInlined+  type DocItemReferenced DView = 'True+  docItemRef (DView name _) = DocItemRefInlined $+    DocItemId ("views-" <> pretty name)+  docItemPos = 12000+  docItemSectionName = Just "Contract views"+  docItemSectionDescription = Just+    "On-chain views of the contract."+  docItemToMarkdown lvl (DView name block) = mconcat+    [ mdHeader lvl $ mdTicked (build name)+    , subDocToMarkdown (nextHeaderLevel lvl) block+    ]++-- View list+----------------------------------------------------------------------------++-- | Helper typeclass to renders information about view interface.+class RenderViewsImpl (vs :: [ViewTyInfo]) where+  renderViewsDocImpl :: Proxy vs -> Builder++instance RenderViewsImpl '[] where+  renderViewsDocImpl _ = mempty++instance ( KnownSymbol name, TypeHasDoc arg, TypeHasDoc ret+         , RenderViewsImpl vs+         ) =>+         RenderViewsImpl ('ViewTyInfo name arg ret ': vs) where+  renderViewsDocImpl _ = mconcat+    [ mconcat $ map (<> "\n")+      [ "* " <> mdTicked (pretty $ demoteViewName @name)+      , "  + Parameter type: "+      , "    * Haskell representation: " <> typeDocMdReference (Proxy @arg) (WithinParens False)+      , "    * Michelson: " <> typeDocBuiltMichelsonRep (Proxy @arg)+      , "  + Return type: "+      , "    * Haskell representation: " <> typeDocMdReference (Proxy @ret) (WithinParens False)+      , "    * Michelson: " <> typeDocBuiltMichelsonRep (Proxy @ret)+      , ""+      ]+    , renderViewsDocImpl (Proxy @vs)+    ]++-- | Provides documentation for views descriptor.+--+-- Note that views descriptors may describe views that do not belong to the+-- current contract, e.g. @TAddress@ may refer to an external contract provided+-- by the user in which we want to call a view.+class (Typeable vd, RenderViewsImpl (RevealViews vd)) =>+      ViewsDescriptorHasDoc (vd :: Type) where++  viewsDescriptorName :: Proxy vd -> Text+  default viewsDescriptorName+    :: (Generic vd, KnownSymbol (GenericTypeName vd))+    => Proxy vd -> Text+  viewsDescriptorName _ = toText $ symbolVal (Proxy @(GenericTypeName vd))+    where _reallyNeedGenerics = Dict @(Generic vd)++  renderViewsDescriptorDoc :: Proxy vd -> Builder+  renderViewsDescriptorDoc _ =+    "Contract having this type must contain the following views:\n"+    <> renderViewsDocImpl (Proxy @(RevealViews vd))++-- | Renders to documentation of view descriptor.+data DViewDesc = forall vd. ViewsDescriptorHasDoc vd => DViewDesc (Proxy vd)++instance Eq DViewDesc where+  (==) = (== Prelude.EQ) ... compare+instance Ord DViewDesc where+  compare = compare `on` (\(DViewDesc p) -> typeRep p)++instance DocItem DViewDesc where+  type DocItemPlacement DViewDesc = 'DocItemInDefinitions+  type DocItemReferenced DViewDesc = 'True+  docItemRef (DViewDesc p) = DocItemRef $+    DocItemId ("views-descs-" <> show (typeRep p))+  docItemPos = 18010+  docItemSectionName = Just "Referenced views descriptors"+  docItemSectionDescription = Just+    "All the mentioned views descriptors.\n\+    \Each descriptor stands for a set of views"+  docItemToMarkdown lvl (DViewDesc p) =+    mconcat+    [ mdSeparator+    , mdHeader lvl $ mdTicked $ build (viewsDescriptorName p)+    , "\n\n"+    , renderViewsDescriptorDoc p+    ]
src/Lorentz/Errors.hs view
@@ -335,7 +335,6 @@ -- be changed in the future. data UnitErrorArg - -- | How 'CustomError' is actually represented in Michelson. type CustomErrorRep tag = CustomErrorArgRep (ErrorArg tag)
src/Lorentz/Expr.hs view
@@ -91,9 +91,11 @@   , (|@|)   , listE   , transferTokensE+  , createContractE+  , viewE   ) where -import Prelude (foldr, uncurry)+import Prelude (HasCallStack, foldr, uncurry)  import Lorentz.Arith import Lorentz.Base@@ -102,8 +104,10 @@ import Lorentz.Macro import Lorentz.Rebinded import Lorentz.Value+import Lorentz.ViewBase import Morley.Michelson.Typed.Arith import Morley.Util.Named+import Morley.Util.TypeLits  -- | Expression is just an instruction accepting stack @inp@ and producing -- stack @out@ with evaluation result @res@ at the top.@@ -250,7 +254,7 @@ -- one :: a : s :-> [a] : s -- one = take |:| nil -- @-infix 1 |:|+infixr 1 |:| (|:|) :: Expr s0 s1 a -> Expr s1 s2 [a] -> Expr s0 s2 [a] (|:|) = binaryExpr cons @@ -263,7 +267,7 @@ -- -- This is useful as pair appears even in simple contracts. -- For more advanced types, use 'Lorentz.ADT.constructT'.-infix 0 |@|+infixr 0 |@| (|@|) :: Expr s0 s1 a -> Expr s1 s2 b -> Expr s0 s2 (a, b) (|@|) = binaryExpr pair @@ -309,3 +313,46 @@                 (N amountE)                 (N contractE) =   paramE # dip (amountE # dip contractE) # transferTokens++-- | Version of 'createContract' instruction that accepts+-- all the arguments as expressions.+--+-- @+-- createContractE+--   ! #delegate none+--   ! #balance (push zeroMutez)+--   ! #storage unit+--   ! #contract myContract+-- @+--+-- Note that this returns an operation, and pushes the address of the newly+-- created contract as a side-effect.+createContractE+  :: ("delegate" :! Expr s0 s1 (Maybe KeyHash))+  -> ("balance" :! Expr s1 s2 Mutez)+  -> ("storage" :! Expr s2 s3 st)+  -> ("contract" :! Contract p st vd)+  -> Expr s0 (Address : s3) Operation+createContractE (N delegatorE)+                (N balanceE)+                (N storageE)+                (N contract') =+  delegatorE # dip (balanceE # dip storageE) # createContract contract'++-- | Version of 'view' instruction that accepts all the arguments as expressions.+--+-- @+-- viewE @"myview"+--   ! #arg (push zeroMutez)+--   ! #address (push addr)+-- @+viewE+  :: forall name arg ret p vd s0 s1 s2.+    ( HasCallStack, KnownSymbol name, KnownValue arg+    , NiceViewable ret, HasView vd name arg ret+    )+  => ("arg" :! Expr s0 s1 arg)+  -> ("address" :! Expr s1 s2 (TAddress p vd))+  -> Expr s0 s2 ret+viewE (N argE) (N addrE) =+  argE # dip addrE # view @name
src/Lorentz/Instr.hs view
@@ -89,6 +89,7 @@   , ge0   , int   , toTAddress_+  , view'   , self   , selfCalling   , contract@@ -123,6 +124,7 @@   , splitTicket   , splitTicketNamed   , joinTickets+  , openChest   , chainId   , level   , never@@ -144,6 +146,7 @@ import Lorentz.Entrypoints import Lorentz.Polymorphic import Lorentz.Value+import Lorentz.ViewBase import Lorentz.Zip import Morley.Michelson.Typed   (ConstraintDIG, ConstraintDIG', ConstraintDIPN, ConstraintDIPN', ConstraintDUG, ConstraintDUG',@@ -156,6 +159,7 @@ import Morley.Util.Peano import Morley.Util.PeanoNatural import Morley.Util.Type+import Morley.Util.TypeLits  nop :: s :-> s nop = I Nop@@ -614,6 +618,18 @@ int :: (ToIntegerArithOpHs i) => i : s :-> Integer : s int = evalToIntOpHs +-- | Manual variation of @VIEW@ instruction.+-- It is pretty much like Michelson's @VIEW@, you must make sure that the compiler can+-- infer the argument and return types of the view.+--+-- In most cases prefer 'Lorentz.Macro.view' instead.+view'+  :: forall name ret arg s.+    (HasCallStack, KnownSymbol name, KnownValue arg, NiceViewable ret)+  => arg : Address : s :-> Maybe ret : s+view' = I $ VIEW (demoteViewName @name) starNotes+  \\ niceViewableEvi @ret+ -- | Get a reference to the current contract. -- -- Note that, similar to 'CONTRACT' instruction, in Michelson 'SELF' instruction@@ -655,9 +671,9 @@ -- -- If you are going to call a specific entrypoint of the contract, see 'contractCalling'. contract-  :: forall p addr s.+  :: forall p vd addr s.       ( NiceParameterFull p, ForbidExplicitDefaultEntrypoint p-      , ToTAddress_ p addr+      , ToTAddress_ p vd addr       )   => addr : s :-> Maybe (ContractRef p) : s contract = I (CONTRACT starNotes epName) \\ niceParameterEvi @p@@ -670,8 +686,8 @@ -- 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)+  :: forall cp epRef epArg addr vd s.+     (HasEntrypointArg cp epRef epArg, ToTAddress_ cp vd addr)   => epRef   -> addr : s :-> Maybe (ContractRef epArg) : s contractCalling epRef = I $@@ -719,7 +735,7 @@ setDelegate = I SET_DELEGATE  createContract-  :: forall p g s. Contract p g+  :: forall p g vd s. Contract p g vd   -> Maybe KeyHash : Mutez : g : s   :-> Operation : Address : s createContract cntrc@Contract{} =@@ -814,6 +830,9 @@ -- | Note: for more advanced helpers for tickets see "Lorentz.Tickets" module. joinTickets :: (Ticket a, Ticket a) : s :-> Maybe (Ticket a) : s joinTickets = I JOIN_TICKETS++openChest :: ChestKey : Chest : Natural : s :-> OpenChest : s+openChest = I OPEN_CHEST  -- | Execute given instruction on truncated stack. --
src/Lorentz/Macro.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE NoStarIsType #-}  {-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}  -- | Common Michelson macros defined using Lorentz syntax.@@ -98,13 +99,13 @@   , updateN    -- * Additional Morley macros-  , View (..)+  , View_ (..)   , Void_ (..)   , VoidResult(..)   , view_-  , mkView-  , wrapView-  , unwrapView+  , mkView_+  , wrapView_+  , unwrapView_   , void_   , mkVoid   , wrapVoid@@ -119,17 +120,19 @@   , NonZero (..)    -- * Buildable utils for additional Morley macros-  , buildView-  , buildViewTuple+  , buildView_+  , buildViewTuple_    -- * Macros for working with @address@ and @contract@-like types   , addressToEpAddress   , pushContractRef   , selfAddress+  , view   ) where -import Prelude hiding (and, compare, drop, some, swap)+import Prelude hiding (and, compare, drop, some, swap, view) +import Data.Constraint ((\\)) import Fmt (Buildable(..), Builder, pretty, tupleF, (+|), (|+)) import Fmt.Internal.Tuple (TupleF) import qualified GHC.TypeLits as Lit@@ -148,13 +151,15 @@ import Lorentz.Instr import Lorentz.Polymorphic import Lorentz.Value-import Morley.Michelson.Typed (ConstraintDIPN', ConstraintDUG', T)+import Lorentz.ViewBase+import Morley.Michelson.Typed (ConstraintDIPN', ConstraintDUG', T, viewNameToMText) import Morley.Michelson.Typed.Arith import Morley.Michelson.Typed.Haskell.Value import Morley.Michelson.Typed.Scope import Morley.Util.Markdown import Morley.Util.Peano import Morley.Util.Type+import Morley.Util.TypeLits  -- $setup -- >>> :m +Lorentz.Run.Simple Lorentz.Instr@@ -638,17 +643,18 @@ ----------------------------------------------------------------------------  -- | @view@ type synonym as described in A1.-data View (a :: Type) (r :: Type) = View+data View_ (a :: Type) (r :: Type) = View_   { viewParam :: a   , viewCallbackTo :: ContractRef r   } deriving stock (Eq, Show, Generic)     deriving anyclass (HasAnnotation) -deriving anyclass instance (HasNoOpToT r, WellTypedIsoValue r, WellTypedIsoValue a) => IsoValue (View a r)+deriving anyclass instance (HasNoOpToT r, WellTypedIsoValue r, WellTypedIsoValue a) => IsoValue (View_ a r) -instance (CanCastTo a1 a2, CanCastTo r1 r2) => CanCastTo (View a1 r1) (View a2 r2)+instance (CanCastTo a1 a2, CanCastTo r1 r2) => CanCastTo (View_ a1 r1) (View_ a2 r2) -instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (View a r) where+instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (View_ a r) where+  typeDocName _ = "View"   typeDocMdDescription =     "`View a r` accepts an argument of type `a` and callback contract \     \which accepts `r` and returns result via calling that contract.\n\@@ -658,45 +664,45 @@     genericTypeDocDependencies p <>     [dTypeDep @MText, dTypeDep @Integer]   typeDocHaskellRep =-    haskellRepNoFields $ concreteTypeDocHaskellRep @(View MText Integer)+    haskellRepNoFields $ concreteTypeDocHaskellRep @(View_ MText Integer)   typeDocMichelsonRep =-    concreteTypeDocMichelsonRep @(View MText Integer)+    concreteTypeDocMichelsonRep @(View_ MText Integer) -instance {-# OVERLAPPABLE #-} (Buildable a, WellTypedIsoValue r, HasNoOpToT r) => Buildable (View a r) where-  build = buildView build+instance {-# OVERLAPPABLE #-} (Buildable a, WellTypedIsoValue r, HasNoOpToT r) => Buildable (View_ a r) where+  build = buildView_ build -instance {-# OVERLAPPING  #-} (WellTypedIsoValue r, HasNoOpToT r) => Buildable (View () r) where-  build = buildView $ const "()"+instance {-# OVERLAPPING  #-} (WellTypedIsoValue r, HasNoOpToT r) => Buildable (View_ () r) where+  build = buildView_ $ const "()" -buildViewTuple :: (HasNoOpToT r, WellTypedIsoValue r, TupleF a) => View a r -> Builder-buildViewTuple = buildView tupleF+buildViewTuple_ :: (HasNoOpToT r, WellTypedIsoValue r, TupleF a) => View_ a r -> Builder+buildViewTuple_ = buildView_ tupleF -buildView :: (WellTypedIsoValue r, HasNoOpToT r) => (a -> Builder) -> View a r -> Builder-buildView bfp (View {..}) =+buildView_ :: (WellTypedIsoValue r, HasNoOpToT r) => (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)+-- | 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.+-- | 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_+-- '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.+-- | 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_' is part of public standard and should not change often.+unwrapView_ :: View_ a r : s :-> (a, ContractRef r) : s+unwrapView_ = forcedCoerce_  view_ ::      (NiceParameter r, Dupable storage)   => (forall s0. a : storage : s0 :-> r : s0)-  -> View a r : storage : s :-> (List Operation, storage) : s+  -> View_ a r : storage : s :-> (List Operation, storage) : s view_ code =-  unwrapView #+  unwrapView_ #   unpair # dip (dupN @2) # code # dip amount #   transferTokens # nil # swap # cons # pair @@ -900,3 +906,32 @@ instance (NiceComparable d) => NonZero (Ticket d) where   nonZero =     readTicket # toField #rtAmount # int # eq0 # if_ (drop # none) some++type instance ErrorArg "no_view" = MText+instance CustomErrorHasDoc "no_view" where+  customErrClass = ErrClassBadArgument+  customErrDocMdCause =+    "Failed to call on-chain view. \+    \Check whether the view with the given name exists in the called contract, \+    \and that argument and return types match the expected ones."+  customErrArgumentSemantics = Just "view name"++-- | Call a view.+--+-- Accepts the view name via a type annotation.+-- This internally asserts the view to be present, as if the supplied+-- @TAddress@ argument is valid, the view is guaranteed to be called+-- successfully.+view+  :: forall name arg ret p vd s.+    ( HasCallStack, KnownSymbol name, KnownValue arg+    , NiceViewable ret, HasView vd name arg ret+    )+  => arg : TAddress p vd : s :-> ret : s+view =+  dip checkedCoerce_ # view' @name #+  ifSome nop (push (viewNameToMText viewName) # failCustom #no_view)+  \\ niceViewableEvi @ret+  where+    viewName = demoteViewName @name+    _needHasView = Dict @(HasView vd name arg ret)
src/Lorentz/OpSize.hs view
@@ -21,7 +21,7 @@ import qualified Morley.Michelson.Typed as T  -- | Estimate code operation size.-contractOpSize :: Contract cp st -> OpSize+contractOpSize :: Contract cp st vd -> OpSize contractOpSize =   T.contractOpSize . toMichelsonContract
src/Lorentz/Polymorphic.hs view
@@ -2,8 +2,6 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ -{-# LANGUAGE QuantifiedConstraints #-}- -- | Type families from "Morley.Michelson.Typed.Polymorphic" lifted to Haskell types. module Lorentz.Polymorphic   ( MemOpHs (..)@@ -14,13 +12,10 @@   , GetOpHs (..)   , ConcatOpHs   , SliceOpHs-  , EDivOpHs (..)    , IsoMapOpRes   ) where -import Data.Fixed- import Lorentz.Constraints.Scopes (NiceComparable) import Lorentz.Value import Morley.Michelson.Typed@@ -140,68 +135,3 @@  instance SliceOpHs MText instance SliceOpHs ByteString---- | Lifted 'EDivOp'.-class ( EDivOp (ToT n) (ToT m)-      , NiceComparable n, NiceComparable m-      , ToT (EDivOpResHs n m) ~ EDivOpRes (ToT n) (ToT m)-      , ToT (EModOpResHs n m) ~ EModOpRes (ToT n) (ToT m)-      ) => EDivOpHs n m where-  type EDivOpResHs n m :: Type-  type EModOpResHs n m :: 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--instance (KnownNat a) => EDivOpHs (Fixed (DecBase a)) Integer where-  type EDivOpResHs (Fixed (DecBase a)) Integer = Integer-  type EModOpResHs (Fixed (DecBase a)) Integer = (NFixed (DecBase a))--instance (KnownNat a) => EDivOpHs (Fixed (BinBase a)) Integer where-  type EDivOpResHs (Fixed (BinBase a)) Integer = Integer-  type EModOpResHs (Fixed (BinBase a)) Integer = (NFixed (BinBase a))--instance (KnownNat a) => EDivOpHs (Fixed (DecBase a)) Natural where-  type EDivOpResHs (Fixed (DecBase a)) Natural = Integer-  type EModOpResHs (Fixed (DecBase a)) Natural = (NFixed (DecBase a))--instance (KnownNat a) => EDivOpHs (Fixed (BinBase a)) Natural where-  type EDivOpResHs (Fixed (BinBase a)) Natural = Integer-  type EModOpResHs (Fixed (BinBase a)) Natural = (NFixed (BinBase a))--instance (KnownNat a) => EDivOpHs (NFixed (DecBase a)) Integer where-  type EDivOpResHs (NFixed (DecBase a)) Integer = Integer-  type EModOpResHs (NFixed (DecBase a)) Integer = (NFixed (DecBase a))--instance (KnownNat a) => EDivOpHs (NFixed (BinBase a)) Integer where-  type EDivOpResHs (NFixed (BinBase a)) Integer = Integer-  type EModOpResHs (NFixed (BinBase a)) Integer = (NFixed (BinBase a))--instance (KnownNat a) => EDivOpHs (NFixed (DecBase a)) Natural where-  type EDivOpResHs (NFixed (DecBase a)) Natural = Natural-  type EModOpResHs (NFixed (DecBase a)) Natural = (NFixed (DecBase a))--instance (KnownNat a) => EDivOpHs (NFixed (BinBase a)) Natural where-  type EDivOpResHs (NFixed (BinBase a)) Natural = Natural-  type EModOpResHs (NFixed (BinBase a)) Natural = (NFixed (BinBase a))
src/Lorentz/Prelude.hs view
@@ -6,6 +6,7 @@ module Lorentz.Prelude   ( ($)   , (.)+  , (&)   , type ($)   , Eq   , Ord@@ -20,4 +21,7 @@   , fromString   , undefined   , error+  , (!)   ) where++import Named ((!))
src/Lorentz/Print.hs view
@@ -26,6 +26,6 @@  -- | Pretty-print a Lorentz contract into Michelson code. printLorentzContract-  :: Bool -> Contract cp st -> LText+  :: Bool -> Contract cp st vd -> LText printLorentzContract forceSingleLine =   printTypedContract forceSingleLine . toMichelsonContract
src/Lorentz/Run.hs view
@@ -39,8 +39,13 @@   , mkContractWith    , ContractData(..)+  , ContractView(..)   , defaultContractData   , compileLorentzContract+  , mkView+  , setViews+  , setViewsRec+  , noViews   , cdCodeL   , coDisableInitialCastL   , cdCompilationOptionsL@@ -55,21 +60,28 @@ import Data.Constraint ((\\)) import Data.Default (def) import Data.Vinyl.Core (Rec(..))+import qualified Data.Vinyl.Functor as Rec+import qualified Data.Vinyl.Recursive as Rec+import Fmt ((+|), (|+))  import Lorentz.Annotation import Lorentz.Base+import Lorentz.Coercions import Lorentz.Constraints import Lorentz.Doc import Lorentz.Entrypoints import Lorentz.Entrypoints.Doc+import Lorentz.ViewBase import Morley.Michelson.Analyzer (AnalyzerRes, analyze) import Morley.Michelson.Interpret import Morley.Michelson.Optimizer (OptimizerConf, optimizeWithConf) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed (Instr(..), IsoValue, IsoValuesStack(..), ToTs, starParamNotes)-import qualified Morley.Michelson.Typed as M (Contract(..))+import qualified Morley.Michelson.Typed as M import qualified Morley.Michelson.Untyped as U (canonicalEntriesOrder) import Morley.Util.Lens+import Morley.Util.TypeLits+import Morley.Util.TypeTuple  -- | Options to control Lorentz to Michelson compilation. data CompilationOptions = CompilationOptions@@ -122,9 +134,9 @@ -- This is an alias for 'mkContract'. defaultContract   :: (NiceParameterFull cp, NiceStorage st)-  => ContractCode cp st -> Contract cp st+  => ContractCode cp st -> Contract cp st () defaultContract code =-  compileLorentzContract $ ContractData code defaultCompilationOptions+  compileLorentzContract $ ContractData code mempty defaultCompilationOptions  -- | Construct and compile Lorentz contract. --@@ -132,15 +144,15 @@ -- simplicity. mkContract   :: (NiceParameterFull cp, NiceStorage st)-  => ContractCode cp st -> Contract cp st+  => ContractCode cp st -> Contract cp st () mkContract = mkContractWith defaultCompilationOptions  -- | Version of 'mkContract' that accepts custom compilation options. mkContractWith   :: (NiceParameterFull cp, NiceStorage st)-  => CompilationOptions -> ContractCode cp st -> Contract cp st+  => CompilationOptions -> ContractCode cp st -> Contract cp st () mkContractWith opts code =-  compileLorentzContract $ ContractData code opts+  compileLorentzContract $ ContractData code mempty opts  -- | Code for a contract along with compilation options for the Lorentz compiler. --@@ -151,19 +163,51 @@ -- environments, like production and testing. -- -- Raw 'ContractCode' should not be used for distribution of contracts.-data ContractData cp st = (NiceParameterFull cp, NiceStorage st) => ContractData+data ContractData cp st vd =+  (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd) =>+  ContractData   { cdCode :: ContractCode cp st   -- ^ The contract itself.+  , cdViews :: Rec (ContractView st) (RevealViews vd)+  -- ^ Contract views.   , cdCompilationOptions :: CompilationOptions   -- ^ General compilation options for the Lorentz compiler.   } +-- | Single contract view.+data ContractView st (v :: ViewTyInfo) where+  ContractView+    :: ( KnownSymbol name, NiceViewable arg, NiceViewable ret+       , HasAnnotation arg, HasAnnotation ret+       )+    => ViewCode arg st ret+    -> ContractView st ('ViewTyInfo name arg ret)++-- | Construct a view.+--+-- > mkView @"add" @(Integer, Integer) do+-- >  car; unpair; add+mkView+  :: forall name arg ret st.+     ( KnownSymbol name, NiceViewable arg, NiceViewable ret+     , HasAnnotation arg, HasAnnotation ret+     , TypeHasDoc arg, TypeHasDoc ret+     )+  => ViewCode arg st ret+  -> ContractView st ('ViewTyInfo name arg ret)+mkView code = ContractView $+  docGroup (DView (demoteViewName @name)) $+    doc (DViewArg (Proxy @arg)) #+    doc (DViewRet (Proxy @ret)) #+    code+ -- | Compile contract with 'defaultCompilationOptions'. defaultContractData   :: forall cp st. (NiceParameterFull cp, NiceStorage st)-  => ContractCode cp st -> ContractData cp st+  => ContractCode cp st -> ContractData cp st () defaultContractData code = ContractData   { cdCode = code+  , cdViews = RNil   , cdCompilationOptions = defaultCompilationOptions   } @@ -174,25 +218,121 @@ -- is @True@, resulted contract can be ill-typed). -- However, compilation with 'defaultCompilationOptions' should be valid. compileLorentzContract-  :: forall cp st. ContractData cp st -> Contract cp st+  :: forall cp st vd. ContractData cp st vd -> Contract cp st vd compileLorentzContract ContractData{..} = Contract{..}   where     cMichelsonContract = M.Contract-      { cCode = if (cpNotes == starParamNotes || coDisableInitialCast cdCompilationOptions)-          then -- If contract parameter type has no annotations or explicitly asked, we drop CAST.-            compileLorentzWithOptions cdCompilationOptions cdCode-          else -- Perform CAST otherwise.-            compileLorentzWithOptions cdCompilationOptions (I CAST # cdCode :: ContractCode cp st)+      { cCode =+          let+            maybeAddInitialCast =+              if (cpNotes == starParamNotes || coDisableInitialCast cdCompilationOptions)+              then id else (I CAST #)+          in compileLorentzWithOptions cdCompilationOptions $+                maybeAddInitialCast cdCode+                -- TODO [#997]: make ^^^ saner, as well as 'compileLorentzView'+       , cParamNotes = cpNotes       , cStoreNotes = getAnnotation @st NotFollowEntrypoint       , cEntriesOrder = U.canonicalEntriesOrder+      , cViews = compileLorentzViews cdCompilationOptions cdViews       } \\ niceParameterEvi @cp         \\ niceStorageEvi @st -    cDocumentedCode = finalizeParamCallingDoc' (Proxy @cp) cdCode+    cDocumentedCode =+      finalizeParamCallingDoc' (Proxy @cp) cdCode #+      foldr (#) (I Nop)+        ( Rec.recordToList $+           Rec.rmap (\(ContractView code) -> Rec.Const $ fakeCoercing code) cdViews+        )      cpNotes = parameterEntrypointsToNotes @cp +-- | Compile multiple views, with the related checks.+compileLorentzViews+  :: forall vs st.+      ( HasCallStack+      , KnownValue st+      )+  => CompilationOptions+  -> Rec (ContractView st) vs+  -> M.ViewsSet (M.ToT st)+compileLorentzViews co views =+  let+    viewsList =+      Rec.recordToList $+      Rec.rmap (\v -> Rec.Const $ compileLorentzView co v) views+  in case M.mkViewsSet viewsList of+      Right viewsSet -> viewsSet+      Left e@M.DuplicatedViewName{} ->+        error $ "An impossble happened: " +| e |+ ""++-- | Compile a single view.+compileLorentzView+  :: forall st vt.+     (KnownValue st)+  => CompilationOptions+  -> ContractView st vt+  -> M.SomeView (M.ToT st)+compileLorentzView co (ContractView viewCode)+  | (_ :: Proxy ('ViewTyInfo name arg ret)) <- Proxy @vt =+    let argNotes = getAnnotation @arg NotFollowEntrypoint in+    let retNotes = getAnnotation @ret NotFollowEntrypoint in+    M.SomeView M.View+      { M.vName = demoteViewName @name+      , M.vArgument = argNotes+      , M.vReturn = retNotes+      , M.vCode =+          let+            maybeAddInitialCast =+              if (argNotes == M.starNotes || coDisableInitialCast co)+              then id else (I CAST #)+          in compileLorentzWithOptions co $+              maybeAddInitialCast viewCode+      }+      \\ niceViewableEvi @arg+      \\ niceViewableEvi @ret++{- | Set all the contract's views.++@+compileLorentzContract $+  defaultContractData do+    ...+  & setViews+    ( mkView @"myView" @() do+        ...+    , mkView @"anotherView" @Integer do+        ...+    )+@+-}+setViews+  :: forall vd cp st.+     ( RecFromTuple (Rec (ContractView st) (RevealViews vd))+     , NiceViewsDescriptor vd+     )+  => IsoRecTuple (Rec (ContractView st) (RevealViews vd))+  -> ContractData cp st ()+  -> ContractData cp st vd+setViews views = setViewsRec (recFromTuple views)++-- | Version of 'setViews' that accepts a 'Rec'.+--+-- May be useful if you have too many views or want to combine views sets.+setViewsRec+  :: forall vd cp st.+     (NiceViewsDescriptor vd)+  => Rec (ContractView st) (RevealViews vd)+  -> ContractData cp st ()+  -> ContractData cp st vd+setViewsRec views ContractData{..} =+  ContractData{ cdViews = views, .. }++-- | Restrict type of 'Contract', 'ContractData' or other similar type to+-- have no views.+noViews :: contract cp st () -> contract cp st ()+noViews = id+ -- | Interpret a Lorentz instruction, for test purposes. Note that this does not run the -- optimizer. interpretLorentzInstr@@ -217,10 +357,10 @@   let Identity out :& RNil = res   return out -instance ContainsDoc (ContractData cp st) where+instance ContainsDoc (ContractData cp st vd) where   buildDocUnfinalized =     buildDocUnfinalized . compileLorentzContract-instance ContainsUpdateableDoc (ContractData cp st) where+instance ContainsUpdateableDoc (ContractData cp st vd) where   modifyDocEntirely how c =     c{ cdCode = modifyDocEntirely how (cdCode c) } @@ -231,13 +371,13 @@ makeLensesWith postfixLFields ''CompilationOptions  cdCodeL ::-  forall cp st cp1 st1. (NiceParameterFull cp1, NiceStorage st1) =>-  Lens.Lens (ContractData cp st) (ContractData cp1 st1) (ContractCode cp st) (ContractCode cp1 st1)-cdCodeL f (ContractData code options)-  = fmap (`ContractData` options) (f code)+  forall cp st vd cp1. (NiceParameterFull cp1, NiceStorage st) =>+  Lens.Lens (ContractData cp st vd) (ContractData cp1 st vd) (ContractCode cp st) (ContractCode cp1 st)+cdCodeL f (ContractData code views options)+  = fmap (\code' -> ContractData code' views options) (f code)  cdCompilationOptionsL ::-  forall cp st.-  Lens.Lens' (ContractData cp st) CompilationOptions-cdCompilationOptionsL f (ContractData code options)-  = fmap (ContractData code) (f options)+  forall cp st vd.+  Lens.Lens' (ContractData cp st vd) CompilationOptions+cdCompilationOptionsL f (ContractData code views options)+  = fmap (\options' -> ContractData code views options') (f options)
src/Lorentz/Tickets.hs view
@@ -152,7 +152,7 @@       -- ^ Ticket tokens verifier   -> td : s :-> s'       -- ^ Ticket data verifier-  -> TAddress emitterParam : Ticket td : s :-> Ticket td : s'+  -> TAddress emitterParam vd : Ticket td : s :-> Ticket td : s' verifyTicketGeneric' verifyTicketer' verifyTokens verifyData = do   dip do     readTicket; swap; dip deconstruct@@ -169,7 +169,7 @@   :: (IsoValue td)   => (forall s0. Natural : s0 :-> s0)  -- ^ Ticket tokens verifier   -> td : s :-> s'                     -- ^ Ticket data verifier-  -> TAddress emitterParam : Ticket td : s :-> Ticket td : s'+  -> TAddress emitterParam vd : Ticket td : s :-> Ticket td : s' verifyTicketGeneric = verifyTicketGeneric' verifyTicketer  -- | Generic method for verifying the ticketer.@@ -183,12 +183,12 @@ -- other data that is to be verified with the given handler. verifyTargetContractAnd   :: (d : s :-> s')-  -> (TAddress selfParam, d) : s :-> s'+  -> (TAddress selfParam vd, d) : s :-> s' verifyTargetContractAnd verifyData = do   unpair; verifyTargetContract; verifyData  -- | Check data in a ticket when it solely carries target contract address.-verifyTargetContract :: TAddress selfParam : s :-> s+verifyTargetContract :: TAddress selfParam vd : s :-> s verifyTargetContract =   if checkedCoerce_ |==| selfAddress   then nop@@ -207,7 +207,7 @@ authorizeAction   :: (IsoValue td)   => (td : s :-> s')-  -> TAddress emitterParam : Ticket td : s :-> s'+  -> TAddress emitterParam vd : Ticket td : s :-> s' authorizeAction verifyTicketData = do   verifyTicketGeneric     verifySingleToken
src/Lorentz/Value.hs view
@@ -43,6 +43,9 @@   , TAddress (..)   , FutureContract (..)   , M.Ticket (..)+  , Chest+  , ChestKey+  , OpenChest    , M.EpName   , pattern M.DefEpName@@ -104,7 +107,8 @@ import Morley.Tezos.Core   (ChainId, Mutez, Timestamp, oneMutez, timestampFromSeconds, timestampFromUTCTime, timestampQuote,   toMutez, zeroMutez)-import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature)+import Morley.Tezos.Crypto+  (Bls12381Fr, Bls12381G1, Bls12381G2, Chest, ChestKey, KeyHash, PublicKey, Signature) import Morley.Util.CustomGeneric as ReExports import Morley.Util.Label (Label(..)) @@ -194,3 +198,10 @@ -- Helpers copied from Data.Fixed, because they are not exported from there withResolution :: forall a f. (HasResolution a) => (Natural -> f a) -> f a withResolution foo = foo . fromInteger . resolution $ Proxy @a++data OpenChest = ChestContent ByteString | ChestOpenFailed Bool+  deriving stock (Generic, Show, Eq)+  deriving anyclass (M.IsoValue, HasAnnotation)++instance M.TypeHasDoc OpenChest where+  typeDocMdDescription = "Result of opening a chest"
+ src/Lorentz/ViewBase.hs view
@@ -0,0 +1,164 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.ViewBase+  ( ViewTyInfo(..)+  , type (?::)+  , type (>->)+  , ViewsList+  , RevealViews+  , LookupView+  , LookupRevealView+  , HasView+  , ViewsNames++  , ViewName (..)+  , ViewInterface (..)+  , demoteViewName+  , demoteViewTyInfos+  , DemoteViewsDescriptor+  , demoteViewsDescriptor+  , ViewInterfaceMatchError (..)+  , checkViewsCoverInterface+  ) where++import Control.Monad.Except (throwError)+import qualified Data.Map as Map+import Data.Singletons (demote)+import Fmt (Buildable(..), pretty, (+|), (|+))++import Morley.Michelson.Typed+import Morley.Util.TypeLits++-- | Type-level information about a view.+data ViewTyInfo = ViewTyInfo Symbol Type Type++-- | Neat constructor for 'ViewTyInfo'.+--+-- type View = "view" ?:: Integer >-> Natural+type family (?::) (name :: Symbol) (tys :: (Type, Type)) where+  name ?:: '(arg, ret) = 'ViewTyInfo name arg ret+infix 3 ?::++type arg >-> ret = '(arg, ret)+infix 5 >->++-- | Get a list of views by a descriptor object.+--+-- The problem this type family solves:+-- it is unpleasant to carry around a list of views because it may be large,+-- and if we merely hide this list under a type alias, error messages will still+-- mention the type alias expanded.+-- We want e.g. @Contract Parameter Storage Views@ to be carried as-is.+-- @Parameter@ and @Storage@ are usually datatypes and they are fine, while+-- for @Views@ to be not automatically expanded we have to take special care.+--+-- You can still provide the list of 'ViewTyInfo's to this type family using+-- t'ViewsList', but generally prefer creating a dedicated datatype that would+-- expand to a views list.+type family RevealViews (desc :: Type) :: [ViewTyInfo]++-- | A views descriptor that directly carries the full list of views.+data ViewsList (vl :: [ViewTyInfo])++type instance RevealViews () = '[]+type instance RevealViews (ViewsList info) = info++-- | Find a view in a contract by name.+type family LookupView (name :: Symbol) (views :: [ViewTyInfo]) :: (Type, Type) where+  LookupView name '[] =+    TypeError ('Text "View " ':<>: 'ShowType name ':<>: 'Text " is not found")+  LookupView name ('ViewTyInfo name arg ret ': _) = '(arg, ret)+  LookupView name ('ViewTyInfo _ _ _ ': vs) = LookupView name vs++-- | Reveal views and find a view there.+type LookupRevealView name viewRef = LookupView name (RevealViews viewRef)++-- | Constraint indicating that presence of the view with the specified+-- parameters is implied by the views descriptor.+type HasView vd name arg ret = (LookupRevealView name vd ~ '(arg, ret))++-- | Map views to get their names.+type family ViewsNames (vs :: [ViewTyInfo]) :: [Symbol] where+  ViewsNames '[] = '[]+  ViewsNames ('ViewTyInfo name _ _ ': vs) = name ': ViewsNames vs++-- | Demote view name from type level to term level.+demoteViewName+  :: forall name.+     (KnownSymbol name, HasCallStack)+  => ViewName+demoteViewName = unsafeMkViewName (symbolValT' @name)++-- | Interface of a single view at term-level.+data ViewInterface = ViewInterface+  { viName :: ViewName+  , viArg :: T+  , viRet :: T+  }++-- | Helper typeclass to demote 'ViewTyInfo's to 'ViewInterface's.+class DemoteViewTyInfo (vs :: [ViewTyInfo]) where+  demoteViewTyInfos' :: Proxy vs -> [ViewInterface]++instance DemoteViewTyInfo '[] where+  demoteViewTyInfos' _ = []+instance (KnownSymbol name, IsoValue arg, IsoValue ret, DemoteViewTyInfo vs) =>+         DemoteViewTyInfo ('ViewTyInfo name arg ret ': vs) where+  demoteViewTyInfos' _ =+    ViewInterface+    { viName = demoteViewName @name+    , viArg = demote @(ToT arg)+    , viRet = demote @(ToT ret)+    } : demoteViewTyInfos' (Proxy @vs)++-- | Demote 'ViewTyInfo's to 'ViewInterface's.+demoteViewTyInfos+  :: forall (vs :: [ViewTyInfo]). DemoteViewTyInfo vs+  => [ViewInterface]+demoteViewTyInfos = demoteViewTyInfos' (Proxy @vs)++type DemoteViewsDescriptor vd = DemoteViewTyInfo (RevealViews vd)++-- | Demote views descriptor to 'ViewInterface's.+demoteViewsDescriptor+  :: forall (vd :: Type). DemoteViewTyInfo (RevealViews vd)+  => [ViewInterface]+demoteViewsDescriptor = demoteViewTyInfos @(RevealViews vd)++data ViewInterfaceMatchError+  = VIMViewNotFound ViewName+  | VIMViewArgMismatch T T+  | VIMViewRetMismatch T T+  deriving stock (Show, Eq)++instance Buildable ViewInterfaceMatchError where+  build = \case+    VIMViewNotFound name ->+      "View not found in the contract " +| name |+ ""+    VIMViewArgMismatch actual expected ->+      "View argument type " +| actual |+ " does not match the expected " +| expected |+ ""+    VIMViewRetMismatch actual expected ->+      "View return type " +| actual |+ " does not match the expected " +| expected |+ ""++instance Exception ViewInterfaceMatchError where+  displayException = pretty++-- | Check that the given set of views covers the given view interfaces.+-- Extra views in the set, that do not appear in the interface, are fine.+checkViewsCoverInterface+  :: forall st. [ViewInterface] -> ViewsSet st -> Either ViewInterfaceMatchError ()+checkViewsCoverInterface interfaces (ViewsList views) =+  forM_ interfaces $ \ViewInterface{..} -> do+    () <- case Map.lookup viName viewsMap of+      Nothing -> throwError (VIMViewNotFound viName)+      Just (SomeView View{..}) -> do+        unless (notesT vArgument == viArg) $+          throwError (VIMViewArgMismatch (notesT vArgument) viArg)+        unless (notesT vReturn == viRet) $+          throwError (VIMViewRetMismatch (notesT vReturn) viRet)+    pass+  where+    viewsMap :: Map.Map ViewName (SomeView st)+    viewsMap = Map.fromList [ (vName, v) | v@(SomeView View{..}) <- views ]