diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,22 @@ +0.14.1 +====== +* [!1214](https://gitlab.com/morley-framework/morley/-/merge_requests/1214) + Add emit instructions +* [!1202](https://gitlab.com/morley-framework/morley/-/merge_requests/1202) + Make type errors less confusing when types are ambiguous +* [!1177](https://gitlab.com/morley-framework/morley/-/merge_requests/1177) + Distinguish implicit/contract aliases and addresses on the type level +* [!1136](https://gitlab.com/morley-framework/morley/-/merge_requests/1136) + Add `idiv` and `imod` macros to Lorentz. +* [!1181](https://gitlab.com/morley-framework/morley/-/merge_requests/1181) + Add a few missing instances + + `CanCastTo` instances for `ZippedStackRepr` and `WrappedLambda`, + + `Generic` and `MapLorentzInstr` instances for `WrappedLambda`, + + `HasAnnotation` instances for `ZippedStackRepr`. + 0.14.0 ====== * [!1123](https://gitlab.com/morley-framework/morley/-/merge_requests/1123) diff --git a/lorentz.cabal b/lorentz.cabal --- a/lorentz.cabal +++ b/lorentz.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: lorentz -version: 0.14.0 +version: 0.14.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 @@ -78,6 +78,7 @@ Lorentz.StoreClass Lorentz.StoreClass.Extra Lorentz.Tickets + Lorentz.Txr1Call Lorentz.UParam Lorentz.Util.TH Lorentz.Value @@ -112,6 +113,7 @@ GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf diff --git a/src/Lorentz.hs b/src/Lorentz.hs --- a/src/Lorentz.hs +++ b/src/Lorentz.hs @@ -36,6 +36,7 @@ import Lorentz.Run as Exports import Lorentz.Run.Simple as Exports import Lorentz.StoreClass as Exports +import Lorentz.Txr1Call as Exports import Lorentz.UParam as Exports import Lorentz.Util.TH as Exports import Lorentz.Value as Exports diff --git a/src/Lorentz/Address.hs b/src/Lorentz/Address.hs --- a/src/Lorentz/Address.hs +++ b/src/Lorentz/Address.hs @@ -62,7 +62,7 @@ import Morley.Michelson.Typed (ContractRef(..), IsoValue(..)) import Morley.Michelson.Typed qualified as M import Morley.Michelson.Typed.Entrypoints (EpAddress(..)) -import Morley.Tezos.Address (Address) +import Morley.Tezos.Address import Morley.Util.Type import Morley.Util.TypeLits @@ -156,6 +156,12 @@ instance ToAddress Address where toAddress = id +instance ToAddress L1Address where + toAddress (MkConstrainedAddress x) = MkAddress x + +instance ToAddress (KindedAddress kind) where + toAddress = MkAddress + instance ToAddress EpAddress where toAddress = eaAddress @@ -175,6 +181,15 @@ instance ToTAddress cp vd Address where toTAddress = TAddress + +instance ToTAddress cp vd ContractAddress where + toTAddress = TAddress . MkAddress + +instance (cp ~ (), vd ~ ()) => ToTAddress cp vd ImplicitAddress where + toTAddress = TAddress . MkAddress + +instance ToTAddress cp vd L1Address where + toTAddress (MkConstrainedAddress x) = TAddress $ MkAddress x instance (cp ~ cp', vd ~ vd') => ToTAddress cp vd (TAddress cp' vd') where toTAddress = id diff --git a/src/Lorentz/Base.hs b/src/Lorentz/Base.hs --- a/src/Lorentz/Base.hs +++ b/src/Lorentz/Base.hs @@ -45,7 +45,7 @@ import Morley.Michelson.Preprocess (transformBytes, transformStrings) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended) import Morley.Michelson.Text (MText) -import Morley.Michelson.TypeCheck (TCError, runTypeCheckIsolated, typeCheckValue, typeCheckingWith) +import Morley.Michelson.TypeCheck (TCError, typeCheckValue, typeCheckingWith) import Morley.Michelson.Typed (Instr(..), IsNotInView, IsoValue(..), Operation, RemFail(..), ToT, ToTs, Value, rfAnyInstr, rfMapAnyInstr, rfMerge) @@ -221,8 +221,6 @@ toTyped = first ParseLorentzTypecheckError . typeCheckingWith def . - runTypeCheckIsolated . - usingReaderT def . typeCheckValue -- | Lorentz version of 'transformStrings'. diff --git a/src/Lorentz/Coercions.hs b/src/Lorentz/Coercions.hs --- a/src/Lorentz/Coercions.hs +++ b/src/Lorentz/Coercions.hs @@ -42,6 +42,7 @@ import Lorentz.Address import Lorentz.Base import Lorentz.Bytes +import Lorentz.Lambda import Lorentz.Value import Lorentz.Wrappable import Lorentz.Zip @@ -236,6 +237,15 @@ GCanCastTo G.U1 G.U1 = () GCanCastTo G.V1 G.V1 = () GCanCastTo (G.Rec0 a) (G.Rec0 b) = CanCastTo a b + +instance (CanCastTo a1 a2, CanCastTo b1 b2) + => CanCastTo (ZippedStackRepr a1 b1) (ZippedStackRepr a2 b2) where + castDummy = castDummyG + +instance ( CanCastTo (ZippedStack inp1) (ZippedStack inp2) + , CanCastTo (ZippedStack out1) (ZippedStack out2) ) + => WrappedLambda inp1 out1 `CanCastTo` WrappedLambda inp2 out2 where + castDummy = castDummyG {- Note about potential use of 'Coercible'. diff --git a/src/Lorentz/CustomArith/FixedArith.hs b/src/Lorentz/CustomArith/FixedArith.hs --- a/src/Lorentz/CustomArith/FixedArith.hs +++ b/src/Lorentz/CustomArith/FixedArith.hs @@ -2,7 +2,6 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-OA -{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-orphans #-} module Lorentz.CustomArith.FixedArith diff --git a/src/Lorentz/Entrypoints/Doc.hs b/src/Lorentz/Entrypoints/Doc.hs --- a/src/Lorentz/Entrypoints/Doc.hs +++ b/src/Lorentz/Entrypoints/Doc.hs @@ -2,7 +2,6 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# LANGUAGE InstanceSigs #-} -- | Utilities for declaring and documenting entry points. module Lorentz.Entrypoints.Doc @@ -832,11 +831,10 @@ type family HasEntrypoints mode cp syms :: Constraint where HasEntrypoints mode cp (x ': xs) = - If (IsJust @@ (EpdLookupEntrypoint mode cp @@ x)) - (HasEntrypoints mode cp xs) - (TypeError - ('Text "Parameter type " ':<>: 'ShowType cp - ':<>: 'Text " does not contain entrypoint " ':<>: 'ShowType x)) + FailUnlessElse (IsJust @@ (EpdLookupEntrypoint mode cp @@ x)) + ('Text "Parameter type " ':<>: 'ShowType cp + ':<>: 'Text " does not contain entrypoint " ':<>: 'ShowType x) + (HasEntrypoints mode cp xs) HasEntrypoints _ _ '[] = () --------------------------- diff --git a/src/Lorentz/Entrypoints/Helpers.hs b/src/Lorentz/Entrypoints/Helpers.hs --- a/src/Lorentz/Entrypoints/Helpers.hs +++ b/src/Lorentz/Entrypoints/Helpers.hs @@ -34,7 +34,7 @@ newtype ShouldHaveEntrypoints a = ShouldHaveEntrypoints { unHasEntrypoints :: a } deriving stock Generic -deriving anyclass instance (WellTypedIsoValue r) => IsoValue (ShouldHaveEntrypoints r) +deriving anyclass instance (WellTypedToT r) => IsoValue (ShouldHaveEntrypoints r) instance HasRPCRepr a => HasRPCRepr (ShouldHaveEntrypoints a) where type AsRPC (ShouldHaveEntrypoints a) = ShouldHaveEntrypoints (AsRPC a) @@ -53,8 +53,7 @@ -- This helps to prevent attempts to apply a function to, for instance, a pair. type family RequireSumType (a :: Type) :: Constraint where RequireSumType a = - If (CanHaveEntrypoints a) - (() :: Constraint) - (TypeError ('Text "Expected Michelson sum type" ':$$: - 'Text "In type `" ':<>: 'ShowType a ':<>: 'Text "`" - )) + FailUnless (CanHaveEntrypoints a) + ('Text "Expected Michelson sum type" ':$$: + 'Text "In type `" ':<>: 'ShowType a ':<>: 'Text "`" + ) diff --git a/src/Lorentz/Errors.hs b/src/Lorentz/Errors.hs --- a/src/Lorentz/Errors.hs +++ b/src/Lorentz/Errors.hs @@ -373,7 +373,7 @@ ] -- | This instance cannot be implemented, use 'IsError' instance instead. -instance (WellTypedIsoValue (CustomErrorRep tag), TypeError ('Text "CustomError has no IsoValue instance")) => +instance (WellTypedToT (CustomErrorRep tag), TypeError ('Text "CustomError has no IsoValue instance")) => IsoValue (CustomError tag) where -- Originally we had a `TypeError` here, but that had to be changed when -- `WellTyped (ToT a)` was added as a superclass of `IsoValue`, because it @@ -453,14 +453,12 @@ type MustHaveErrorArg errorTag expectedArgRep = - ( AssertTypesEqual (CustomErrorRep errorTag) expectedArgRep - ('Text "Error argument type is " - ':<>: 'ShowType (expectedArgRep) - ':<>: 'Text " but given error requires argument of type " - ':<>: 'ShowType (CustomErrorRep errorTag) - ) - , CustomErrorRep errorTag ~ expectedArgRep - ) + FailUnlessEqual (CustomErrorRep errorTag) expectedArgRep + ('Text "Error argument type is " + ':<>: 'ShowType (expectedArgRep) + ':<>: 'Text " but given error requires argument of type " + ':<>: 'ShowType (CustomErrorRep errorTag) + ) -- | Specialization of 'failCustom' for unit-arg errors. failCustom_ @@ -470,11 +468,10 @@ ) => Label tag -> s :-> any failCustom_ l = - reifyTypeEquality @(CustomErrorRep tag) @(MText, ()) $ - doc (DThrows (Proxy @(CustomError tag))) # - unit # - push (errorTagToMText l) # pair @MText @() # - FI (FAILWITH @(ToT (MText, ()))) + doc (DThrows (Proxy @(CustomError tag))) # + unit # + push (errorTagToMText l) # pair @MText @() # + FI (FAILWITH @(ToT (MText, ()))) -- Special treatment of no-arg errors ---------------------------------------------------------------------------- @@ -483,20 +480,17 @@ -- that this is unit-arg error and interpret the passed value as complete. instance ( Typeable arg , IsError (CustomError tag) - , AssertTypesEqual arg () notVoidError , arg ~ ErrorArg tag - , notVoidError ~ + , FailUnlessEqual arg () ('Text "This error requires argument of type " ':<>: 'ShowType (ErrorArg tag) ) ) => IsError (arg -> CustomError tag) where errorToVal mkCustomError cont = - reifyTypeEquality @arg @() $ - errorToVal (mkCustomError ()) cont + errorToVal (mkCustomError ()) cont errorFromVal v = - reifyTypeEquality @arg @() $ - errorFromVal v <&> \(CustomError l a) b -> CustomError l (fst a, b) + errorFromVal v <&> \(CustomError l a) b -> CustomError l (fst a, b) instance (Typeable arg, ErrorHasDoc (CustomError tag)) => ErrorHasDoc (arg -> CustomError tag) where diff --git a/src/Lorentz/Extensible.hs b/src/Lorentz/Extensible.hs --- a/src/Lorentz/Extensible.hs +++ b/src/Lorentz/Extensible.hs @@ -40,7 +40,6 @@ data BadSumTypeV2 = A Natural | B | C MText -} -{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} module Lorentz.Extensible diff --git a/src/Lorentz/Instr.hs b/src/Lorentz/Instr.hs --- a/src/Lorentz/Instr.hs +++ b/src/Lorentz/Instr.hs @@ -130,6 +130,9 @@ , level , never , framed + , emit + , emit' + , emitAuto , LorentzFunctor (..) ) where @@ -140,6 +143,7 @@ import GHC.TypeNats (Nat) import Lorentz.Address +import Lorentz.Annotation import Lorentz.Arith import Lorentz.Base import Lorentz.Bytes @@ -153,11 +157,12 @@ import Morley.Michelson.Typed (ConstraintDIG, ConstraintDIG', ConstraintDIPN, ConstraintDIPN', ConstraintDUG, ConstraintDUG', ConstraintDUPN, ConstraintDUPN', ConstraintGetN, ConstraintUpdateN, EntrypointCallT(..), GetN, - Instr(..), RemFail(..), SingI, SomeEntrypointCallT(..), UpdateN, Value'(..), pattern CAR, - pattern CDR, pattern LEFT, pattern PAIR, pattern RIGHT, pattern UNPAIR, sepcName) + Instr(..), Notes, RemFail(..), SingI, SomeEntrypointCallT(..), UpdateN, Value'(..), pattern CAR, + pattern CDR, pattern LEFT, pattern PAIR, pattern RIGHT, pattern UNPAIR, sepcName, starNotes) import Morley.Michelson.Typed.Arith import Morley.Michelson.Typed.Contract (giveNotInView) import Morley.Michelson.Typed.Haskell.Value +import Morley.Michelson.Untyped (FieldAnn) import Morley.Util.Named import Morley.Util.Peano import Morley.Util.PeanoNatural @@ -846,6 +851,28 @@ openChest :: ChestKey : Chest : Natural : s :-> OpenChest : s openChest = I OPEN_CHEST + +-- | Version of 'emit' that adds the type annotation, only when @t@ has annotations. +emit :: forall t s. (NicePackedValue t, HasAnnotation t) => FieldAnn -> t : s :-> Operation : s +emit tag = emit' tag ann' + where + ann = getAnnotation @t NotFollowEntrypoint + -- type without annotations can be inferred by the runtime, so + -- here we omit the annotation for efficiency if it's unnecessary. + ann' | ann == starNotes = Nothing + | otherwise = Just ann + +-- | Version of 'emit' that omits the type annotation, letting the runtime infer +-- it instead. +emitAuto :: forall t s. NicePackedValue t => FieldAnn -> t : s :-> Operation : s +emitAuto tag = emit' tag Nothing + +emit' + :: forall t s. NicePackedValue t + => FieldAnn + -> Maybe (Notes (ToT t)) + -> t : s :-> Operation : s +emit' tag mNotes = I $ EMIT tag mNotes \\ nicePackedValueEvi @t -- | Execute given instruction on truncated stack. -- diff --git a/src/Lorentz/Lambda.hs b/src/Lorentz/Lambda.hs --- a/src/Lorentz/Lambda.hs +++ b/src/Lorentz/Lambda.hs @@ -19,7 +19,8 @@ -- The primary reason this is a newtype and not a type synonym is to avoid -- accidentally splicing the output of 'mkLambda' in-line. newtype WrappedLambda i o = WrappedLambda {unWrappedLambda :: i :-> o} - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving newtype MapLorentzInstr deriving newtype instance IsoValue (a :-> b) => IsoValue (WrappedLambda a b) deriving newtype instance HasAnnotation (i :-> o) => HasAnnotation (WrappedLambda i o) diff --git a/src/Lorentz/Macro.hs b/src/Lorentz/Macro.hs --- a/src/Lorentz/Macro.hs +++ b/src/Lorentz/Macro.hs @@ -127,6 +127,12 @@ , pushContractRef , selfAddress , view + + -- * Integer division + , IDiv + , IMod + , idiv + , imod ) where import Prelude hiding (and, compare, drop, some, swap, view) @@ -405,7 +411,7 @@ -- >>> framedN @5 (drop # drop # drop # drop) -$ arg -- ... -- ... error: --- ... Couldn't match type ‘ZippedStackRepr a0 (ZippedStackRepr a1 out)’ +-- ... Couldn't match type ‘ZippedStackRepr a1 (ZippedStackRepr a0 out)’ -- ... with ‘Integer’ -- ... @@ -787,7 +793,7 @@ } 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, WellTypedToT a) => IsoValue (View_ a r) instance (CanCastTo a1 a2, CanCastTo r1 r2) => CanCastTo (View_ a1 r1) (View_ a2 r2) @@ -809,16 +815,16 @@ typeDocMichelsonRep = concreteTypeDocMichelsonRep @(View_ MText Integer) -instance {-# OVERLAPPABLE #-} (Buildable a, WellTypedIsoValue r, HasNoOpToT r) => Buildable (View_ a r) where +instance {-# OVERLAPPABLE #-} (Buildable a, HasNoOpToT r) => Buildable (View_ a r) where build = buildView_ build -instance {-# OVERLAPPING #-} (WellTypedIsoValue r, HasNoOpToT r) => Buildable (View_ () r) where +instance {-# OVERLAPPING #-} (HasNoOpToT r) => Buildable (View_ () r) where build = buildView_ $ const "()" -buildViewTuple_ :: (HasNoOpToT r, WellTypedIsoValue r, TupleF a) => View_ a r -> Builder +buildViewTuple_ :: (HasNoOpToT r, TupleF a) => View_ a r -> Builder buildViewTuple_ = buildView_ tupleF -buildView_ :: (WellTypedIsoValue r, HasNoOpToT r) => (a -> Builder) -> View_ a r -> Builder +buildView_ :: (HasNoOpToT r) => (a -> Builder) -> View_ a r -> Builder buildView_ bfp (View_ {..}) = "(View param: " +| bfp viewParam |+ " callbackTo: " +| viewCallbackTo |+ ")" @@ -856,7 +862,7 @@ } deriving stock (Generic, Show) deriving anyclass (HasAnnotation) -deriving anyclass instance (WellTypedIsoValue r, WellTypedIsoValue a) => IsoValue (Void_ a r) +deriving anyclass instance (WellTypedToT r, WellTypedToT a) => IsoValue (Void_ a r) instance (CanCastTo a1 a2, CanCastTo r1 r2) => CanCastTo (Void_ a1 r1) (Void_ a2 r2) @@ -943,7 +949,7 @@ [dTypeDep @MText, dTypeDep @r] instance - ( WellTypedIsoValue (VoidResult r) + ( WellTypedToT (VoidResult r) , Lit.TypeError ('Lit.Text "No IsoValue instance for VoidResult " 'Lit.:<>: 'Lit.ShowType r) ) => IsoValue (VoidResult r) where type ToT (VoidResult r) = @@ -1079,3 +1085,43 @@ where viewName = demoteViewName @name _needHasView = Dict @(HasView vd name arg ret) + +-- | Michelson supports only `EDiv`, which gives both the quotient and the +-- remainder for integers. For convenience, we also offer `IDiv`, which gives +-- just the quotient. +data IDiv + +instance (ArithOpHs EDiv n d (Maybe (q, r)), mq ~ Maybe q, KnownValue q) => ArithOpHs IDiv n d mq where + evalArithOpHs = evalArithOpHs @EDiv @n @d @(Maybe (q, r)) # lmap car + +-- | Integer division. +-- +-- >>> idiv -$ (5 :: Integer) ::: (2 :: Integer) +-- Just 2 +-- +-- >>> idiv -$ (5 :: Integer) ::: (0 :: Integer) +-- Nothing +idiv + :: ArithOpHs IDiv n d q + => n : d : s :-> q : s +idiv = evalArithOpHs @IDiv + +-- | Michelson supports only `EDiv`, which gives both the quotient and the +-- remainder for integers. For convenience, we also offer `IMod`, which gives +-- just the remainder. +data IMod + +instance (ArithOpHs EDiv n d (Maybe (q, r)), mr ~ Maybe r, KnownValue r) => ArithOpHs IMod n d mr where + evalArithOpHs = evalArithOpHs @EDiv @n @d @(Maybe (q, r)) # lmap cdr + +-- | Integer modulus. +-- +-- >>> imod -$ (5 :: Integer) ::: (2 :: Integer) +-- Just 1 +-- +-- >>> imod -$ (5 :: Integer) ::: (0 :: Integer) +-- Nothing +imod + :: ArithOpHs IMod n d r + => n : d : s :-> r : s +imod = evalArithOpHs @IMod diff --git a/src/Lorentz/Referenced.hs b/src/Lorentz/Referenced.hs --- a/src/Lorentz/Referenced.hs +++ b/src/Lorentz/Referenced.hs @@ -57,9 +57,7 @@ dupTImpl = error "impossible" instance {-# OVERLAPPING #-} - ( If (a `IsElem` st) - (TypeError (StackElemAmbiguous origSt a)) - (() :: Constraint) + ( FailWhen (a `IsElem` st) (StackElemAmbiguous origSt a) , Dupable a ) => DupT origSt a (a : st) where @@ -100,9 +98,7 @@ dipTImpl = error "impossible" instance {-# OVERLAPPING #-} - ( If (a `IsElem` st) - (TypeError (StackElemAmbiguous origSt a)) - (() :: Constraint) + ( FailWhen (a `IsElem` st) (StackElemAmbiguous origSt a) , dipInp ~ (a : st) , dipOut ~ out ) => diff --git a/src/Lorentz/Run/Simple.hs b/src/Lorentz/Run/Simple.hs --- a/src/Lorentz/Run/Simple.hs +++ b/src/Lorentz/Run/Simple.hs @@ -41,7 +41,7 @@ -- -- For testing and demonstration purposes. infixr 2 -$? -(-$?) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out) +(-$?) :: (ZipInstr inps, IsoValue out) => (IsNotInView => inps :-> '[out]) -> ZippedStack inps -> Either MichelsonFailureWithStack out code -$? inp = interpretLorentzLambda dummyContractEnv (unzipInstr # code) inp @@ -62,7 +62,7 @@ -- >>> add # add -$ 1 ::: 2 ::: 3 :: Integer -- 6 infixr 2 -$ -(-$) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack) +(-$) :: (ZipInstr inps, IsoValue out, HasCallStack) => (IsNotInView => inps :-> '[out]) -> ZippedStack inps -> out code -$ inp = unsafe $ code -$? inp @@ -72,13 +72,13 @@ -- | Version of (-$?) with arguments flipped. infixl 2 &?- -(&?-) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out) +(&?-) :: (ZipInstr inps, IsoValue out) => ZippedStack inps -> (IsNotInView => inps :-> '[out]) -> Either MichelsonFailureWithStack out (&?-) x y = (-$?) y x -- | Version of (-$) with arguments flipped. infixl 2 &- -(&-) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack) +(&-) :: (ZipInstr inps, IsoValue out, HasCallStack) => ZippedStack inps -> (IsNotInView => inps :-> '[out]) -> out (&-) x y = (-$) y x @@ -88,6 +88,6 @@ -- | Version of (-$) applicable to a series of values. infixl 2 <-$> -(<-$>) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack) +(<-$>) :: (ZipInstr inps, IsoValue out, HasCallStack) => (inps :-> '[out]) -> [ZippedStack inps] -> [out] code <-$> inps = map (code -$) inps diff --git a/src/Lorentz/Txr1Call.hs b/src/Lorentz/Txr1Call.hs new file mode 100644 --- /dev/null +++ b/src/Lorentz/Txr1Call.hs @@ -0,0 +1,30 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Definitions for calling @txr1@ addresses +module Lorentz.Txr1Call + ( Txr1CallParam + ) where + +import Lorentz.Annotation +import Lorentz.Constraints.Scopes +import Lorentz.Entrypoints +import Lorentz.Value +import Morley.Tezos.Address + +-- | Call parameter for @txr1@ addresses. Default entrypoint doesn't exist, but +-- here we simply represent it as having @never@ parameter, thus uncallable. +data Txr1CallParam a = Deposit (Ticket a, TxRollupL2Address) | Default Never + deriving stock Generic + deriving anyclass (HasAnnotation) + +instance NiceComparable a => IsoValue (Txr1CallParam a) + +instance (HasAnnotation a, NiceComparable a) => ParameterHasEntrypoints (Txr1CallParam a) where + type ParameterEntrypointsDerivation (Txr1CallParam a) = EpdPlain + +-- NB: This is an orphan, because otherwise we have nasty circular dependencies between modules +instance (cp ~ Txr1CallParam a, vd ~ ()) => ToTAddress cp vd TxRollupAddress where + toTAddress = TAddress . MkAddress diff --git a/src/Lorentz/Value.hs b/src/Lorentz/Value.hs --- a/src/Lorentz/Value.hs +++ b/src/Lorentz/Value.hs @@ -9,7 +9,7 @@ module Lorentz.Value ( M.Value , M.IsoValue (..) - , M.WellTypedIsoValue + , M.WellTypedToT -- * Primitive types , Integer diff --git a/src/Lorentz/Zip.hs b/src/Lorentz/Zip.hs --- a/src/Lorentz/Zip.hs +++ b/src/Lorentz/Zip.hs @@ -56,12 +56,12 @@ -- isomorphic to a pair and represented as such in Michelson. data ZippedStackRepr a b = a ::: b deriving stock (Show, Eq, Generic) - deriving anyclass (IsoValue) + deriving anyclass (IsoValue, HasAnnotation) -- | A type used to represent an empty zipped stack, isomorphic to a unit and -- represented as such in Michelson. data ZSNil = ZSNil deriving stock (Show, Eq, Generic) - deriving anyclass (IsoValue) + deriving anyclass (IsoValue, HasAnnotation) -- | Zipping stack into tuple and back. class (KnownIsoT (ZippedStack s)) => ZipInstr (s :: [Type]) where