mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 09:17:43 +03:00
Better errors when trying to use guards in LF 15 (#14884)
* Make InterfaceGuardedNotExtended error out with guard message * Move ConvertM into own module, make convertPrim failable * Error out when exerciseGuarded is called * Remove _exerciseDefault, now unused * Error at runtime if _exerciseInterfaceGuard called in <= LF 1.15 * Add InterfaceChoiceGuardFailedNotExtended - test guarded exercises error * lint * Satisfy changelog CHANGELOG_BEGIN CHANGELOG_END * Only error on exerciseGuarded if extended interfaces are NOT supported * Make convertPrim impure - handle strict errors by inserting runtime errs * Use ifdef/else/endif instead of ifdef/endif/ifndef/endif Co-authored-by: Moisés Ackerman <6054733+akrmn@users.noreply.github.com> Co-authored-by: Moisés Ackerman <6054733+akrmn@users.noreply.github.com>
This commit is contained in:
dylant-da
GitHub
parent
8d48eebc06
commit
69296455f3
@ -83,6 +83,7 @@ module DA.Daml.LFConversion
|
||||
|
||||
import DA.Daml.LFConversion.Primitives
|
||||
import DA.Daml.LFConversion.MetadataEncoding
|
||||
import DA.Daml.LFConversion.ConvertM
|
||||
import DA.Daml.Preprocessor (isInternal)
|
||||
import DA.Daml.UtilGHC
|
||||
import DA.Daml.UtilLF
|
||||
@ -95,14 +96,12 @@ import Development.IDE.GHC.Util
|
||||
import Control.Lens hiding (MethodName)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State.Strict
|
||||
import DA.Daml.LF.Ast as LF
|
||||
import DA.Daml.LF.Ast.Numeric
|
||||
import DA.Daml.LF.TemplateOrInterface (TemplateOrInterface')
|
||||
import qualified DA.Daml.LF.TemplateOrInterface as TemplateOrInterface
|
||||
import DA.Daml.Options.Types (EnableScenarios (..))
|
||||
import Data.Data hiding (TyCon)
|
||||
import qualified Data.Decimal as Decimal
|
||||
import Data.Foldable (foldlM)
|
||||
import Data.Int
|
||||
@ -129,39 +128,6 @@ import qualified "ghc-lib-parser" BooleanFormula as BF
|
||||
import Safe.Exact (zipExact, zipExactMay)
|
||||
import SdkVersion
|
||||
|
||||
---------------------------------------------------------------------
|
||||
-- FAILURE REPORTING
|
||||
|
||||
conversionError :: String -> ConvertM e
|
||||
conversionError msg = do
|
||||
ConversionEnv{..} <- ask
|
||||
throwError $ (convModuleFilePath,ShowDiag,) Diagnostic
|
||||
{ _range = maybe noRange sourceLocToRange convRange
|
||||
, _severity = Just DsError
|
||||
, _source = Just "Core to Daml-LF"
|
||||
, _message = T.pack msg
|
||||
, _code = Nothing
|
||||
, _relatedInformation = Nothing
|
||||
, _tags = Nothing
|
||||
}
|
||||
|
||||
unsupported :: (HasCallStack, Outputable a) => String -> a -> ConvertM e
|
||||
unsupported typ x = conversionError errMsg
|
||||
where
|
||||
errMsg =
|
||||
"Failure to process Daml program, this feature is not currently supported.\n" ++
|
||||
typ ++ "\n" ++
|
||||
prettyPrint x
|
||||
|
||||
unknown :: HasCallStack => GHC.UnitId -> MS.Map GHC.UnitId DalfPackage -> ConvertM e
|
||||
unknown unitId pkgMap = conversionError errMsg
|
||||
where errMsg =
|
||||
"Unknown package: " ++ GHC.unitIdString unitId
|
||||
++ "\n" ++ "Loaded packages are:" ++ prettyPrint (MS.keys pkgMap)
|
||||
|
||||
unhandled :: (HasCallStack, Data a, Outputable a) => String -> a -> ConvertM e
|
||||
unhandled typ x = unsupported (typ ++ " with " ++ lower (show (toConstr x))) x
|
||||
|
||||
---------------------------------------------------------------------
|
||||
-- FUNCTIONS ON THE ENVIRONMENT
|
||||
|
||||
@ -309,47 +275,6 @@ getDepOrphanModules = dep_orphs . mi_deps
|
||||
---------------------------------------------------------------------
|
||||
-- CONVERSION
|
||||
|
||||
data ConversionError
|
||||
= ConversionError
|
||||
{ errorFilePath :: !NormalizedFilePath
|
||||
, errorRange :: !(Maybe Range)
|
||||
, errorMessage :: !String
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data ConversionEnv = ConversionEnv
|
||||
{ convModuleFilePath :: !NormalizedFilePath
|
||||
, convRange :: !(Maybe SourceLoc)
|
||||
}
|
||||
|
||||
data ConversionState = ConversionState
|
||||
{ freshTmVarCounter :: Int
|
||||
}
|
||||
|
||||
newtype ConvertM a = ConvertM (ReaderT ConversionEnv (StateT ConversionState (Except FileDiagnostic)) a)
|
||||
deriving (Functor, Applicative, Monad, MonadError FileDiagnostic, MonadState ConversionState, MonadReader ConversionEnv)
|
||||
|
||||
instance MonadFail ConvertM where
|
||||
fail = conversionError
|
||||
|
||||
runConvertM :: ConversionEnv -> ConvertM a -> Either FileDiagnostic a
|
||||
runConvertM s (ConvertM a) = runExcept (evalStateT (runReaderT a s) st0)
|
||||
where
|
||||
st0 = ConversionState
|
||||
{ freshTmVarCounter = 0
|
||||
}
|
||||
|
||||
withRange :: Maybe SourceLoc -> ConvertM a -> ConvertM a
|
||||
withRange r = local (\s -> s { convRange = r })
|
||||
|
||||
freshTmVar :: ConvertM LF.ExprVarName
|
||||
freshTmVar = do
|
||||
n <- state (\st -> let k = freshTmVarCounter st + 1 in (k, st{freshTmVarCounter = k}))
|
||||
pure $ LF.ExprVarName ("$$v" <> T.show n)
|
||||
|
||||
resetFreshVarCounters :: ConvertM ()
|
||||
resetFreshVarCounters = modify' (\st -> st{freshTmVarCounter = 0})
|
||||
|
||||
convertInt64 :: Integer -> ConvertM LF.Expr
|
||||
convertInt64 x
|
||||
| toInteger (minBound :: Int64) <= x && x <= toInteger (maxBound :: Int64) =
|
||||
@ -1381,10 +1306,6 @@ convertBind env mc (name, x)
|
||||
, DesugarDFunId _ _ (NameIn DA_Internal_Template_Functions "HasExerciseGuarded") _ <- name
|
||||
= pure []
|
||||
|
||||
| not (envLfVersion env `supports` featureExtendedInterfaces)
|
||||
, NameIn DA_Internal_Interface "_exerciseDefault" <- name
|
||||
= pure []
|
||||
|
||||
-- Remove internal functions.
|
||||
| Just internals <- lookupUFM internalFunctions (envGHCModuleName env)
|
||||
, getOccFS name `elementOfUniqSet` internals
|
||||
@ -1554,7 +1475,7 @@ convertExpr env0 e = do
|
||||
let mkFieldProj i (name, _typ) = (mkIndexedField i, EStructProj name (EVar v))
|
||||
pure $ ETmLam (v, TStruct fields) $ ERecCon tupleType $ zipWithFrom mkFieldProj (1 :: Int) fields
|
||||
go env (VarIn GHC_Types "primitive") (LType (isStrLitTy -> Just y) : LType t : args)
|
||||
= fmap (, args) $ convertPrim (envLfVersion env) (unpackFS y) <$> convertType env t
|
||||
= fmap (, args) $ convertPrim (envLfVersion env) (unpackFS y) =<< convertType env t
|
||||
-- erase mkMethod calls and leave only the body.
|
||||
go env (VarIn DA_Internal_Desugar "mkMethod") (LType _parent : LType _iface : LType _tpl : LType _methodName : LType _methodTy : LExpr _implDict : LExpr _hasMethodDic : LExpr body : args)
|
||||
= go env body args
|
||||
@ -1631,6 +1552,9 @@ convertExpr env0 e = do
|
||||
t1' <- convertType env t1
|
||||
t2' <- convertType env t2
|
||||
pure (x' `ETyApp` t1' `ETyApp` t2' `ETmApp` EBuiltin (BEText (unpackCStringUtf8 s)))
|
||||
go env (VarIn DA_Internal_Template_Functions "exerciseGuarded") _
|
||||
| not $ envLfVersion env `supports` featureExtendedInterfaces
|
||||
= conversionError "Guarded exercises are only available with --target=1.dev"
|
||||
|
||||
go env (ConstraintTupleProjection index arity) args
|
||||
| (LExpr x : args') <- drop arity args -- drop the type arguments
|
||||
|
||||
@ -0,0 +1,109 @@
|
||||
-- Copyright (c) 2022 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
module DA.Daml.LFConversion.ConvertM (
|
||||
ConversionError(..),
|
||||
ConversionEnv(..),
|
||||
ConvertM(..),
|
||||
runConvertM,
|
||||
withRange,
|
||||
freshTmVar,
|
||||
resetFreshVarCounters,
|
||||
conversionError,
|
||||
unsupported,
|
||||
unknown,
|
||||
unhandled
|
||||
) where
|
||||
|
||||
import DA.Daml.UtilLF
|
||||
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.GHC.Util
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State.Strict
|
||||
import DA.Daml.LF.Ast as LF
|
||||
import Data.Data hiding (TyCon)
|
||||
import Data.List.Extra
|
||||
import qualified Data.Map.Strict as MS
|
||||
import qualified Data.Text.Extended as T
|
||||
import "ghc-lib" GHC
|
||||
import "ghc-lib" GhcPlugins as GHC hiding ((<>), notNull)
|
||||
|
||||
data ConversionError
|
||||
= ConversionError
|
||||
{ errorFilePath :: !NormalizedFilePath
|
||||
, errorRange :: !(Maybe Range)
|
||||
, errorMessage :: !String
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data ConversionEnv = ConversionEnv
|
||||
{ convModuleFilePath :: !NormalizedFilePath
|
||||
, convRange :: !(Maybe SourceLoc)
|
||||
}
|
||||
|
||||
data ConversionState = ConversionState
|
||||
{ freshTmVarCounter :: Int
|
||||
}
|
||||
|
||||
newtype ConvertM a = ConvertM (ReaderT ConversionEnv (StateT ConversionState (Except FileDiagnostic)) a)
|
||||
deriving (Functor, Applicative, Monad, MonadError FileDiagnostic, MonadState ConversionState, MonadReader ConversionEnv)
|
||||
|
||||
instance MonadFail ConvertM where
|
||||
fail = conversionError
|
||||
|
||||
runConvertM :: ConversionEnv -> ConvertM a -> Either FileDiagnostic a
|
||||
runConvertM s (ConvertM a) = runExcept (evalStateT (runReaderT a s) st0)
|
||||
where
|
||||
st0 = ConversionState
|
||||
{ freshTmVarCounter = 0
|
||||
}
|
||||
|
||||
withRange :: Maybe SourceLoc -> ConvertM a -> ConvertM a
|
||||
withRange r = local (\s -> s { convRange = r })
|
||||
|
||||
freshTmVar :: ConvertM LF.ExprVarName
|
||||
freshTmVar = do
|
||||
n <- state (\st -> let k = freshTmVarCounter st + 1 in (k, st{freshTmVarCounter = k}))
|
||||
pure $ LF.ExprVarName ("$$v" <> T.show n)
|
||||
|
||||
resetFreshVarCounters :: ConvertM ()
|
||||
resetFreshVarCounters = modify' (\st -> st{freshTmVarCounter = 0})
|
||||
|
||||
---------------------------------------------------------------------
|
||||
-- FAILURE REPORTING
|
||||
|
||||
conversionError :: String -> ConvertM e
|
||||
conversionError msg = do
|
||||
ConversionEnv{..} <- ask
|
||||
throwError $ (convModuleFilePath,ShowDiag,) Diagnostic
|
||||
{ _range = maybe noRange sourceLocToRange convRange
|
||||
, _severity = Just DsError
|
||||
, _source = Just "Core to Daml-LF"
|
||||
, _message = T.pack msg
|
||||
, _code = Nothing
|
||||
, _relatedInformation = Nothing
|
||||
, _tags = Nothing
|
||||
}
|
||||
|
||||
unsupported :: (HasCallStack, Outputable a) => String -> a -> ConvertM e
|
||||
unsupported typ x = conversionError errMsg
|
||||
where
|
||||
errMsg =
|
||||
"Failure to process Daml program, this feature is not currently supported.\n" ++
|
||||
typ ++ "\n" ++
|
||||
prettyPrint x
|
||||
|
||||
unknown :: HasCallStack => GHC.UnitId -> MS.Map GHC.UnitId DalfPackage -> ConvertM e
|
||||
unknown unitId pkgMap = conversionError errMsg
|
||||
where errMsg =
|
||||
"Unknown package: " ++ GHC.unitIdString unitId
|
||||
++ "\n" ++ "Loaded packages are:" ++ prettyPrint (MS.keys pkgMap)
|
||||
|
||||
unhandled :: (HasCallStack, Data a, Outputable a) => String -> a -> ConvertM e
|
||||
unhandled typ x = unsupported (typ ++ " with " ++ lower (show (toConstr x))) x
|
||||
|
||||
|
||||
@ -8,262 +8,277 @@
|
||||
-- | The Daml-LF primitives, matched with their type, and using 'primitive' on the libraries side.
|
||||
module DA.Daml.LFConversion.Primitives(convertPrim) where
|
||||
|
||||
import DA.Daml.LFConversion.ConvertM
|
||||
import DA.Daml.LF.Ast
|
||||
import DA.Daml.UtilLF
|
||||
import DA.Pretty (renderPretty)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.List as L
|
||||
|
||||
convertPrim :: Version -> String -> Type -> Expr
|
||||
convertPrim :: Version -> String -> Type -> ConvertM Expr
|
||||
-- Update
|
||||
convertPrim _ "UPure" (a1 :-> TUpdate a2) | a1 == a2 =
|
||||
ETmLam (varV1, a1) $ EUpdate $ UPure a1 $ EVar varV1
|
||||
pure $ ETmLam (varV1, a1) $ EUpdate $ UPure a1 $ EVar varV1
|
||||
convertPrim _ "UBind" (t1@(TUpdate a1) :-> t2@(a2 :-> TUpdate b1) :-> TUpdate b2) | a1 == a2, b1 == b2 =
|
||||
ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EUpdate $ UBind (Binding (varV3, a1) (EVar varV1)) (EVar varV2 `ETmApp` EVar varV3)
|
||||
pure $ ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EUpdate $ UBind (Binding (varV3, a1) (EVar varV1)) (EVar varV2 `ETmApp` EVar varV3)
|
||||
convertPrim _ "UAbort" (TText :-> t@(TUpdate a)) =
|
||||
ETmLam (varV1, TText) $ EUpdate (UEmbedExpr a (EBuiltin BEError `ETyApp` t `ETmApp` EVar varV1))
|
||||
pure $ ETmLam (varV1, TText) $ EUpdate (UEmbedExpr a (EBuiltin BEError `ETyApp` t `ETmApp` EVar varV1))
|
||||
convertPrim _ "UGetTime" (TUpdate TTimestamp) =
|
||||
EUpdate UGetTime
|
||||
pure $ EUpdate UGetTime
|
||||
|
||||
-- Scenario
|
||||
convertPrim _ "SPure" (a1 :-> TScenario a2) | a1 == a2 =
|
||||
ETmLam (varV1, a1) $ EScenario $ SPure a1 $ EVar varV1
|
||||
pure $ ETmLam (varV1, a1) $ EScenario $ SPure a1 $ EVar varV1
|
||||
convertPrim _ "SBind" (t1@(TScenario a1) :-> t2@(a2 :-> TScenario b1) :-> TScenario b2) | a1 == a2, b1 == b2 =
|
||||
ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EScenario $ SBind (Binding (varV3, a1) (EVar varV1)) (EVar varV2 `ETmApp` EVar varV3)
|
||||
pure $ ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EScenario $ SBind (Binding (varV3, a1) (EVar varV1)) (EVar varV2 `ETmApp` EVar varV3)
|
||||
convertPrim _ "SAbort" (TText :-> t@(TScenario a)) =
|
||||
ETmLam (varV1, TText) $ EScenario (SEmbedExpr a (EBuiltin BEError `ETyApp` t `ETmApp` EVar varV1))
|
||||
pure $ ETmLam (varV1, TText) $ EScenario (SEmbedExpr a (EBuiltin BEError `ETyApp` t `ETmApp` EVar varV1))
|
||||
convertPrim _ "SCommit" (t1@TParty :-> t2@(TUpdate a1) :-> TScenario a2) | a1 == a2 =
|
||||
ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EScenario $ SCommit a1 (EVar varV1) (EVar varV2)
|
||||
pure $ ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EScenario $ SCommit a1 (EVar varV1) (EVar varV2)
|
||||
convertPrim _ "SMustFailAt" (t1@TParty :-> t2@(TUpdate a1) :-> TScenario TUnit) =
|
||||
ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EScenario $ SMustFailAt a1 (EVar varV1) (EVar varV2)
|
||||
pure $ ETmLam (varV1, t1) $ ETmLam (varV2, t2) $ EScenario $ SMustFailAt a1 (EVar varV1) (EVar varV2)
|
||||
convertPrim _ "SPass" (t1@TInt64 :-> TScenario TTimestamp) =
|
||||
ETmLam (varV1, t1) $ EScenario $ SPass $ EVar varV1
|
||||
pure $ ETmLam (varV1, t1) $ EScenario $ SPass $ EVar varV1
|
||||
convertPrim _ "SGetTime" (TScenario TTimestamp) =
|
||||
EScenario SGetTime
|
||||
pure $ EScenario SGetTime
|
||||
convertPrim _ "SGetParty" (t1@TText :-> TScenario TParty) =
|
||||
ETmLam (varV1, t1) $ EScenario $ SGetParty $ EVar varV1
|
||||
pure $ ETmLam (varV1, t1) $ EScenario $ SGetParty $ EVar varV1
|
||||
|
||||
-- Comparison
|
||||
convertPrim _ "BEEqual" (a1 :-> a2 :-> TBool) | a1 == a2 =
|
||||
EBuiltin BEEqualGeneric `ETyApp` a1
|
||||
pure $ EBuiltin BEEqualGeneric `ETyApp` a1
|
||||
convertPrim _ "BELess" (a1 :-> a2 :-> TBool) | a1 == a2 =
|
||||
EBuiltin BELessGeneric `ETyApp` a1
|
||||
pure $ EBuiltin BELessGeneric `ETyApp` a1
|
||||
convertPrim _ "BELessEq" (a1 :-> a2 :-> TBool) | a1 == a2 =
|
||||
EBuiltin BELessEqGeneric `ETyApp` a1
|
||||
pure $ EBuiltin BELessEqGeneric `ETyApp` a1
|
||||
convertPrim _ "BEGreater" (a1 :-> a2 :-> TBool) | a1 == a2 =
|
||||
EBuiltin BEGreaterGeneric `ETyApp` a1
|
||||
pure $ EBuiltin BEGreaterGeneric `ETyApp` a1
|
||||
convertPrim _ "BEGreaterEq" (a1 :-> a2 :-> TBool) | a1 == a2 =
|
||||
EBuiltin BEGreaterEqGeneric `ETyApp` a1
|
||||
pure $ EBuiltin BEGreaterEqGeneric `ETyApp` a1
|
||||
convertPrim _ "BEEqualList" ((a1 :-> a2 :-> TBool) :-> TList a3 :-> TList a4 :-> TBool) | a1 == a2, a2 == a3, a3 == a4 =
|
||||
EBuiltin BEEqualList `ETyApp` a1
|
||||
pure $ EBuiltin BEEqualList `ETyApp` a1
|
||||
|
||||
-- Integer arithmetic
|
||||
convertPrim _ "BEAddInt64" (TInt64 :-> TInt64 :-> TInt64) =
|
||||
EBuiltin BEAddInt64
|
||||
pure $ EBuiltin BEAddInt64
|
||||
convertPrim _ "BESubInt64" (TInt64 :-> TInt64 :-> TInt64) =
|
||||
EBuiltin BESubInt64
|
||||
pure $ EBuiltin BESubInt64
|
||||
convertPrim _ "BEMulInt64" (TInt64 :-> TInt64 :-> TInt64) =
|
||||
EBuiltin BEMulInt64
|
||||
pure $ EBuiltin BEMulInt64
|
||||
convertPrim _ "BEDivInt64" (TInt64 :-> TInt64 :-> TInt64) =
|
||||
EBuiltin BEDivInt64
|
||||
pure $ EBuiltin BEDivInt64
|
||||
convertPrim _ "BEModInt64" (TInt64 :-> TInt64 :-> TInt64) =
|
||||
EBuiltin BEModInt64
|
||||
pure $ EBuiltin BEModInt64
|
||||
convertPrim _ "BEExpInt64" (TInt64 :-> TInt64 :-> TInt64) =
|
||||
EBuiltin BEExpInt64
|
||||
pure $ EBuiltin BEExpInt64
|
||||
|
||||
-- Time arithmetic
|
||||
convertPrim _ "BETimestampToUnixMicroseconds" (TTimestamp :-> TInt64) =
|
||||
EBuiltin BETimestampToUnixMicroseconds
|
||||
pure $ EBuiltin BETimestampToUnixMicroseconds
|
||||
convertPrim _ "BEUnixMicrosecondsToTimestamp" (TInt64 :-> TTimestamp) =
|
||||
EBuiltin BEUnixMicrosecondsToTimestamp
|
||||
pure $ EBuiltin BEUnixMicrosecondsToTimestamp
|
||||
convertPrim _ "BEDateToUnixDays" (TDate :-> TInt64) =
|
||||
EBuiltin BEDateToUnixDays
|
||||
pure $ EBuiltin BEDateToUnixDays
|
||||
convertPrim _ "BEUnixDaysToDate" (TInt64 :-> TDate) =
|
||||
EBuiltin BEUnixDaysToDate
|
||||
pure $ EBuiltin BEUnixDaysToDate
|
||||
|
||||
-- List operations
|
||||
convertPrim _ "BEFoldl" ((b1 :-> a1 :-> b2) :-> b3 :-> TList a2 :-> b4) | a1 == a2, b1 == b2, b2 == b3, b3 == b4 =
|
||||
EBuiltin BEFoldl `ETyApp` a1 `ETyApp` b1
|
||||
pure $ EBuiltin BEFoldl `ETyApp` a1 `ETyApp` b1
|
||||
convertPrim _ "BEFoldr" ((a1 :-> b1 :-> b2) :-> b3 :-> TList a2 :-> b4) | a1 == a2, b1 == b2, b2 == b3, b3 == b4 =
|
||||
EBuiltin BEFoldr `ETyApp` a1 `ETyApp` b1
|
||||
pure $ EBuiltin BEFoldr `ETyApp` a1 `ETyApp` b1
|
||||
|
||||
-- Error
|
||||
convertPrim _ "BEError" (TText :-> t2) =
|
||||
ETyApp (EBuiltin BEError) t2
|
||||
pure $ ETyApp (EBuiltin BEError) t2
|
||||
|
||||
-- Text operations
|
||||
convertPrim _ "BEToText" (TBuiltin x :-> TText) =
|
||||
EBuiltin $ BEToText x
|
||||
pure $ EBuiltin $ BEToText x
|
||||
convertPrim _ "BEExplodeText" (TText :-> TList TText) =
|
||||
EBuiltin BEExplodeText
|
||||
pure $ EBuiltin BEExplodeText
|
||||
convertPrim _ "BEImplodeText" (TList TText :-> TText) =
|
||||
EBuiltin BEImplodeText
|
||||
pure $ EBuiltin BEImplodeText
|
||||
convertPrim _ "BEAppendText" (TText :-> TText :-> TText) =
|
||||
EBuiltin BEAppendText
|
||||
pure $ EBuiltin BEAppendText
|
||||
convertPrim _ "BETrace" (TText :-> a1 :-> a2) | a1 == a2 =
|
||||
EBuiltin BETrace `ETyApp` a1
|
||||
pure $ EBuiltin BETrace `ETyApp` a1
|
||||
convertPrim _ "BESha256Text" (TText :-> TText) =
|
||||
EBuiltin BESha256Text
|
||||
pure $ EBuiltin BESha256Text
|
||||
convertPrim _ "BEPartyToQuotedText" (TParty :-> TText) =
|
||||
EBuiltin BEPartyToQuotedText
|
||||
pure $ EBuiltin BEPartyToQuotedText
|
||||
convertPrim _ "BETextToParty" (TText :-> TOptional TParty) =
|
||||
EBuiltin BETextToParty
|
||||
pure $ EBuiltin BETextToParty
|
||||
convertPrim _ "BETextToInt64" (TText :-> TOptional TInt64) =
|
||||
EBuiltin BETextToInt64
|
||||
pure $ EBuiltin BETextToInt64
|
||||
convertPrim _ "BETextToCodePoints" (TText :-> TList TInt64) =
|
||||
EBuiltin BETextToCodePoints
|
||||
pure $ EBuiltin BETextToCodePoints
|
||||
convertPrim _ "BECodePointsToText" (TList TInt64 :-> TText) =
|
||||
EBuiltin BECodePointsToText
|
||||
pure $ EBuiltin BECodePointsToText
|
||||
|
||||
-- Map operations
|
||||
|
||||
convertPrim _ "BETextMapEmpty" (TTextMap a) =
|
||||
EBuiltin BETextMapEmpty `ETyApp` a
|
||||
pure $ EBuiltin BETextMapEmpty `ETyApp` a
|
||||
convertPrim _ "BETextMapInsert" (TText :-> a1 :-> TTextMap a2 :-> TTextMap a3) | a1 == a2, a2 == a3 =
|
||||
EBuiltin BETextMapInsert `ETyApp` a1
|
||||
pure $ EBuiltin BETextMapInsert `ETyApp` a1
|
||||
convertPrim _ "BETextMapLookup" (TText :-> TTextMap a1 :-> TOptional a2) | a1 == a2 =
|
||||
EBuiltin BETextMapLookup `ETyApp` a1
|
||||
pure $ EBuiltin BETextMapLookup `ETyApp` a1
|
||||
convertPrim _ "BETextMapDelete" (TText :-> TTextMap a1 :-> TTextMap a2) | a1 == a2 =
|
||||
EBuiltin BETextMapDelete `ETyApp` a1
|
||||
pure $ EBuiltin BETextMapDelete `ETyApp` a1
|
||||
convertPrim _ "BETextMapToList" (TTextMap a1 :-> TList (TTextMapEntry a2)) | a1 == a2 =
|
||||
EBuiltin BETextMapToList `ETyApp` a1
|
||||
pure $ EBuiltin BETextMapToList `ETyApp` a1
|
||||
convertPrim _ "BETextMapSize" (TTextMap a :-> TInt64) =
|
||||
EBuiltin BETextMapSize `ETyApp` a
|
||||
pure $ EBuiltin BETextMapSize `ETyApp` a
|
||||
|
||||
|
||||
convertPrim _ "BEGenMapEmpty" (TGenMap a b) =
|
||||
EBuiltin BEGenMapEmpty `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BEGenMapEmpty `ETyApp` a `ETyApp` b
|
||||
convertPrim _ "BEGenMapInsert" (a :-> b :-> TGenMap a1 b1 :-> TGenMap a2 b2) | a == a1, a == a2, b == b1, b == b2 =
|
||||
EBuiltin BEGenMapInsert `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BEGenMapInsert `ETyApp` a `ETyApp` b
|
||||
convertPrim _ "BEGenMapLookup" (a1 :-> TGenMap a b :-> TOptional b1) | a == a1, b == b1 =
|
||||
EBuiltin BEGenMapLookup `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BEGenMapLookup `ETyApp` a `ETyApp` b
|
||||
convertPrim _ "BEGenMapDelete" (a2 :-> TGenMap a b :-> TGenMap a1 b1) | a == a1, a == a2, b == b1 =
|
||||
EBuiltin BEGenMapDelete `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BEGenMapDelete `ETyApp` a `ETyApp` b
|
||||
convertPrim _ "BEGenMapKeys" (TGenMap a b :-> TList a1) | a == a1 =
|
||||
EBuiltin BEGenMapKeys `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BEGenMapKeys `ETyApp` a `ETyApp` b
|
||||
convertPrim _ "BEGenMapValues" (TGenMap a b :-> TList b1) | b == b1 =
|
||||
EBuiltin BEGenMapValues `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BEGenMapValues `ETyApp` a `ETyApp` b
|
||||
convertPrim _ "BEGenMapSize" (TGenMap a b :-> TInt64) =
|
||||
EBuiltin BEGenMapSize `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BEGenMapSize `ETyApp` a `ETyApp` b
|
||||
|
||||
convertPrim _ "BECoerceContractId" (TContractId a :-> TContractId b) =
|
||||
EBuiltin BECoerceContractId `ETyApp` a `ETyApp` b
|
||||
pure $ EBuiltin BECoerceContractId `ETyApp` a `ETyApp` b
|
||||
|
||||
-- Decimal->Numeric compatibility. These will only be invoked when
|
||||
-- Numeric is available as a feature (otherwise it would not appear
|
||||
-- in the type) but Decimal primitives are still used (from the
|
||||
-- stdlib). Eventually the Decimal primitives will be phased out.
|
||||
convertPrim _ "BEAddDecimal" (TNumeric10 :-> TNumeric10 :-> TNumeric10) =
|
||||
ETyApp (EBuiltin BEAddNumeric) TNat10
|
||||
pure $ ETyApp (EBuiltin BEAddNumeric) TNat10
|
||||
convertPrim _ "BESubDecimal" (TNumeric10 :-> TNumeric10 :-> TNumeric10) =
|
||||
ETyApp (EBuiltin BESubNumeric) TNat10
|
||||
pure $ ETyApp (EBuiltin BESubNumeric) TNat10
|
||||
convertPrim _ "BEMulDecimal" (TNumeric10 :-> TNumeric10 :-> TNumeric10) =
|
||||
EBuiltin BEMulNumeric `ETyApp` TNat10 `ETyApp` TNat10 `ETyApp` TNat10
|
||||
pure $ EBuiltin BEMulNumeric `ETyApp` TNat10 `ETyApp` TNat10 `ETyApp` TNat10
|
||||
convertPrim _ "BEDivDecimal" (TNumeric10 :-> TNumeric10 :-> TNumeric10) =
|
||||
EBuiltin BEDivNumeric `ETyApp` TNat10 `ETyApp` TNat10 `ETyApp` TNat10
|
||||
pure $ EBuiltin BEDivNumeric `ETyApp` TNat10 `ETyApp` TNat10 `ETyApp` TNat10
|
||||
convertPrim _ "BERoundDecimal" (TInt64 :-> TNumeric10 :-> TNumeric10) =
|
||||
ETyApp (EBuiltin BERoundNumeric) TNat10
|
||||
pure $ ETyApp (EBuiltin BERoundNumeric) TNat10
|
||||
convertPrim _ "BEInt64ToDecimal" (TInt64 :-> TNumeric10) =
|
||||
ETyApp (EBuiltin BEInt64ToNumeric) TNat10
|
||||
pure $ ETyApp (EBuiltin BEInt64ToNumeric) TNat10
|
||||
convertPrim _ "BEDecimalToInt64" (TNumeric10 :-> TInt64) =
|
||||
ETyApp (EBuiltin BENumericToInt64) TNat10
|
||||
pure $ ETyApp (EBuiltin BENumericToInt64) TNat10
|
||||
convertPrim _ "BEToText" (TNumeric10 :-> TText) =
|
||||
ETyApp (EBuiltin BENumericToText) TNat10
|
||||
pure $ ETyApp (EBuiltin BENumericToText) TNat10
|
||||
convertPrim _ "BETextToDecimal" (TText :-> TOptional TNumeric10) =
|
||||
ETyApp (EBuiltin BETextToNumeric) TNat10
|
||||
pure $ ETyApp (EBuiltin BETextToNumeric) TNat10
|
||||
|
||||
-- Numeric primitives. These are polymorphic in the scale.
|
||||
convertPrim _ "BEAddNumeric" (TNumeric n1 :-> TNumeric n2 :-> TNumeric n3) | n1 == n2, n1 == n3 =
|
||||
ETyApp (EBuiltin BEAddNumeric) n1
|
||||
pure $ ETyApp (EBuiltin BEAddNumeric) n1
|
||||
convertPrim _ "BESubNumeric" (TNumeric n1 :-> TNumeric n2 :-> TNumeric n3) | n1 == n2, n1 == n3 =
|
||||
ETyApp (EBuiltin BESubNumeric) n1
|
||||
pure $ ETyApp (EBuiltin BESubNumeric) n1
|
||||
convertPrim _ "BEMulNumeric" (TNumeric n1 :-> TNumeric n2 :-> TNumeric n3) =
|
||||
EBuiltin BEMulNumeric `ETyApp` n1 `ETyApp` n2 `ETyApp` n3
|
||||
pure $ EBuiltin BEMulNumeric `ETyApp` n1 `ETyApp` n2 `ETyApp` n3
|
||||
convertPrim _ "BEDivNumeric" (TNumeric n1 :-> TNumeric n2 :-> TNumeric n3) =
|
||||
EBuiltin BEDivNumeric `ETyApp` n1 `ETyApp` n2 `ETyApp` n3
|
||||
pure $ EBuiltin BEDivNumeric `ETyApp` n1 `ETyApp` n2 `ETyApp` n3
|
||||
convertPrim _ "BERoundNumeric" (TInt64 :-> TNumeric n1 :-> TNumeric n2) | n1 == n2 =
|
||||
ETyApp (EBuiltin BERoundNumeric) n1
|
||||
pure $ ETyApp (EBuiltin BERoundNumeric) n1
|
||||
convertPrim _ "BECastNumeric" (TNumeric n1 :-> TNumeric n2) =
|
||||
EBuiltin BECastNumeric `ETyApp` n1 `ETyApp` n2
|
||||
pure $ EBuiltin BECastNumeric `ETyApp` n1 `ETyApp` n2
|
||||
convertPrim _ "BEShiftNumeric" (TNumeric n1 :-> TNumeric n2) =
|
||||
EBuiltin BEShiftNumeric `ETyApp` n1 `ETyApp` n2
|
||||
pure $ EBuiltin BEShiftNumeric `ETyApp` n1 `ETyApp` n2
|
||||
convertPrim _ "BEInt64ToNumeric" (TInt64 :-> TNumeric n) =
|
||||
ETyApp (EBuiltin BEInt64ToNumeric) n
|
||||
pure $ ETyApp (EBuiltin BEInt64ToNumeric) n
|
||||
convertPrim _ "BENumericToInt64" (TNumeric n :-> TInt64) =
|
||||
ETyApp (EBuiltin BENumericToInt64) n
|
||||
pure $ ETyApp (EBuiltin BENumericToInt64) n
|
||||
convertPrim _ "BENumericToText" (TNumeric n :-> TText) =
|
||||
ETyApp (EBuiltin BENumericToText) n
|
||||
pure $ ETyApp (EBuiltin BENumericToText) n
|
||||
convertPrim _ "BETextToNumeric" (TText :-> TOptional (TNumeric n)) =
|
||||
ETyApp (EBuiltin BETextToNumeric) n
|
||||
pure $ ETyApp (EBuiltin BETextToNumeric) n
|
||||
|
||||
convertPrim version "BEScaleBigNumeric" ty@(TBigNumeric :-> TInt64) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEScaleBigNumeric
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEScaleBigNumeric
|
||||
convertPrim version "BEPrecisionBigNumeric" ty@(TBigNumeric :-> TInt64) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEPrecisionBigNumeric
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEPrecisionBigNumeric
|
||||
convertPrim version "BEAddBigNumeric" ty@(TBigNumeric :-> TBigNumeric :-> TBigNumeric) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEAddBigNumeric
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEAddBigNumeric
|
||||
convertPrim version "BESubBigNumeric" ty@(TBigNumeric :-> TBigNumeric :-> TBigNumeric) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BESubBigNumeric
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BESubBigNumeric
|
||||
convertPrim version "BEMulBigNumeric" ty@(TBigNumeric :-> TBigNumeric :-> TBigNumeric) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEMulBigNumeric
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEMulBigNumeric
|
||||
convertPrim version "BEDivBigNumeric" ty@(TInt64 :-> TRoundingMode :-> TBigNumeric :-> TBigNumeric :-> TBigNumeric) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEDivBigNumeric
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEDivBigNumeric
|
||||
convertPrim version "BEShiftRightBigNumeric" ty@(TInt64 :-> TBigNumeric :-> TBigNumeric) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEShiftRightBigNumeric
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEShiftRightBigNumeric
|
||||
convertPrim version "BENumericToBigNumeric" ty@(TNumeric n :-> TBigNumeric) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BENumericToBigNumeric `ETyApp` n
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BENumericToBigNumeric `ETyApp` n
|
||||
convertPrim version "BEBigNumericToNumeric" ty@(TBigNumeric :-> TNumeric n) =
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEBigNumericToNumeric `ETyApp` n
|
||||
pure $
|
||||
whenRuntimeSupports version featureBigNumeric ty $
|
||||
EBuiltin BEBigNumericToNumeric `ETyApp` n
|
||||
|
||||
-- Experimental text primitives.
|
||||
convertPrim _ "BETextToUpper" (TText :-> TText) = EBuiltin BETextToUpper
|
||||
convertPrim _ "BETextToLower" (TText :-> TText) = EBuiltin BETextToLower
|
||||
convertPrim _ "BETextSlice" (TInt64 :-> TInt64 :-> TText :-> TText) = EBuiltin BETextSlice
|
||||
convertPrim _ "BETextSliceIndex" (TText :-> TText :-> TOptional TInt64) = EBuiltin BETextSliceIndex
|
||||
convertPrim _ "BETextContainsOnly" (TText :-> TText :-> TBool) = EBuiltin BETextContainsOnly
|
||||
convertPrim _ "BETextReplicate" (TInt64 :-> TText :-> TText) = EBuiltin BETextReplicate
|
||||
convertPrim _ "BETextSplitOn" (TText :-> TText :-> TList TText) = EBuiltin BETextSplitOn
|
||||
convertPrim _ "BETextIntercalate" (TText :-> TList TText :-> TText) = EBuiltin BETextIntercalate
|
||||
convertPrim _ "BETextToUpper" (TText :-> TText) = pure $ EBuiltin BETextToUpper
|
||||
convertPrim _ "BETextToLower" (TText :-> TText) = pure $ EBuiltin BETextToLower
|
||||
convertPrim _ "BETextSlice" (TInt64 :-> TInt64 :-> TText :-> TText) = pure $ EBuiltin BETextSlice
|
||||
convertPrim _ "BETextSliceIndex" (TText :-> TText :-> TOptional TInt64) = pure $ EBuiltin BETextSliceIndex
|
||||
convertPrim _ "BETextContainsOnly" (TText :-> TText :-> TBool) = pure $ EBuiltin BETextContainsOnly
|
||||
convertPrim _ "BETextReplicate" (TInt64 :-> TText :-> TText) = pure $ EBuiltin BETextReplicate
|
||||
convertPrim _ "BETextSplitOn" (TText :-> TText :-> TList TText) = pure $ EBuiltin BETextSplitOn
|
||||
convertPrim _ "BETextIntercalate" (TText :-> TList TText :-> TText) = pure $ EBuiltin BETextIntercalate
|
||||
|
||||
-- Conversion from ContractId to Text
|
||||
|
||||
convertPrim _ "BEContractIdToText" (TContractId t :-> TOptional TText) =
|
||||
ETyApp (EBuiltin BEContractIdToText) t
|
||||
pure $ ETyApp (EBuiltin BEContractIdToText) t
|
||||
|
||||
|
||||
-- Template Desugaring.
|
||||
|
||||
convertPrim _ "UCreate" (TCon template :-> TUpdate (TContractId (TCon template')))
|
||||
| template == template' =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TCon template) $
|
||||
EUpdate $ UCreate template (EVar (mkVar "this"))
|
||||
|
||||
convertPrim _ "UCreateInterface" (TCon interface :-> TUpdate (TContractId (TCon interface')))
|
||||
| interface == interface' =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TCon interface) $
|
||||
EUpdate $ UCreateInterface interface (EVar (mkVar "this"))
|
||||
|
||||
convertPrim _ "UFetch" (TContractId (TCon template) :-> TUpdate (TCon template'))
|
||||
| template == template' =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TContractId (TCon template)) $
|
||||
EUpdate $ UFetch template (EVar (mkVar "this"))
|
||||
|
||||
convertPrim _ "UFetchInterface" (TContractId (TCon iface) :-> TUpdate (TCon iface'))
|
||||
| iface == iface' =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TContractId (TCon iface)) $
|
||||
EUpdate $ UFetchInterface iface (EVar (mkVar "this"))
|
||||
|
||||
convertPrim _ "UExercise"
|
||||
(TContractId (TCon template) :-> TCon choice :-> TUpdate _returnTy) =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TContractId (TCon template)) $
|
||||
ETmLam (mkVar "arg", TCon choice) $
|
||||
EUpdate $ UExercise template choiceName (EVar (mkVar "this")) (EVar (mkVar "arg"))
|
||||
@ -274,6 +289,7 @@ convertPrim _ "UExerciseInterface"
|
||||
( TContractId (TCon iface)
|
||||
:-> TCon choice
|
||||
:-> TUpdate _returnTy) =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TContractId (TCon iface)) $
|
||||
ETmLam (mkVar "arg", TCon choice) $
|
||||
EUpdate $ UExerciseInterface
|
||||
@ -286,12 +302,17 @@ convertPrim _ "UExerciseInterface"
|
||||
where
|
||||
choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choice)
|
||||
|
||||
convertPrim version "UExerciseInterfaceGuarded" _
|
||||
| not (version `supports` featureExtendedInterfaces) =
|
||||
conversionError "Guards on choice exercises are only available with --target=1.dev"
|
||||
|
||||
convertPrim _ "UExerciseInterfaceGuarded"
|
||||
( TContractId (TCon iface)
|
||||
:-> TCon choice
|
||||
:-> (TCon iface2 :-> TBuiltin BTBool)
|
||||
:-> TUpdate _returnTy)
|
||||
| iface == iface2 =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TContractId (TCon iface)) $
|
||||
ETmLam (mkVar "arg", TCon choice) $
|
||||
ETmLam (mkVar "pred", TCon iface :-> TBuiltin BTBool) $
|
||||
@ -307,6 +328,7 @@ convertPrim _ "UExerciseInterfaceGuarded"
|
||||
|
||||
convertPrim _ "UExerciseByKey"
|
||||
(tProxy@(TApp _ (TCon template)) :-> key :-> TCon choice :-> TUpdate _returnTy) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETmLam (mkVar "key", key) $
|
||||
ETmLam (mkVar "arg", TCon choice) $
|
||||
@ -315,12 +337,14 @@ convertPrim _ "UExerciseByKey"
|
||||
choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choice)
|
||||
|
||||
convertPrim _ "ULookupByKey" (key :-> TUpdate (TOptional (TContractId (TCon template)))) =
|
||||
ETmLam (mkVar "key", key) $ EUpdate $
|
||||
pure $
|
||||
ETmLam (mkVar "key", key) $ EUpdate $
|
||||
ULookupByKey $ RetrieveByKey template (EVar $ mkVar "key")
|
||||
|
||||
convertPrim _ "UFetchByKey"
|
||||
(key :-> TUpdate ty@(TApp (TApp (TCon tuple) ty1@(TContractId (TCon template))) ty2))
|
||||
| ty2 == TCon template =
|
||||
pure $
|
||||
ETmLam (mkVar "key", key) $
|
||||
EUpdate $ UBind
|
||||
(Binding (mkVar "res", TStruct
|
||||
@ -334,22 +358,26 @@ convertPrim _ "UFetchByKey"
|
||||
|
||||
convertPrim _ "ETemplateTypeRep"
|
||||
(tProxy@(TApp _ tCon@(TCon _)) :-> TTypeRep) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETypeRep tCon
|
||||
|
||||
convertPrim _ "EFromAnyTemplate"
|
||||
(TAny :-> TOptional (TCon template)) =
|
||||
pure $
|
||||
ETmLam (mkVar "any", TAny) $
|
||||
EFromAny (TCon template) (EVar $ mkVar "any")
|
||||
|
||||
convertPrim _ "EFromAnyTemplateChoice"
|
||||
(tProxy :-> TAny :-> TOptional choice) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETmLam (mkVar "any", TAny) $
|
||||
EFromAny choice (EVar $ mkVar "any")
|
||||
|
||||
convertPrim _ "EFromAnyInterfaceChoice"
|
||||
(tProxy :-> TAny :-> TOptional choice) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETmLam (mkVar "any", TAny) $
|
||||
ECase (EFromAny (mkTAnyInterfaceChoice choice) (EVar $ mkVar "any"))
|
||||
@ -358,59 +386,68 @@ convertPrim _ "EFromAnyInterfaceChoice"
|
||||
|
||||
convertPrim _ "EFromAnyContractKey"
|
||||
(tProxy@(TApp _ (TCon _)) :-> TAny :-> TOptional key) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETmLam (mkVar "any", TAny) $
|
||||
EFromAny key (EVar $ mkVar "any")
|
||||
|
||||
convertPrim _ "EToAnyTemplate"
|
||||
(TCon template :-> TAny) =
|
||||
pure $
|
||||
ETmLam (mkVar "template", TCon template) $
|
||||
EToAny (TCon template) (EVar $ mkVar "template")
|
||||
|
||||
convertPrim _ "EToAnyTemplateChoice"
|
||||
(tProxy :-> choice :-> TAny) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETmLam (mkVar "choice", choice) $
|
||||
EToAny choice (EVar $ mkVar "choice")
|
||||
|
||||
convertPrim _ "EToAnyInterfaceChoice"
|
||||
(tProxy@(TApp _ (TCon typeId)) :-> choice :-> TAny) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETmLam (mkVar "choice", choice) $
|
||||
EToAny (mkTAnyInterfaceChoice choice) (mkEAnyInterfaceChoice choice typeId $ EVar $ mkVar "choice")
|
||||
|
||||
convertPrim _ "EToAnyContractKey"
|
||||
(tProxy@(TApp _ (TCon _)) :-> key :-> TAny) =
|
||||
pure $
|
||||
ETmLam (mkVar "_", tProxy) $
|
||||
ETmLam (mkVar "key", key) $
|
||||
EToAny key (EVar $ mkVar "key")
|
||||
|
||||
convertPrim _ "EInterfaceTemplateTypeRep" (TCon interface :-> TTypeRep) =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TCon interface) $
|
||||
EInterfaceTemplateTypeRep interface (EVar (mkVar "this"))
|
||||
|
||||
convertPrim _ "ESignatoryInterface" (TCon interface :-> TList TParty) =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TCon interface) $
|
||||
ESignatoryInterface interface (EVar (mkVar "this"))
|
||||
|
||||
convertPrim _ "EObserverInterface" (TCon interface :-> TList TParty) =
|
||||
pure $
|
||||
ETmLam (mkVar "this", TCon interface) $
|
||||
EObserverInterface interface (EVar (mkVar "this"))
|
||||
|
||||
-- Exceptions
|
||||
convertPrim _ "BEAnyExceptionMessage" (TBuiltin BTAnyException :-> TText) =
|
||||
EBuiltin BEAnyExceptionMessage
|
||||
pure $ EBuiltin BEAnyExceptionMessage
|
||||
|
||||
convertPrim _ "EThrow" (ty1 :-> ty2) =
|
||||
ETmLam (mkVar "x", ty1) (EThrow ty2 ty1 (EVar (mkVar "x")))
|
||||
pure $ ETmLam (mkVar "x", ty1) (EThrow ty2 ty1 (EVar (mkVar "x")))
|
||||
convertPrim _ "EToAnyException" (ty :-> TBuiltin BTAnyException) =
|
||||
ETmLam (mkVar "x", ty) (EToAnyException ty (EVar (mkVar "x")))
|
||||
pure $ ETmLam (mkVar "x", ty) (EToAnyException ty (EVar (mkVar "x")))
|
||||
convertPrim _ "EFromAnyException" (TBuiltin BTAnyException :-> TOptional ty) =
|
||||
ETmLam (mkVar "x", TBuiltin BTAnyException) (EFromAnyException ty (EVar (mkVar "x")))
|
||||
pure $ ETmLam (mkVar "x", TBuiltin BTAnyException) (EFromAnyException ty (EVar (mkVar "x")))
|
||||
|
||||
convertPrim _ "UTryCatch" ((TUnit :-> TUpdate t1) :-> (TBuiltin BTAnyException :-> TOptional (TUpdate t2)) :-> TUpdate t3)
|
||||
| t1 == t2, t2 == t3
|
||||
= ETmLam (mkVar "t", TUnit :-> TUpdate t1)
|
||||
= pure
|
||||
$ ETmLam (mkVar "t", TUnit :-> TUpdate t1)
|
||||
$ ETmLam (mkVar "c", TBuiltin BTAnyException :-> TOptional (TUpdate t2))
|
||||
$ EUpdate
|
||||
$ UTryCatch t3
|
||||
@ -419,44 +456,62 @@ convertPrim _ "UTryCatch" ((TUnit :-> TUpdate t1) :-> (TBuiltin BTAnyException :
|
||||
(EVar (mkVar "c") `ETmApp` EVar (mkVar "x"))
|
||||
|
||||
convertPrim _ "EToInterface" (TCon tpid :-> TCon iface) =
|
||||
ETmLam (mkVar "t", TCon tpid) $
|
||||
pure $
|
||||
ETmLam (mkVar "t", TCon tpid) $
|
||||
EToInterface iface tpid (EVar $ mkVar "t")
|
||||
|
||||
convertPrim _ "EFromInterface" (TCon iface :-> TOptional (TCon tpid)) =
|
||||
ETmLam (mkVar "i", TCon iface) $
|
||||
pure $
|
||||
ETmLam (mkVar "i", TCon iface) $
|
||||
EFromInterface iface tpid (EVar $ mkVar "i")
|
||||
|
||||
convertPrim _ "EUnsafeFromInterface" (TContractId (TCon iface) :-> TCon iface1 :-> TCon tpid)
|
||||
| iface == iface1
|
||||
= ETmLam (mkVar "cid", TContractId (TCon iface))
|
||||
= pure
|
||||
$ ETmLam (mkVar "cid", TContractId (TCon iface))
|
||||
$ ETmLam (mkVar "i", TCon iface)
|
||||
$ EUnsafeFromInterface iface tpid (EVar $ mkVar "cid") (EVar $ mkVar "i")
|
||||
|
||||
convertPrim _ "EToRequiredInterface" (TCon subIface :-> TCon superIface) =
|
||||
ETmLam (mkVar "i", TCon subIface) $
|
||||
pure $
|
||||
ETmLam (mkVar "i", TCon subIface) $
|
||||
EToRequiredInterface superIface subIface (EVar $ mkVar "i")
|
||||
|
||||
convertPrim _ "EToRequiredInterface" ty@(TCon _ :-> retTy) =
|
||||
pure $ runtimeError ty $ "Tried to convert to a required interface '" <> T.pack (renderPretty retTy) <> "', but that type is not an interface."
|
||||
|
||||
convertPrim _ "EFromRequiredInterface" (TCon superIface :-> TOptional (TCon subIface)) =
|
||||
ETmLam (mkVar "i", TCon superIface) $
|
||||
pure $
|
||||
ETmLam (mkVar "i", TCon superIface) $
|
||||
EFromRequiredInterface superIface subIface (EVar $ mkVar "i")
|
||||
|
||||
convertPrim _ "EFromRequiredInterface" ty@(fromTy :-> TOptional (TCon _)) =
|
||||
pure $ runtimeError ty $ "Tried to convert from a required interface '" <> T.pack (renderPretty fromTy) <> "', but that type is not an interface."
|
||||
|
||||
convertPrim _ "EUnsafeFromRequiredInterface" (TContractId (TCon superIface) :-> TCon superIface1 :-> TCon subIface)
|
||||
| superIface == superIface1
|
||||
= ETmLam (mkVar "cid", TContractId (TCon superIface))
|
||||
= pure
|
||||
$ ETmLam (mkVar "cid", TContractId (TCon superIface))
|
||||
$ ETmLam (mkVar "i", TCon superIface)
|
||||
$ EUnsafeFromRequiredInterface superIface subIface (EVar $ mkVar "cid") (EVar $ mkVar "i")
|
||||
|
||||
convertPrim _ "ETypeRepTyConName" (TTypeRep :-> TOptional TText) = EBuiltin BETypeRepTyConName
|
||||
convertPrim _ "EUnsafeFromRequiredInterface" ty@(TContractId fromTy :-> fromTy1 :-> TCon _)
|
||||
| fromTy == fromTy1
|
||||
= pure $ runtimeError ty $ "Tried to unsafely convert from a required interface '" <> T.pack (renderPretty fromTy) <> "', but that type is not an interface."
|
||||
|
||||
convertPrim _ "ETypeRepTyConName" (TTypeRep :-> TOptional TText) = pure $ EBuiltin BETypeRepTyConName
|
||||
|
||||
convertPrim _ "EViewInterface" (TCon iface :-> _) =
|
||||
ETmLam (mkVar "i", TCon iface) $
|
||||
pure $
|
||||
ETmLam (mkVar "i", TCon iface) $
|
||||
EViewInterface iface (EVar $ mkVar "i")
|
||||
|
||||
convertPrim (V1 PointDev) (L.stripPrefix "$" -> Just builtin) typ =
|
||||
EExperimental (T.pack builtin) typ
|
||||
pure $
|
||||
EExperimental (T.pack builtin) typ
|
||||
|
||||
-- Unknown primitive.
|
||||
convertPrim _ x ty = error $ "Unknown primitive " ++ show x ++ " at type " ++ renderPretty ty
|
||||
convertPrim _ x ty = conversionError $ "Unknown primitive " ++ show x ++ " at type " ++ renderPretty ty
|
||||
|
||||
typeRepField, choiceField :: FieldName
|
||||
typeRepField = FieldName "choiceInterfaceIdRep"
|
||||
@ -475,10 +530,11 @@ projChoice _ = EStructProj choiceField
|
||||
whenRuntimeSupports :: Version -> Feature -> Type -> Expr -> Expr
|
||||
whenRuntimeSupports version feature t e
|
||||
| version `supports` feature = e
|
||||
| otherwise = runtimeUnsupported feature t
|
||||
| otherwise = runtimeError t (featureErrorMessage feature)
|
||||
|
||||
runtimeUnsupported :: Feature -> Type -> Expr
|
||||
runtimeUnsupported (Feature name version _) t =
|
||||
ETmApp
|
||||
(ETyApp (EBuiltin BEError) t)
|
||||
(EBuiltin (BEText (name <> " only supported when compiling to Daml-LF " <> T.pack (renderVersion version) <> " or later")))
|
||||
runtimeError :: Type -> T.Text -> Expr
|
||||
runtimeError t msg = ETmApp (ETyApp (EBuiltin BEError) t) (EBuiltin (BEText msg))
|
||||
|
||||
featureErrorMessage :: Feature -> T.Text
|
||||
featureErrorMessage (Feature name version _) =
|
||||
name <> " only supported when compiling to Daml-LF " <> T.pack (renderVersion version) <> " or later"
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- | MOVE Prelude interface functionality
|
||||
module DA.Internal.Interface (
|
||||
@ -16,7 +17,6 @@ module DA.Internal.Interface (
|
||||
toInterfaceContractId,
|
||||
fromInterfaceContractId,
|
||||
fetchFromInterface,
|
||||
_exerciseDefault,
|
||||
_exerciseInterfaceGuard,
|
||||
HasInterfaceView(..),
|
||||
view
|
||||
@ -141,12 +141,7 @@ fetchFromInterface cid = do
|
||||
None -> pure None
|
||||
Some tpl -> pure (Some (fromInterfaceContractId @t cid, tpl))
|
||||
|
||||
-- | HIDE Gives a valid implementation of `HasExercise.exercise`
|
||||
-- for types that implement `HasExerciseGuarded`. This is used
|
||||
-- in interface desugaring.
|
||||
_exerciseDefault : HasExerciseGuarded t c r => ContractId t -> c -> Update r
|
||||
_exerciseDefault = exerciseGuarded (const True)
|
||||
|
||||
#ifdef DAML_INTERFACE_EXTENDED
|
||||
-- | HIDE The guard used for UExerciseInterface, during interface
|
||||
-- desugaring. This function converts a guard on type t into a
|
||||
-- guard on the type i, raising a WronglyTypedContract error if
|
||||
@ -164,6 +159,11 @@ _exerciseInterfaceGuard : forall i t.
|
||||
ContractId t -> (t -> Bool) -> i -> Bool
|
||||
_exerciseInterfaceGuard cid tpred ivalue =
|
||||
tpred (unsafeFromInterface (coerceContractId cid) ivalue)
|
||||
#else
|
||||
_exerciseInterfaceGuard : forall t i a b c. a -> b -> c -> Bool
|
||||
_exerciseInterfaceGuard cid tpred ivalue =
|
||||
error "Interfaces not supported in this version of Daml LF"
|
||||
#endif
|
||||
|
||||
-- Read: Interface `i` has a view of type `v`
|
||||
class HasInterfaceView i v | i -> v where
|
||||
|
||||
@ -0,0 +1,167 @@
|
||||
module InterfaceChoiceGuardFailedNotExtended where
|
||||
import (implicit) qualified DA.Internal.Record
|
||||
import (implicit) qualified GHC.Types
|
||||
import (implicit) qualified DA.Internal.Desugar
|
||||
import (implicit) DA.Internal.RebindableSyntax
|
||||
data EmptyInterfaceView = EmptyInterfaceView {}
|
||||
data GHC.Types.DamlInterface => I = I GHC.Types.Opaque
|
||||
instance DA.Internal.Desugar.HasInterfaceTypeRep I where
|
||||
_interfaceTypeRep
|
||||
= GHC.Types.primitive @"EInterfaceTemplateTypeRep"
|
||||
instance DA.Internal.Desugar.HasFetch I where
|
||||
fetch = GHC.Types.primitive @"UFetchInterface"
|
||||
instance DA.Internal.Desugar.HasToInterface I I where
|
||||
_toInterface this = this
|
||||
instance DA.Internal.Desugar.HasFromInterface I I where
|
||||
fromInterface this = DA.Internal.Desugar.Some this
|
||||
unsafeFromInterface _ this = this
|
||||
instance DA.Internal.Desugar.HasMethod I "getController" (Party)
|
||||
getController : I -> Party
|
||||
getController = GHC.Types.primitiveInterface @"getController"
|
||||
instance DA.Internal.Desugar.HasToAnyTemplate I where
|
||||
_toAnyTemplate = GHC.Types.primitive @"EToAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasFromAnyTemplate I where
|
||||
_fromAnyTemplate = GHC.Types.primitive @"EFromAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasTemplateTypeRep I where
|
||||
_templateTypeRep = GHC.Types.primitive @"ETemplateTypeRep"
|
||||
instance DA.Internal.Desugar.HasSignatory I where
|
||||
signatory = GHC.Types.primitive @"ESignatoryInterface"
|
||||
instance DA.Internal.Desugar.HasObserver I where
|
||||
observer = GHC.Types.primitive @"EObserverInterface"
|
||||
instance DA.Internal.Desugar.HasCreate I where
|
||||
create = GHC.Types.primitive @"UCreateInterface"
|
||||
instance DA.Internal.Desugar.HasIsInterfaceType I where
|
||||
_isInterfaceType _ = DA.Internal.Desugar.True
|
||||
instance DA.Internal.Desugar.Eq I where
|
||||
(==) = GHC.Types.primitive @"BEEqual"
|
||||
instance DA.Internal.Desugar.HasToAnyChoice I IChoice (()) where
|
||||
_toAnyChoice _
|
||||
= GHC.Types.primitive @"EToAnyInterfaceChoice" ([] : [I])
|
||||
instance DA.Internal.Desugar.HasFromAnyChoice I IChoice (()) where
|
||||
_fromAnyChoice _
|
||||
= GHC.Types.primitive @"EFromAnyInterfaceChoice" ([] : [I])
|
||||
instance DA.Internal.Desugar.HasExerciseGuarded I IChoice (()) where
|
||||
exerciseGuarded pred cid arg
|
||||
= GHC.Types.primitive
|
||||
@"UExerciseInterfaceGuarded"
|
||||
(DA.Internal.Desugar.toInterfaceContractId @I cid)
|
||||
arg
|
||||
(DA.Internal.Desugar._exerciseInterfaceGuard @I cid pred)
|
||||
instance DA.Internal.Desugar.HasExercise I IChoice (()) where
|
||||
exercise cid arg
|
||||
= GHC.Types.primitive
|
||||
@"UExerciseInterface"
|
||||
(DA.Internal.Desugar.toInterfaceContractId @I cid)
|
||||
arg
|
||||
data IChoice
|
||||
= IChoice {}
|
||||
deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
|
||||
_choice_IIChoice :
|
||||
(I -> IChoice -> [DA.Internal.Desugar.Party],
|
||||
DA.Internal.Desugar.ContractId I
|
||||
-> I -> IChoice -> DA.Internal.Desugar.Update (()),
|
||||
DA.Internal.Desugar.Consuming I,
|
||||
DA.Internal.Desugar.Optional (I
|
||||
-> IChoice -> [DA.Internal.Desugar.Party]))
|
||||
_choice_IIChoice
|
||||
= (\ this arg@IChoice
|
||||
-> let _ = this in
|
||||
let _ = arg in DA.Internal.Desugar.toParties (getController this),
|
||||
\ self this arg@IChoice
|
||||
-> let _ = self in let _ = this in let _ = arg in do pure (),
|
||||
DA.Internal.Desugar.Consuming, DA.Internal.Desugar.None)
|
||||
instance DA.Internal.Desugar.HasInterfaceView I EmptyInterfaceView where
|
||||
_view = GHC.Types.primitive @"EViewInterface"
|
||||
data GHC.Types.DamlTemplate => T
|
||||
= T {party : Party}
|
||||
deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
|
||||
instance DA.Internal.Record.HasField "party" T Party where
|
||||
getField = DA.Internal.Record.getFieldPrim @"party" @T @Party
|
||||
setField = DA.Internal.Record.setFieldPrim @"party" @T @Party
|
||||
instance DA.Internal.Desugar.HasSignatory T where
|
||||
signatory this@T {..}
|
||||
= DA.Internal.Desugar.toParties (party)
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasObserver T where
|
||||
observer this@T {..}
|
||||
= []
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasEnsure T where
|
||||
ensure this@T {..}
|
||||
= DA.Internal.Desugar.True
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasAgreement T where
|
||||
agreement this@T {..}
|
||||
= ""
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasArchive T where
|
||||
archive cid
|
||||
= DA.Internal.Desugar.exercise cid DA.Internal.Desugar.Archive
|
||||
where
|
||||
_ = cid
|
||||
instance DA.Internal.Desugar.HasCreate T where
|
||||
create = GHC.Types.primitive @"UCreate"
|
||||
instance DA.Internal.Desugar.HasFetch T where
|
||||
fetch = GHC.Types.primitive @"UFetch"
|
||||
instance DA.Internal.Desugar.HasToAnyTemplate T where
|
||||
_toAnyTemplate = GHC.Types.primitive @"EToAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasFromAnyTemplate T where
|
||||
_fromAnyTemplate = GHC.Types.primitive @"EFromAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasTemplateTypeRep T where
|
||||
_templateTypeRep = GHC.Types.primitive @"ETemplateTypeRep"
|
||||
instance DA.Internal.Desugar.HasIsInterfaceType T where
|
||||
_isInterfaceType _ = DA.Internal.Desugar.False
|
||||
instance DA.Internal.Desugar.HasExercise T DA.Internal.Desugar.Archive (()) where
|
||||
exercise = GHC.Types.primitive @"UExercise"
|
||||
instance DA.Internal.Desugar.HasToAnyChoice T DA.Internal.Desugar.Archive (()) where
|
||||
_toAnyChoice = GHC.Types.primitive @"EToAnyTemplateChoice"
|
||||
instance DA.Internal.Desugar.HasFromAnyChoice T DA.Internal.Desugar.Archive (()) where
|
||||
_fromAnyChoice = GHC.Types.primitive @"EFromAnyTemplateChoice"
|
||||
_choice_TArchive :
|
||||
(T -> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party],
|
||||
DA.Internal.Desugar.ContractId T
|
||||
-> T
|
||||
-> DA.Internal.Desugar.Archive -> DA.Internal.Desugar.Update (()),
|
||||
DA.Internal.Desugar.Consuming T,
|
||||
DA.Internal.Desugar.Optional (T
|
||||
-> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party]))
|
||||
_choice_TArchive
|
||||
= (\ this _ -> DA.Internal.Desugar.signatory this,
|
||||
\ _ _ _ -> pure (), DA.Internal.Desugar.Consuming,
|
||||
DA.Internal.Desugar.None)
|
||||
_interface_instance_T_I_T :
|
||||
DA.Internal.Desugar.InterfaceInstance T I T
|
||||
_interface_instance_T_I_T
|
||||
= DA.Internal.Desugar.mkInterfaceInstance @T @I @T
|
||||
_method_T_I_T_getController :
|
||||
DA.Internal.Desugar.Method T I T "getController"
|
||||
_method_T_I_T_getController
|
||||
= DA.Internal.Desugar.mkMethod
|
||||
@T
|
||||
@I
|
||||
@T
|
||||
@"getController"
|
||||
\ this@T {..}
|
||||
-> let _ = this in let getController = party in getController
|
||||
_view_T_I_T : DA.Internal.Desugar.InterfaceView T I T
|
||||
_view_T_I_T
|
||||
= DA.Internal.Desugar.mkInterfaceView
|
||||
@T
|
||||
@I
|
||||
@T
|
||||
\ this@T {..}
|
||||
-> let _ = this in let view = EmptyInterfaceView in view
|
||||
instance DA.Internal.Desugar.HasToInterface T I where
|
||||
_toInterface = GHC.Types.primitive @"EToInterface"
|
||||
instance DA.Internal.Desugar.HasFromInterface T I where
|
||||
fromInterface = GHC.Types.primitive @"EFromInterface"
|
||||
unsafeFromInterface = GHC.Types.primitive @"EUnsafeFromInterface"
|
||||
main
|
||||
= do alice <- getParty "alice"
|
||||
cidT <- alice `submit` create T {party = alice}
|
||||
let cidI = toInterfaceContractId @I cidT
|
||||
alice `submit` exerciseGuarded (const False) cidI IChoice
|
||||
@ -0,0 +1,32 @@
|
||||
-- Copyright (c) 2022, Digital Asset (Switzerland) GmbH and/or its affiliates.
|
||||
-- All rights reserved.
|
||||
|
||||
module InterfaceChoiceGuardFailedNotExtended where
|
||||
|
||||
-- @SINCE-LF-FEATURE DAML_INTERFACE
|
||||
-- @UNTIL-LF-FEATURE DAML_INTERFACE_EXTENDED
|
||||
-- @ERROR Guarded exercises are only available with --target=1.dev
|
||||
data EmptyInterfaceView = EmptyInterfaceView {}
|
||||
|
||||
interface I where
|
||||
viewtype EmptyInterfaceView
|
||||
getController : Party
|
||||
choice IChoice : ()
|
||||
controller getController this
|
||||
do pure ()
|
||||
|
||||
template T
|
||||
with
|
||||
party : Party
|
||||
where
|
||||
signatory party
|
||||
interface instance I for T where
|
||||
view = EmptyInterfaceView
|
||||
getController = party
|
||||
|
||||
-- @ENABLE-SCENARIOS
|
||||
main = do
|
||||
alice <- getParty "alice"
|
||||
cidT <- alice `submit` create T with party = alice
|
||||
let cidI = toInterfaceContractId @I cidT
|
||||
alice `submit` exerciseGuarded (const False) cidI IChoice
|
||||
@ -0,0 +1,392 @@
|
||||
module InterfaceGuardedNotExtended where
|
||||
import (implicit) qualified DA.Internal.Record
|
||||
import (implicit) qualified GHC.Types
|
||||
import (implicit) qualified DA.Internal.Desugar
|
||||
import (implicit) DA.Internal.RebindableSyntax
|
||||
import DA.Exception ( GeneralError(..), throwPure )
|
||||
data EmptyInterfaceView = EmptyInterfaceView {}
|
||||
data GHC.Types.DamlInterface => Token = Token GHC.Types.Opaque
|
||||
instance DA.Internal.Desugar.HasInterfaceTypeRep Token where
|
||||
_interfaceTypeRep
|
||||
= GHC.Types.primitive @"EInterfaceTemplateTypeRep"
|
||||
instance DA.Internal.Desugar.HasFetch Token where
|
||||
fetch = GHC.Types.primitive @"UFetchInterface"
|
||||
instance DA.Internal.Desugar.HasToInterface Token Token where
|
||||
_toInterface this = this
|
||||
instance DA.Internal.Desugar.HasFromInterface Token Token where
|
||||
fromInterface this = DA.Internal.Desugar.Some this
|
||||
unsafeFromInterface _ this = this
|
||||
instance DA.Internal.Desugar.HasMethod Token "getOwner" (Party)
|
||||
getOwner : Token -> Party
|
||||
getOwner = GHC.Types.primitiveInterface @"getOwner"
|
||||
instance DA.Internal.Desugar.HasMethod Token "getAmount" (Int)
|
||||
getAmount : Token -> Int
|
||||
getAmount = GHC.Types.primitiveInterface @"getAmount"
|
||||
instance DA.Internal.Desugar.HasMethod Token "setAmount" (Int
|
||||
-> Token)
|
||||
setAmount : Token -> Int -> Token
|
||||
setAmount = GHC.Types.primitiveInterface @"setAmount"
|
||||
instance DA.Internal.Desugar.HasToAnyTemplate Token where
|
||||
_toAnyTemplate = GHC.Types.primitive @"EToAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasFromAnyTemplate Token where
|
||||
_fromAnyTemplate = GHC.Types.primitive @"EFromAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasTemplateTypeRep Token where
|
||||
_templateTypeRep = GHC.Types.primitive @"ETemplateTypeRep"
|
||||
instance DA.Internal.Desugar.HasSignatory Token where
|
||||
signatory = GHC.Types.primitive @"ESignatoryInterface"
|
||||
instance DA.Internal.Desugar.HasObserver Token where
|
||||
observer = GHC.Types.primitive @"EObserverInterface"
|
||||
instance DA.Internal.Desugar.HasCreate Token where
|
||||
create = GHC.Types.primitive @"UCreateInterface"
|
||||
instance DA.Internal.Desugar.HasIsInterfaceType Token where
|
||||
_isInterfaceType _ = DA.Internal.Desugar.True
|
||||
instance DA.Internal.Desugar.Eq Token where
|
||||
(==) = GHC.Types.primitive @"BEEqual"
|
||||
instance DA.Internal.Desugar.HasToAnyChoice Token GetRich (ContractId Token) where
|
||||
_toAnyChoice _
|
||||
= GHC.Types.primitive @"EToAnyInterfaceChoice" ([] : [Token])
|
||||
instance DA.Internal.Desugar.HasFromAnyChoice Token GetRich (ContractId Token) where
|
||||
_fromAnyChoice _
|
||||
= GHC.Types.primitive @"EFromAnyInterfaceChoice" ([] : [Token])
|
||||
instance DA.Internal.Desugar.HasExerciseGuarded Token GetRich (ContractId Token) where
|
||||
exerciseGuarded pred cid arg
|
||||
= GHC.Types.primitive
|
||||
@"UExerciseInterfaceGuarded"
|
||||
(DA.Internal.Desugar.toInterfaceContractId @Token cid)
|
||||
arg
|
||||
(DA.Internal.Desugar._exerciseInterfaceGuard @Token cid pred)
|
||||
instance DA.Internal.Desugar.HasExercise Token GetRich (ContractId Token) where
|
||||
exercise cid arg
|
||||
= GHC.Types.primitive
|
||||
@"UExerciseInterface"
|
||||
(DA.Internal.Desugar.toInterfaceContractId @Token cid)
|
||||
arg
|
||||
data GetRich
|
||||
= GetRich {byHowMuch : Int}
|
||||
deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
|
||||
instance DA.Internal.Record.HasField "byHowMuch" GetRich Int where
|
||||
getField
|
||||
= DA.Internal.Record.getFieldPrim @"byHowMuch" @GetRich @Int
|
||||
setField
|
||||
= DA.Internal.Record.setFieldPrim @"byHowMuch" @GetRich @Int
|
||||
_choice_TokenGetRich :
|
||||
(Token -> GetRich -> [DA.Internal.Desugar.Party],
|
||||
DA.Internal.Desugar.ContractId Token
|
||||
-> Token
|
||||
-> GetRich -> DA.Internal.Desugar.Update (ContractId Token),
|
||||
DA.Internal.Desugar.Consuming Token,
|
||||
DA.Internal.Desugar.Optional (Token
|
||||
-> GetRich -> [DA.Internal.Desugar.Party]))
|
||||
_choice_TokenGetRich
|
||||
= (\ this arg@GetRich {..}
|
||||
-> let _ = this in
|
||||
let _ = arg in DA.Internal.Desugar.toParties (getOwner this),
|
||||
\ self this arg@GetRich {..}
|
||||
-> let _ = self in
|
||||
let _ = this in
|
||||
let _ = arg
|
||||
in
|
||||
do assert (byHowMuch > 0)
|
||||
create $ setAmount this (getAmount this + byHowMuch),
|
||||
DA.Internal.Desugar.Consuming, DA.Internal.Desugar.None)
|
||||
instance DA.Internal.Desugar.HasInterfaceView Token EmptyInterfaceView where
|
||||
_view = GHC.Types.primitive @"EViewInterface"
|
||||
data GHC.Types.DamlTemplate => Asset
|
||||
= Asset {issuer : Party, owner : Party, amount : Int}
|
||||
deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
|
||||
instance DA.Internal.Record.HasField "issuer" Asset Party where
|
||||
getField = DA.Internal.Record.getFieldPrim @"issuer" @Asset @Party
|
||||
setField = DA.Internal.Record.setFieldPrim @"issuer" @Asset @Party
|
||||
instance DA.Internal.Record.HasField "owner" Asset Party where
|
||||
getField = DA.Internal.Record.getFieldPrim @"owner" @Asset @Party
|
||||
setField = DA.Internal.Record.setFieldPrim @"owner" @Asset @Party
|
||||
instance DA.Internal.Record.HasField "amount" Asset Int where
|
||||
getField = DA.Internal.Record.getFieldPrim @"amount" @Asset @Int
|
||||
setField = DA.Internal.Record.setFieldPrim @"amount" @Asset @Int
|
||||
instance DA.Internal.Desugar.HasSignatory Asset where
|
||||
signatory this@Asset {..}
|
||||
= DA.Internal.Desugar.toParties (owner)
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasObserver Asset where
|
||||
observer this@Asset {..}
|
||||
= []
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasEnsure Asset where
|
||||
ensure this@Asset {..}
|
||||
= DA.Internal.Desugar.True
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasAgreement Asset where
|
||||
agreement this@Asset {..}
|
||||
= ""
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasArchive Asset where
|
||||
archive cid
|
||||
= DA.Internal.Desugar.exercise cid DA.Internal.Desugar.Archive
|
||||
where
|
||||
_ = cid
|
||||
instance DA.Internal.Desugar.HasCreate Asset where
|
||||
create = GHC.Types.primitive @"UCreate"
|
||||
instance DA.Internal.Desugar.HasFetch Asset where
|
||||
fetch = GHC.Types.primitive @"UFetch"
|
||||
instance DA.Internal.Desugar.HasToAnyTemplate Asset where
|
||||
_toAnyTemplate = GHC.Types.primitive @"EToAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasFromAnyTemplate Asset where
|
||||
_fromAnyTemplate = GHC.Types.primitive @"EFromAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasTemplateTypeRep Asset where
|
||||
_templateTypeRep = GHC.Types.primitive @"ETemplateTypeRep"
|
||||
instance DA.Internal.Desugar.HasIsInterfaceType Asset where
|
||||
_isInterfaceType _ = DA.Internal.Desugar.False
|
||||
instance DA.Internal.Desugar.HasExercise Asset DA.Internal.Desugar.Archive (()) where
|
||||
exercise = GHC.Types.primitive @"UExercise"
|
||||
instance DA.Internal.Desugar.HasToAnyChoice Asset DA.Internal.Desugar.Archive (()) where
|
||||
_toAnyChoice = GHC.Types.primitive @"EToAnyTemplateChoice"
|
||||
instance DA.Internal.Desugar.HasFromAnyChoice Asset DA.Internal.Desugar.Archive (()) where
|
||||
_fromAnyChoice = GHC.Types.primitive @"EFromAnyTemplateChoice"
|
||||
_choice_AssetArchive :
|
||||
(Asset
|
||||
-> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party],
|
||||
DA.Internal.Desugar.ContractId Asset
|
||||
-> Asset
|
||||
-> DA.Internal.Desugar.Archive -> DA.Internal.Desugar.Update (()),
|
||||
DA.Internal.Desugar.Consuming Asset,
|
||||
DA.Internal.Desugar.Optional (Asset
|
||||
-> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party]))
|
||||
_choice_AssetArchive
|
||||
= (\ this _ -> DA.Internal.Desugar.signatory this,
|
||||
\ _ _ _ -> pure (), DA.Internal.Desugar.Consuming,
|
||||
DA.Internal.Desugar.None)
|
||||
_interface_instance_Asset_Token_Asset :
|
||||
DA.Internal.Desugar.InterfaceInstance Asset Token Asset
|
||||
_interface_instance_Asset_Token_Asset
|
||||
= DA.Internal.Desugar.mkInterfaceInstance @Asset @Token @Asset
|
||||
_method_Asset_Token_Asset_getOwner :
|
||||
DA.Internal.Desugar.Method Asset Token Asset "getOwner"
|
||||
_method_Asset_Token_Asset_getOwner
|
||||
= DA.Internal.Desugar.mkMethod
|
||||
@Asset
|
||||
@Token
|
||||
@Asset
|
||||
@"getOwner"
|
||||
\ this@Asset {..}
|
||||
-> let _ = this in let getOwner = owner in getOwner
|
||||
_method_Asset_Token_Asset_getAmount :
|
||||
DA.Internal.Desugar.Method Asset Token Asset "getAmount"
|
||||
_method_Asset_Token_Asset_getAmount
|
||||
= DA.Internal.Desugar.mkMethod
|
||||
@Asset
|
||||
@Token
|
||||
@Asset
|
||||
@"getAmount"
|
||||
\ this@Asset {..}
|
||||
-> let _ = this in let getAmount = amount in getAmount
|
||||
_method_Asset_Token_Asset_setAmount :
|
||||
DA.Internal.Desugar.Method Asset Token Asset "setAmount"
|
||||
_method_Asset_Token_Asset_setAmount
|
||||
= DA.Internal.Desugar.mkMethod
|
||||
@Asset
|
||||
@Token
|
||||
@Asset
|
||||
@"setAmount"
|
||||
\ this@Asset {..}
|
||||
-> let _ = this in
|
||||
let setAmount x = toInterface @Token (this {amount = x})
|
||||
in setAmount
|
||||
_view_Asset_Token_Asset :
|
||||
DA.Internal.Desugar.InterfaceView Asset Token Asset
|
||||
_view_Asset_Token_Asset
|
||||
= DA.Internal.Desugar.mkInterfaceView
|
||||
@Asset
|
||||
@Token
|
||||
@Asset
|
||||
\ this@Asset {..}
|
||||
-> let _ = this in let view = EmptyInterfaceView in view
|
||||
instance DA.Internal.Desugar.HasToInterface Asset Token where
|
||||
_toInterface = GHC.Types.primitive @"EToInterface"
|
||||
instance DA.Internal.Desugar.HasFromInterface Asset Token where
|
||||
fromInterface = GHC.Types.primitive @"EFromInterface"
|
||||
unsafeFromInterface = GHC.Types.primitive @"EUnsafeFromInterface"
|
||||
data GHC.Types.DamlTemplate => AnotherAsset
|
||||
= AnotherAsset {owner : Party, amount : Int}
|
||||
deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
|
||||
instance DA.Internal.Record.HasField "owner" AnotherAsset Party where
|
||||
getField
|
||||
= DA.Internal.Record.getFieldPrim @"owner" @AnotherAsset @Party
|
||||
setField
|
||||
= DA.Internal.Record.setFieldPrim @"owner" @AnotherAsset @Party
|
||||
instance DA.Internal.Record.HasField "amount" AnotherAsset Int where
|
||||
getField
|
||||
= DA.Internal.Record.getFieldPrim @"amount" @AnotherAsset @Int
|
||||
setField
|
||||
= DA.Internal.Record.setFieldPrim @"amount" @AnotherAsset @Int
|
||||
instance DA.Internal.Desugar.HasSignatory AnotherAsset where
|
||||
signatory this@AnotherAsset {..}
|
||||
= DA.Internal.Desugar.toParties (owner)
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasObserver AnotherAsset where
|
||||
observer this@AnotherAsset {..}
|
||||
= []
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasEnsure AnotherAsset where
|
||||
ensure this@AnotherAsset {..}
|
||||
= DA.Internal.Desugar.True
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasAgreement AnotherAsset where
|
||||
agreement this@AnotherAsset {..}
|
||||
= ""
|
||||
where
|
||||
_ = this
|
||||
instance DA.Internal.Desugar.HasArchive AnotherAsset where
|
||||
archive cid
|
||||
= DA.Internal.Desugar.exercise cid DA.Internal.Desugar.Archive
|
||||
where
|
||||
_ = cid
|
||||
instance DA.Internal.Desugar.HasCreate AnotherAsset where
|
||||
create = GHC.Types.primitive @"UCreate"
|
||||
instance DA.Internal.Desugar.HasFetch AnotherAsset where
|
||||
fetch = GHC.Types.primitive @"UFetch"
|
||||
instance DA.Internal.Desugar.HasToAnyTemplate AnotherAsset where
|
||||
_toAnyTemplate = GHC.Types.primitive @"EToAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasFromAnyTemplate AnotherAsset where
|
||||
_fromAnyTemplate = GHC.Types.primitive @"EFromAnyTemplate"
|
||||
instance DA.Internal.Desugar.HasTemplateTypeRep AnotherAsset where
|
||||
_templateTypeRep = GHC.Types.primitive @"ETemplateTypeRep"
|
||||
instance DA.Internal.Desugar.HasIsInterfaceType AnotherAsset where
|
||||
_isInterfaceType _ = DA.Internal.Desugar.False
|
||||
instance DA.Internal.Desugar.HasExercise AnotherAsset DA.Internal.Desugar.Archive (()) where
|
||||
exercise = GHC.Types.primitive @"UExercise"
|
||||
instance DA.Internal.Desugar.HasToAnyChoice AnotherAsset DA.Internal.Desugar.Archive (()) where
|
||||
_toAnyChoice = GHC.Types.primitive @"EToAnyTemplateChoice"
|
||||
instance DA.Internal.Desugar.HasFromAnyChoice AnotherAsset DA.Internal.Desugar.Archive (()) where
|
||||
_fromAnyChoice = GHC.Types.primitive @"EFromAnyTemplateChoice"
|
||||
_choice_AnotherAssetArchive :
|
||||
(AnotherAsset
|
||||
-> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party],
|
||||
DA.Internal.Desugar.ContractId AnotherAsset
|
||||
-> AnotherAsset
|
||||
-> DA.Internal.Desugar.Archive -> DA.Internal.Desugar.Update (()),
|
||||
DA.Internal.Desugar.Consuming AnotherAsset,
|
||||
DA.Internal.Desugar.Optional (AnotherAsset
|
||||
-> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party]))
|
||||
_choice_AnotherAssetArchive
|
||||
= (\ this _ -> DA.Internal.Desugar.signatory this,
|
||||
\ _ _ _ -> pure (), DA.Internal.Desugar.Consuming,
|
||||
DA.Internal.Desugar.None)
|
||||
_interface_instance_AnotherAsset_Token_AnotherAsset :
|
||||
DA.Internal.Desugar.InterfaceInstance AnotherAsset Token AnotherAsset
|
||||
_interface_instance_AnotherAsset_Token_AnotherAsset
|
||||
= DA.Internal.Desugar.mkInterfaceInstance
|
||||
@AnotherAsset @Token @AnotherAsset
|
||||
_method_AnotherAsset_Token_AnotherAsset_getOwner :
|
||||
DA.Internal.Desugar.Method AnotherAsset Token AnotherAsset "getOwner"
|
||||
_method_AnotherAsset_Token_AnotherAsset_getOwner
|
||||
= DA.Internal.Desugar.mkMethod
|
||||
@AnotherAsset
|
||||
@Token
|
||||
@AnotherAsset
|
||||
@"getOwner"
|
||||
\ this@AnotherAsset {..}
|
||||
-> let _ = this in let getOwner = owner in getOwner
|
||||
_method_AnotherAsset_Token_AnotherAsset_getAmount :
|
||||
DA.Internal.Desugar.Method AnotherAsset Token AnotherAsset "getAmount"
|
||||
_method_AnotherAsset_Token_AnotherAsset_getAmount
|
||||
= DA.Internal.Desugar.mkMethod
|
||||
@AnotherAsset
|
||||
@Token
|
||||
@AnotherAsset
|
||||
@"getAmount"
|
||||
\ this@AnotherAsset {..}
|
||||
-> let _ = this in let getAmount = amount in getAmount
|
||||
_method_AnotherAsset_Token_AnotherAsset_setAmount :
|
||||
DA.Internal.Desugar.Method AnotherAsset Token AnotherAsset "setAmount"
|
||||
_method_AnotherAsset_Token_AnotherAsset_setAmount
|
||||
= DA.Internal.Desugar.mkMethod
|
||||
@AnotherAsset
|
||||
@Token
|
||||
@AnotherAsset
|
||||
@"setAmount"
|
||||
\ this@AnotherAsset {..}
|
||||
-> let _ = this in
|
||||
let setAmount x = toInterface @Token (this {amount = x})
|
||||
in setAmount
|
||||
_view_AnotherAsset_Token_AnotherAsset :
|
||||
DA.Internal.Desugar.InterfaceView AnotherAsset Token AnotherAsset
|
||||
_view_AnotherAsset_Token_AnotherAsset
|
||||
= DA.Internal.Desugar.mkInterfaceView
|
||||
@AnotherAsset
|
||||
@Token
|
||||
@AnotherAsset
|
||||
\ this@AnotherAsset {..}
|
||||
-> let _ = this in let view = EmptyInterfaceView in view
|
||||
instance DA.Internal.Desugar.HasToInterface AnotherAsset Token where
|
||||
_toInterface = GHC.Types.primitive @"EToInterface"
|
||||
instance DA.Internal.Desugar.HasFromInterface AnotherAsset Token where
|
||||
fromInterface = GHC.Types.primitive @"EFromInterface"
|
||||
unsafeFromInterface = GHC.Types.primitive @"EUnsafeFromInterface"
|
||||
data DA.Internal.Desugar.DamlException => GuardException
|
||||
= GuardException {m : Text}
|
||||
deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
|
||||
instance DA.Internal.Record.HasField "m" GuardException Text where
|
||||
getField
|
||||
= DA.Internal.Record.getFieldPrim @"m" @GuardException @Text
|
||||
setField
|
||||
= DA.Internal.Record.setFieldPrim @"m" @GuardException @Text
|
||||
instance DA.Internal.Desugar.HasMessage GuardException where
|
||||
message this@GuardException {..} = m
|
||||
instance DA.Internal.Desugar.HasThrow GuardException where
|
||||
throwPure = GHC.Types.primitive @"EThrow"
|
||||
instance DA.Internal.Desugar.HasToAnyException GuardException where
|
||||
toAnyException = GHC.Types.primitive @"EToAnyException"
|
||||
instance DA.Internal.Desugar.HasFromAnyException GuardException where
|
||||
fromAnyException = GHC.Types.primitive @"EFromAnyException"
|
||||
main
|
||||
= scenario
|
||||
do p <- getParty "Alice"
|
||||
let assetTpl = Asset {issuer = p, owner = p, amount = 100}
|
||||
let getRich = GetRich {byHowMuch = 1000000}
|
||||
let exerciseGetRich guard asset
|
||||
= exerciseGuarded
|
||||
guard (toInterfaceContractId @Token asset) getRich
|
||||
p `submit`
|
||||
do asset <- create assetTpl
|
||||
exerciseGetRich (const True) asset
|
||||
p `submitMustFail`
|
||||
do asset <- create assetTpl
|
||||
exerciseGetRich (const False) asset
|
||||
p `submitMustFail`
|
||||
do asset <- create assetTpl
|
||||
exerciseGetRich (\ _ -> error "foo") asset
|
||||
p `submitMustFail`
|
||||
do asset <- create assetTpl
|
||||
exerciseGetRich (\ _ -> throwPure (GuardException "bar")) asset
|
||||
p `submitMustFail`
|
||||
do asset <- create assetTpl
|
||||
DA.Internal.Desugar._tryCatch
|
||||
\ _ -> do exerciseGetRich (\ _ -> error "foo") asset
|
||||
\case
|
||||
(DA.Internal.Desugar.fromAnyException -> DA.Internal.Desugar.Some GeneralError {})
|
||||
-> DA.Internal.Desugar.Some
|
||||
pure $ toInterfaceContractId @Token asset
|
||||
_ -> DA.Internal.Desugar.None
|
||||
p `submitMustFail`
|
||||
do asset <- create assetTpl
|
||||
DA.Internal.Desugar._tryCatch
|
||||
\ _
|
||||
-> do exerciseGetRich
|
||||
(\ _ -> throwPure (GuardException "bar")) asset
|
||||
\case
|
||||
(DA.Internal.Desugar.fromAnyException -> DA.Internal.Desugar.Some GuardException {})
|
||||
-> DA.Internal.Desugar.Some
|
||||
pure $ toInterfaceContractId @Token asset
|
||||
_ -> DA.Internal.Desugar.None
|
||||
p `submitMustFail`
|
||||
do anotherAsset <- coerceContractId @_ @AnotherAsset
|
||||
<$> create assetTpl
|
||||
exerciseGetRich (const True) anotherAsset
|
||||
pure ()
|
||||
@ -3,7 +3,7 @@
|
||||
|
||||
-- @SINCE-LF-FEATURE DAML_INTERFACE
|
||||
-- @UNTIL-LF-FEATURE DAML_INTERFACE_EXTENDED
|
||||
-- @ERROR Requires in Daml interfaces are only available with --target=1.dev
|
||||
-- @ERROR Guarded exercises are only available with --target=1.dev
|
||||
|
||||
module InterfaceGuardedNotExtended where
|
||||
|
||||
@ -26,9 +26,6 @@ interface Token where
|
||||
assert (byHowMuch > 0)
|
||||
create $ setAmount this (getAmount this + byHowMuch)
|
||||
|
||||
interface SubToken requires Token where
|
||||
viewtype EmptyInterfaceView
|
||||
|
||||
template Asset
|
||||
with
|
||||
issuer : Party
|
||||
@ -54,8 +51,6 @@ template AnotherAsset
|
||||
getOwner = owner
|
||||
getAmount = amount
|
||||
setAmount x = toInterface @Token (this with amount = x)
|
||||
interface instance SubToken for AnotherAsset where
|
||||
view = EmptyInterfaceView
|
||||
|
||||
exception GuardException
|
||||
with
|
||||
@ -117,11 +112,6 @@ main = scenario do
|
||||
anotherAsset <- coerceContractId @_ @AnotherAsset <$> create assetTpl
|
||||
exerciseGetRich (const True) anotherAsset
|
||||
|
||||
p `submitMustFail` do
|
||||
-- Fail if predicate doesn't match underlying template's interfaces
|
||||
subToken <- coerceContractId @_ @SubToken <$> create assetTpl
|
||||
exerciseGetRich (const True) subToken
|
||||
|
||||
pure ()
|
||||
|
||||
-- @ENABLE-SCENARIOS
|
||||
|
||||
Loading…
Reference in New Issue
Block a user