{-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} {- | Module, containing restrictions imposed by instruction or value scope. Michelson have multiple restrictions on values, examples: * @operation@ type cannot appear in parameter. * @big_map@ type cannot appear in @PUSH@-able constants. * @contract@ type cannot appear in type we @UNPACK@ to. Thus we declare multiple "scopes" - constraints applied in corresponding situations, for instance * 'ParameterScope'; * 'StorageScope'; * 'ConstantScope'. Also we separate multiple "classes" of scope-related constraints. * 'ParameterScope' and similar ones are used within Michelson engine, they are understandable by GHC but produce not very clarifying errors. * 'ProperParameterBetterErrors' and similar ones are middle-layer constraints, they produce human-readable errors but GHC cannot make conclusions from them. They are supposed to be used only by eDSLs to define their own high-level constraints. * Lorentz and other eDSLs may declare their own constraints, in most cases you should use them. For example see 'Lorentz.Constraints' module. -} module Michelson.Typed.Scope ( -- * Scopes ParameterScope , StorageScope , ConstantScope , PackedValScope , UnpackedValScope , PrintedValScope , ProperParameterBetterErrors , ProperStorageBetterErrors , ProperConstantBetterErrors , ProperPackedValBetterErrors , ProperUnpackedValBetterErrors , ProperPrintedValBetterErrors , properParameterEvi , properStorageEvi , properConstantEvi , properPackedValEvi , properUnpackedValEvi , properPrintedValEvi , (:-)(..) -- * Implementation internals , HasNoBigMap , HasNoNestedBigMaps , HasNoOp , HasNoContract , ContainsBigMap , ContainsNestedBigMaps , ForbidOp , ForbidContract , ForbidBigMap , ForbidNestedBigMaps , FailOnBigMapFound , FailOnNestedBigMapsFound , FailOnOperationFound , OpPresence (..) , ContractPresence (..) , BigMapPresence (..) , NestedBigMapsPresence (..) , checkOpPresence , checkContractTypePresence , checkBigMapPresence , checkNestedBigMapsPresence , opAbsense , contractTypeAbsense , bigMapAbsense , nestedBigMapsAbsense , forbiddenOp , forbiddenContractType , forbiddenBigMap , forbiddenNestedBigMaps -- * Re-exports , withDict ) where import Data.Constraint ((:-)(..), Dict(..), withDict, (\\)) import qualified Data.Constraint as C import Data.Singletons (SingI(..)) import Data.Type.Bool (type (||)) import GHC.TypeLits (ErrorMessage(..), TypeError) import Michelson.Typed.Sing (Sing(..)) import Michelson.Typed.T (T(..)) ---------------------------------------------------------------------------- -- Constraints ---------------------------------------------------------------------------- -- | Whether this type contains 'TOperation' type. -- -- In some scopes (constants, parameters, storage) appearing for operation type -- is prohibited. -- Operations in input/output of lambdas are allowed without limits though. type family ContainsOp (t :: T) :: Bool where ContainsOp ('Tc _) = 'False ContainsOp 'TKey = 'False ContainsOp 'TUnit = 'False ContainsOp 'TSignature = 'False ContainsOp 'TChainId = 'False ContainsOp ('TOption t) = ContainsOp t ContainsOp ('TList t) = ContainsOp t ContainsOp ('TSet _) = 'False ContainsOp 'TOperation = 'True ContainsOp ('TContract t) = ContainsOp t ContainsOp ('TPair a b) = ContainsOp a || ContainsOp b ContainsOp ('TOr a b) = ContainsOp a || ContainsOp b ContainsOp ('TLambda _ _) = 'False ContainsOp ('TMap _ v) = ContainsOp v ContainsOp ('TBigMap _ v) = ContainsOp v -- | Whether this type contains 'TContract' type. -- -- In some scopes (constants, storage) appearing for contract type -- is prohibited. -- Contracts in input/output of lambdas are allowed without limits though. type family ContainsContract (t :: T) :: Bool where ContainsContract ('Tc _) = 'False ContainsContract 'TKey = 'False ContainsContract 'TUnit = 'False ContainsContract 'TSignature = 'False ContainsContract 'TChainId = 'False ContainsContract ('TOption t) = ContainsContract t ContainsContract ('TList t) = ContainsContract t ContainsContract ('TSet _) = 'False ContainsContract 'TOperation = 'False ContainsContract ('TContract _) = 'True ContainsContract ('TPair a b) = ContainsContract a || ContainsContract b ContainsContract ('TOr a b) = ContainsContract a || ContainsContract b ContainsContract ('TLambda _ _) = 'False ContainsContract ('TMap _ v) = ContainsContract v ContainsContract ('TBigMap _ v) = ContainsContract v -- | Whether this type contains 'TBigMap' type. type family ContainsBigMap (t :: T) :: Bool where ContainsBigMap ('Tc _) = 'False ContainsBigMap 'TKey = 'False ContainsBigMap 'TUnit = 'False ContainsBigMap 'TSignature = 'False ContainsBigMap 'TChainId = 'False ContainsBigMap ('TOption t) = ContainsBigMap t ContainsBigMap ('TList t) = ContainsBigMap t ContainsBigMap ('TSet _) = 'False ContainsBigMap 'TOperation = 'False ContainsBigMap ('TContract t) = ContainsBigMap t ContainsBigMap ('TPair a b) = ContainsBigMap a || ContainsBigMap b ContainsBigMap ('TOr a b) = ContainsBigMap a || ContainsBigMap b ContainsBigMap ('TLambda _ _) = 'False ContainsBigMap ('TMap _ v) = ContainsBigMap v ContainsBigMap ('TBigMap _ _) = 'True -- | Whether this type contains a type with nested 'TBigMap's . -- -- Nested big_maps (i.e. big_map which contains another big_map inside of it's value type). Are -- prohibited in all contexts. Some context such as PUSH, APPLY, PACK/UNPACK instructions are more -- strict because they doesn't work with big_map at all. type family ContainsNestedBigMaps (t :: T) :: Bool where ContainsNestedBigMaps ('Tc _) = 'False ContainsNestedBigMaps 'TKey = 'False ContainsNestedBigMaps 'TUnit = 'False ContainsNestedBigMaps 'TSignature = 'False ContainsNestedBigMaps 'TChainId = 'False ContainsNestedBigMaps ('TOption t) = ContainsNestedBigMaps t ContainsNestedBigMaps ('TList t) = ContainsNestedBigMaps t ContainsNestedBigMaps ('TSet _) = 'False ContainsNestedBigMaps 'TOperation = 'False ContainsNestedBigMaps ('TContract t) = ContainsNestedBigMaps t ContainsNestedBigMaps ('TPair a b) = ContainsNestedBigMaps a || ContainsNestedBigMaps b ContainsNestedBigMaps ('TOr a b) = ContainsNestedBigMaps a || ContainsNestedBigMaps b ContainsNestedBigMaps ('TLambda _ _) = 'False ContainsNestedBigMaps ('TMap _ v) = ContainsNestedBigMaps v ContainsNestedBigMaps ('TBigMap _ v) = ContainsBigMap v -- | Constraint which ensures that operation type does not appear in a given type. -- -- Not just a type alias in order to be able to partially apply it -- (e.g. in 'Each'). class (ContainsOp t ~ 'False) => HasNoOp t instance (ContainsOp t ~ 'False) => HasNoOp t -- | Constraint which ensures that contract type does not appear in a given type. class (ContainsContract t ~ 'False) => HasNoContract t instance (ContainsContract t ~ 'False) => HasNoContract t -- | Constraint which ensures that bigmap does not appear in a given type. class (ContainsBigMap t ~ 'False) => HasNoBigMap t instance (ContainsBigMap t ~ 'False) => HasNoBigMap t -- | Constraint which ensures that there are no nested bigmaps class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t instance (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t -- | Report a human-readable error about 'TOperation' at a wrong place. type family FailOnOperationFound (enabled :: Bool) :: Constraint where FailOnOperationFound 'True = TypeError ('Text "Operations are not allowed in this scope") FailOnOperationFound 'False = () -- | Report a human-readable error about 'TContract' at a wrong place. type family FailOnContractFound (enabled :: Bool) :: Constraint where FailOnContractFound 'True = TypeError ('Text "Contracts are not allowed in this scope") FailOnContractFound 'False = () -- | Report a human-readable error about 'TBigMap' at a wrong place. type family FailOnBigMapFound (enabled :: Bool) :: Constraint where FailOnBigMapFound 'True = TypeError ('Text "BigMaps are not allowed in this scope") FailOnBigMapFound 'False = () -- | Report a human-readable error that 'TBigMap' contains another 'TBigMap' type family FailOnNestedBigMapsFound (enabled :: Bool) :: Constraint where FailOnNestedBigMapsFound 'True = TypeError ('Text "Nested BigMaps are not allowed") FailOnNestedBigMapsFound 'False = () -- | This is like 'HasNoOp', it raises a more human-readable error -- when @t@ type is concrete, but GHC cannot make any conclusions -- from such constraint as it can for 'HasNoOp. -- -- Use it in our eDSL. type ForbidOp t = FailOnOperationFound (ContainsOp t) type ForbidContract t = FailOnContractFound (ContainsContract t) type ForbidBigMap t = FailOnBigMapFound (ContainsBigMap t) type ForbidNestedBigMaps t = FailOnNestedBigMapsFound (ContainsNestedBigMaps t) -- | Evidence of that 'HasNoOp' is deducable from 'ForbidOp'. forbiddenOpEvi :: forall t. (SingI t, ForbidOp t) :- HasNoOp t forbiddenOpEvi = Sub $ -- It's not clear now to proof GHC that @HasNoOp t@ is implication of -- @ForbidOp t@, so we use @error@ below and also disable -- "-Wredundant-constraints" extension. case checkOpPresence (sing @t) of OpAbsent -> Dict OpPresent -> error "impossible" -- | Reify 'HasNoOp' contraint from 'ForbidOp'. -- -- Left for backward compatibility. forbiddenOp :: forall t a. (SingI t, ForbidOp t) => (HasNoOp t => a) -> a forbiddenOp = withDict $ forbiddenOpEvi @t forbiddenBigMapEvi :: forall t. (SingI t, ForbidBigMap t) :- HasNoBigMap t forbiddenBigMapEvi = Sub $ case checkBigMapPresence (sing @t) of BigMapAbsent -> Dict BigMapPresent -> error "impossible" forbiddenNestedBigMapsEvi :: forall t. (SingI t, ForbidNestedBigMaps t) :- HasNoNestedBigMaps t forbiddenNestedBigMapsEvi = Sub $ case checkNestedBigMapsPresence (sing @t) of NestedBigMapsAbsent -> Dict NestedBigMapsPresent -> error "impossible" forbiddenBigMap :: forall t a. (SingI t, ForbidBigMap t) => (HasNoBigMap t => a) -> a forbiddenBigMap = withDict $ forbiddenBigMapEvi @t forbiddenNestedBigMaps :: forall t a. (SingI t, ForbidNestedBigMaps t) => (HasNoNestedBigMaps t => a) -> a forbiddenNestedBigMaps = withDict $ forbiddenNestedBigMapsEvi @t -- | Reify 'HasNoContract' contraint from 'ForbidContract'. forbiddenContractTypeEvi :: forall t. (SingI t, ForbidContract t) :- HasNoContract t forbiddenContractTypeEvi = Sub $ case checkContractTypePresence (sing @t) of ContractAbsent -> Dict ContractPresent -> error "impossible" -- | Reify 'HasNoContract' contraint from 'ForbidContract'. forbiddenContractType :: forall t a. (SingI t, ForbidContract t) => (HasNoContract t => a) -> a forbiddenContractType = withDict $ forbiddenContractTypeEvi @t -- | Whether the type contains 'TOperation', with proof. data OpPresence (t :: T) = ContainsOp t ~ 'True => OpPresent | ContainsOp t ~ 'False => OpAbsent data ContractPresence (t :: T) = ContainsContract t ~ 'True => ContractPresent | ContainsContract t ~ 'False => ContractAbsent data BigMapPresence (t :: T) = ContainsBigMap t ~ 'True => BigMapPresent | ContainsBigMap t ~ 'False => BigMapAbsent data NestedBigMapsPresence (t :: T) = ContainsNestedBigMaps t ~ 'True => NestedBigMapsPresent | ContainsNestedBigMaps t ~ 'False => NestedBigMapsAbsent -- @rvem: IMO, generalization of OpPresence and BigMapPresence to -- TPresence is not worth it, due to the fact that -- it will require more boilerplate in checkTPresence implementation -- than it is already done in checkOpPresence and checkBigMapPresence -- | Check at runtime whether the given type contains 'TOperation'. checkOpPresence :: Sing (ty :: T) -> OpPresence ty checkOpPresence = \case -- This is a sad amount of boilerplate, but at least -- there is no chance to make a mistake in it. -- We can't do in a simpler way while requiring only @Sing ty@ / @SingI ty@, -- and a more complex constraint would be too unpleasant and confusing to -- propagate everywhere. STc _ -> OpAbsent STKey -> OpAbsent STSignature -> OpAbsent STChainId -> OpAbsent STUnit -> OpAbsent STOption t -> case checkOpPresence t of OpPresent -> OpPresent OpAbsent -> OpAbsent STList t -> case checkOpPresence t of OpPresent -> OpPresent OpAbsent -> OpAbsent STSet _ -> OpAbsent STOperation -> OpPresent STContract t -> case checkOpPresence t of OpPresent -> OpPresent OpAbsent -> OpAbsent STPair a b -> case (checkOpPresence a, checkOpPresence b) of (OpPresent, _) -> OpPresent (_, OpPresent) -> OpPresent (OpAbsent, OpAbsent) -> OpAbsent STOr a b -> case (checkOpPresence a, checkOpPresence b) of (OpPresent, _) -> OpPresent (_, OpPresent) -> OpPresent (OpAbsent, OpAbsent) -> OpAbsent STLambda _ _ -> OpAbsent STMap _ v -> case checkOpPresence v of OpPresent -> OpPresent OpAbsent -> OpAbsent STBigMap _ v -> case checkOpPresence v of OpPresent -> OpPresent OpAbsent -> OpAbsent -- | Check at runtime whether the given type contains 'TContract'. checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty checkContractTypePresence = \case STc _ -> ContractAbsent STKey -> ContractAbsent STSignature -> ContractAbsent STChainId -> ContractAbsent STUnit -> ContractAbsent STOption t -> case checkContractTypePresence t of ContractPresent -> ContractPresent ContractAbsent -> ContractAbsent STList t -> case checkContractTypePresence t of ContractPresent -> ContractPresent ContractAbsent -> ContractAbsent STSet _ -> ContractAbsent STOperation -> ContractAbsent STContract _ -> ContractPresent STPair a b -> case (checkContractTypePresence a, checkContractTypePresence b) of (ContractPresent, _) -> ContractPresent (_, ContractPresent) -> ContractPresent (ContractAbsent, ContractAbsent) -> ContractAbsent STOr a b -> case (checkContractTypePresence a, checkContractTypePresence b) of (ContractPresent, _) -> ContractPresent (_, ContractPresent) -> ContractPresent (ContractAbsent, ContractAbsent) -> ContractAbsent STLambda _ _ -> ContractAbsent STMap _ v -> case checkContractTypePresence v of ContractPresent -> ContractPresent ContractAbsent -> ContractAbsent STBigMap _ v -> case checkContractTypePresence v of ContractPresent -> ContractPresent ContractAbsent -> ContractAbsent -- | Check at runtime whether the given type contains 'TBigMap'. checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty checkBigMapPresence = \case -- More boilerplate to boilerplate god. STc _ -> BigMapAbsent STKey -> BigMapAbsent STSignature -> BigMapAbsent STChainId -> BigMapAbsent STUnit -> BigMapAbsent STOption t -> case checkBigMapPresence t of BigMapPresent -> BigMapPresent BigMapAbsent -> BigMapAbsent STList t -> case checkBigMapPresence t of BigMapPresent -> BigMapPresent BigMapAbsent -> BigMapAbsent STSet _ -> BigMapAbsent STOperation -> BigMapAbsent STContract t -> case checkBigMapPresence t of BigMapPresent -> BigMapPresent BigMapAbsent -> BigMapAbsent STPair a b -> case (checkBigMapPresence a, checkBigMapPresence b) of (BigMapPresent, _) -> BigMapPresent (_, BigMapPresent) -> BigMapPresent (BigMapAbsent, BigMapAbsent) -> BigMapAbsent STOr a b -> case (checkBigMapPresence a, checkBigMapPresence b) of (BigMapPresent, _) -> BigMapPresent (_, BigMapPresent) -> BigMapPresent (BigMapAbsent, BigMapAbsent) -> BigMapAbsent STLambda _ _ -> BigMapAbsent STMap _ v -> case checkBigMapPresence v of BigMapPresent -> BigMapPresent BigMapAbsent -> BigMapAbsent STBigMap _ _ -> BigMapPresent -- | Check at runtime whether the given type contains 'TBigMap'. checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty checkNestedBigMapsPresence = \case -- More boilerplate to boilerplate god. STc _ -> NestedBigMapsAbsent STKey -> NestedBigMapsAbsent STSignature -> NestedBigMapsAbsent STChainId -> NestedBigMapsAbsent STUnit -> NestedBigMapsAbsent STOption t -> case checkNestedBigMapsPresence t of NestedBigMapsPresent -> NestedBigMapsPresent NestedBigMapsAbsent -> NestedBigMapsAbsent STList t -> case checkNestedBigMapsPresence t of NestedBigMapsPresent -> NestedBigMapsPresent NestedBigMapsAbsent -> NestedBigMapsAbsent STSet _ -> NestedBigMapsAbsent STOperation -> NestedBigMapsAbsent STContract t -> case checkNestedBigMapsPresence t of NestedBigMapsPresent -> NestedBigMapsPresent NestedBigMapsAbsent -> NestedBigMapsAbsent STPair a b -> case (checkNestedBigMapsPresence a, checkNestedBigMapsPresence b) of (NestedBigMapsPresent, _) -> NestedBigMapsPresent (_, NestedBigMapsPresent) -> NestedBigMapsPresent (NestedBigMapsAbsent, NestedBigMapsAbsent) -> NestedBigMapsAbsent STOr a b -> case (checkNestedBigMapsPresence a, checkNestedBigMapsPresence b) of (NestedBigMapsPresent, _) -> NestedBigMapsPresent (_, NestedBigMapsPresent) -> NestedBigMapsPresent (NestedBigMapsAbsent, NestedBigMapsAbsent) -> NestedBigMapsAbsent STLambda _ _ -> NestedBigMapsAbsent STMap _ v -> case checkNestedBigMapsPresence v of NestedBigMapsPresent -> NestedBigMapsPresent NestedBigMapsAbsent -> NestedBigMapsAbsent STBigMap _ v -> case checkBigMapPresence v of BigMapPresent -> NestedBigMapsPresent BigMapAbsent -> NestedBigMapsAbsent -- | Check at runtime that the given type does not contain 'TOperation'. opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t) opAbsense s = case checkOpPresence s of OpPresent -> Nothing OpAbsent -> Just Dict -- | Check at runtime that the given type does not contain 'TContract'. contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoContract t) contractTypeAbsense s = case checkContractTypePresence s of ContractPresent -> Nothing ContractAbsent -> Just Dict -- | Check at runtime that the given type does not containt 'TBigMap' bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t) bigMapAbsense s = case checkBigMapPresence s of BigMapPresent -> Nothing BigMapAbsent -> Just Dict -- | Check at runtime that the given type does not contain nested 'TBigMap' nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoNestedBigMaps t) nestedBigMapsAbsense s = case checkNestedBigMapsPresence s of NestedBigMapsPresent -> Nothing NestedBigMapsAbsent -> Just Dict ---------------------------------------------------------------------------- -- Scopes ---------------------------------------------------------------------------- -- | Alias for constraints which Michelson applies to parameter. type ParameterScope t = (Typeable t, SingI t, HasNoOp t, HasNoNestedBigMaps t) -- | Alias for constraints which Michelson applies to contract storage. type StorageScope t = (Typeable t, SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) -- | Alias for constraints which Michelson applies to pushed constants. type ConstantScope t = (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t) -- | Alias for constraints which Michelson applies to packed values. type PackedValScope t = (SingI t, HasNoOp t, HasNoBigMap t) -- | Alias for constraints which Michelson applies to unpacked values. -- -- It is different from 'PackedValScope', e.g. @contract@ type cannot appear -- in a value we unpack to. type UnpackedValScope t = (PackedValScope t, ConstantScope t) -- | Alias for constraints which are required for printing. type PrintedValScope t = (SingI t, HasNoOp t) -- Versions for eDSL ---------------------------------------------------------------------------- {- These constraints are supposed to be used only in eDSL code and eDSL should define its own wrapers over it. -} type ProperParameterBetterErrors t = (Typeable t, SingI t, ForbidOp t, ForbidNestedBigMaps t) type ProperStorageBetterErrors t = (Typeable t, SingI t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t) type ProperConstantBetterErrors t = (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t) type ProperPackedValBetterErrors t = (SingI t, ForbidOp t, ForbidBigMap t) type ProperUnpackedValBetterErrors t = (ProperPackedValBetterErrors t, ProperConstantBetterErrors t) type ProperPrintedValBetterErrors t = (SingI t, ForbidOp t) properParameterEvi :: forall t. ProperParameterBetterErrors t :- ParameterScope t properParameterEvi = Sub $ Dict \\ forbiddenOpEvi @t \\ forbiddenNestedBigMapsEvi @t properStorageEvi :: forall t. ProperStorageBetterErrors t :- StorageScope t properStorageEvi = Sub $ Dict \\ forbiddenOpEvi @t \\ forbiddenContractTypeEvi @t \\ forbiddenNestedBigMapsEvi @t \\ forbiddenContractTypeEvi @t properConstantEvi :: forall t. ProperConstantBetterErrors t :- ConstantScope t properConstantEvi = Sub $ Dict \\ forbiddenOpEvi @t \\ forbiddenBigMapEvi @t \\ forbiddenContractTypeEvi @t properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t properPackedValEvi = Sub $ Dict \\ forbiddenOpEvi @t \\ forbiddenBigMapEvi @t properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t properUnpackedValEvi = properPackedValEvi @t C.*** properConstantEvi @t properPrintedValEvi :: forall t. ProperPrintedValBetterErrors t :- PrintedValScope t properPrintedValEvi = Sub $ Dict \\ forbiddenOpEvi @t