morley 1.15.1 → 1.16.0

raw patch · 255 files changed

+29842/−28845 lines, 255 filesdep −Cabaldep −doctestdep −interpolatedep ~fmtdep ~morley-preludedep ~vinylPVP ok

version bump matches the API change (PVP)

Dependencies removed: Cabal, doctest, interpolate, process

Dependency ranges changed: fmt, morley-prelude, vinyl

API changes (from Hackage documentation)

- Michelson.Analyzer: AnalyzerRes :: HashMap MText Word -> HashMap ByteString Word -> HashMap MText Word -> AnalyzerRes

- Michelson.Analyzer: [arConstBytes] :: AnalyzerRes -> HashMap ByteString Word

- Michelson.Analyzer: [arConstStrings] :: AnalyzerRes -> HashMap MText Word

- Michelson.Analyzer: [arErrorTags] :: AnalyzerRes -> HashMap MText Word

- Michelson.Analyzer: analyze :: Instr inp out -> AnalyzerRes

- Michelson.Analyzer: data AnalyzerRes

- Michelson.Analyzer: instance Formatting.Buildable.Buildable Michelson.Analyzer.AnalyzerRes

- Michelson.Analyzer: instance GHC.Base.Monoid Michelson.Analyzer.AnalyzerRes

- Michelson.Analyzer: instance GHC.Base.Semigroup Michelson.Analyzer.AnalyzerRes

- Michelson.Analyzer: instance GHC.Classes.Eq Michelson.Analyzer.AnalyzerRes

- Michelson.Analyzer: instance GHC.Show.Show Michelson.Analyzer.AnalyzerRes

- Michelson.Doc: --

- Michelson.Doc: -- Inline right here (default behaviour); 2. Put into definitions

- Michelson.Doc: -- Note that we require all doc items with "in definitions" placement to

- Michelson.Doc: -- have <a>Eq</a> and <a>Ord</a> instances which comply the following

- Michelson.Doc: -- law: if two documentation items describe the same entity or property,

- Michelson.Doc: -- section.

- Michelson.Doc: -- they should be considered equal.

- Michelson.Doc: -- | Defines where given doc item should be put. There are two options: 1.

- Michelson.Doc: ContractDoc :: DocBlock -> DocBlock -> Set SomeDocDefinitionItem -> Set DocItemId -> ContractDoc

- Michelson.Doc: DAnchor :: Anchor -> DAnchor

- Michelson.Doc: DComment :: Text -> DComment

- Michelson.Doc: DConversionInfo :: DConversionInfo

- Michelson.Doc: DDescription :: Markdown -> DDescription

- Michelson.Doc: DGeneralInfoSection :: SubDoc -> DGeneralInfoSection

- Michelson.Doc: DGitRevisionKnown :: DGitRevisionInfo -> DGitRevision

- Michelson.Doc: DGitRevisionUnknown :: DGitRevision

- Michelson.Doc: DName :: Text -> SubDoc -> DName

- Michelson.Doc: DToc :: Markdown -> DToc

- Michelson.Doc: DocElem :: d -> Maybe SubDoc -> DocElem d

- Michelson.Doc: DocItemId :: Text -> DocItemId

- Michelson.Doc: DocItemInDefinitions :: DocItemPlacementKind

- Michelson.Doc: DocItemInlined :: DocItemPlacementKind

- Michelson.Doc: DocItemPos :: (Natural, Text) -> DocItemPos

- Michelson.Doc: DocSection :: (NonEmpty $ DocElem d) -> DocSection

- Michelson.Doc: DocSectionNameBig :: DocSectionNameStyle

- Michelson.Doc: DocSectionNameSmall :: DocSectionNameStyle

- Michelson.Doc: GitRepoSettings :: (Text -> Text) -> GitRepoSettings

- Michelson.Doc: SubDoc :: DocBlock -> SubDoc

- Michelson.Doc: WithFinalizedDoc :: Identity a -> WithFinalizedDoc a

- Michelson.Doc: [DocItemNoRef] :: DocItemRef 'DocItemInlined 'False

- Michelson.Doc: [DocItemRefInlined] :: DocItemId -> DocItemRef 'DocItemInlined 'True

- Michelson.Doc: [DocItemRef] :: DocItemId -> DocItemRef 'DocItemInDefinitions 'True

- Michelson.Doc: [SomeDocDefinitionItem] :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) => d -> SomeDocDefinitionItem

- Michelson.Doc: [SomeDocItem] :: DocItem d => d -> SomeDocItem

- Michelson.Doc: [cdContents] :: ContractDoc -> DocBlock

- Michelson.Doc: [cdDefinitionIds] :: ContractDoc -> Set DocItemId

- Michelson.Doc: [cdDefinitionsSet] :: ContractDoc -> Set SomeDocDefinitionItem

- Michelson.Doc: [cdDefinitions] :: ContractDoc -> DocBlock

- Michelson.Doc: [deItem] :: DocElem d -> d

- Michelson.Doc: [deSub] :: DocElem d -> Maybe SubDoc

- Michelson.Doc: [grsMkGitRevision] :: GitRepoSettings -> Text -> Text

- Michelson.Doc: attachDocCommons :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a

- Michelson.Doc: attachGitInfo :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a

- Michelson.Doc: attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a

- Michelson.Doc: buildDoc :: ContainsDoc a => WithFinalizedDoc a -> ContractDoc

- Michelson.Doc: buildDocUnfinalized :: ContainsDoc a => a -> ContractDoc

- Michelson.Doc: buildMarkdownDoc :: ContainsDoc a => WithFinalizedDoc a -> LText

- Michelson.Doc: cdContentsL :: Lens' ContractDoc DocBlock

- Michelson.Doc: cdDefinitionIdsL :: Lens' ContractDoc (Set DocItemId)

- Michelson.Doc: cdDefinitionsL :: Lens' ContractDoc DocBlock

- Michelson.Doc: cdDefinitionsSetL :: Lens' ContractDoc (Set SomeDocDefinitionItem)

- Michelson.Doc: class ContainsDoc a

- Michelson.Doc: class ContainsDoc a => ContainsUpdateableDoc a

- Michelson.Doc: class (Typeable d, DOrd d) => DocItem d where {

- Michelson.Doc: contractDocToMarkdown :: ContractDoc -> LText

- Michelson.Doc: contractDocToToc :: ContractDoc -> Markdown

- Michelson.Doc: data ContractDoc

- Michelson.Doc: data DAnchor

- Michelson.Doc: data DComment

- Michelson.Doc: data DConversionInfo

- Michelson.Doc: data DDescription

- Michelson.Doc: data DGitRevision

- Michelson.Doc: data DName

- Michelson.Doc: data DToc

- Michelson.Doc: data DocElem d

- Michelson.Doc: data DocItemPlacementKind

- Michelson.Doc: data DocItemRef (p :: DocItemPlacementKind) (r :: DocItemReferencedKind)

- Michelson.Doc: data DocSection

- Michelson.Doc: data DocSectionNameStyle

- Michelson.Doc: data SomeDocDefinitionItem

- Michelson.Doc: data SomeDocItem

- Michelson.Doc: deIsAtomic :: DocElem d -> Bool

- Michelson.Doc: docDefinitionRef :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) => Markdown -> d -> Markdown

- Michelson.Doc: docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc

- Michelson.Doc: docItemDependencies :: DocItem d => d -> [SomeDocDefinitionItem]

- Michelson.Doc: docItemPos :: DocItem d => Natural

- Michelson.Doc: docItemPosition :: forall d. DocItem d => DocItemPos

- Michelson.Doc: docItemRef :: (DocItem d, DocItemPlacement d ~ 'DocItemInlined, DocItemReferenced d ~ 'False) => d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)

- Michelson.Doc: docItemSectionDescription :: DocItem d => Maybe Markdown

- Michelson.Doc: docItemSectionName :: DocItem d => Maybe Text

- Michelson.Doc: docItemSectionNameStyle :: DocItem d => DocSectionNameStyle

- Michelson.Doc: docItemSectionRef :: forall di. DocItem di => Maybe Markdown

- Michelson.Doc: docItemToBlock :: forall di. DocItem di => di -> DocBlock

- Michelson.Doc: docItemToMarkdown :: DocItem d => HeaderLevel -> d -> Markdown

- Michelson.Doc: docItemToToc :: DocItem d => HeaderLevel -> d -> Markdown

- Michelson.Doc: docItemsOrder :: DocItem d => [d] -> [d]

- Michelson.Doc: finalizedAsIs :: a -> WithFinalizedDoc a

- Michelson.Doc: instance (di GHC.Types.~ Michelson.Doc.DName) => Data.String.IsString (Michelson.Doc.SubDoc -> di)

- Michelson.Doc: instance Control.DeepSeq.NFData Michelson.Doc.SomeDocItem

- Michelson.Doc: instance Formatting.Buildable.Buildable Michelson.Doc.DocItemPos

- Michelson.Doc: instance GHC.Base.Applicative Michelson.Doc.WithFinalizedDoc

- Michelson.Doc: instance GHC.Base.Functor Michelson.Doc.WithFinalizedDoc

- Michelson.Doc: instance GHC.Base.Monad Michelson.Doc.WithFinalizedDoc

- Michelson.Doc: instance GHC.Base.Monoid Michelson.Doc.ContractDoc

- Michelson.Doc: instance GHC.Base.Semigroup Michelson.Doc.ContractDoc

- Michelson.Doc: instance GHC.Classes.Eq Michelson.Doc.DocItemId

- Michelson.Doc: instance GHC.Classes.Eq Michelson.Doc.DocItemPos

- Michelson.Doc: instance GHC.Classes.Eq Michelson.Doc.SomeDocDefinitionItem

- Michelson.Doc: instance GHC.Classes.Ord Michelson.Doc.DocItemId

- Michelson.Doc: instance GHC.Classes.Ord Michelson.Doc.DocItemPos

- Michelson.Doc: instance GHC.Classes.Ord Michelson.Doc.SomeDocDefinitionItem

- Michelson.Doc: instance GHC.Show.Show Michelson.Doc.DocGrouping

- Michelson.Doc: instance GHC.Show.Show Michelson.Doc.DocItemId

- Michelson.Doc: instance GHC.Show.Show Michelson.Doc.DocItemPos

- Michelson.Doc: instance GHC.Show.Show Michelson.Doc.DocSection

- Michelson.Doc: instance GHC.Show.Show Michelson.Doc.SomeDocItem

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DAnchor

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DComment

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DConversionInfo

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DDescription

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DGeneralInfoSection

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DGitRevision

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DName

- Michelson.Doc: instance Michelson.Doc.DocItem Michelson.Doc.DToc

- Michelson.Doc: instance Util.Markdown.ToAnchor (Michelson.Doc.DocItemRef d 'GHC.Types.True)

- Michelson.Doc: instance Util.Markdown.ToAnchor Michelson.Doc.DocItemId

- Michelson.Doc: instance Util.Markdown.ToAnchor Michelson.Doc.SectionAnchor

- Michelson.Doc: lookupDocBlockSection :: forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)

- Michelson.Doc: mdTocFromRef :: (DocItem d, DocItemReferenced d ~ 'True) => HeaderLevel -> Markdown -> d -> Markdown

- Michelson.Doc: mkDGitRevision :: ExpQ

- Michelson.Doc: modifyDoc :: (ContainsUpdateableDoc a, DocItem i1, DocItem i2) => (i1 -> Maybe i2) -> a -> a

- Michelson.Doc: modifyDocEntirely :: ContainsUpdateableDoc a => (SomeDocItem -> SomeDocItem) -> a -> a

- Michelson.Doc: morleyRepoSettings :: GitRepoSettings

- Michelson.Doc: newtype DGeneralInfoSection

- Michelson.Doc: newtype DocItemId

- Michelson.Doc: newtype DocItemPos

- Michelson.Doc: newtype GitRepoSettings

- Michelson.Doc: newtype SubDoc

- Michelson.Doc: newtype WithFinalizedDoc a

- Michelson.Doc: subDocToMarkdown :: HeaderLevel -> SubDoc -> Markdown

- Michelson.Doc: type DocBlock = Map DocItemPos DocSection

- Michelson.Doc: type DocGrouping = SubDoc -> SomeDocItem

- Michelson.Doc: type DocItemPlacement _ = 'DocItemInlined;

- Michelson.Doc: type DocItemReferenced _ = 'False;

- Michelson.Doc: type DocItemReferencedKind = Bool

- Michelson.Doc: type family DocItemReferenced d :: DocItemReferencedKind;

- Michelson.Doc: }

- Michelson.ErrorPos: InstrCallStack :: LetCallStack -> SrcPos -> InstrCallStack

- Michelson.ErrorPos: LetName :: Text -> LetName

- Michelson.ErrorPos: Pos :: Word -> Pos

- Michelson.ErrorPos: SrcPos :: Pos -> Pos -> SrcPos

- Michelson.ErrorPos: [icsCallStack] :: InstrCallStack -> LetCallStack

- Michelson.ErrorPos: [icsSrcPos] :: InstrCallStack -> SrcPos

- Michelson.ErrorPos: [srcCol] :: SrcPos -> Pos

- Michelson.ErrorPos: [srcLine] :: SrcPos -> Pos

- Michelson.ErrorPos: [unPos] :: Pos -> Word

- Michelson.ErrorPos: data InstrCallStack

- Michelson.ErrorPos: data SrcPos

- Michelson.ErrorPos: instance Control.DeepSeq.NFData Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance Control.DeepSeq.NFData Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance Control.DeepSeq.NFData Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance Control.DeepSeq.NFData Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance Data.Data.Data Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance Data.Data.Data Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance Data.Data.Data Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance Data.Data.Data Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance Data.Default.Class.Default Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance Data.Default.Class.Default Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance Data.Default.Class.Default Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance Formatting.Buildable.Buildable Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance Formatting.Buildable.Buildable Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance GHC.Classes.Eq Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance GHC.Classes.Eq Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance GHC.Classes.Eq Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance GHC.Classes.Eq Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance GHC.Classes.Ord Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance GHC.Classes.Ord Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance GHC.Classes.Ord Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance GHC.Classes.Ord Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance GHC.Generics.Generic Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance GHC.Generics.Generic Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance GHC.Generics.Generic Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance GHC.Generics.Generic Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance GHC.Show.Show Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: instance GHC.Show.Show Michelson.ErrorPos.LetName

- Michelson.ErrorPos: instance GHC.Show.Show Michelson.ErrorPos.Pos

- Michelson.ErrorPos: instance GHC.Show.Show Michelson.ErrorPos.SrcPos

- Michelson.ErrorPos: instance Michelson.Printer.Util.RenderDoc Michelson.ErrorPos.InstrCallStack

- Michelson.ErrorPos: mkPos :: Int -> Maybe Pos

- Michelson.ErrorPos: newtype LetName

- Michelson.ErrorPos: newtype Pos

- Michelson.ErrorPos: srcPos :: Word -> Word -> SrcPos

- Michelson.ErrorPos: type LetCallStack = [LetName]

- Michelson.ErrorPos: unsafeMkPos :: Int -> Pos

- Michelson.FailPattern: data TypicalFailWith

- Michelson.FailPattern: isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith

- Michelson.FailPattern: modifyTypicalFailWith :: HasCallStack => (MText -> SomeConstrainedValue ConstantScope) -> Instr inp out -> Instr inp out

- Michelson.FailPattern: typicalFailWithTag :: TypicalFailWith -> MText

- Michelson.Interpret: ContractEnv :: Timestamp -> RemainingSteps -> Mutez -> TcOriginatedContracts -> Address -> Address -> Address -> Mutez -> VotingPowers -> ChainId -> Maybe OperationHash -> GlobalCounter -> Natural -> ContractEnv

- Michelson.Interpret: InterpretError :: (MichelsonFailed, MorleyLogs) -> InterpretError

- Michelson.Interpret: InterpreterState :: MorleyLogs -> RemainingSteps -> OriginationIndex -> BigMapCounter -> InterpreterState

- Michelson.Interpret: MorleyLogs :: [Text] -> MorleyLogs

- Michelson.Interpret: RemainingSteps :: Word64 -> RemainingSteps

- Michelson.Interpret: StkEl :: Value t -> VarAnn -> Notes t -> StkEl t

- Michelson.Interpret: [InterpretResult] :: StorageScope st => {iurOps :: [Operation], iurNewStorage :: Value st, iurNewState :: InterpreterState} -> InterpretResult

- Michelson.Interpret: [MichelsonArithError] :: (Typeable n, Typeable m, Typeable instr) => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed

- Michelson.Interpret: [MichelsonFailedTestAssert] :: Text -> MichelsonFailed

- Michelson.Interpret: [MichelsonFailedWith] :: (SingI t, ConstantScope t) => Value t -> MichelsonFailed

- Michelson.Interpret: [MichelsonGasExhaustion] :: MichelsonFailed

- Michelson.Interpret: [SomeItStack] :: ExtInstr inp -> Rec StkEl inp -> SomeItStack

- Michelson.Interpret: [ceAmount] :: ContractEnv -> Mutez

- Michelson.Interpret: [ceBalance] :: ContractEnv -> Mutez

- Michelson.Interpret: [ceChainId] :: ContractEnv -> ChainId

- Michelson.Interpret: [ceContracts] :: ContractEnv -> TcOriginatedContracts

- Michelson.Interpret: [ceGlobalCounter] :: ContractEnv -> GlobalCounter

- Michelson.Interpret: [ceLevel] :: ContractEnv -> Natural

- Michelson.Interpret: [ceMaxSteps] :: ContractEnv -> RemainingSteps

- Michelson.Interpret: [ceNow] :: ContractEnv -> Timestamp

- Michelson.Interpret: [ceOperationHash] :: ContractEnv -> Maybe OperationHash

- Michelson.Interpret: [ceSelf] :: ContractEnv -> Address

- Michelson.Interpret: [ceSender] :: ContractEnv -> Address

- Michelson.Interpret: [ceSource] :: ContractEnv -> Address

- Michelson.Interpret: [ceVotingPowers] :: ContractEnv -> VotingPowers

- Michelson.Interpret: [isBigMapCounter] :: InterpreterState -> BigMapCounter

- Michelson.Interpret: [isMorleyLogs] :: InterpreterState -> MorleyLogs

- Michelson.Interpret: [isOriginationNonce] :: InterpreterState -> OriginationIndex

- Michelson.Interpret: [isRemainingSteps] :: InterpreterState -> RemainingSteps

- Michelson.Interpret: [seNotes] :: StkEl t -> Notes t

- Michelson.Interpret: [seValue] :: StkEl t -> Value t

- Michelson.Interpret: [seVarAnn] :: StkEl t -> VarAnn

- Michelson.Interpret: assignBigMapIds :: MonadState BigMapCounter m => Value t -> m (Value t)

- Michelson.Interpret: class Monad m => InterpreterStateMonad m

- Michelson.Interpret: data ContractEnv

- Michelson.Interpret: data InterpretResult

- Michelson.Interpret: data InterpreterState

- Michelson.Interpret: data MichelsonFailed

- Michelson.Interpret: data SomeItStack

- Michelson.Interpret: data StkEl t

- Michelson.Interpret: fromFinalStack :: Rec StkEl (ContractOut st) -> ([Operation], Value st)

- Michelson.Interpret: getInterpreterState :: InterpreterStateMonad m => m InterpreterState

- Michelson.Interpret: handleContractReturn :: StorageScope st => ContractReturn st -> Either InterpretError InterpretResult

- Michelson.Interpret: initInterpreterState :: BigMapCounter -> ContractEnv -> InterpreterState

- Michelson.Interpret: instance Control.DeepSeq.NFData Michelson.Interpret.InterpreterState

- Michelson.Interpret: instance Control.DeepSeq.NFData Michelson.Interpret.MichelsonFailed

- Michelson.Interpret: instance Control.DeepSeq.NFData Michelson.Interpret.MorleyLogs

- Michelson.Interpret: instance Control.DeepSeq.NFData Michelson.Interpret.RemainingSteps

- Michelson.Interpret: instance Data.Default.Class.Default Michelson.Interpret.MorleyLogs

- Michelson.Interpret: instance Formatting.Buildable.Buildable Michelson.Interpret.InterpretError

- Michelson.Interpret: instance Formatting.Buildable.Buildable Michelson.Interpret.MichelsonFailed

- Michelson.Interpret: instance Formatting.Buildable.Buildable Michelson.Interpret.MorleyLogs

- Michelson.Interpret: instance Formatting.Buildable.Buildable Michelson.Interpret.RemainingSteps

- Michelson.Interpret: instance GHC.Classes.Eq (Michelson.Interpret.StkEl t)

- Michelson.Interpret: instance GHC.Classes.Eq Michelson.Interpret.MichelsonFailed

- Michelson.Interpret: instance GHC.Classes.Eq Michelson.Interpret.MorleyLogs

- Michelson.Interpret: instance GHC.Classes.Eq Michelson.Interpret.RemainingSteps

- Michelson.Interpret: instance GHC.Classes.Ord Michelson.Interpret.RemainingSteps

- Michelson.Interpret: instance GHC.Generics.Generic Michelson.Interpret.InterpretError

- Michelson.Interpret: instance GHC.Generics.Generic Michelson.Interpret.InterpreterState

- Michelson.Interpret: instance GHC.Generics.Generic Michelson.Interpret.MorleyLogs

- Michelson.Interpret: instance GHC.Generics.Generic Michelson.Interpret.RemainingSteps

- Michelson.Interpret: instance GHC.Num.Num Michelson.Interpret.RemainingSteps

- Michelson.Interpret: instance GHC.Show.Show (Michelson.Interpret.StkEl t)

- Michelson.Interpret: instance GHC.Show.Show Michelson.Interpret.InterpretError

- Michelson.Interpret: instance GHC.Show.Show Michelson.Interpret.InterpretResult

- Michelson.Interpret: instance GHC.Show.Show Michelson.Interpret.InterpreterState

- Michelson.Interpret: instance GHC.Show.Show Michelson.Interpret.MichelsonFailed

- Michelson.Interpret: instance GHC.Show.Show Michelson.Interpret.MorleyLogs

- Michelson.Interpret: instance GHC.Show.Show Michelson.Interpret.RemainingSteps

- Michelson.Interpret: instance Michelson.Interpret.InterpreterStateMonad (Control.Monad.Trans.Except.ExceptT Michelson.Interpret.MichelsonFailed Universum.TypeOps.$ (Control.Monad.Trans.Reader.ReaderT Michelson.Interpret.ContractEnv Universum.TypeOps.$ Control.Monad.Trans.State.Strict.State Michelson.Interpret.InterpreterState))

- Michelson.Interpret: interpret :: Contract cp st -> EntrypointCallT cp arg -> Value arg -> Value st -> BigMapCounter -> ContractEnv -> ContractReturn st

- Michelson.Interpret: interpretInstr :: ContractEnv -> Instr inp out -> Rec Value inp -> Either MichelsonFailed (Rec Value out)

- Michelson.Interpret: interpretInstrAnnotated :: ContractEnv -> Instr inp out -> Rec Value inp -> Either MichelsonFailed (Rec StkEl out)

- Michelson.Interpret: isMorleyLogsL :: Lens' InterpreterState MorleyLogs

- Michelson.Interpret: mkInitStack :: Value param -> ParamNotes param -> Value st -> Notes st -> Rec StkEl (ContractInp param st)

- Michelson.Interpret: modifyInterpreterState :: InterpreterStateMonad m => (InterpreterState -> InterpreterState) -> m ()

- Michelson.Interpret: newtype InterpretError

- Michelson.Interpret: newtype MorleyLogs

- Michelson.Interpret: newtype RemainingSteps

- Michelson.Interpret: noMorleyLogs :: MorleyLogs

- Michelson.Interpret: pickMorleyLogs :: MorleyLogs -> [Text]

- Michelson.Interpret: putInterpreterState :: InterpreterStateMonad m => InterpreterState -> m ()

- Michelson.Interpret: runInstr :: EvalM m => InstrRunner m

- Michelson.Interpret: runInstrImpl :: forall m. EvalM m => InstrRunner m -> InstrRunner m

- Michelson.Interpret: runInstrNoGas :: EvalM m => InstrRunner m

- Michelson.Interpret: runUnpack :: forall t. UnpackedValScope t => ByteString -> Either UnpackError (Value t)

- Michelson.Interpret: starNotesStkEl :: forall t. Value t -> StkEl t

- Michelson.Interpret: stateInterpreterState :: InterpreterStateMonad m => (InterpreterState -> (a, InterpreterState)) -> m a

- Michelson.Interpret: type ContractReturn st = (Either MichelsonFailed ([Operation], Value st), InterpreterState)

- Michelson.Interpret: type EvalM m = (MonadReader ContractEnv m, InterpreterStateMonad m, MonadError MichelsonFailed m)

- Michelson.Interpret: type InstrRunner m = forall inp out. Instr inp out -> Rec StkEl inp -> m (Rec StkEl out)

- Michelson.Interpret.Pack: packValue :: PackedValScope t => Value t -> LByteString

- Michelson.Interpret.Pack: packValue' :: PackedValScope t => Value t -> ByteString

- Michelson.Interpret.Pack: packValuePrefix :: IsString s => s

- Michelson.Interpret.Pack: toBinary :: ToExpression a => a -> LByteString

- Michelson.Interpret.Pack: toBinary' :: ToExpression a => a -> ByteString

- Michelson.Interpret.Unpack: UnpackError :: Text -> UnpackError

- Michelson.Interpret.Unpack: [unUnpackError] :: UnpackError -> Text

- Michelson.Interpret.Unpack: newtype UnpackError

- Michelson.Interpret.Unpack: unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]

- Michelson.Interpret.Unpack: unpackUValue' :: ByteString -> Either UnpackError Value

- Michelson.Interpret.Unpack: unpackValue' :: forall t. UnpackedValScope t => ByteString -> Either UnpackError (Value t)

- Michelson.Interpret.Utils: encodeZarithNumber :: Integer -> NonEmpty Word8

- Michelson.Let: LetType :: Text -> Ty -> LetType

- Michelson.Let: LetValue :: Text -> Ty -> Value' ParsedOp -> LetValue

- Michelson.Let: [ltName] :: LetType -> Text

- Michelson.Let: [ltSig] :: LetType -> Ty

- Michelson.Let: [lvName] :: LetValue -> Text

- Michelson.Let: [lvSig] :: LetValue -> Ty

- Michelson.Let: [lvVal] :: LetValue -> Value' ParsedOp

- Michelson.Let: data LetType

- Michelson.Let: data LetValue

- Michelson.Let: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Let.LetType

- Michelson.Let: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Let.LetValue

- Michelson.Let: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Let.LetType

- Michelson.Let: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Let.LetValue

- Michelson.Let: instance GHC.Classes.Eq Michelson.Let.LetType

- Michelson.Let: instance GHC.Classes.Eq Michelson.Let.LetValue

- Michelson.Let: instance GHC.Show.Show Michelson.Let.LetType

- Michelson.Let: instance GHC.Show.Show Michelson.Let.LetValue

- Michelson.Macro: A :: CadrStruct

- Michelson.Macro: ACCESS :: Natural -> Positive -> Macro

- Michelson.Macro: ASSERT :: Macro

- Michelson.Macro: ASSERTX :: ParsedInstr -> Macro

- Michelson.Macro: ASSERT_CMP :: ParsedInstr -> Macro

- Michelson.Macro: ASSERT_LEFT :: Macro

- Michelson.Macro: ASSERT_NONE :: Macro

- Michelson.Macro: ASSERT_RIGHT :: Macro

- Michelson.Macro: ASSERT_SOME :: Macro

- Michelson.Macro: CADR :: [CadrStruct] -> VarAnn -> FieldAnn -> Macro

- Michelson.Macro: CARN :: VarAnn -> Word -> Macro

- Michelson.Macro: CASE :: NonEmpty [ParsedOp] -> Macro

- Michelson.Macro: CDRN :: VarAnn -> Word -> Macro

- Michelson.Macro: CMP :: ParsedInstr -> VarAnn -> Macro

- Michelson.Macro: CONSTRUCT :: NonEmpty [ParsedOp] -> Macro

- Michelson.Macro: D :: CadrStruct

- Michelson.Macro: DIIP :: Word -> [ParsedOp] -> Macro

- Michelson.Macro: DUUP :: Word -> VarAnn -> Macro

- Michelson.Macro: F :: FieldAnn -> PairStruct

- Michelson.Macro: FAIL :: Macro

- Michelson.Macro: IFCMP :: ParsedInstr -> VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro

- Michelson.Macro: IFX :: ParsedInstr -> [ParsedOp] -> [ParsedOp] -> Macro

- Michelson.Macro: IF_RIGHT :: [ParsedOp] -> [ParsedOp] -> Macro

- Michelson.Macro: IF_SOME :: [ParsedOp] -> [ParsedOp] -> Macro

- Michelson.Macro: LMac :: LetMacro -> SrcPos -> ParsedOp

- Michelson.Macro: LetMacro :: Text -> StackFn -> [ParsedOp] -> LetMacro

- Michelson.Macro: MAP_CADR :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> Macro

- Michelson.Macro: Mac :: Macro -> SrcPos -> ParsedOp

- Michelson.Macro: P :: PairStruct -> PairStruct -> PairStruct

- Michelson.Macro: PAPAIR :: PairStruct -> TypeAnn -> VarAnn -> Macro

- Michelson.Macro: Prim :: ParsedInstr -> SrcPos -> ParsedOp

- Michelson.Macro: SET :: Natural -> Positive -> Macro

- Michelson.Macro: SET_CADR :: [CadrStruct] -> VarAnn -> FieldAnn -> Macro

- Michelson.Macro: Seq :: [ParsedOp] -> SrcPos -> ParsedOp

- Michelson.Macro: TAG :: Natural -> NonEmpty Ty -> Macro

- Michelson.Macro: UF :: UnpairStruct

- Michelson.Macro: UNPAPAIR :: UnpairStruct -> Macro

- Michelson.Macro: UP :: UnpairStruct -> UnpairStruct -> UnpairStruct

- Michelson.Macro: VIEW :: [ParsedOp] -> Macro

- Michelson.Macro: VOID :: [ParsedOp] -> Macro

- Michelson.Macro: [lmExpr] :: LetMacro -> [ParsedOp]

- Michelson.Macro: [lmName] :: LetMacro -> Text

- Michelson.Macro: [lmSig] :: LetMacro -> StackFn

- Michelson.Macro: data CadrStruct

- Michelson.Macro: data LetMacro

- Michelson.Macro: data Macro

- Michelson.Macro: data PairStruct

- Michelson.Macro: data ParsedOp

- Michelson.Macro: data UnpairStruct

- Michelson.Macro: expand :: LetCallStack -> ParsedOp -> ExpandedOp

- Michelson.Macro: expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]

- Michelson.Macro: expandContract :: Contract' ParsedOp -> Contract

- Michelson.Macro: expandList :: [ParsedOp] -> [ExpandedOp]

- Michelson.Macro: expandMacro :: InstrCallStack -> Macro -> [ExpandedOp]

- Michelson.Macro: expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp]

- Michelson.Macro: expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp]

- Michelson.Macro: expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]

- Michelson.Macro: expandUnpapair :: InstrCallStack -> UnpairStruct -> [ExpandedOp]

- Michelson.Macro: expandValue :: ParsedValue -> Value

- Michelson.Macro: instance Control.DeepSeq.NFData Michelson.Macro.CadrStruct

- Michelson.Macro: instance Control.DeepSeq.NFData Michelson.Macro.LetMacro

- Michelson.Macro: instance Control.DeepSeq.NFData Michelson.Macro.Macro

- Michelson.Macro: instance Control.DeepSeq.NFData Michelson.Macro.PairStruct

- Michelson.Macro: instance Control.DeepSeq.NFData Michelson.Macro.ParsedOp

- Michelson.Macro: instance Control.DeepSeq.NFData Michelson.Macro.UnpairStruct

- Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Macro.CadrStruct

- Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Macro.LetMacro

- Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Macro.Macro

- Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Macro.PairStruct

- Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Macro.ParsedOp

- Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Macro.UnpairStruct

- Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Macro.CadrStruct

- Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Macro.LetMacro

- Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Macro.Macro

- Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Macro.PairStruct

- Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Macro.ParsedOp

- Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Macro.UnpairStruct

- Michelson.Macro: instance Data.Data.Data Michelson.Macro.CadrStruct

- Michelson.Macro: instance Data.Data.Data Michelson.Macro.LetMacro

- Michelson.Macro: instance Data.Data.Data Michelson.Macro.Macro

- Michelson.Macro: instance Data.Data.Data Michelson.Macro.PairStruct

- Michelson.Macro: instance Data.Data.Data Michelson.Macro.ParsedOp

- Michelson.Macro: instance Data.Data.Data Michelson.Macro.UnpairStruct

- Michelson.Macro: instance Formatting.Buildable.Buildable Michelson.Macro.CadrStruct

- Michelson.Macro: instance Formatting.Buildable.Buildable Michelson.Macro.LetMacro

- Michelson.Macro: instance Formatting.Buildable.Buildable Michelson.Macro.Macro

- Michelson.Macro: instance Formatting.Buildable.Buildable Michelson.Macro.PairStruct

- Michelson.Macro: instance Formatting.Buildable.Buildable Michelson.Macro.ParsedOp

- Michelson.Macro: instance Formatting.Buildable.Buildable Michelson.Macro.UnpairStruct

- Michelson.Macro: instance GHC.Classes.Eq Michelson.Macro.CadrStruct

- Michelson.Macro: instance GHC.Classes.Eq Michelson.Macro.LetMacro

- Michelson.Macro: instance GHC.Classes.Eq Michelson.Macro.Macro

- Michelson.Macro: instance GHC.Classes.Eq Michelson.Macro.PairStruct

- Michelson.Macro: instance GHC.Classes.Eq Michelson.Macro.ParsedOp

- Michelson.Macro: instance GHC.Classes.Eq Michelson.Macro.UnpairStruct

- Michelson.Macro: instance GHC.Generics.Generic Michelson.Macro.CadrStruct

- Michelson.Macro: instance GHC.Generics.Generic Michelson.Macro.LetMacro

- Michelson.Macro: instance GHC.Generics.Generic Michelson.Macro.Macro

- Michelson.Macro: instance GHC.Generics.Generic Michelson.Macro.PairStruct

- Michelson.Macro: instance GHC.Generics.Generic Michelson.Macro.ParsedOp

- Michelson.Macro: instance GHC.Generics.Generic Michelson.Macro.UnpairStruct

- Michelson.Macro: instance GHC.Show.Show Michelson.Macro.CadrStruct

- Michelson.Macro: instance GHC.Show.Show Michelson.Macro.LetMacro

- Michelson.Macro: instance GHC.Show.Show Michelson.Macro.Macro

- Michelson.Macro: instance GHC.Show.Show Michelson.Macro.PairStruct

- Michelson.Macro: instance GHC.Show.Show Michelson.Macro.ParsedOp

- Michelson.Macro: instance GHC.Show.Show Michelson.Macro.UnpairStruct

- Michelson.Macro: instance Michelson.Printer.Util.RenderDoc Michelson.Macro.ParsedOp

- Michelson.Macro: mapPairLeaves :: [FieldAnn] -> PairStruct -> PairStruct

- Michelson.Macro: type ParsedInstr = InstrAbstract ParsedOp

- Michelson.Macro: type ParsedUExtInstr = ExtInstrAbstract ParsedOp

- Michelson.Macro: type ParsedValue = Value' ParsedOp

- Michelson.Optimizer: OptimizerConf :: Bool -> (Rule -> Rule) -> OptimizerConf

- Michelson.Optimizer: [ocGotoValues] :: OptimizerConf -> Bool

- Michelson.Optimizer: [ocRuleset] :: OptimizerConf -> Rule -> Rule

- Michelson.Optimizer: data OptimizerConf

- Michelson.Optimizer: defaultOptimizerConf :: OptimizerConf

- Michelson.Optimizer: defaultRules :: Rule -> Rule

- Michelson.Optimizer: defaultRulesAndPushPack :: Rule -> Rule

- Michelson.Optimizer: instance Data.Default.Class.Default Michelson.Optimizer.OptimizerConf

- Michelson.Optimizer: ocGotoValuesL :: Lens' OptimizerConf Bool

- Michelson.Optimizer: optimize :: Instr inp out -> Instr inp out

- Michelson.Optimizer: optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out

- Michelson.Optimizer: orRule :: (Rule -> Rule) -> (Rule -> Rule) -> Rule -> Rule

- Michelson.Optimizer: orSimpleRule :: (Rule -> Rule) -> Rule -> Rule -> Rule

- Michelson.Optimizer: type Rule = forall inp out. Instr inp out -> Maybe (Instr inp out)

- Michelson.Parser: ExcessFieldAnnotation :: CustomParserException

- Michelson.Parser: InvalidChar :: Char -> StringLiteralParserException

- Michelson.Parser: InvalidEscapeSequence :: Char -> StringLiteralParserException

- Michelson.Parser: MultiRootAnnotationException :: CustomParserException

- Michelson.Parser: OddNumberBytesException :: CustomParserException

- Michelson.Parser: ParserException :: ParseErrorBundle Text CustomParserException -> ParserException

- Michelson.Parser: StringLiteralException :: StringLiteralParserException -> CustomParserException

- Michelson.Parser: WrongAccessArgs :: Natural -> Positive -> CustomParserException

- Michelson.Parser: WrongSetArgs :: Natural -> Positive -> CustomParserException

- Michelson.Parser: WrongTagArgs :: Natural -> Positive -> CustomParserException

- Michelson.Parser: bytesLiteral :: Parser (Value' op)

- Michelson.Parser: codeEntry :: Parser [ParsedOp]

- Michelson.Parser: data CustomParserException

- Michelson.Parser: data ParseErrorBundle s e

- Michelson.Parser: data ParserException

- Michelson.Parser: data StringLiteralParserException

- Michelson.Parser: errorBundlePretty :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String

- Michelson.Parser: intLiteral :: Parser (Value' op)

- Michelson.Parser: letInner :: Parser ParsedOp -> Parser LetEnv

- Michelson.Parser: letType :: Parser LetType

- Michelson.Parser: ops :: Parser [ParsedOp]

- Michelson.Parser: parseExpandValue :: Text -> Either ParserException Value

- Michelson.Parser: parseExpandValueFromFile :: FilePath -> Text -> Either ParserException Value

- Michelson.Parser: parseNoEnv :: Parser a -> String -> Text -> Either (ParseErrorBundle Text CustomParserException) a

- Michelson.Parser: parseValue :: Text -> Either ParserException ParsedValue

- Michelson.Parser: parseValueFromFile :: FilePath -> Text -> Either ParserException ParsedValue

- Michelson.Parser: parsedOp :: Parser ParsedOp

- Michelson.Parser: printComment :: Parser PrintComment

- Michelson.Parser: program :: Parsec CustomParserException Text (Contract' ParsedOp)

- Michelson.Parser: stringLiteral :: Parser ParsedValue

- Michelson.Parser: type Parser = ReaderT LetEnv (Parsec CustomParserException Text)

- Michelson.Parser: type_ :: Parser Ty

- Michelson.Parser: uparamTypeQ :: QuasiQuoter

- Michelson.Parser: utypeQ :: QuasiQuoter

- Michelson.Parser: value :: Parser ParsedValue

- Michelson.Parser.Annotations: fieldType :: Default a => Parser a -> Parser (a, TypeAnn)

- Michelson.Parser.Annotations: note :: forall tag. KnownAnnTag tag => Parser (Annotation tag)

- Michelson.Parser.Annotations: noteDef :: KnownAnnTag tag => Parser (Annotation tag)

- Michelson.Parser.Annotations: noteF :: Parser FieldAnn

- Michelson.Parser.Annotations: noteV :: Parser VarAnn

- Michelson.Parser.Annotations: noteV2Def :: Parser (VarAnn, VarAnn)

- Michelson.Parser.Annotations: notesTF :: Parser (TypeAnn, FieldAnn)

- Michelson.Parser.Annotations: notesTV :: Parser (TypeAnn, VarAnn)

- Michelson.Parser.Annotations: notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn)

- Michelson.Parser.Annotations: notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))

- Michelson.Parser.Annotations: notesVF :: Parser (VarAnn, FieldAnn)

- Michelson.Parser.Annotations: notesVVFF :: Parser ((VarAnn, VarAnn), (FieldAnn, FieldAnn))

- Michelson.Parser.Annotations: permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a, b)

- Michelson.Parser.Annotations: permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) => f a -> f b -> f c -> f (a, b, c)

- Michelson.Parser.Error: ExcessFieldAnnotation :: CustomParserException

- Michelson.Parser.Error: InvalidChar :: Char -> StringLiteralParserException

- Michelson.Parser.Error: InvalidEscapeSequence :: Char -> StringLiteralParserException

- Michelson.Parser.Error: MultiRootAnnotationException :: CustomParserException

- Michelson.Parser.Error: OddNumberBytesException :: CustomParserException

- Michelson.Parser.Error: ParserException :: ParseErrorBundle Text CustomParserException -> ParserException

- Michelson.Parser.Error: StringLiteralException :: StringLiteralParserException -> CustomParserException

- Michelson.Parser.Error: WrongAccessArgs :: Natural -> Positive -> CustomParserException

- Michelson.Parser.Error: WrongSetArgs :: Natural -> Positive -> CustomParserException

- Michelson.Parser.Error: WrongTagArgs :: Natural -> Positive -> CustomParserException

- Michelson.Parser.Error: data CustomParserException

- Michelson.Parser.Error: data ParseErrorBundle s e

- Michelson.Parser.Error: data ParserException

- Michelson.Parser.Error: data StringLiteralParserException

- Michelson.Parser.Error: instance Control.DeepSeq.NFData Michelson.Parser.Error.CustomParserException

- Michelson.Parser.Error: instance Control.DeepSeq.NFData Michelson.Parser.Error.StringLiteralParserException

- Michelson.Parser.Error: instance Data.Data.Data Michelson.Parser.Error.CustomParserException

- Michelson.Parser.Error: instance Data.Data.Data Michelson.Parser.Error.StringLiteralParserException

- Michelson.Parser.Error: instance Formatting.Buildable.Buildable Michelson.Parser.Error.ParserException

- Michelson.Parser.Error: instance GHC.Classes.Eq Michelson.Parser.Error.CustomParserException

- Michelson.Parser.Error: instance GHC.Classes.Eq Michelson.Parser.Error.ParserException

- Michelson.Parser.Error: instance GHC.Classes.Eq Michelson.Parser.Error.StringLiteralParserException

- Michelson.Parser.Error: instance GHC.Classes.Ord Michelson.Parser.Error.CustomParserException

- Michelson.Parser.Error: instance GHC.Classes.Ord Michelson.Parser.Error.StringLiteralParserException

- Michelson.Parser.Error: instance GHC.Exception.Type.Exception Michelson.Parser.Error.ParserException

- Michelson.Parser.Error: instance GHC.Generics.Generic Michelson.Parser.Error.CustomParserException

- Michelson.Parser.Error: instance GHC.Generics.Generic Michelson.Parser.Error.StringLiteralParserException

- Michelson.Parser.Error: instance GHC.Show.Show Michelson.Parser.Error.CustomParserException

- Michelson.Parser.Error: instance GHC.Show.Show Michelson.Parser.Error.ParserException

- Michelson.Parser.Error: instance GHC.Show.Show Michelson.Parser.Error.StringLiteralParserException

- Michelson.Parser.Error: instance Text.Megaparsec.Error.ShowErrorComponent Michelson.Parser.Error.CustomParserException

- Michelson.Parser.Error: instance Text.Megaparsec.Error.ShowErrorComponent Michelson.Parser.Error.StringLiteralParserException

- Michelson.Parser.Ext: extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr

- Michelson.Parser.Ext: printComment :: Parser PrintComment

- Michelson.Parser.Ext: stackType :: Parser StackTypePattern

- Michelson.Parser.Helpers: mkParser :: (a -> Text) -> a -> Parser a

- Michelson.Parser.Helpers: mparens :: Parser a -> Parser a

- Michelson.Parser.Helpers: parseDef :: Default a => Parser a -> Parser a

- Michelson.Parser.Helpers: positive :: Parser Positive

- Michelson.Parser.Helpers: sepBy2 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)

- Michelson.Parser.Helpers: sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)

- Michelson.Parser.Instr: carOp :: Parser ParsedInstr

- Michelson.Parser.Instr: cdrOp :: Parser ParsedInstr

- Michelson.Parser.Instr: cmpOp :: Parser ParsedInstr

- Michelson.Parser.Instr: dupOp :: Parser ParsedInstr

- Michelson.Parser.Instr: mapOp :: Parser ParsedOp -> Parser ParsedInstr

- Michelson.Parser.Instr: ops' :: Parser ParsedOp -> Parser [ParsedOp]

- Michelson.Parser.Instr: pairNOp :: Parser ParsedInstr

- Michelson.Parser.Instr: pairOp :: Parser ParsedInstr

- Michelson.Parser.Instr: primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr

- Michelson.Parser.Instr: unpairOp :: Parser ParsedInstr

- Michelson.Parser.Let: letBlock :: Parser ParsedOp -> Parser LetEnv

- Michelson.Parser.Let: letInner :: Parser ParsedOp -> Parser LetEnv

- Michelson.Parser.Let: letType :: Parser LetType

- Michelson.Parser.Let: mkLetMac :: Map Text LetMacro -> Parser LetMacro

- Michelson.Parser.Lexer: braces :: Parser a -> Parser a

- Michelson.Parser.Lexer: brackets :: Parser a -> Parser a

- Michelson.Parser.Lexer: brackets' :: Parser a -> Parser a

- Michelson.Parser.Lexer: comma :: Parser ()

- Michelson.Parser.Lexer: lexeme :: Parser a -> Parser a

- Michelson.Parser.Lexer: mSpace :: Parser ()

- Michelson.Parser.Lexer: parens :: Parser a -> Parser a

- Michelson.Parser.Lexer: semicolon :: Parser ()

- Michelson.Parser.Lexer: string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text

- Michelson.Parser.Lexer: symbol :: Tokens Text -> Parser ()

- Michelson.Parser.Lexer: symbol' :: Text -> Parser ()

- Michelson.Parser.Lexer: varID :: Parser Var

- Michelson.Parser.Lexer: word :: Tokens Text -> a -> Parser a

- Michelson.Parser.Lexer: word' :: Tokens Text -> a -> Parser a

- Michelson.Parser.Macro: cadrMac :: Parser Macro

- Michelson.Parser.Macro: carnMac :: Parser Macro

- Michelson.Parser.Macro: cdrnMac :: Parser Macro

- Michelson.Parser.Macro: duupMac :: Parser Macro

- Michelson.Parser.Macro: ifCmpMac :: Parser ParsedOp -> Parser Macro

- Michelson.Parser.Macro: macro :: Parser ParsedOp -> Parser Macro

- Michelson.Parser.Macro: mapCadrMac :: Parser ParsedOp -> Parser Macro

- Michelson.Parser.Macro: pairMac :: Parser Macro

- Michelson.Parser.Type: field :: Parser (FieldAnn, Ty)

- Michelson.Parser.Type: typeWithParen :: Parser Ty

- Michelson.Parser.Type: type_ :: Parser Ty

- Michelson.Parser.Types: LetEnv :: Map Text LetMacro -> Map Text LetValue -> Map Text LetType -> LetEnv

- Michelson.Parser.Types: [letMacros] :: LetEnv -> Map Text LetMacro

- Michelson.Parser.Types: [letTypes] :: LetEnv -> Map Text LetType

- Michelson.Parser.Types: [letValues] :: LetEnv -> Map Text LetValue

- Michelson.Parser.Types: data LetEnv

- Michelson.Parser.Types: instance Data.Default.Class.Default a => Data.Default.Class.Default (Michelson.Parser.Types.Parser a)

- Michelson.Parser.Types: instance GHC.Classes.Eq Michelson.Parser.Types.LetEnv

- Michelson.Parser.Types: instance GHC.Show.Show Michelson.Parser.Types.LetEnv

- Michelson.Parser.Types: noLetEnv :: LetEnv

- Michelson.Parser.Types: type Parser = ReaderT LetEnv (Parsec CustomParserException Text)

- Michelson.Parser.Value: bytesLiteral :: Parser (Value' op)

- Michelson.Parser.Value: intLiteral :: Parser (Value' op)

- Michelson.Parser.Value: mkLetVal :: Map Text LetValue -> Parser LetValue

- Michelson.Parser.Value: stringLiteral :: Parser ParsedValue

- Michelson.Parser.Value: value' :: Parser ParsedOp -> Parser ParsedValue

- Michelson.Preprocess: transformBytes :: Bool -> (ByteString -> ByteString) -> Instr inp out -> Instr inp out

- Michelson.Preprocess: transformStrings :: Bool -> (MText -> MText) -> Instr inp out -> Instr inp out

- Michelson.Printer: class RenderDoc a

- Michelson.Printer: isRenderable :: RenderDoc a => a -> Bool

- Michelson.Printer: printDoc :: Bool -> Doc -> Text

- Michelson.Printer: printSomeContract :: Bool -> SomeContract -> Text

- Michelson.Printer: printTypedContract :: Bool -> Contract p s -> Text

- Michelson.Printer: printTypedContractCode :: (SingI p, SingI s) => Bool -> ContractCode p s -> Text

- Michelson.Printer: printTypedValue :: forall t. ProperPrintedValBetterErrors t => Bool -> Value t -> Text

- Michelson.Printer: printUntypedContract :: RenderDoc op => Bool -> Contract' op -> Text

- Michelson.Printer: printUntypedValue :: RenderDoc op => Bool -> Value' op -> Text

- Michelson.Printer: renderAnyBuildable :: Buildable a => a -> Doc

- Michelson.Printer: renderDoc :: RenderDoc a => RenderContext -> a -> Doc

- Michelson.Printer.Util: Prettier :: a -> Prettier a

- Michelson.Printer.Util: addParens :: RenderContext -> Doc -> Doc

- Michelson.Printer.Util: assertParensNotNeeded :: RenderContext -> a -> a

- Michelson.Printer.Util: buildRenderDoc :: RenderDoc a => a -> Builder

- Michelson.Printer.Util: buildRenderDocExtended :: RenderDoc a => a -> Builder

- Michelson.Printer.Util: class RenderDoc a

- Michelson.Printer.Util: data RenderContext

- Michelson.Printer.Util: doesntNeedParens :: RenderContext

- Michelson.Printer.Util: isRenderable :: RenderDoc a => a -> Bool

- Michelson.Printer.Util: needsParens :: RenderContext

- Michelson.Printer.Util: newtype Prettier a

- Michelson.Printer.Util: printDoc :: Bool -> Doc -> Text

- Michelson.Printer.Util: printDocB :: Bool -> Doc -> Builder

- Michelson.Printer.Util: printDocS :: Bool -> Doc -> String

- Michelson.Printer.Util: renderAnyBuildable :: Buildable a => a -> Doc

- Michelson.Printer.Util: renderDoc :: RenderDoc a => RenderContext -> a -> Doc

- Michelson.Printer.Util: renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc

- Michelson.Printer.Util: renderOps :: RenderDoc op => Bool -> NonEmpty op -> Doc

- Michelson.Printer.Util: renderOpsList :: RenderDoc op => Bool -> [op] -> Doc

- Michelson.Printer.Util: renderOpsListNoBraces :: RenderDoc op => Bool -> [op] -> Doc

- Michelson.Printer.Util: spaces :: Int -> Doc

- Michelson.Printer.Util: wrapInParens :: RenderContext -> NonEmpty Doc -> Doc

- Michelson.Runtime: ASContract :: ContractState -> AddressState

- Michelson.Runtime: ASSimple :: Mutez -> AddressState

- Michelson.Runtime: ContractState :: Mutez -> Contract cp st -> Value st -> ContractState

- Michelson.Runtime: EEAlreadyOriginated :: a -> ContractState -> ExecutorError' a

- Michelson.Runtime: EEFailedToApplyUpdates :: GStateUpdateError -> ExecutorError' a

- Michelson.Runtime: EEIllTypedParameter :: a -> TCError -> ExecutorError' a

- Michelson.Runtime: EEInterpreterFailed :: a -> InterpretError -> ExecutorError' a

- Michelson.Runtime: EENotEnoughFunds :: a -> Mutez -> ExecutorError' a

- Michelson.Runtime: EETransactionFromContract :: a -> Mutez -> ExecutorError' a

- Michelson.Runtime: EEUnexpectedParameterType :: a -> T -> T -> ExecutorError' a

- Michelson.Runtime: EEUnknownContract :: a -> ExecutorError' a

- Michelson.Runtime: EEUnknownEntrypoint :: EpName -> ExecutorError' a

- Michelson.Runtime: EEUnknownManager :: a -> ExecutorError' a

- Michelson.Runtime: EEUnknownSender :: a -> ExecutorError' a

- Michelson.Runtime: EEWrongParameterType :: a -> ExecutorError' a

- Michelson.Runtime: EEZeroTransaction :: a -> ExecutorError' a

- Michelson.Runtime: ExecutorRes :: GState -> [GStateUpdate] -> [(Address, InterpretResult)] -> RemainingSteps -> ExecutorRes

- Michelson.Runtime: OriginateOp :: OriginationOperation -> ExecutorOp

- Michelson.Runtime: TransferOp :: Address -> TxData -> ExecutorOp

- Michelson.Runtime: TxData :: Address -> TxParam -> EpName -> Mutez -> TxData

- Michelson.Runtime: [TxTypedParam] :: forall t. ParameterScope t => Value t -> TxParam

- Michelson.Runtime: [TxUntypedParam] :: Value -> TxParam

- Michelson.Runtime: [_erGState] :: ExecutorRes -> GState

- Michelson.Runtime: [_erInterpretResults] :: ExecutorRes -> [(Address, InterpretResult)]

- Michelson.Runtime: [_erRemainingSteps] :: ExecutorRes -> RemainingSteps

- Michelson.Runtime: [_erUpdates] :: ExecutorRes -> [GStateUpdate]

- Michelson.Runtime: [csBalance] :: ContractState -> Mutez

- Michelson.Runtime: [csContract] :: ContractState -> Contract cp st

- Michelson.Runtime: [csStorage] :: ContractState -> Value st

- Michelson.Runtime: [tdAmount] :: TxData -> Mutez

- Michelson.Runtime: [tdEntrypoint] :: TxData -> EpName

- Michelson.Runtime: [tdParameter] :: TxData -> TxParam

- Michelson.Runtime: [tdSenderAddress] :: TxData -> Address

- Michelson.Runtime: data AddressState

- Michelson.Runtime: data ContractState

- Michelson.Runtime: data ExecutorError' a

- Michelson.Runtime: data ExecutorOp

- Michelson.Runtime: data ExecutorRes

- Michelson.Runtime: data TxData

- Michelson.Runtime: data TxParam

- Michelson.Runtime: data VotingPowers

- Michelson.Runtime: elInterpreterResults :: Lens' ExecutorLog [(Address, InterpretResult)]

- Michelson.Runtime: elUpdates :: Lens' ExecutorLog [GStateUpdate]

- Michelson.Runtime: erGState :: Lens' ExecutorRes GState

- Michelson.Runtime: erInterpretResults :: Lens' ExecutorRes [(Address, InterpretResult)]

- Michelson.Runtime: erRemainingSteps :: Lens' ExecutorRes RemainingSteps

- Michelson.Runtime: erUpdates :: Lens' ExecutorRes [GStateUpdate]

- Michelson.Runtime: executeGlobalOperations :: TypeCheckOptions -> [ExecutorOp] -> ExecutorM ()

- Michelson.Runtime: executeGlobalOrigination :: OriginationOperation -> ExecutorM Address

- Michelson.Runtime: executeOrigination :: ("isGlobalOp" :! Bool) -> OriginationOperation -> ExecutorM Address

- Michelson.Runtime: executeTransfer :: ("isGlobalOp" :! Bool) -> TypeCheckOptions -> Address -> TxData -> ExecutorM [ExecutorOp]

- Michelson.Runtime: instance (Data.Typeable.Internal.Typeable a, GHC.Show.Show a, Formatting.Buildable.Buildable a) => GHC.Exception.Type.Exception (Michelson.Runtime.ExecutorError' a)

- Michelson.Runtime: instance Formatting.Buildable.Buildable a => Formatting.Buildable.Buildable (Michelson.Runtime.ExecutorError' a)

- Michelson.Runtime: instance GHC.Base.Functor Michelson.Runtime.ExecutorError'

- Michelson.Runtime: instance GHC.Base.Monoid Michelson.Runtime.ExecutorLog

- Michelson.Runtime: instance GHC.Base.Semigroup Michelson.Runtime.ExecutorLog

- Michelson.Runtime: instance GHC.Generics.Generic Michelson.Runtime.ExecutorEnv

- Michelson.Runtime: instance GHC.Generics.Generic Michelson.Runtime.ExecutorLog

- Michelson.Runtime: instance GHC.Generics.Generic Michelson.Runtime.ExecutorState

- Michelson.Runtime: instance GHC.Show.Show Michelson.Runtime.ExecutorEnv

- Michelson.Runtime: instance GHC.Show.Show Michelson.Runtime.ExecutorLog

- Michelson.Runtime: instance GHC.Show.Show Michelson.Runtime.ExecutorOp

- Michelson.Runtime: instance GHC.Show.Show Michelson.Runtime.ExecutorRes

- Michelson.Runtime: instance GHC.Show.Show Michelson.Runtime.ExecutorState

- Michelson.Runtime: instance GHC.Show.Show a => GHC.Show.Show (Michelson.Runtime.ExecutorError' a)

- Michelson.Runtime: mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers

- Michelson.Runtime: mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers

- Michelson.Runtime: originateContract :: FilePath -> TypeCheckOptions -> Address -> Maybe KeyHash -> Mutez -> Value -> Contract -> ("verbose" :! Bool) -> IO Address

- Michelson.Runtime: parseContract :: Maybe FilePath -> Text -> Either ParserException (Contract' ParsedOp)

- Michelson.Runtime: parseExpandContract :: Maybe FilePath -> Text -> Either ParserException Contract

- Michelson.Runtime: prepareContract :: Maybe FilePath -> IO Contract

- Michelson.Runtime: readAndParseContract :: Maybe FilePath -> IO (Contract' ParsedOp)

- Michelson.Runtime: runContract :: Maybe Timestamp -> Maybe Natural -> Word64 -> Mutez -> FilePath -> TypeCheckOptions -> Value -> Contract -> TxData -> ("verbose" :! Bool) -> ("dryRun" :! Bool) -> IO SomeStorage

- Michelson.Runtime: runExecutorM :: Timestamp -> Natural -> RemainingSteps -> GState -> ExecutorM a -> Either ExecutorError (ExecutorRes, a)

- Michelson.Runtime: runExecutorMWithDB :: Maybe Timestamp -> Maybe Natural -> FilePath -> RemainingSteps -> ("verbose" :! Bool) -> ("dryRun" :? Bool) -> ExecutorM a -> IO (ExecutorRes, a)

- Michelson.Runtime: transfer :: Maybe Timestamp -> Maybe Natural -> Word64 -> FilePath -> TypeCheckOptions -> Address -> TxData -> ("verbose" :! Bool) -> ("dryRun" :? Bool) -> IO ()

- Michelson.Runtime: type ExecutorError = ExecutorError' Address

- Michelson.Runtime: type ExecutorM = ReaderT ExecutorEnv (StateT ExecutorState (Except ExecutorError))

- Michelson.Runtime.Dummy: dummyBigMapCounter :: BigMapCounter

- Michelson.Runtime.Dummy: dummyContractEnv :: ContractEnv

- Michelson.Runtime.Dummy: dummyLevel :: Natural

- Michelson.Runtime.Dummy: dummyMaxSteps :: RemainingSteps

- Michelson.Runtime.Dummy: dummyNow :: Timestamp

- Michelson.Runtime.Dummy: dummyOrigination :: (ParameterScope cp, StorageScope st) => Value st -> Contract cp st -> OriginationOperation

- Michelson.Runtime.Dummy: dummyVotingPowers :: VotingPowers

- Michelson.Runtime.GState: ASContract :: ContractState -> AddressState

- Michelson.Runtime.GState: ASSimple :: Mutez -> AddressState

- Michelson.Runtime.GState: BigMapCounter :: Natural -> BigMapCounter

- Michelson.Runtime.GState: ContractState :: Mutez -> Contract cp st -> Value st -> ContractState

- Michelson.Runtime.GState: GState :: ChainId -> Map Address AddressState -> VotingPowers -> GlobalCounter -> BigMapCounter -> GState

- Michelson.Runtime.GState: GStateAddressExists :: Address -> GStateUpdateError

- Michelson.Runtime.GState: GStateNotContract :: Address -> GStateUpdateError

- Michelson.Runtime.GState: GStateStorageNotMatch :: Address -> GStateUpdateError

- Michelson.Runtime.GState: GStateUnknownAddress :: Address -> GStateUpdateError

- Michelson.Runtime.GState: VotingPowers :: Map KeyHash Natural -> VotingPowers

- Michelson.Runtime.GState: [GSAddAddress] :: Address -> AddressState -> GStateUpdate

- Michelson.Runtime.GState: [GSIncrementCounter] :: GStateUpdate

- Michelson.Runtime.GState: [GSSetBalance] :: Address -> Mutez -> GStateUpdate

- Michelson.Runtime.GState: [GSSetBigMapCounter] :: BigMapCounter -> GStateUpdate

- Michelson.Runtime.GState: [GSSetStorageValue] :: StorageScope st => Address -> Value st -> GStateUpdate

- Michelson.Runtime.GState: [_bigMapCounter] :: BigMapCounter -> Natural

- Michelson.Runtime.GState: [csBalance] :: ContractState -> Mutez

- Michelson.Runtime.GState: [csContract] :: ContractState -> Contract cp st

- Michelson.Runtime.GState: [csStorage] :: ContractState -> Value st

- Michelson.Runtime.GState: [gsAddresses] :: GState -> Map Address AddressState

- Michelson.Runtime.GState: [gsBigMapCounter] :: GState -> BigMapCounter

- Michelson.Runtime.GState: [gsChainId] :: GState -> ChainId

- Michelson.Runtime.GState: [gsCounter] :: GState -> GlobalCounter

- Michelson.Runtime.GState: [gsVotingPowers] :: GState -> VotingPowers

- Michelson.Runtime.GState: applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState

- Michelson.Runtime.GState: applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState

- Michelson.Runtime.GState: asBalance :: AddressState -> Mutez

- Michelson.Runtime.GState: bigMapCounter :: Iso' BigMapCounter Natural

- Michelson.Runtime.GState: data AddressState

- Michelson.Runtime.GState: data ContractState

- Michelson.Runtime.GState: data GState

- Michelson.Runtime.GState: data GStateUpdate

- Michelson.Runtime.GState: data GStateUpdateError

- Michelson.Runtime.GState: dummyVotingPowers :: VotingPowers

- Michelson.Runtime.GState: extractAllContracts :: GState -> TcOriginatedContracts

- Michelson.Runtime.GState: genesisAddress :: Address

- Michelson.Runtime.GState: genesisAddress1 :: Address

- Michelson.Runtime.GState: genesisAddress2 :: Address

- Michelson.Runtime.GState: genesisAddress3 :: Address

- Michelson.Runtime.GState: genesisAddress4 :: Address

- Michelson.Runtime.GState: genesisAddress5 :: Address

- Michelson.Runtime.GState: genesisAddress6 :: Address

- Michelson.Runtime.GState: genesisAddresses :: NonEmpty Address

- Michelson.Runtime.GState: genesisKeyHash :: KeyHash

- Michelson.Runtime.GState: genesisKeyHashes :: NonEmpty KeyHash

- Michelson.Runtime.GState: genesisSecretKey :: SecretKey

- Michelson.Runtime.GState: genesisSecrets :: NonEmpty SecretKey

- Michelson.Runtime.GState: gsAddressesL :: Lens' GState (Map Address AddressState)

- Michelson.Runtime.GState: gsBigMapCounterL :: Lens' GState BigMapCounter

- Michelson.Runtime.GState: gsChainIdL :: Lens' GState ChainId

- Michelson.Runtime.GState: gsCounterL :: Lens' GState GlobalCounter

- Michelson.Runtime.GState: gsVotingPowersL :: Lens' GState VotingPowers

- Michelson.Runtime.GState: initGState :: GState

- Michelson.Runtime.GState: instance Control.DeepSeq.NFData Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Runtime.GState.AddressState

- Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Runtime.GState.ContractState

- Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Runtime.GState.GState

- Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Runtime.GState.VotingPowers

- Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Runtime.GState.AddressState

- Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Runtime.GState.ContractState

- Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Runtime.GState.GState

- Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Runtime.GState.VotingPowers

- Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Michelson.Runtime.GState.AddressState

- Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Michelson.Runtime.GState.ContractState

- Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Michelson.Runtime.GState.GStateUpdate

- Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Michelson.Runtime.GState.GStateUpdateError

- Michelson.Runtime.GState: instance GHC.Classes.Eq Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance GHC.Exception.Type.Exception Michelson.Runtime.GState.GStateParseError

- Michelson.Runtime.GState: instance GHC.Generics.Generic Michelson.Runtime.GState.AddressState

- Michelson.Runtime.GState: instance GHC.Generics.Generic Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance GHC.Num.Num Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.AddressState

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.BigMapCounter

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.ContractState

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.GState

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.GStateParseError

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.GStateUpdate

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.GStateUpdateError

- Michelson.Runtime.GState: instance GHC.Show.Show Michelson.Runtime.GState.VotingPowers

- Michelson.Runtime.GState: mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers

- Michelson.Runtime.GState: mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers

- Michelson.Runtime.GState: newtype BigMapCounter

- Michelson.Runtime.GState: newtype VotingPowers

- Michelson.Runtime.GState: readGState :: FilePath -> IO GState

- Michelson.Runtime.GState: vpPick :: KeyHash -> VotingPowers -> Natural

- Michelson.Runtime.GState: vpTotal :: VotingPowers -> Natural

- Michelson.Runtime.GState: writeGState :: FilePath -> GState -> IO ()

- Michelson.Runtime.Import: ICEParse :: FilePath -> ParserException -> ImportContractError

- Michelson.Runtime.Import: ICETypeCheck :: FilePath -> TCError -> ImportContractError

- Michelson.Runtime.Import: IVEParse :: FilePath -> ParserException -> ImportValueError

- Michelson.Runtime.Import: IVETypeCheck :: FilePath -> TCError -> ImportValueError

- Michelson.Runtime.Import: data ImportContractError

- Michelson.Runtime.Import: data ImportValueError

- Michelson.Runtime.Import: importContract :: forall cp st. Each '[SingI] [cp, st] => FilePath -> IO (Contract cp st)

- Michelson.Runtime.Import: importSomeContract :: FilePath -> IO SomeContract

- Michelson.Runtime.Import: importSomeValue :: Ty -> FilePath -> IO SomeValue

- Michelson.Runtime.Import: importUntypedContract :: FilePath -> IO Contract

- Michelson.Runtime.Import: importUntypedValue :: FilePath -> IO Value

- Michelson.Runtime.Import: importUsing :: Exception e => (FilePath -> Text -> Either e a) -> FilePath -> IO a

- Michelson.Runtime.Import: importValue :: forall t. SingI t => FilePath -> IO (Value t)

- Michelson.Runtime.Import: instance Formatting.Buildable.Buildable Michelson.Runtime.Import.ImportContractError

- Michelson.Runtime.Import: instance Formatting.Buildable.Buildable Michelson.Runtime.Import.ImportValueError

- Michelson.Runtime.Import: instance GHC.Classes.Eq Michelson.Runtime.Import.ImportContractError

- Michelson.Runtime.Import: instance GHC.Classes.Eq Michelson.Runtime.Import.ImportValueError

- Michelson.Runtime.Import: instance GHC.Exception.Type.Exception Michelson.Runtime.Import.ImportContractError

- Michelson.Runtime.Import: instance GHC.Exception.Type.Exception Michelson.Runtime.Import.ImportValueError

- Michelson.Runtime.Import: instance GHC.Show.Show Michelson.Runtime.Import.ImportContractError

- Michelson.Runtime.Import: instance GHC.Show.Show Michelson.Runtime.Import.ImportValueError

- Michelson.Runtime.Import: readContract :: forall cp st. Each '[SingI] [cp, st] => FilePath -> Text -> Either ImportContractError (Contract cp st)

- Michelson.Runtime.Import: readSomeContract :: FilePath -> Text -> Either ImportContractError SomeContract

- Michelson.Runtime.Import: readUntypedContract :: FilePath -> Text -> Either ImportContractError Contract

- Michelson.Runtime.Import: readValue :: forall t. SingI t => FilePath -> Text -> Either ImportValueError (Value t)

- Michelson.Runtime.TxData: TxData :: Address -> TxParam -> EpName -> Mutez -> TxData

- Michelson.Runtime.TxData: [TxTypedParam] :: forall t. ParameterScope t => Value t -> TxParam

- Michelson.Runtime.TxData: [TxUntypedParam] :: Value -> TxParam

- Michelson.Runtime.TxData: [tdAmount] :: TxData -> Mutez

- Michelson.Runtime.TxData: [tdEntrypoint] :: TxData -> EpName

- Michelson.Runtime.TxData: [tdParameter] :: TxData -> TxParam

- Michelson.Runtime.TxData: [tdSenderAddress] :: TxData -> Address

- Michelson.Runtime.TxData: data TxData

- Michelson.Runtime.TxData: data TxParam

- Michelson.Runtime.TxData: instance GHC.Show.Show Michelson.Runtime.TxData.TxData

- Michelson.Runtime.TxData: instance GHC.Show.Show Michelson.Runtime.TxData.TxParam

- Michelson.Runtime.TxData: tdAmountL :: Lens' TxData Mutez

- Michelson.Runtime.TxData: tdEntrypointL :: Lens' TxData EpName

- Michelson.Runtime.TxData: tdParameterL :: Lens' TxData TxParam

- Michelson.Runtime.TxData: tdSenderAddressL :: Lens' TxData Address

- Michelson.Text: UnsafeMText :: Text -> MText

- Michelson.Text: [unMText] :: MText -> Text

- Michelson.Text: dropMText :: Int -> MText -> MText

- Michelson.Text: instance Control.DeepSeq.NFData Michelson.Text.MText

- Michelson.Text: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Text.MText

- Michelson.Text: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Text.MText

- Michelson.Text: instance Data.Data.Data Michelson.Text.MText

- Michelson.Text: instance Data.Hashable.Class.Hashable Michelson.Text.MText

- Michelson.Text: instance Formatting.Buildable.Buildable Michelson.Text.MText

- Michelson.Text: instance GHC.Base.Monoid Michelson.Text.MText

- Michelson.Text: instance GHC.Base.Semigroup Michelson.Text.MText

- Michelson.Text: instance GHC.Classes.Eq Michelson.Text.MText

- Michelson.Text: instance GHC.Classes.Ord Michelson.Text.MText

- Michelson.Text: instance GHC.Generics.Generic Michelson.Text.MText

- Michelson.Text: instance GHC.Show.Show Michelson.Text.MText

- Michelson.Text: instance Universum.Container.Class.Container Michelson.Text.MText

- Michelson.Text: instance Universum.String.Conversion.ToText Michelson.Text.MText

- Michelson.Text: instance Util.CLI.HasCLReader Michelson.Text.MText

- Michelson.Text: isMChar :: Char -> Bool

- Michelson.Text: labelToMText :: Label name -> MText

- Michelson.Text: maxBoundMChar :: Int

- Michelson.Text: minBoundMChar :: Int

- Michelson.Text: mkMText :: Text -> Either Text MText

- Michelson.Text: mkMTextCut :: Text -> MText

- Michelson.Text: mt :: QuasiQuoter

- Michelson.Text: mtextHeadToUpper :: HasCallStack => MText -> MText

- Michelson.Text: newtype MText

- Michelson.Text: qqMText :: String -> Either Text String

- Michelson.Text: symbolToMText :: forall name. KnownSymbol name => MText

- Michelson.Text: takeMText :: Int -> MText -> MText

- Michelson.Text: type family DoNotUseTextError

- Michelson.Text: unsafeMkMText :: HasCallStack => Text -> MText

- Michelson.Text: writeMText :: MText -> Text

- Michelson.TypeCheck: eqType :: forall (a :: T) (b :: T). Each '[SingI] [a, b] => Either TCTypeError (a :~: b)

- Michelson.TypeCheck: matchTypes :: forall t1 t2. Each '[SingI] [t1, t2] => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)

- Michelson.TypeCheck: typeCheckContract :: Contract -> TypeCheckResult SomeContract

- Michelson.TypeCheck: typeCheckContractAndStorage :: Contract -> Value -> TypeCheckResult SomeContractAndStorage

- Michelson.TypeCheck: typeCheckExt :: forall s. SingI s => TcInstrHandler -> ExpandedExtInstr -> HST s -> TypeCheckInstrNoExcept (TypeCheckedSeq s)

- Michelson.TypeCheck: typeCheckInstr :: TcInstrHandler

- Michelson.TypeCheck: typeCheckList :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheck (SomeInstr inp)

- Michelson.TypeCheck: typeCheckListNoExcept :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)

- Michelson.TypeCheck: typeCheckParameter :: TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

- Michelson.TypeCheck: typeCheckStorage :: Ty -> Value -> TypeCheckResult SomeValue

- Michelson.TypeCheck: typeCheckTopLevelType :: Maybe TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

- Michelson.TypeCheck: typeCheckValue :: forall t. SingI t => Value -> TypeCheckInstr (Value t)

- Michelson.TypeCheck: typeVerifyContract :: forall cp st. (SingI cp, SingI st) => Contract -> TypeCheckResult (Contract cp st)

- Michelson.TypeCheck: typeVerifyParameter :: SingI t => TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

- Michelson.TypeCheck: typeVerifyStorage :: SingI t => Value -> TypeCheckResult (Value t)

- Michelson.TypeCheck: typeVerifyTopLevelType :: forall t. SingI t => Maybe TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

- Michelson.TypeCheck.Error: AnnError :: AnnConvergeError -> TCTypeError

- Michelson.TypeCheck.Error: AnyError :: TCTypeError

- Michelson.TypeCheck.Error: ArithmeticOperation :: TypeContext

- Michelson.TypeCheck.Error: CarArgument :: TypeContext

- Michelson.TypeCheck.Error: Cast :: TypeContext

- Michelson.TypeCheck.Error: CdrArgument :: TypeContext

- Michelson.TypeCheck.Error: CodeAlwaysFails :: TCTypeError

- Michelson.TypeCheck.Error: ComparisonArguments :: TypeContext

- Michelson.TypeCheck.Error: ConcatArgument :: TypeContext

- Michelson.TypeCheck.Error: ConsArgument :: TypeContext

- Michelson.TypeCheck.Error: ContainerKeyType :: TypeContext

- Michelson.TypeCheck.Error: ContainerValueType :: TypeContext

- Michelson.TypeCheck.Error: ContractParameter :: TypeContext

- Michelson.TypeCheck.Error: ContractStorage :: TypeContext

- Michelson.TypeCheck.Error: DipCode :: TypeContext

- Michelson.TypeCheck.Error: EmptyCode :: TCTypeError

- Michelson.TypeCheck.Error: EntrypointNotFound :: EpName -> TCTypeError

- Michelson.TypeCheck.Error: FailwithArgument :: TypeContext

- Michelson.TypeCheck.Error: If :: TypeContext

- Michelson.TypeCheck.Error: IllegalEntrypoint :: EpNameFromRefAnnError -> TCTypeError

- Michelson.TypeCheck.Error: IllegalParamDecl :: ParamEpError -> TCTypeError

- Michelson.TypeCheck.Error: InvalidAddress :: ParseEpAddressError -> TCTypeError

- Michelson.TypeCheck.Error: InvalidBls12381Object :: DeserializationError -> TCTypeError

- Michelson.TypeCheck.Error: InvalidInstruction :: ExpandedInstr -> Text -> TCTypeError

- Michelson.TypeCheck.Error: InvalidKeyHash :: CryptoParseError -> TCTypeError

- Michelson.TypeCheck.Error: InvalidStackReference :: StackRef -> StackSize -> ExtError

- Michelson.TypeCheck.Error: InvalidTimestamp :: TCTypeError

- Michelson.TypeCheck.Error: InvalidValueType :: T -> TCTypeError

- Michelson.TypeCheck.Error: Iteration :: TypeContext

- Michelson.TypeCheck.Error: LambdaArgument :: TypeContext

- Michelson.TypeCheck.Error: LambdaCode :: TypeContext

- Michelson.TypeCheck.Error: LengthMismatch :: StackTypePattern -> ExtError

- Michelson.TypeCheck.Error: MutezOverflow :: TCTypeError

- Michelson.TypeCheck.Error: NegativeNat :: TCTypeError

- Michelson.TypeCheck.Error: NotEnoughItemsOnStack :: TCTypeError

- Michelson.TypeCheck.Error: NotNumericTypes :: T -> T -> TCTypeError

- Michelson.TypeCheck.Error: StackEqError :: [T] -> [T] -> TCTypeError

- Michelson.TypeCheck.Error: StackSize :: Natural -> StackSize

- Michelson.TypeCheck.Error: StkRestMismatch :: StackTypePattern -> SomeHST -> SomeHST -> TCTypeError -> ExtError

- Michelson.TypeCheck.Error: TCContractError :: Text -> Maybe TCTypeError -> TCError

- Michelson.TypeCheck.Error: TCExtError :: SomeHST -> InstrCallStack -> ExtError -> TCError

- Michelson.TypeCheck.Error: TCFailedOnInstr :: ExpandedInstr -> SomeHST -> InstrCallStack -> Maybe TypeContext -> Maybe TCTypeError -> TCError

- Michelson.TypeCheck.Error: TCFailedOnValue :: Value -> T -> Text -> InstrCallStack -> Maybe TCTypeError -> TCError

- Michelson.TypeCheck.Error: TCIncompletelyTyped :: TCError -> Contract' TypeCheckedOp -> TCError

- Michelson.TypeCheck.Error: TCUnreachableCode :: InstrCallStack -> NonEmpty ExpandedOp -> TCError

- Michelson.TypeCheck.Error: TestAssertError :: Text -> ExtError

- Michelson.TypeCheck.Error: TicketsJoin :: TypeContext

- Michelson.TypeCheck.Error: TltParameterType :: TopLevelType

- Michelson.TypeCheck.Error: TltStorageType :: TopLevelType

- Michelson.TypeCheck.Error: TyVarMismatch :: Var -> Ty -> StackTypePattern -> Int -> TCTypeError -> ExtError

- Michelson.TypeCheck.Error: TypeEqError :: T -> T -> TCTypeError

- Michelson.TypeCheck.Error: TypeMismatch :: StackTypePattern -> Int -> TCTypeError -> ExtError

- Michelson.TypeCheck.Error: UnexpectedTopLevelType :: TopLevelType -> ("expected" :! T) -> ("got" :! T) -> TCTypeError

- Michelson.TypeCheck.Error: UnexpectedType :: NonEmpty (NonEmpty Text) -> TCTypeError

- Michelson.TypeCheck.Error: UnknownContract :: Address -> TCTypeError

- Michelson.TypeCheck.Error: UnpairArgument :: TypeContext

- Michelson.TypeCheck.Error: UnsupportedTypeForScope :: T -> BadTypeForScope -> TCTypeError

- Michelson.TypeCheck.Error: VarError :: Text -> StackFn -> ExtError

- Michelson.TypeCheck.Error: data ExtError

- Michelson.TypeCheck.Error: data TCError

- Michelson.TypeCheck.Error: data TCTypeError

- Michelson.TypeCheck.Error: data TopLevelType

- Michelson.TypeCheck.Error: data TypeContext

- Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Michelson.TypeCheck.Error.ExtError

- Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Michelson.TypeCheck.Error.StackSize

- Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Michelson.TypeCheck.Error.TCError

- Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Michelson.TypeCheck.Error.TCTypeError

- Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Michelson.TypeCheck.Error.TopLevelType

- Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Michelson.TypeCheck.Error.TypeContext

- Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Michelson.TypeCheck.Error.ExtError

- Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Michelson.TypeCheck.Error.TCError

- Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Michelson.TypeCheck.Error.TCTypeError

- Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Michelson.TypeCheck.Error.TopLevelType

- Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Michelson.TypeCheck.Error.TypeContext

- Michelson.TypeCheck.Error: instance GHC.Classes.Eq Michelson.TypeCheck.Error.ExtError

- Michelson.TypeCheck.Error: instance GHC.Classes.Eq Michelson.TypeCheck.Error.StackSize

- Michelson.TypeCheck.Error: instance GHC.Classes.Eq Michelson.TypeCheck.Error.TCError

- Michelson.TypeCheck.Error: instance GHC.Classes.Eq Michelson.TypeCheck.Error.TCTypeError

- Michelson.TypeCheck.Error: instance GHC.Classes.Eq Michelson.TypeCheck.Error.TopLevelType

- Michelson.TypeCheck.Error: instance GHC.Classes.Eq Michelson.TypeCheck.Error.TypeContext

- Michelson.TypeCheck.Error: instance GHC.Exception.Type.Exception Michelson.TypeCheck.Error.TCError

- Michelson.TypeCheck.Error: instance GHC.Generics.Generic Michelson.TypeCheck.Error.ExtError

- Michelson.TypeCheck.Error: instance GHC.Generics.Generic Michelson.TypeCheck.Error.StackSize

- Michelson.TypeCheck.Error: instance GHC.Generics.Generic Michelson.TypeCheck.Error.TCError

- Michelson.TypeCheck.Error: instance GHC.Generics.Generic Michelson.TypeCheck.Error.TCTypeError

- Michelson.TypeCheck.Error: instance GHC.Generics.Generic Michelson.TypeCheck.Error.TopLevelType

- Michelson.TypeCheck.Error: instance GHC.Generics.Generic Michelson.TypeCheck.Error.TypeContext

- Michelson.TypeCheck.Error: instance GHC.Show.Show Michelson.TypeCheck.Error.StackSize

- Michelson.TypeCheck.Error: instance GHC.Show.Show Michelson.TypeCheck.Error.TCError

- Michelson.TypeCheck.Error: instance GHC.Show.Show Michelson.TypeCheck.Error.TCTypeError

- Michelson.TypeCheck.Error: instance GHC.Show.Show Michelson.TypeCheck.Error.TopLevelType

- Michelson.TypeCheck.Error: instance GHC.Show.Show Michelson.TypeCheck.Error.TypeContext

- Michelson.TypeCheck.Error: instance Michelson.Printer.Util.RenderDoc Michelson.TypeCheck.Error.TCError

- Michelson.TypeCheck.Error: instance Michelson.Printer.Util.RenderDoc Michelson.TypeCheck.Error.TCTypeError

- Michelson.TypeCheck.Error: instance Michelson.Printer.Util.RenderDoc Michelson.TypeCheck.Error.TopLevelType

- Michelson.TypeCheck.Error: instance Michelson.Printer.Util.RenderDoc Michelson.TypeCheck.Error.TypeContext

- Michelson.TypeCheck.Error: newtype StackSize

- Michelson.TypeCheck.Error: pairWithElems :: Word -> Text

- Michelson.TypeCheck.Error: pairWithNodeIndex :: Word -> Text

- Michelson.TypeCheck.Ext: typeCheckExt :: forall s. SingI s => TcInstrHandler -> ExpandedExtInstr -> HST s -> TypeCheckInstrNoExcept (TypeCheckedSeq s)

- Michelson.TypeCheck.Helpers: addImpl :: forall a b inp rs m. (Each '[SingI] [a, b], inp ~ (a : (b : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: arithImpl :: forall aop inp m n s t. (ArithOp aop n m, WellTyped (ArithRes aop n m), inp ~ (n : (m : s)), MonadReader InstrCallStack t, MonadError TCError t) => Instr inp (ArithRes aop n m : s) -> HST inp -> VarAnn -> ExpandedInstr -> t (SomeInstr inp)

- Michelson.TypeCheck.Helpers: concatImpl :: (ConcatOp c, inp ~ (c : (c : rs)), WellTyped c, MonadReader InstrCallStack m, MonadError TCError m) => HST inp -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: concatImpl' :: (ConcatOp c, WellTyped c, inp ~ ('TList c : rs), Monad m) => HST inp -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: convergeHST :: HST ts -> HST ts -> Either AnnConvergeError (HST ts)

- Michelson.TypeCheck.Helpers: convergeHSTEl :: (Notes t, Dict (WellTyped t), VarAnn) -> (Notes t, Dict (WellTyped t), VarAnn) -> Either AnnConvergeError (Notes t, Dict (WellTyped t), VarAnn)

- Michelson.TypeCheck.Helpers: deriveNsOption :: Notes ('TOption a) -> VarAnn -> (Notes a, VarAnn)

- Michelson.TypeCheck.Helpers: deriveNsOr :: Notes ('TOr a b) -> VarAnn -> (Notes a, Notes b, VarAnn, VarAnn)

- Michelson.TypeCheck.Helpers: deriveSpecialFNs :: FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn -> (VarAnn, FieldAnn, FieldAnn)

- Michelson.TypeCheck.Helpers: deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn

- Michelson.TypeCheck.Helpers: deriveVN :: VarAnn -> VarAnn -> VarAnn

- Michelson.TypeCheck.Helpers: edivImpl :: forall a b inp rs m. (SingI rs, Each '[SingI] [a, b], inp ~ (a : (b : rs)), MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: ensureDistinctAsc :: (Ord b, Show a) => (a -> b) -> [a] -> Either Text [a]

- Michelson.TypeCheck.Helpers: eqHST :: forall as bs. (SingI as, SingI bs) => HST as -> HST bs -> Either TCTypeError (as :~: bs)

- Michelson.TypeCheck.Helpers: eqHST1 :: forall t st. (SingI st, WellTyped t) => HST st -> Either TCTypeError (st :~: '[t])

- Michelson.TypeCheck.Helpers: eqType :: forall (a :: T) (b :: T). Each '[SingI] [a, b] => Either TCTypeError (a :~: b)

- Michelson.TypeCheck.Helpers: getImpl :: forall c getKey rs inp m. (GetOp c, SingI (GetOpKey c), WellTyped (GetOpVal c), inp ~ (getKey : (c : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Notes (GetOpKey c) -> HST inp -> Notes (GetOpVal c) -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: getUpdImpl :: forall c updKey updParams rs inp m. (UpdOp c, GetOp c, SingI (UpdOpKey c), SingI (GetOpVal c), inp ~ (updKey : (updParams : (c : rs))), SingI rs, GetOpKey c ~ UpdOpKey c, UpdOpParams c ~ 'TOption (GetOpVal c), MonadReader InstrCallStack m, MonadError TCError m) => Notes (UpdOpKey c) -> HST inp -> Notes (UpdOpParams c) -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: hstToTs :: HST st -> [T]

- Michelson.TypeCheck.Helpers: lengthHST :: HST xs -> Natural

- Michelson.TypeCheck.Helpers: matchTypes :: forall t1 t2. Each '[SingI] [t1, t2] => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)

- Michelson.TypeCheck.Helpers: memImpl :: forall c memKey rs inp m. (MemOp c, SingI (MemOpKey c), inp ~ (memKey : (c : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Notes (MemOpKey c) -> HST inp -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: mulImpl :: forall a b inp rs m. (Each '[SingI] [a, b], inp ~ (a : (b : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: onScopeCheckInstrErr :: forall (t :: T) m a. (MonadReader InstrCallStack m, MonadError TCError m, SingI t) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> Either BadTypeForScope a -> m a

- Michelson.TypeCheck.Helpers: onTypeCheckInstrAnnErr :: (MonadReader InstrCallStack m, MonadError TCError m, SingI ts) => ExpandedInstr -> HST ts -> Maybe TypeContext -> Either AnnConvergeError a -> m a

- Michelson.TypeCheck.Helpers: onTypeCheckInstrErr :: (MonadReader InstrCallStack m, MonadError TCError m) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> Either TCTypeError a -> m a

- Michelson.TypeCheck.Helpers: sizeImpl :: (SizeOp c, inp ~ (c : rs), Monad m) => HST inp -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: sliceImpl :: (SliceOp c, inp ~ ('TNat : ('TNat : (c : rs))), Monad m) => HST inp -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: subImpl :: forall a b inp rs m. (Each '[SingI] [a, b], inp ~ (a : (b : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: typeCheckImpl :: forall inp. SingI inp => TcInstrHandler -> [ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

- Michelson.TypeCheck.Helpers: typeCheckImplStripped :: forall inp. SingI inp => TcInstrHandler -> [ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

- Michelson.TypeCheck.Helpers: typeCheckInstrErr :: (MonadReader InstrCallStack m, MonadError TCError m) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> m a

- Michelson.TypeCheck.Helpers: typeCheckInstrErr' :: (MonadReader InstrCallStack m, MonadError TCError m) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> TCTypeError -> m a

- Michelson.TypeCheck.Helpers: unaryArithImpl :: (WellTyped (UnaryArithRes aop n), inp ~ (n : s), Monad t) => Instr inp (UnaryArithRes aop n : s) -> HST inp -> VarAnn -> t (SomeInstr inp)

- Michelson.TypeCheck.Helpers: unaryArithImplAnnotated :: (WellTyped (UnaryArithRes aop n), inp ~ (n : s), Monad t, n ~ UnaryArithRes aop n) => Instr inp (UnaryArithRes aop n : s) -> HST inp -> VarAnn -> t (SomeInstr inp)

- Michelson.TypeCheck.Helpers: updImpl :: forall c updKey updParams rs inp m. (UpdOp c, SingI (UpdOpKey c), SingI (UpdOpParams c), SingI rs, inp ~ (updKey : (updParams : (c : rs))), MonadReader InstrCallStack m, MonadError TCError m) => Notes (UpdOpKey c) -> HST inp -> Notes (UpdOpParams c) -> VarAnn -> m (SomeInstr inp)

- Michelson.TypeCheck.Helpers: withCompareableCheck :: forall a m v ts. (SingI ts, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> ExpandedInstr -> HST ts -> (Comparable a => v) -> m v

- Michelson.TypeCheck.Instr: typeCheckContract :: Contract -> TypeCheckResult SomeContract

- Michelson.TypeCheck.Instr: typeCheckContractAndStorage :: Contract -> Value -> TypeCheckResult SomeContractAndStorage

- Michelson.TypeCheck.Instr: typeCheckInstr :: TcInstrHandler

- Michelson.TypeCheck.Instr: typeCheckList :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheck (SomeInstr inp)

- Michelson.TypeCheck.Instr: typeCheckListNoExcept :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)

- Michelson.TypeCheck.Instr: typeCheckParameter :: TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

- Michelson.TypeCheck.Instr: typeCheckStorage :: Ty -> Value -> TypeCheckResult SomeValue

- Michelson.TypeCheck.Instr: typeCheckTopLevelType :: Maybe TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

- Michelson.TypeCheck.Instr: typeCheckValue :: forall t. SingI t => Value -> TypeCheckInstr (Value t)

- Michelson.TypeCheck.Instr: typeVerifyContract :: forall cp st. (SingI cp, SingI st) => Contract -> TypeCheckResult (Contract cp st)

- Michelson.TypeCheck.Instr: typeVerifyParameter :: SingI t => TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

- Michelson.TypeCheck.Instr: typeVerifyStorage :: SingI t => Value -> TypeCheckResult (Value t)

- Michelson.TypeCheck.Instr: typeVerifyTopLevelType :: forall t. SingI t => Maybe TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

- Michelson.TypeCheck.TypeCheck: SomeParamType :: Sing t -> ParamNotes t -> SomeParamType

- Michelson.TypeCheck.TypeCheck: TypeCheckContract :: SomeParamType -> TypeCheckMode

- Michelson.TypeCheck.TypeCheck: TypeCheckEnv :: ~TcExtFrames -> ~TypeCheckMode -> TypeCheckEnv

- Michelson.TypeCheck.TypeCheck: TypeCheckOptions :: Bool -> Bool -> TypeCheckOptions

- Michelson.TypeCheck.TypeCheck: TypeCheckPack :: TypeCheckMode

- Michelson.TypeCheck.TypeCheck: TypeCheckTest :: TypeCheckMode

- Michelson.TypeCheck.TypeCheck: TypeCheckValue :: (Value, T) -> TypeCheckMode

- Michelson.TypeCheck.TypeCheck: [tcExtFrames] :: TypeCheckEnv -> ~TcExtFrames

- Michelson.TypeCheck.TypeCheck: [tcMode] :: TypeCheckEnv -> ~TypeCheckMode

- Michelson.TypeCheck.TypeCheck: [tcStrict] :: TypeCheckOptions -> Bool

- Michelson.TypeCheck.TypeCheck: [tcVerbose] :: TypeCheckOptions -> Bool

- Michelson.TypeCheck.TypeCheck: data SomeParamType

- Michelson.TypeCheck.TypeCheck: data TypeCheckEnv

- Michelson.TypeCheck.TypeCheck: data TypeCheckMode

- Michelson.TypeCheck.TypeCheck: data TypeCheckOptions

- Michelson.TypeCheck.TypeCheck: guarding :: ExpandedInstr -> TypeCheckInstr a -> (a -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

- Michelson.TypeCheck.TypeCheck: guarding_ :: ExpandedInstr -> TypeCheckInstr a -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

- Michelson.TypeCheck.TypeCheck: instance Data.Default.Class.Default Michelson.TypeCheck.TypeCheck.TypeCheckOptions

- Michelson.TypeCheck.TypeCheck: instance Formatting.Buildable.Buildable Michelson.TypeCheck.TypeCheck.SomeParamType

- Michelson.TypeCheck.TypeCheck: instance GHC.Classes.Eq Michelson.TypeCheck.TypeCheck.SomeParamType

- Michelson.TypeCheck.TypeCheck: instance GHC.Show.Show Michelson.TypeCheck.TypeCheck.SomeParamType

- Michelson.TypeCheck.TypeCheck: liftNoExcept :: TypeCheckInstrNoExcept a -> TypeCheckInstr a

- Michelson.TypeCheck.TypeCheck: liftNoExcept' :: TypeCheckNoExcept a -> TypeCheck a

- Michelson.TypeCheck.TypeCheck: mkSomeParamType :: ParameterType -> Either TCError SomeParamType

- Michelson.TypeCheck.TypeCheck: preserving :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> ([TypeCheckedOp] -> TypeCheckedInstr) -> (SomeInstr inp -> TypeCheckInstr (SomeInstr inp')) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')

- Michelson.TypeCheck.TypeCheck: preserving' :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> ([TypeCheckedOp] -> TypeCheckedInstr) -> (SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')

- Michelson.TypeCheck.TypeCheck: runTypeCheck :: TypeCheckMode -> TypeCheck a -> TypeCheckResult a

- Michelson.TypeCheck.TypeCheck: runTypeCheckInstrIsolated :: TypeCheckInstr a -> TypeCheckResult a

- Michelson.TypeCheck.TypeCheck: runTypeCheckIsolated :: TypeCheck a -> TypeCheckResult a

- Michelson.TypeCheck.TypeCheck: tcEither :: (TCError -> TypeCheckInstrNoExcept a) -> (b -> TypeCheckInstrNoExcept a) -> TypeCheckInstr b -> TypeCheckInstrNoExcept a

- Michelson.TypeCheck.TypeCheck: tcExtFramesL :: Lens' TypeCheckEnv TcExtFrames

- Michelson.TypeCheck.TypeCheck: tcModeL :: Lens' TypeCheckEnv TypeCheckMode

- Michelson.TypeCheck.TypeCheck: throwingTCError :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> TypeCheckInstr (SomeInstr inp)

- Michelson.TypeCheck.TypeCheck: throwingTCError' :: TypeCheckNoExcept (TypeCheckedSeq inp) -> TypeCheck (SomeInstr inp)

- Michelson.TypeCheck.TypeCheck: type TcInstrHandler = forall inp. (SingI inp, HasCallStack) => ExpandedInstr -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

- Michelson.TypeCheck.TypeCheck: type TcOriginatedContracts = Map ContractHash SomeParamType

- Michelson.TypeCheck.TypeCheck: type TypeCheck = (ReaderT TypeCheckOptions (ExceptT TCError (State TypeCheckEnv)))

- Michelson.TypeCheck.TypeCheck: type TypeCheckInstr = ReaderT InstrCallStack TypeCheck

- Michelson.TypeCheck.TypeCheck: type TypeCheckInstrNoExcept = ReaderT InstrCallStack TypeCheckNoExcept

- Michelson.TypeCheck.TypeCheck: type TypeCheckNoExcept = (ReaderT TypeCheckOptions (State TypeCheckEnv))

- Michelson.TypeCheck.TypeCheck: type TypeCheckResult = (ReaderT TypeCheckOptions (Except TCError))

- Michelson.TypeCheck.TypeCheck: typeCheckingWith :: TypeCheckOptions -> TypeCheckResult a -> Either TCError a

- Michelson.TypeCheck.TypeCheck: unsafeMkSomeParamType :: HasCallStack => ParameterType -> SomeParamType

- Michelson.TypeCheck.TypeCheckedOp: NonTypedInstr :: ExpandedOp -> IllTypedInstr

- Michelson.TypeCheck.TypeCheckedOp: SemiTypedInstr :: TypeCheckedInstr -> IllTypedInstr

- Michelson.TypeCheck.TypeCheckedOp: [IllTypedOp] :: IllTypedInstr -> TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedOp: [WellTypedOp] :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedOp: data IllTypedInstr

- Michelson.TypeCheck.TypeCheckedOp: data TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedOp: instance Control.DeepSeq.NFData Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedOp: instance Control.DeepSeq.NFData Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp => Control.DeepSeq.NFData Michelson.TypeCheck.TypeCheckedOp.IllTypedInstr

- Michelson.TypeCheck.TypeCheckedOp: instance GHC.Classes.Eq Michelson.TypeCheck.TypeCheckedOp.IllTypedInstr

- Michelson.TypeCheck.TypeCheckedOp: instance GHC.Classes.Eq Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedOp: instance GHC.Generics.Generic Michelson.TypeCheck.TypeCheckedOp.IllTypedInstr

- Michelson.TypeCheck.TypeCheckedOp: instance Michelson.Printer.Util.RenderDoc Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedOp: someInstrToOp :: SomeInstr inp -> TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedOp: type TypeCheckedInstr = InstrAbstract TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedSeq: IllTypedSeq :: TCError -> [IllTypedInstr] -> TypeCheckedSeq inp

- Michelson.TypeCheck.TypeCheckedSeq: MixedSeq :: SomeInstr inp -> TCError -> [IllTypedInstr] -> TypeCheckedSeq inp

- Michelson.TypeCheck.TypeCheckedSeq: NonTypedInstr :: ExpandedOp -> IllTypedInstr

- Michelson.TypeCheck.TypeCheckedSeq: SemiTypedInstr :: TypeCheckedInstr -> IllTypedInstr

- Michelson.TypeCheck.TypeCheckedSeq: WellTypedSeq :: SomeInstr inp -> TypeCheckedSeq inp

- Michelson.TypeCheck.TypeCheckedSeq: [IllTypedOp] :: IllTypedInstr -> TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedSeq: [WellTypedOp] :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedSeq: data IllTypedInstr

- Michelson.TypeCheck.TypeCheckedSeq: data TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedSeq: data TypeCheckedSeq inp

- Michelson.TypeCheck.TypeCheckedSeq: seqToOps :: TypeCheckedSeq inp -> [TypeCheckedOp]

- Michelson.TypeCheck.TypeCheckedSeq: someInstrToOp :: SomeInstr inp -> TypeCheckedOp

- Michelson.TypeCheck.TypeCheckedSeq: tcsEither :: ([TypeCheckedOp] -> TCError -> a) -> (SomeInstr inp -> a) -> TypeCheckedSeq inp -> a

- Michelson.TypeCheck.TypeCheckedSeq: type TypeCheckedInstr = InstrAbstract TypeCheckedOp

- Michelson.TypeCheck.Types: (-:&) :: (WellTyped x, SingI xs) => Sing x -> HST xs -> HST (x : xs)

- Michelson.TypeCheck.Types: BoundVars :: Map Var Ty -> Maybe SomeHST -> BoundVars

- Michelson.TypeCheck.Types: NotWellTyped :: T -> BadTypeForScope -> NotWellTyped

- Michelson.TypeCheck.Types: [:/] :: HST inp -> SomeInstrOut inp -> SomeInstr inp

- Michelson.TypeCheck.Types: [::&] :: (SingI x, SingI xs) => (Notes x, Dict (WellTyped x), VarAnn) -> HST xs -> HST (x : xs)

- Michelson.TypeCheck.Types: [:::] :: SingI out => Instr inp out -> HST out -> SomeInstrOut inp

- Michelson.TypeCheck.Types: [AnyOutInstr] :: (forall out. Instr inp out) -> SomeInstrOut inp

- Michelson.TypeCheck.Types: [SNil] :: HST '[]

- Michelson.TypeCheck.Types: [SomeHST] :: SingI ts => HST ts -> SomeHST

- Michelson.TypeCheck.Types: [nwtBadType] :: NotWellTyped -> T

- Michelson.TypeCheck.Types: [nwtCause] :: NotWellTyped -> BadTypeForScope

- Michelson.TypeCheck.Types: data BoundVars

- Michelson.TypeCheck.Types: data HST (ts :: [T])

- Michelson.TypeCheck.Types: data NotWellTyped

- Michelson.TypeCheck.Types: data SomeHST

- Michelson.TypeCheck.Types: data SomeInstr inp

- Michelson.TypeCheck.Types: data SomeInstrOut inp

- Michelson.TypeCheck.Types: getWTP :: forall t. SingI t => Either NotWellTyped (Dict (WellTyped t))

- Michelson.TypeCheck.Types: getWTP_ :: forall t. Sing t -> Either NotWellTyped (Dict (WellTyped t))

- Michelson.TypeCheck.Types: infix 8 :/

- Michelson.TypeCheck.Types: infix 9 :::

- Michelson.TypeCheck.Types: infixr 7 ::&+

- Michelson.TypeCheck.Types: instance Control.DeepSeq.NFData (Michelson.TypeCheck.Types.HST ts)

- Michelson.TypeCheck.Types: instance Control.DeepSeq.NFData Michelson.TypeCheck.Types.SomeHST

- Michelson.TypeCheck.Types: instance Formatting.Buildable.Buildable (Michelson.TypeCheck.Types.HST ts)

- Michelson.TypeCheck.Types: instance Formatting.Buildable.Buildable Michelson.TypeCheck.Types.NotWellTyped

- Michelson.TypeCheck.Types: instance GHC.Classes.Eq (Michelson.TypeCheck.Types.HST ts)

- Michelson.TypeCheck.Types: instance GHC.Classes.Eq Michelson.TypeCheck.Types.SomeHST

- Michelson.TypeCheck.Types: instance GHC.Show.Show (Michelson.TypeCheck.Types.HST ts)

- Michelson.TypeCheck.Types: instance GHC.Show.Show (Michelson.Typed.Instr.ExtInstr inp) => GHC.Show.Show (Michelson.TypeCheck.Types.SomeInstr inp)

- Michelson.TypeCheck.Types: instance GHC.Show.Show (Michelson.Typed.Instr.ExtInstr inp) => GHC.Show.Show (Michelson.TypeCheck.Types.SomeInstrOut inp)

- Michelson.TypeCheck.Types: instance GHC.Show.Show Michelson.TypeCheck.Types.SomeHST

- Michelson.TypeCheck.Types: instance Michelson.Printer.Util.RenderDoc (Michelson.TypeCheck.Types.HST ts)

- Michelson.TypeCheck.Types: mapSomeContract :: (forall inp out. Instr inp out -> Instr inp out) -> SomeContract -> SomeContract

- Michelson.TypeCheck.Types: mapSomeInstr :: (forall out. Instr inp out -> Instr inp out) -> SomeInstr inp -> SomeInstr inp

- Michelson.TypeCheck.Types: mapSomeInstrOut :: (forall out. Instr inp out -> Instr inp' out) -> SomeInstrOut inp -> SomeInstrOut inp'

- Michelson.TypeCheck.Types: noBoundVars :: BoundVars

- Michelson.TypeCheck.Types: pattern (::&+) :: () => (ys ~ (x : xs), SingI x, SingI xs) => (Sing x, Notes x, Dict (WellTyped x), VarAnn) -> HST xs -> HST ys

- Michelson.TypeCheck.Types: type TcExtFrames = [BoundVars]

- Michelson.TypeCheck.Types: unsafeWithWTP :: forall t a. SingI t => (WellTyped t => a) -> a

- Michelson.TypeCheck.Types: withWTPm :: forall t m a. (MonadFail m, SingI t) => (WellTyped t => m a) -> m a

- Michelson.TypeCheck.Value: tcFailedOnValue :: Value -> T -> Text -> Maybe TCTypeError -> TypeCheckInstr a

- Michelson.TypeCheck.Value: typeCheckValImpl :: forall ty. SingI ty => Maybe TcOriginatedContracts -> TcInstrHandler -> Value -> TypeCheckInstr (Value ty)

- Michelson.Typed.Aliases: type Operation = Operation' Instr

- Michelson.Typed.Aliases: type Value = Value' Instr

- Michelson.Typed.Annotation: [AnnConvergeError] :: forall (tag :: Type). (Buildable (Annotation tag), Show (Annotation tag), Typeable tag) => Annotation tag -> Annotation tag -> AnnConvergeError

- Michelson.Typed.Annotation: [NTAddress] :: TypeAnn -> Notes 'TAddress

- Michelson.Typed.Annotation: [NTBigMap] :: TypeAnn -> Notes k -> Notes v -> Notes ('TBigMap k v)

- Michelson.Typed.Annotation: [NTBls12381Fr] :: TypeAnn -> Notes 'TBls12381Fr

- Michelson.Typed.Annotation: [NTBls12381G1] :: TypeAnn -> Notes 'TBls12381G1

- Michelson.Typed.Annotation: [NTBls12381G2] :: TypeAnn -> Notes 'TBls12381G2

- Michelson.Typed.Annotation: [NTBool] :: TypeAnn -> Notes 'TBool

- Michelson.Typed.Annotation: [NTBytes] :: TypeAnn -> Notes 'TBytes

- Michelson.Typed.Annotation: [NTChainId] :: TypeAnn -> Notes 'TChainId

- Michelson.Typed.Annotation: [NTContract] :: TypeAnn -> Notes t -> Notes ('TContract t)

- Michelson.Typed.Annotation: [NTInt] :: TypeAnn -> Notes 'TInt

- Michelson.Typed.Annotation: [NTKeyHash] :: TypeAnn -> Notes 'TKeyHash

- Michelson.Typed.Annotation: [NTKey] :: TypeAnn -> Notes 'TKey

- Michelson.Typed.Annotation: [NTLambda] :: TypeAnn -> Notes p -> Notes q -> Notes ('TLambda p q)

- Michelson.Typed.Annotation: [NTList] :: TypeAnn -> Notes t -> Notes ('TList t)

- Michelson.Typed.Annotation: [NTMap] :: TypeAnn -> Notes k -> Notes v -> Notes ('TMap k v)

- Michelson.Typed.Annotation: [NTMutez] :: TypeAnn -> Notes 'TMutez

- Michelson.Typed.Annotation: [NTNat] :: TypeAnn -> Notes 'TNat

- Michelson.Typed.Annotation: [NTNever] :: TypeAnn -> Notes 'TNever

- Michelson.Typed.Annotation: [NTOperation] :: TypeAnn -> Notes 'TOperation

- Michelson.Typed.Annotation: [NTOption] :: TypeAnn -> Notes t -> Notes ('TOption t)

- Michelson.Typed.Annotation: [NTOr] :: TypeAnn -> FieldAnn -> FieldAnn -> Notes p -> Notes q -> Notes ('TOr p q)

- Michelson.Typed.Annotation: [NTPair] :: TypeAnn -> FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> Notes p -> Notes q -> Notes ('TPair p q)

- Michelson.Typed.Annotation: [NTSet] :: TypeAnn -> Notes t -> Notes ('TSet t)

- Michelson.Typed.Annotation: [NTSignature] :: TypeAnn -> Notes 'TSignature

- Michelson.Typed.Annotation: [NTString] :: TypeAnn -> Notes 'TString

- Michelson.Typed.Annotation: [NTTicket] :: TypeAnn -> Notes t -> Notes ('TTicket t)

- Michelson.Typed.Annotation: [NTTimestamp] :: TypeAnn -> Notes 'TTimestamp

- Michelson.Typed.Annotation: [NTUnit] :: TypeAnn -> Notes 'TUnit

- Michelson.Typed.Annotation: converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t)

- Michelson.Typed.Annotation: convergeAnns :: forall (tag :: Type). (Buildable (Annotation tag), Show (Annotation tag), Typeable tag) => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)

- Michelson.Typed.Annotation: convergeDestrAnns :: FieldAnn -> FieldAnn -> Either AnnConvergeError FieldAnn

- Michelson.Typed.Annotation: data AnnConvergeError

- Michelson.Typed.Annotation: data Notes t

- Michelson.Typed.Annotation: insertTypeAnn :: forall (b :: T). TypeAnn -> Notes b -> Notes b

- Michelson.Typed.Annotation: instance Control.DeepSeq.NFData (Michelson.Typed.Annotation.Notes t)

- Michelson.Typed.Annotation: instance Control.DeepSeq.NFData Michelson.Typed.Annotation.AnnConvergeError

- Michelson.Typed.Annotation: instance Formatting.Buildable.Buildable (Michelson.Typed.Annotation.Notes t)

- Michelson.Typed.Annotation: instance Formatting.Buildable.Buildable Michelson.Typed.Annotation.AnnConvergeError

- Michelson.Typed.Annotation: instance GHC.Classes.Eq (Michelson.Typed.Annotation.Notes t)

- Michelson.Typed.Annotation: instance GHC.Classes.Eq Michelson.Typed.Annotation.AnnConvergeError

- Michelson.Typed.Annotation: instance GHC.Show.Show (Michelson.Typed.Annotation.Notes t)

- Michelson.Typed.Annotation: instance GHC.Show.Show Michelson.Typed.Annotation.AnnConvergeError

- Michelson.Typed.Annotation: instance Michelson.Printer.Util.RenderDoc (Michelson.Typed.Annotation.Notes t)

- Michelson.Typed.Annotation: isStar :: SingI t => Notes t -> Bool

- Michelson.Typed.Annotation: notesSing :: SingI t => Notes t -> Sing t

- Michelson.Typed.Annotation: notesT :: SingI t => Notes t -> T

- Michelson.Typed.Annotation: starNotes :: forall t. SingI t => Notes t

- Michelson.Typed.Arith: --

- Michelson.Typed.Arith: -- <tt>m</tt>.

- Michelson.Typed.Arith: -- CInt = CInt</tt>.

- Michelson.Typed.Arith: -- For instance, adding integer to natural produces integer, which is

- Michelson.Typed.Arith: -- computing operation <tt>op</tt> from operands of types <tt>n</tt> and

- Michelson.Typed.Arith: -- reflected in following instance of type family: <tt>ArithRes Add CNat

- Michelson.Typed.Arith: -- | Type family <tt>ArithRes</tt> denotes the type resulting from

- Michelson.Typed.Arith: AddOverflow :: MutezArithErrorType

- Michelson.Typed.Arith: LslOverflow :: ShiftArithErrorType

- Michelson.Typed.Arith: LsrUnderflow :: ShiftArithErrorType

- Michelson.Typed.Arith: MulOverflow :: MutezArithErrorType

- Michelson.Typed.Arith: MutezArithError :: MutezArithErrorType -> n -> m -> ArithError n m

- Michelson.Typed.Arith: ShiftArithError :: ShiftArithErrorType -> n -> m -> ArithError n m

- Michelson.Typed.Arith: SubUnderflow :: MutezArithErrorType

- Michelson.Typed.Arith: class (Typeable n, Typeable m) => ArithOp aop (n :: T) (m :: T) where {

- Michelson.Typed.Arith: class ToIntArithOp (n :: T)

- Michelson.Typed.Arith: class UnaryArithOp aop (n :: T) where {

- Michelson.Typed.Arith: commutativityProof :: ArithOp aop n m => Maybe $ Dict (ArithRes aop n m ~ ArithRes aop m n, ArithOp aop m n)

- Michelson.Typed.Arith: compareOp :: Comparable t => Value' i t -> Value' i t -> Integer

- Michelson.Typed.Arith: convergeArith :: ArithOp aop n m => proxy aop -> Notes n -> Notes m -> Either AnnConvergeError (Notes (ArithRes aop n m))

- Michelson.Typed.Arith: data Abs

- Michelson.Typed.Arith: data Add

- Michelson.Typed.Arith: data And

- Michelson.Typed.Arith: data ArithError n m

- Michelson.Typed.Arith: data Compare

- Michelson.Typed.Arith: data Eq'

- Michelson.Typed.Arith: data Ge

- Michelson.Typed.Arith: data Gt

- Michelson.Typed.Arith: data Le

- Michelson.Typed.Arith: data Lsl

- Michelson.Typed.Arith: data Lsr

- Michelson.Typed.Arith: data Lt

- Michelson.Typed.Arith: data Mul

- Michelson.Typed.Arith: data MutezArithErrorType

- Michelson.Typed.Arith: data Neg

- Michelson.Typed.Arith: data Neq

- Michelson.Typed.Arith: data Not

- Michelson.Typed.Arith: data Or

- Michelson.Typed.Arith: data ShiftArithErrorType

- Michelson.Typed.Arith: data Sub

- Michelson.Typed.Arith: data Xor

- Michelson.Typed.Arith: evalOp :: ArithOp aop n m => proxy aop -> Value' instr n -> Value' instr m -> Either (ArithError (Value' instr n) (Value' instr m)) (Value' instr (ArithRes aop n m))

- Michelson.Typed.Arith: evalToIntOp :: ToIntArithOp n => Value' instr n -> Value' instr 'TInt

- Michelson.Typed.Arith: evalUnaryArithOp :: UnaryArithOp aop n => proxy aop -> Value' instr n -> Value' instr (UnaryArithRes aop n)

- Michelson.Typed.Arith: instance (Control.DeepSeq.NFData n, Control.DeepSeq.NFData m) => Control.DeepSeq.NFData (Michelson.Typed.Arith.ArithError n m)

- Michelson.Typed.Arith: instance (GHC.Classes.Eq n, GHC.Classes.Eq m) => GHC.Classes.Eq (Michelson.Typed.Arith.ArithError n m)

- Michelson.Typed.Arith: instance (GHC.Classes.Ord n, GHC.Classes.Ord m) => GHC.Classes.Ord (Michelson.Typed.Arith.ArithError n m)

- Michelson.Typed.Arith: instance (GHC.Show.Show n, GHC.Show.Show m) => Formatting.Buildable.Buildable (Michelson.Typed.Arith.ArithError n m)

- Michelson.Typed.Arith: instance (GHC.Show.Show n, GHC.Show.Show m) => GHC.Show.Show (Michelson.Typed.Arith.ArithError n m)

- Michelson.Typed.Arith: instance Control.DeepSeq.NFData Michelson.Typed.Arith.MutezArithErrorType

- Michelson.Typed.Arith: instance Control.DeepSeq.NFData Michelson.Typed.Arith.ShiftArithErrorType

- Michelson.Typed.Arith: instance Formatting.Buildable.Buildable Michelson.Typed.Arith.MutezArithErrorType

- Michelson.Typed.Arith: instance Formatting.Buildable.Buildable Michelson.Typed.Arith.ShiftArithErrorType

- Michelson.Typed.Arith: instance GHC.Classes.Eq Michelson.Typed.Arith.MutezArithErrorType

- Michelson.Typed.Arith: instance GHC.Classes.Eq Michelson.Typed.Arith.ShiftArithErrorType

- Michelson.Typed.Arith: instance GHC.Classes.Ord Michelson.Typed.Arith.MutezArithErrorType

- Michelson.Typed.Arith: instance GHC.Classes.Ord Michelson.Typed.Arith.ShiftArithErrorType

- Michelson.Typed.Arith: instance GHC.Generics.Generic (Michelson.Typed.Arith.ArithError n m)

- Michelson.Typed.Arith: instance GHC.Generics.Generic Michelson.Typed.Arith.MutezArithErrorType

- Michelson.Typed.Arith: instance GHC.Generics.Generic Michelson.Typed.Arith.ShiftArithErrorType

- Michelson.Typed.Arith: instance GHC.Show.Show Michelson.Typed.Arith.MutezArithErrorType

- Michelson.Typed.Arith: instance GHC.Show.Show Michelson.Typed.Arith.ShiftArithErrorType

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TBls12381Fr 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TBls12381G1 'Michelson.Typed.T.TBls12381G1

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TBls12381G2 'Michelson.Typed.T.TBls12381G2

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TTimestamp

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TMutez 'Michelson.Typed.T.TMutez

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Add 'Michelson.Typed.T.TTimestamp 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.And 'Michelson.Typed.T.TBool 'Michelson.Typed.T.TBool

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.And 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.And 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Lsl 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Lsr 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TBls12381Fr 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TBls12381Fr 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TBls12381Fr 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TBls12381G1 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TBls12381G2 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TMutez 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TMutez

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Or 'Michelson.Typed.T.TBool 'Michelson.Typed.T.TBool

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Or 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Sub 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Sub 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Sub 'Michelson.Typed.T.TMutez 'Michelson.Typed.T.TMutez

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Sub 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Sub 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Sub 'Michelson.Typed.T.TTimestamp 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Sub 'Michelson.Typed.T.TTimestamp 'Michelson.Typed.T.TTimestamp

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Xor 'Michelson.Typed.T.TBool 'Michelson.Typed.T.TBool

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Xor 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.Bls12381MulBadOrder Tezos.Crypto.BLS12381.Bls12381Fr Tezos.Crypto.BLS12381.Bls12381G1 => Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TBls12381Fr 'Michelson.Typed.T.TBls12381G1

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.Bls12381MulBadOrder Tezos.Crypto.BLS12381.Bls12381Fr Tezos.Crypto.BLS12381.Bls12381G2 => Michelson.Typed.Arith.ArithOp Michelson.Typed.Arith.Mul 'Michelson.Typed.T.TBls12381Fr 'Michelson.Typed.T.TBls12381G2

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ToIntArithOp 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.ToIntArithOp 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Abs 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Eq' 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Ge 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Gt 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Le 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Lt 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Neg 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Neg 'Michelson.Typed.T.TBls12381G1

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Neg 'Michelson.Typed.T.TBls12381G2

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Neg 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Neg 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Neq 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Not 'Michelson.Typed.T.TBool

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Not 'Michelson.Typed.T.TInt

- Michelson.Typed.Arith: instance Michelson.Typed.Arith.UnaryArithOp Michelson.Typed.Arith.Not 'Michelson.Typed.T.TNat

- Michelson.Typed.Arith: type family Bls12381MulBadOrder a1 a2

- Michelson.Typed.Arith: }

- Michelson.Typed.Convert: convertContract :: Contract param store -> Contract

- Michelson.Typed.Convert: convertContractCode :: forall param store. (SingI param, SingI store) => ContractCode param store -> Contract

- Michelson.Typed.Convert: convertParamNotes :: SingI cp => ParamNotes cp -> ParameterType

- Michelson.Typed.Convert: flattenEntrypoints :: SingI t => ParamNotes t -> Map EpName Ty

- Michelson.Typed.Convert: instance (Data.Singletons.Internal.SingI t, Michelson.Typed.Scope.HasNoOp t) => Formatting.Buildable.Buildable (Michelson.Typed.Value.Value' Michelson.Typed.Instr.Instr t)

- Michelson.Typed.Convert: instance Data.Singletons.Internal.SingI s => GHC.Classes.Eq (Michelson.Typed.Instr.TestAssert s)

- Michelson.Typed.Convert: instance Formatting.Buildable.Buildable (Michelson.Typed.Instr.Instr inp out)

- Michelson.Typed.Convert: instance GHC.Classes.Eq (Michelson.Typed.Instr.Instr inp out)

- Michelson.Typed.Convert: instance GHC.Classes.Eq Michelson.Typed.Convert.UntypingOptions

- Michelson.Typed.Convert: instance GHC.Show.Show Michelson.Typed.Convert.UntypingOptions

- Michelson.Typed.Convert: instance Michelson.Printer.Util.RenderDoc (Michelson.Typed.Instr.Instr inp out)

- Michelson.Typed.Convert: instrToOps :: HasCallStack => Instr inp out -> [ExpandedOp]

- Michelson.Typed.Convert: instrToOpsOptimized :: HasCallStack => Instr inp out -> [ExpandedOp]

- Michelson.Typed.Convert: sampleTypedValue :: Sing t -> Maybe (Value t)

- Michelson.Typed.Convert: untypeDemoteT :: forall (t :: T). SingI t => Ty

- Michelson.Typed.Convert: untypeValue :: (SingI t, HasNoOp t) => Value' Instr t -> Value

- Michelson.Typed.Convert: untypeValueHashable :: (SingI t, HasNoOp t) => Value' Instr t -> Value

- Michelson.Typed.Convert: untypeValueOptimized :: (SingI t, HasNoOp t) => Value' Instr t -> Value

- Michelson.Typed.Doc: buildInstrDoc :: Instr inp out -> ContractDoc

- Michelson.Typed.Doc: buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc

- Michelson.Typed.Doc: cutInstrNonDoc :: (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr s s

- Michelson.Typed.Doc: docInstr :: DocItem di => di -> Instr s s

- Michelson.Typed.Doc: instance Michelson.Doc.ContainsDoc (Michelson.Typed.Instr.Contract cp st)

- Michelson.Typed.Doc: instance Michelson.Doc.ContainsDoc (Michelson.Typed.Instr.Instr inp out)

- Michelson.Typed.Doc: instance Michelson.Doc.ContainsUpdateableDoc (Michelson.Typed.Instr.Contract cp st)

- Michelson.Typed.Doc: instance Michelson.Doc.ContainsUpdateableDoc (Michelson.Typed.Instr.Instr inp out)

- Michelson.Typed.Doc: modifyInstrAllDoc :: (SomeDocItem -> SomeDocItem) -> Instr inp out -> Instr inp out

- Michelson.Typed.Doc: modifyInstrDoc :: (DocItem i1, DocItem i2) => (i1 -> Maybe i2) -> Instr inp out -> Instr inp out

- Michelson.Typed.Entrypoints: AcLeft :: ArmCoord

- Michelson.Typed.Entrypoints: AcRight :: ArmCoord

- Michelson.Typed.Entrypoints: EntrypointCall :: EpName -> Proxy param -> EpLiftSequence arg param -> EntrypointCallT (param :: T) (arg :: T)

- Michelson.Typed.Entrypoints: EpAddress :: Address -> EpName -> EpAddress

- Michelson.Typed.Entrypoints: InEpNameBadAnnotation :: FieldAnn -> EpNameFromRefAnnError

- Michelson.Typed.Entrypoints: ParamEpDuplicatedNames :: NonEmpty EpName -> ParamEpError

- Michelson.Typed.Entrypoints: ParamEpUncallableArm :: ArmCoords -> ParamEpError

- Michelson.Typed.Entrypoints: ParseEpAddressBadAddress :: ParseAddressError -> ParseEpAddressError

- Michelson.Typed.Entrypoints: ParseEpAddressBadEntryopint :: ByteString -> UnicodeException -> ParseEpAddressError

- Michelson.Typed.Entrypoints: ParseEpAddressBadRefAnn :: Text -> ParseEpAddressError

- Michelson.Typed.Entrypoints: ParseEpAddressInvalidLength :: Int -> ParseEpAddressError

- Michelson.Typed.Entrypoints: ParseEpAddressRawBadAddress :: ParseAddressRawError -> ParseEpAddressError

- Michelson.Typed.Entrypoints: ParseEpAddressRefAnnError :: EpNameFromRefAnnError -> ParseEpAddressError

- Michelson.Typed.Entrypoints: SomeEpc :: EntrypointCallT param arg -> SomeEntrypointCallT (arg :: T)

- Michelson.Typed.Entrypoints: UnsafeEpName :: Text -> EpName

- Michelson.Typed.Entrypoints: UnsafeParamNotes :: Notes t -> RootAnn -> ParamNotes (t :: T)

- Michelson.Typed.Entrypoints: [EplArgHere] :: EpLiftSequence arg arg

- Michelson.Typed.Entrypoints: [EplWrapLeft] :: (SingI subparam, SingI r) => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)

- Michelson.Typed.Entrypoints: [EplWrapRight] :: (SingI l, SingI subparam) => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)

- Michelson.Typed.Entrypoints: [MkEntrypointCallRes] :: ParameterScope arg => Notes arg -> EntrypointCallT param arg -> MkEntrypointCallRes param

- Michelson.Typed.Entrypoints: [eaAddress] :: EpAddress -> Address

- Michelson.Typed.Entrypoints: [eaEntrypoint] :: EpAddress -> EpName

- Michelson.Typed.Entrypoints: [epcLiftSequence] :: EntrypointCallT (param :: T) (arg :: T) -> EpLiftSequence arg param

- Michelson.Typed.Entrypoints: [epcName] :: EntrypointCallT (param :: T) (arg :: T) -> EpName

- Michelson.Typed.Entrypoints: [epcParamProxy] :: EntrypointCallT (param :: T) (arg :: T) -> Proxy param

- Michelson.Typed.Entrypoints: [pnNotes] :: ParamNotes (t :: T) -> Notes t

- Michelson.Typed.Entrypoints: [pnRootAnn] :: ParamNotes (t :: T) -> RootAnn

- Michelson.Typed.Entrypoints: [unEpName] :: EpName -> Text

- Michelson.Typed.Entrypoints: data ArmCoord

- Michelson.Typed.Entrypoints: data EntrypointCallT (param :: T) (arg :: T)

- Michelson.Typed.Entrypoints: data EpAddress

- Michelson.Typed.Entrypoints: data EpLiftSequence (arg :: T) (param :: T)

- Michelson.Typed.Entrypoints: data EpNameFromRefAnnError

- Michelson.Typed.Entrypoints: data MkEntrypointCallRes param

- Michelson.Typed.Entrypoints: data ParamEpError

- Michelson.Typed.Entrypoints: data ParamNotes (t :: T)

- Michelson.Typed.Entrypoints: data ParseEpAddressError

- Michelson.Typed.Entrypoints: data SomeEntrypointCallT (arg :: T)

- Michelson.Typed.Entrypoints: epNameFromParamAnn :: FieldAnn -> Maybe EpName

- Michelson.Typed.Entrypoints: epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName

- Michelson.Typed.Entrypoints: epNameToParamAnn :: EpName -> FieldAnn

- Michelson.Typed.Entrypoints: epNameToRefAnn :: EpName -> FieldAnn

- Michelson.Typed.Entrypoints: epcPrimitive :: forall p. (ParameterScope p, ForbidOr p) => EntrypointCallT p p

- Michelson.Typed.Entrypoints: formatEpAddress :: EpAddress -> Text

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Michelson.Typed.Entrypoints.EntrypointCallT param arg)

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Michelson.Typed.Entrypoints.EpLiftSequence arg param)

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Michelson.Typed.Entrypoints.ParamNotes t)

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Michelson.Typed.Entrypoints.ArmCoord

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Michelson.Typed.Entrypoints.ParamEpError

- Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Michelson.Typed.Entrypoints.ParseEpAddressError

- Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable (Michelson.Typed.Entrypoints.EntrypointCallT param arg)

- Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable (Michelson.Typed.Entrypoints.EpLiftSequence arg param)

- Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable (Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

- Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Michelson.Typed.Entrypoints.ArmCoord

- Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Michelson.Typed.Entrypoints.ParamEpError

- Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Michelson.Typed.Entrypoints.ParseEpAddressError

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Michelson.Typed.Entrypoints.EntrypointCallT param arg)

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Michelson.Typed.Entrypoints.EpLiftSequence arg param)

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Michelson.Typed.Entrypoints.ParamNotes t)

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Michelson.Typed.Entrypoints.ArmCoord

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Michelson.Typed.Entrypoints.ParamEpError

- Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Michelson.Typed.Entrypoints.ParseEpAddressError

- Michelson.Typed.Entrypoints: instance GHC.Classes.Ord Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Entrypoints: instance GHC.Generics.Generic (Michelson.Typed.Entrypoints.ParamNotes t)

- Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Michelson.Typed.Entrypoints.ArmCoord

- Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Michelson.Typed.Entrypoints.ParamEpError

- Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Michelson.Typed.Entrypoints.ParseEpAddressError

- Michelson.Typed.Entrypoints: instance GHC.Show.Show (Michelson.Typed.Entrypoints.EntrypointCallT param arg)

- Michelson.Typed.Entrypoints: instance GHC.Show.Show (Michelson.Typed.Entrypoints.EpLiftSequence arg param)

- Michelson.Typed.Entrypoints: instance GHC.Show.Show (Michelson.Typed.Entrypoints.ParamNotes t)

- Michelson.Typed.Entrypoints: instance GHC.Show.Show (Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

- Michelson.Typed.Entrypoints: instance GHC.Show.Show Michelson.Typed.Entrypoints.ArmCoord

- Michelson.Typed.Entrypoints: instance GHC.Show.Show Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Entrypoints: instance GHC.Show.Show Michelson.Typed.Entrypoints.ParamEpError

- Michelson.Typed.Entrypoints: instance GHC.Show.Show Michelson.Typed.Entrypoints.ParseEpAddressError

- Michelson.Typed.Entrypoints: instance Michelson.Printer.Util.RenderDoc Michelson.Typed.Entrypoints.ArmCoord

- Michelson.Typed.Entrypoints: instance Michelson.Printer.Util.RenderDoc Michelson.Typed.Entrypoints.ParamEpError

- Michelson.Typed.Entrypoints: instance Michelson.Printer.Util.RenderDoc Michelson.Typed.Entrypoints.ParseEpAddressError

- Michelson.Typed.Entrypoints: mformatEpAddress :: EpAddress -> MText

- Michelson.Typed.Entrypoints: mkEntrypointCall :: ParameterScope param => EpName -> ParamNotes param -> Maybe (MkEntrypointCallRes param)

- Michelson.Typed.Entrypoints: mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)

- Michelson.Typed.Entrypoints: newtype EpName

- Michelson.Typed.Entrypoints: parseEpAddress :: Text -> Either ParseEpAddressError EpAddress

- Michelson.Typed.Entrypoints: parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress

- Michelson.Typed.Entrypoints: pattern DefEpName :: EpName

- Michelson.Typed.Entrypoints: pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t

- Michelson.Typed.Entrypoints: sepcName :: SomeEntrypointCallT arg -> EpName

- Michelson.Typed.Entrypoints: sepcPrimitive :: forall t. (ParameterScope t, ForbidOr t) => SomeEntrypointCallT t

- Michelson.Typed.Entrypoints: starParamNotes :: SingI t => ParamNotes t

- Michelson.Typed.Entrypoints: tyImplicitAccountParam :: ParamNotes 'TUnit

- Michelson.Typed.Entrypoints: type ArmCoords = [ArmCoord]

- Michelson.Typed.Entrypoints: type family ForbidOr (t :: T) :: Constraint

- Michelson.Typed.Entrypoints: unsafeEpcCallRoot :: ParameterScope param => EntrypointCallT param param

- Michelson.Typed.Entrypoints: unsafeParseEpAddress :: HasCallStack => Text -> EpAddress

- Michelson.Typed.Entrypoints: unsafeParseEpAddressRaw :: ByteString -> EpAddress

- Michelson.Typed.Entrypoints: unsafeSepcCallRoot :: ParameterScope param => SomeEntrypointCallT param

- Michelson.Typed.Existential: [SomeConstant] :: (ConstantScope t, SingI t) => Value t -> SomeConstant

- Michelson.Typed.Existential: [SomeConstrainedValue] :: forall (t :: T) (c :: T -> Constraint). c t => Value t -> SomeConstrainedValue c

- Michelson.Typed.Existential: [SomeContractAndStorage] :: forall cp st. (StorageScope st, ParameterScope cp) => Contract cp st -> Value st -> SomeContractAndStorage

- Michelson.Typed.Existential: [SomeContract] :: Contract cp st -> SomeContract

- Michelson.Typed.Existential: [SomeIsoValue] :: KnownIsoT a => a -> SomeIsoValue

- Michelson.Typed.Existential: [SomeStorage] :: forall st. StorageScope st => Value st -> SomeStorage

- Michelson.Typed.Existential: [SomeValue] :: SingI t => Value t -> SomeValue

- Michelson.Typed.Existential: data SomeConstant

- Michelson.Typed.Existential: data SomeConstrainedValue (c :: T -> Constraint)

- Michelson.Typed.Existential: data SomeContract

- Michelson.Typed.Existential: data SomeContractAndStorage

- Michelson.Typed.Existential: data SomeIsoValue

- Michelson.Typed.Existential: data SomeStorage

- Michelson.Typed.Existential: data SomeValue

- Michelson.Typed.Existential: instance Control.DeepSeq.NFData Michelson.Typed.Existential.SomeContract

- Michelson.Typed.Existential: instance Formatting.Buildable.Buildable Michelson.Typed.Existential.SomeConstant

- Michelson.Typed.Existential: instance GHC.Classes.Eq Michelson.Typed.Existential.SomeValue

- Michelson.Typed.Existential: instance GHC.Show.Show (Michelson.Typed.Existential.SomeConstrainedValue c)

- Michelson.Typed.Existential: instance GHC.Show.Show Michelson.Typed.Existential.SomeContract

- Michelson.Typed.Existential: instance GHC.Show.Show Michelson.Typed.Existential.SomeContractAndStorage

- Michelson.Typed.Existential: instance GHC.Show.Show Michelson.Typed.Existential.SomeStorage

- Michelson.Typed.Existential: instance GHC.Show.Show Michelson.Typed.Existential.SomeValue

- Michelson.Typed.Extract: fromUType :: Ty -> T

- Michelson.Typed.Extract: mkUType :: SingI x => Notes x -> Ty

- Michelson.Typed.Extract: pattern AsUType :: () => SingI t => Notes t -> Ty

- Michelson.Typed.Extract: pattern AsUTypeExt :: () => SingI t => Sing t -> Notes t -> Ty

- Michelson.Typed.Extract: toUType :: T -> Ty

- Michelson.Typed.Extract: withUType :: Ty -> (forall t. SingI t => Notes t -> r) -> r

- Michelson.Typed.Haskell: (//->) :: Label ("c" `AppendSymbol` ctor) -> RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

- Michelson.Typed.Haskell: --

- Michelson.Typed.Haskell: -- Descriptions will be checked at compile time to make sure that only

- Michelson.Typed.Haskell: -- For implementation of the check see <a>FieldDescriptionsValid</a> type

- Michelson.Typed.Haskell: -- See <a>FieldDescriptions</a> documentation for an example of usage.

- Michelson.Typed.Haskell: -- existing constructors and fields are referenced.

- Michelson.Typed.Haskell: -- family.

- Michelson.Typed.Haskell: -- type.

- Michelson.Typed.Haskell: -- whenever <tt>TypeDocFieldDescriptions</tt> is not empty.

- Michelson.Typed.Haskell: -- | Description of constructors and fields of <tt>a</tt>.

- Michelson.Typed.Haskell: BigMap :: Maybe (BigMapId k v) -> Map k v -> BigMap k v

- Michelson.Typed.Haskell: BigMapId :: Natural -> BigMapId k v

- Michelson.Typed.Haskell: CaseClauseParam :: Symbol -> CtorField -> CaseClauseParam

- Michelson.Typed.Haskell: ComposeCtorNotFound :: ComposeResult a

- Michelson.Typed.Haskell: ComposeFieldTypeMismatch :: T -> T -> ComposeResult a

- Michelson.Typed.Haskell: ComposeOk :: a -> ComposeResult a

- Michelson.Typed.Haskell: ConstructorRep :: Text -> Maybe Text -> [FieldRep a] -> ConstructorRep a

- Michelson.Typed.Haskell: ContractRef :: Address -> SomeEntrypointCall arg -> ContractRef (arg :: Type)

- Michelson.Typed.Haskell: DStorageType :: DType -> DStorageType

- Michelson.Typed.Haskell: FieldConstructor :: Instr (ToTs' st) (ToT field : ToTs' st) -> FieldConstructor (st :: [k]) (field :: Type)

- Michelson.Typed.Haskell: FieldRep :: Maybe Text -> Maybe Text -> a -> FieldRep a

- Michelson.Typed.Haskell: L :: Branch

- Michelson.Typed.Haskell: NoFields :: CtorField

- Michelson.Typed.Haskell: OneField :: Type -> CtorField

- Michelson.Typed.Haskell: R :: Branch

- Michelson.Typed.Haskell: S :: Branch

- Michelson.Typed.Haskell: Ticket :: Address -> arg -> Natural -> Ticket (arg :: Type)

- Michelson.Typed.Haskell: WithinParens :: Bool -> WithinParens

- Michelson.Typed.Haskell: [CaseClause] :: RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

- Michelson.Typed.Haskell: [DType] :: TypeHasDoc a => Proxy a -> DType

- Michelson.Typed.Haskell: [Dict] :: forall a. a => Dict a

- Michelson.Typed.Haskell: [SomeTypeWithDoc] :: TypeHasDoc td => Proxy td -> SomeTypeWithDoc

- Michelson.Typed.Haskell: [bmId] :: BigMap k v -> Maybe (BigMapId k v)

- Michelson.Typed.Haskell: [bmMap] :: BigMap k v -> Map k v

- Michelson.Typed.Haskell: [crAddress] :: ContractRef (arg :: Type) -> Address

- Michelson.Typed.Haskell: [crDescription] :: ConstructorRep a -> Maybe Text

- Michelson.Typed.Haskell: [crEntrypoint] :: ContractRef (arg :: Type) -> SomeEntrypointCall arg

- Michelson.Typed.Haskell: [crFields] :: ConstructorRep a -> [FieldRep a]

- Michelson.Typed.Haskell: [crName] :: ConstructorRep a -> Text

- Michelson.Typed.Haskell: [frDescription] :: FieldRep a -> Maybe Text

- Michelson.Typed.Haskell: [frName] :: FieldRep a -> Maybe Text

- Michelson.Typed.Haskell: [frTypeRep] :: FieldRep a -> a

- Michelson.Typed.Haskell: [tAmount] :: Ticket (arg :: Type) -> Natural

- Michelson.Typed.Haskell: [tData] :: Ticket (arg :: Type) -> arg

- Michelson.Typed.Haskell: [tTicketer] :: Ticket (arg :: Type) -> Address

- Michelson.Typed.Haskell: [unBigMapId] :: BigMapId k v -> Natural

- Michelson.Typed.Haskell: appendCtorFieldAxiom :: (AppendCtorFieldAxiom ('OneField Word) '[Int], AppendCtorFieldAxiom 'NoFields '[Int]) => Dict (AppendCtorFieldAxiom cf st)

- Michelson.Typed.Haskell: applyWithinParens :: WithinParens -> Markdown -> Markdown

- Michelson.Typed.Haskell: buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown

- Michelson.Typed.Haskell: castFieldConstructorsImpl :: CastFieldConstructors xs ys => Rec (FieldConstructor st) xs -> Rec (FieldConstructor st) ys

- Michelson.Typed.Haskell: class ToTs xs ~ ToTs ys => CastFieldConstructors xs ys

- Michelson.Typed.Haskell: class GProductHasDoc (x :: Type -> Type)

- Michelson.Typed.Haskell: class GTypeHasDoc (x :: Type -> Type)

- Michelson.Typed.Haskell: class HaveCommonTypeCtor a b

- Michelson.Typed.Haskell: class IsHomomorphic a

- Michelson.Typed.Haskell: class (WellTypedToT a) => IsoValue a where {

- Michelson.Typed.Haskell: class IsoValuesStack (ts :: [Type])

- Michelson.Typed.Haskell: class (Typeable a, SingI (TypeDocFieldDescriptions a), FieldDescriptionsValid (TypeDocFieldDescriptions a) a) => TypeHasDoc a where {

- Michelson.Typed.Haskell: class (SingI t, WellTypedSuperC t) => WellTyped (t :: T)

- Michelson.Typed.Haskell: coerceContractRef :: ToT a ~ ToT b => ContractRef a -> ContractRef b

- Michelson.Typed.Haskell: concreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a), HaveCommonTypeCtor b a) => TypeDocHaskellRep b

- Michelson.Typed.Haskell: concreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a, HaveCommonTypeCtor b a) => TypeDocMichelsonRep b

- Michelson.Typed.Haskell: contractRefToAddr :: ContractRef cp -> EpAddress

- Michelson.Typed.Haskell: crDescriptionL :: forall a_a6j1N. Lens' (ConstructorRep a_a6j1N) (Maybe Text)

- Michelson.Typed.Haskell: crFieldsL :: forall a_a6j1N a_a6j2Z. Lens (ConstructorRep a_a6j1N) (ConstructorRep a_a6j2Z) [FieldRep a_a6j1N] [FieldRep a_a6j2Z]

- Michelson.Typed.Haskell: crNameL :: forall a_a6j1N. Lens' (ConstructorRep a_a6j1N) Text

- Michelson.Typed.Haskell: customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown

- Michelson.Typed.Haskell: dStorage :: forall store. TypeHasDoc store => DStorageType

- Michelson.Typed.Haskell: dTypeDep :: forall (t :: Type). TypeHasDoc t => SomeDocDefinitionItem

- Michelson.Typed.Haskell: dTypeDepP :: forall (t :: Type). TypeHasDoc t => Proxy t -> SomeDocDefinitionItem

- Michelson.Typed.Haskell: data BigMap k v

- Michelson.Typed.Haskell: data Branch

- Michelson.Typed.Haskell: data CaseClause (inp :: [T]) (out :: [T]) (param :: CaseClauseParam)

- Michelson.Typed.Haskell: data CaseClauseParam

- Michelson.Typed.Haskell: data ComposeResult a

- Michelson.Typed.Haskell: data ConstructorRep a

- Michelson.Typed.Haskell: data ContractRef (arg :: Type)

- Michelson.Typed.Haskell: data CtorField

- Michelson.Typed.Haskell: data DType

- Michelson.Typed.Haskell: data Dict a

- Michelson.Typed.Haskell: data FieldRep a

- Michelson.Typed.Haskell: data MyCompoundType

- Michelson.Typed.Haskell: data SomeTypeWithDoc

- Michelson.Typed.Haskell: data Ticket (arg :: Type)

- Michelson.Typed.Haskell: frDescriptionL :: forall a_a6j1M. Lens' (FieldRep a_a6j1M) (Maybe Text)

- Michelson.Typed.Haskell: frNameL :: forall a_a6j1M. Lens' (FieldRep a_a6j1M) (Maybe Text)

- Michelson.Typed.Haskell: frTypeRepL :: forall a_a6j1M a_a6j4H. Lens (FieldRep a_a6j1M) (FieldRep a_a6j4H) a_a6j1M a_a6j4H

- Michelson.Typed.Haskell: fromTaggedVal :: LooseSumC dt => (Text, SomeValue) -> ComposeResult dt

- Michelson.Typed.Haskell: fromVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => Value (ToT a) -> a

- Michelson.Typed.Haskell: fromValStack :: IsoValuesStack ts => Rec Value (ToTs ts) -> Rec Identity ts

- Michelson.Typed.Haskell: genericTypeDocDependencies :: forall a. (Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

- Michelson.Typed.Haskell: haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a

- Michelson.Typed.Haskell: haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a

- Michelson.Typed.Haskell: haskellRepStripFieldPrefix :: HasCallStack => TypeDocHaskellRep a -> TypeDocHaskellRep a

- Michelson.Typed.Haskell: homomorphicTypeDocHaskellRep :: forall a. (Generic a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep a

- Michelson.Typed.Haskell: homomorphicTypeDocMdReference :: forall (t :: Type). (Typeable t, TypeHasDoc t, IsHomomorphic t) => Proxy t -> WithinParens -> Markdown

- Michelson.Typed.Haskell: homomorphicTypeDocMichelsonRep :: forall a. KnownIsoT a => TypeDocMichelsonRep a

- Michelson.Typed.Haskell: hsUnwrap :: forall dt name. InstrUnwrapC dt name => Label name -> dt -> Maybe (CtorOnlyField name dt)

- Michelson.Typed.Haskell: hsWrap :: forall dt name. InstrWrapC dt name => Label name -> ExtractCtorField (GetCtorField dt name) -> dt

- Michelson.Typed.Haskell: infixr 8 //->

- Michelson.Typed.Haskell: instrCase :: forall dt out inp. InstrCaseC dt => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt : inp) out

- Michelson.Typed.Haskell: instrConstruct :: forall dt st. InstrConstructC dt => Rec (FieldConstructor st) (ConstructorFieldTypes dt) -> Instr st (ToT dt : st)

- Michelson.Typed.Haskell: instrConstructStack :: forall dt stack st. (InstrConstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (stack ++ st) (ToT dt : st)

- Michelson.Typed.Haskell: instrDeconstruct :: forall dt stack st. (InstrDeconstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (ToT dt : st) (stack ++ st)

- Michelson.Typed.Haskell: instrSetField :: forall dt name st. InstrSetFieldC dt name => Label name -> Instr (ToT (GetFieldType dt name) : (ToT dt : st)) (ToT dt : st)

- Michelson.Typed.Haskell: instrToField :: forall dt name st. InstrGetFieldC dt name => Label name -> Instr (ToT dt : st) (ToT (GetFieldType dt name) : st)

- Michelson.Typed.Haskell: instrWrap :: forall dt name st. InstrWrapC dt name => Label name -> Instr (AppendCtorField (GetCtorField dt name) st) (ToT dt : st)

- Michelson.Typed.Haskell: instrWrapOne :: forall dt name st. InstrWrapOneC dt name => Label name -> Instr (ToT (CtorOnlyField name dt) : st) (ToT dt : st)

- Michelson.Typed.Haskell: ligoCombLayout :: GenericStrategy

- Michelson.Typed.Haskell: ligoLayout :: GenericStrategy

- Michelson.Typed.Haskell: mkBigMap :: Ord k => [(k, v)] -> BigMap k v

- Michelson.Typed.Haskell: newtype BigMapId k v

- Michelson.Typed.Haskell: newtype DStorageType

- Michelson.Typed.Haskell: newtype FieldConstructor (st :: [k]) (field :: Type)

- Michelson.Typed.Haskell: newtype WithinParens

- Michelson.Typed.Haskell: poly1TypeDocMdReference :: forall t (r :: Type) (a :: Type). (r ~ t a, Typeable t, Each '[TypeHasDoc] [r, a], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

- Michelson.Typed.Haskell: poly2TypeDocMdReference :: forall t (r :: Type) (a :: Type) (b :: Type). (r ~ t a b, Typeable t, Each '[TypeHasDoc] [r, a, b], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

- Michelson.Typed.Haskell: toTaggedVal :: LooseSumC dt => dt -> (Text, SomeValue)

- Michelson.Typed.Haskell: toVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => a -> Value (ToT a)

- Michelson.Typed.Haskell: toValStack :: IsoValuesStack ts => Rec Identity ts -> Rec Value (ToTs ts)

- Michelson.Typed.Haskell: totsAppendLemma :: forall a b. KnownList a => Dict (ToTs (a ++ b) ~ (ToTs a ++ ToTs b))

- Michelson.Typed.Haskell: totsKnownLemma :: forall s. KnownList s :- KnownList (ToTs s)

- Michelson.Typed.Haskell: type ADTRep a = [ConstructorRep a]

- Michelson.Typed.Haskell: type AppendCtorFieldAxiom (cf :: CtorField) (st :: [Type]) = ToTs (AppendCtorField cf st) ~ AppendCtorField cf (ToTs st)

- Michelson.Typed.Haskell: type CaseClauses a = GCaseClauses (Rep a)

- Michelson.Typed.Haskell: type ConstructorFieldNames dt = GFieldNames (Rep dt)

- Michelson.Typed.Haskell: type ConstructorFieldTypes dt = GFieldTypes (Rep dt)

- Michelson.Typed.Haskell: type CtorHasOnlyField ctor dt f = GetCtorField dt ctor ~ 'OneField f

- Michelson.Typed.Haskell: type CtorOnlyField name dt = RequireOneField name (GetCtorField dt name)

- Michelson.Typed.Haskell: type EntrypointCall param arg = EntrypointCallT (ToT param) (ToT arg)

- Michelson.Typed.Haskell: type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]

- Michelson.Typed.Haskell: type GenericIsoValue t = (IsoValue t, Generic t, ToT t ~ GValueType (Rep t))

- Michelson.Typed.Haskell: type GetCtorField dt ctor = LnrFieldType (GetNamed ctor dt)

- Michelson.Typed.Haskell: type GetFieldType dt name = LnrFieldType (GetNamed name dt)

- Michelson.Typed.Haskell: type HasNoOpToT a = HasNoOp (ToT a)

- Michelson.Typed.Haskell: type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (Rep dt))

- Michelson.Typed.Haskell: type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (Rep dt))

- Michelson.Typed.Haskell: type InstrDeconstructC dt = (GenericIsoValue dt, GInstrDeconstruct (Rep dt))

- Michelson.Typed.Haskell: type InstrGetFieldC dt name = (GenericIsoValue dt, GInstrGet name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

- Michelson.Typed.Haskell: type InstrSetFieldC dt name = (GenericIsoValue dt, GInstrSetField name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

- Michelson.Typed.Haskell: type InstrUnwrapC dt name = (GenericIsoValue dt, GInstrUnwrap (Rep dt) (LnrBranch (GetNamed name dt)) (CtorOnlyField name dt))

- Michelson.Typed.Haskell: type InstrWrapC dt name = (GenericIsoValue dt, GInstrWrap (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

- Michelson.Typed.Haskell: type InstrWrapOneC dt name = (InstrWrapC dt name, GetCtorField dt name ~ 'OneField (CtorOnlyField name dt))

- Michelson.Typed.Haskell: type KnownIsoT a = SingI (ToT a)

- Michelson.Typed.Haskell: type LooseSumC dt = (Generic dt, GLooseSum (Rep dt))

- Michelson.Typed.Haskell: type Path = [Branch]

- Michelson.Typed.Haskell: type PolyTypeHasDocC ts = Each '[TypeHasDoc] ts

- Michelson.Typed.Haskell: type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)

- Michelson.Typed.Haskell: type ToT a = GValueType (Rep a);

- Michelson.Typed.Haskell: type TypeDocFieldDescriptions _ = '[];

- Michelson.Typed.Haskell: type TypeDocHaskellRep a = Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)

- Michelson.Typed.Haskell: type TypeDocMichelsonRep a = Proxy a -> (Maybe DocTypeRepLHS, T)

- Michelson.Typed.Haskell: type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)

- Michelson.Typed.Haskell: type WellTypedToT a = WellTyped (ToT a)

- Michelson.Typed.Haskell: type family TypeDocFieldDescriptions a :: FieldDescriptions;

- Michelson.Typed.Haskell: typeDocDependencies :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

- Michelson.Typed.Haskell: typeDocHaskellRep :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a), IsHomomorphic a) => TypeDocHaskellRep a

- Michelson.Typed.Haskell: typeDocMdDescription :: TypeHasDoc a => Markdown

- Michelson.Typed.Haskell: typeDocMdReference :: (TypeHasDoc a, Typeable a, IsHomomorphic a) => Proxy a -> WithinParens -> Markdown

- Michelson.Typed.Haskell: typeDocMichelsonRep :: (TypeHasDoc a, KnownIsoT a, IsHomomorphic a) => TypeDocMichelsonRep a

- Michelson.Typed.Haskell: typeDocName :: (TypeHasDoc a, Generic a, KnownSymbol (GenericTypeName a)) => Proxy a -> Text

- Michelson.Typed.Haskell: unsafeConcreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep b

- Michelson.Typed.Haskell: unsafeConcreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a) => TypeDocMichelsonRep b

- Michelson.Typed.Haskell: unsafeInstrUnwrap :: forall dt name st. InstrUnwrapC dt name => Label name -> Instr (ToT dt : st) (ToT (CtorOnlyField name dt) : st)

- Michelson.Typed.Haskell: }

- Michelson.Typed.Haskell.Compatibility: ligoCombLayout :: GenericStrategy

- Michelson.Typed.Haskell.Compatibility: ligoLayout :: GenericStrategy

- Michelson.Typed.Haskell.Doc: --

- Michelson.Typed.Haskell.Doc: -- Descriptions will be checked at compile time to make sure that only

- Michelson.Typed.Haskell.Doc: -- For implementation of the check see <a>FieldDescriptionsValid</a> type

- Michelson.Typed.Haskell.Doc: -- See <a>FieldDescriptions</a> documentation for an example of usage.

- Michelson.Typed.Haskell.Doc: -- existing constructors and fields are referenced.

- Michelson.Typed.Haskell.Doc: -- family.

- Michelson.Typed.Haskell.Doc: -- whenever <tt>TypeDocFieldDescriptions</tt> is not empty.

- Michelson.Typed.Haskell.Doc: -- | Description of constructors and fields of <tt>a</tt>.

- Michelson.Typed.Haskell.Doc: ConstructorRep :: Text -> Maybe Text -> [FieldRep a] -> ConstructorRep a

- Michelson.Typed.Haskell.Doc: DStorageType :: DType -> DStorageType

- Michelson.Typed.Haskell.Doc: FieldRep :: Maybe Text -> Maybe Text -> a -> FieldRep a

- Michelson.Typed.Haskell.Doc: WithinParens :: Bool -> WithinParens

- Michelson.Typed.Haskell.Doc: [DType] :: TypeHasDoc a => Proxy a -> DType

- Michelson.Typed.Haskell.Doc: [SomeTypeWithDoc] :: TypeHasDoc td => Proxy td -> SomeTypeWithDoc

- Michelson.Typed.Haskell.Doc: [crDescription] :: ConstructorRep a -> Maybe Text

- Michelson.Typed.Haskell.Doc: [crFields] :: ConstructorRep a -> [FieldRep a]

- Michelson.Typed.Haskell.Doc: [crName] :: ConstructorRep a -> Text

- Michelson.Typed.Haskell.Doc: [frDescription] :: FieldRep a -> Maybe Text

- Michelson.Typed.Haskell.Doc: [frName] :: FieldRep a -> Maybe Text

- Michelson.Typed.Haskell.Doc: [frTypeRep] :: FieldRep a -> a

- Michelson.Typed.Haskell.Doc: applyWithinParens :: WithinParens -> Markdown -> Markdown

- Michelson.Typed.Haskell.Doc: buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown

- Michelson.Typed.Haskell.Doc: class GProductHasDoc (x :: Type -> Type)

- Michelson.Typed.Haskell.Doc: class GTypeHasDoc (x :: Type -> Type)

- Michelson.Typed.Haskell.Doc: class HaveCommonTypeCtor a b

- Michelson.Typed.Haskell.Doc: class IsHomomorphic a

- Michelson.Typed.Haskell.Doc: class (Typeable a, SingI (TypeDocFieldDescriptions a), FieldDescriptionsValid (TypeDocFieldDescriptions a) a) => TypeHasDoc a where {

- Michelson.Typed.Haskell.Doc: concreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a), HaveCommonTypeCtor b a) => TypeDocHaskellRep b

- Michelson.Typed.Haskell.Doc: concreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a, HaveCommonTypeCtor b a) => TypeDocMichelsonRep b

- Michelson.Typed.Haskell.Doc: crDescriptionL :: forall a_a6j1N. Lens' (ConstructorRep a_a6j1N) (Maybe Text)

- Michelson.Typed.Haskell.Doc: crFieldsL :: forall a_a6j1N a_a6j2Z. Lens (ConstructorRep a_a6j1N) (ConstructorRep a_a6j2Z) [FieldRep a_a6j1N] [FieldRep a_a6j2Z]

- Michelson.Typed.Haskell.Doc: crNameL :: forall a_a6j1N. Lens' (ConstructorRep a_a6j1N) Text

- Michelson.Typed.Haskell.Doc: customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown

- Michelson.Typed.Haskell.Doc: dStorage :: forall store. TypeHasDoc store => DStorageType

- Michelson.Typed.Haskell.Doc: dTypeDep :: forall (t :: Type). TypeHasDoc t => SomeDocDefinitionItem

- Michelson.Typed.Haskell.Doc: dTypeDepP :: forall (t :: Type). TypeHasDoc t => Proxy t -> SomeDocDefinitionItem

- Michelson.Typed.Haskell.Doc: data ConstructorRep a

- Michelson.Typed.Haskell.Doc: data DType

- Michelson.Typed.Haskell.Doc: data FieldRep a

- Michelson.Typed.Haskell.Doc: data SomeTypeWithDoc

- Michelson.Typed.Haskell.Doc: frDescriptionL :: forall a_a6j1M. Lens' (FieldRep a_a6j1M) (Maybe Text)

- Michelson.Typed.Haskell.Doc: frNameL :: forall a_a6j1M. Lens' (FieldRep a_a6j1M) (Maybe Text)

- Michelson.Typed.Haskell.Doc: frTypeRepL :: forall a_a6j1M a_a6j4H. Lens (FieldRep a_a6j1M) (FieldRep a_a6j4H) a_a6j1M a_a6j4H

- Michelson.Typed.Haskell.Doc: genericTypeDocDependencies :: forall a. (Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

- Michelson.Typed.Haskell.Doc: haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a

- Michelson.Typed.Haskell.Doc: haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a

- Michelson.Typed.Haskell.Doc: haskellRepStripFieldPrefix :: HasCallStack => TypeDocHaskellRep a -> TypeDocHaskellRep a

- Michelson.Typed.Haskell.Doc: homomorphicTypeDocHaskellRep :: forall a. (Generic a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep a

- Michelson.Typed.Haskell.Doc: homomorphicTypeDocMdReference :: forall (t :: Type). (Typeable t, TypeHasDoc t, IsHomomorphic t) => Proxy t -> WithinParens -> Markdown

- Michelson.Typed.Haskell.Doc: homomorphicTypeDocMichelsonRep :: forall a. KnownIsoT a => TypeDocMichelsonRep a

- Michelson.Typed.Haskell.Doc: instance (Michelson.Typed.Haskell.Doc.GProductHasDoc x, GHC.TypeLits.KnownSymbol ctor) => Michelson.Typed.Haskell.Doc.GTypeHasDoc (GHC.Generics.C1 ('GHC.Generics.MetaCons ctor _1 _2) x)

- Michelson.Typed.Haskell.Doc: instance (Michelson.Typed.Haskell.Doc.GProductHasDoc x, Michelson.Typed.Haskell.Doc.GProductHasDoc y) => Michelson.Typed.Haskell.Doc.GProductHasDoc (x GHC.Generics.:*: y)

- Michelson.Typed.Haskell.Doc: instance (Michelson.Typed.Haskell.Doc.GTypeHasDoc x, Michelson.Typed.Haskell.Doc.GTypeHasDoc y) => Michelson.Typed.Haskell.Doc.GTypeHasDoc (x GHC.Generics.:+: y)

- Michelson.Typed.Haskell.Doc: instance (Michelson.Typed.Haskell.Doc.PolyCTypeHasDocC '[k], Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[v], GHC.Classes.Ord k) => Michelson.Typed.Haskell.Doc.TypeHasDoc (Data.Map.Internal.Map k v)

- Michelson.Typed.Haskell.Doc: instance (Michelson.Typed.Haskell.Doc.TypeHasDoc (Util.Named.ApplyNamedFunctor f a), GHC.TypeLits.KnownSymbol n, Michelson.Typed.Haskell.Value.KnownIsoT (Util.Named.ApplyNamedFunctor f GHC.Integer.Type.Integer), Data.Typeable.Internal.Typeable f, Data.Typeable.Internal.Typeable a) => Michelson.Typed.Haskell.Doc.TypeHasDoc (Named.Internal.NamedF f a n)

- Michelson.Typed.Haskell.Doc: instance (Michelson.Typed.Haskell.Doc.TypeHasDoc a, GHC.TypeLits.KnownSymbol field) => Michelson.Typed.Haskell.Doc.GProductHasDoc (GHC.Generics.S1 ('GHC.Generics.MetaSel ('GHC.Maybe.Just field) _1 _2 _3) (GHC.Generics.Rec0 a))

- Michelson.Typed.Haskell.Doc: instance Data.String.IsString Michelson.Typed.Haskell.Doc.DocTypeRepLHS

- Michelson.Typed.Haskell.Doc: instance Formatting.Buildable.Buildable Michelson.Typed.Haskell.Doc.DocTypeRepLHS

- Michelson.Typed.Haskell.Doc: instance GHC.Classes.Eq Michelson.Typed.Haskell.Doc.DStorageType

- Michelson.Typed.Haskell.Doc: instance GHC.Classes.Eq Michelson.Typed.Haskell.Doc.DType

- Michelson.Typed.Haskell.Doc: instance GHC.Classes.Ord Michelson.Typed.Haskell.Doc.DStorageType

- Michelson.Typed.Haskell.Doc: instance GHC.Classes.Ord Michelson.Typed.Haskell.Doc.DType

- Michelson.Typed.Haskell.Doc: instance GHC.Generics.Generic Michelson.Typed.Haskell.Doc.DStorageType

- Michelson.Typed.Haskell.Doc: instance GHC.Show.Show Michelson.Typed.Haskell.Doc.DType

- Michelson.Typed.Haskell.Doc: instance Michelson.Doc.DocItem Michelson.Typed.Haskell.Doc.DStorageType

- Michelson.Typed.Haskell.Doc: instance Michelson.Doc.DocItem Michelson.Typed.Haskell.Doc.DType

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.GProductHasDoc GHC.Generics.U1

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.GTypeHasDoc GHC.Generics.V1

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.GTypeHasDoc x => Michelson.Typed.Haskell.Doc.GTypeHasDoc (GHC.Generics.D1 ('GHC.Generics.MetaData _a _b _c 'GHC.Types.False) x)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.GTypeHasDoc x => Michelson.Typed.Haskell.Doc.GTypeHasDoc (GHC.Generics.D1 ('GHC.Generics.MetaData _a _b _c 'GHC.Types.True) x)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyCTypeHasDocC '[a] => Michelson.Typed.Haskell.Doc.TypeHasDoc (Data.Set.Internal.Set a)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d, e, f, g] => Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d, e, f, g)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d, e, f] => Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d, e, f)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d, e] => Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d, e)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d] => Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c] => Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b] => Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a] => Michelson.Typed.Haskell.Doc.TypeHasDoc (GHC.Maybe.Maybe a)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a] => Michelson.Typed.Haskell.Doc.TypeHasDoc (Michelson.Typed.Haskell.Value.Ticket a)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a] => Michelson.Typed.Haskell.Doc.TypeHasDoc [a]

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[cp] => Michelson.Typed.Haskell.Doc.TypeHasDoc (Michelson.Typed.Haskell.Value.ContractRef cp)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[l, r] => Michelson.Typed.Haskell.Doc.TypeHasDoc (Data.Either.Either l r)

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc ()

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Data.ByteString.Internal.ByteString

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc GHC.Integer.Type.Integer

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc GHC.Natural.Natural

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc GHC.Types.Bool

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Michelson.Text.MText

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Michelson.Typed.Aliases.Operation

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Tezos.Address.Address

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Tezos.Core.ChainId

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Tezos.Core.Mutez

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Tezos.Core.Timestamp

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Tezos.Crypto.KeyHash

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Tezos.Crypto.PublicKey

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc Tezos.Crypto.Signature

- Michelson.Typed.Haskell.Doc: instance Michelson.Typed.Haskell.Doc.TypeHasDoc a => Michelson.Typed.Haskell.Doc.GProductHasDoc (GHC.Generics.S1 ('GHC.Generics.MetaSel 'GHC.Maybe.Nothing _1 _2 _3) (GHC.Generics.Rec0 a))

- Michelson.Typed.Haskell.Doc: instance forall k (a :: k). Michelson.Typed.Haskell.Doc.HaveCommonTypeCtor a a

- Michelson.Typed.Haskell.Doc: instance forall k (a :: k). Michelson.Typed.Haskell.Doc.IsHomomorphic a

- Michelson.Typed.Haskell.Doc: instance forall k1 k2 (a :: k1 -> k2) (b :: k1). (TypeError ...) => Michelson.Typed.Haskell.Doc.IsHomomorphic (a b)

- Michelson.Typed.Haskell.Doc: instance forall k1 k2 k3 k4 (ac :: k1 -> k2) (bc :: k3 -> k4) (a :: k1) (b :: k3). Michelson.Typed.Haskell.Doc.HaveCommonTypeCtor ac bc => Michelson.Typed.Haskell.Doc.HaveCommonTypeCtor (ac a) (bc b)

- Michelson.Typed.Haskell.Doc: newtype DStorageType

- Michelson.Typed.Haskell.Doc: newtype WithinParens

- Michelson.Typed.Haskell.Doc: poly1TypeDocMdReference :: forall t (r :: Type) (a :: Type). (r ~ t a, Typeable t, Each '[TypeHasDoc] [r, a], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

- Michelson.Typed.Haskell.Doc: poly2TypeDocMdReference :: forall t (r :: Type) (a :: Type) (b :: Type). (r ~ t a b, Typeable t, Each '[TypeHasDoc] [r, a, b], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

- Michelson.Typed.Haskell.Doc: type ADTRep a = [ConstructorRep a]

- Michelson.Typed.Haskell.Doc: type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]

- Michelson.Typed.Haskell.Doc: type PolyTypeHasDocC ts = Each '[TypeHasDoc] ts

- Michelson.Typed.Haskell.Doc: type TypeDocFieldDescriptions _ = '[];

- Michelson.Typed.Haskell.Doc: type TypeDocHaskellRep a = Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)

- Michelson.Typed.Haskell.Doc: type TypeDocMichelsonRep a = Proxy a -> (Maybe DocTypeRepLHS, T)

- Michelson.Typed.Haskell.Doc: type family TypeDocFieldDescriptions a :: FieldDescriptions;

- Michelson.Typed.Haskell.Doc: typeDocDependencies :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

- Michelson.Typed.Haskell.Doc: typeDocHaskellRep :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a), IsHomomorphic a) => TypeDocHaskellRep a

- Michelson.Typed.Haskell.Doc: typeDocMdDescription :: TypeHasDoc a => Markdown

- Michelson.Typed.Haskell.Doc: typeDocMdReference :: (TypeHasDoc a, Typeable a, IsHomomorphic a) => Proxy a -> WithinParens -> Markdown

- Michelson.Typed.Haskell.Doc: typeDocMichelsonRep :: (TypeHasDoc a, KnownIsoT a, IsHomomorphic a) => TypeDocMichelsonRep a

- Michelson.Typed.Haskell.Doc: typeDocName :: (TypeHasDoc a, Generic a, KnownSymbol (GenericTypeName a)) => Proxy a -> Text

- Michelson.Typed.Haskell.Doc: unsafeConcreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep b

- Michelson.Typed.Haskell.Doc: unsafeConcreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a) => TypeDocMichelsonRep b

- Michelson.Typed.Haskell.Doc: }

- Michelson.Typed.Haskell.Instr.Helpers: L :: Branch

- Michelson.Typed.Haskell.Instr.Helpers: R :: Branch

- Michelson.Typed.Haskell.Instr.Helpers: S :: Branch

- Michelson.Typed.Haskell.Instr.Helpers: data Branch

- Michelson.Typed.Haskell.Instr.Helpers: type Path = [Branch]

- Michelson.Typed.Haskell.Instr.Product: FieldConstructor :: Instr (ToTs' st) (ToT field : ToTs' st) -> FieldConstructor (st :: [k]) (field :: Type)

- Michelson.Typed.Haskell.Instr.Product: castFieldConstructorsImpl :: CastFieldConstructors xs ys => Rec (FieldConstructor st) xs -> Rec (FieldConstructor st) ys

- Michelson.Typed.Haskell.Instr.Product: class ToTs xs ~ ToTs ys => CastFieldConstructors xs ys

- Michelson.Typed.Haskell.Instr.Product: instance ((TypeError ...), Michelson.Typed.Haskell.Value.GIsoValue x, Michelson.Typed.Haskell.Value.GIsoValue y) => Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (x GHC.Generics.:+: y)

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Instr.Product.CastFieldConstructors xs ys, Michelson.Typed.Haskell.Value.ToTs xs GHC.Types.~ Michelson.Typed.Haskell.Value.ToTs ys, Michelson.Typed.Haskell.Value.ToT x GHC.Types.~ Michelson.Typed.Haskell.Value.ToT y) => Michelson.Typed.Haskell.Instr.Product.CastFieldConstructors (x : xs) (y : ys)

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Instr.Product.GInstrConstruct x, Michelson.Typed.Haskell.Instr.Product.GInstrConstruct y, Util.Type.RSplit (Michelson.Typed.Haskell.Instr.Product.GFieldTypes x) (Michelson.Typed.Haskell.Instr.Product.GFieldTypes y), Util.Type.KnownList (Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes x)), Util.Type.KnownList (Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)), (Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes x) Data.Vinyl.TypeLevel.++ Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) GHC.Types.~ Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes x Data.Vinyl.TypeLevel.++ Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) => Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (x GHC.Generics.:*: y)

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct x, Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct y, t GHC.Types.~ (x GHC.Generics.:*: y), Util.Type.KnownList (Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes x)), Util.Type.KnownList (Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)), (Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes x) Data.Vinyl.TypeLevel.++ Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) GHC.Types.~ Michelson.Typed.Haskell.Value.ToTs (Michelson.Typed.Haskell.Instr.Product.GFieldTypes x Data.Vinyl.TypeLevel.++ Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) => Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct (x GHC.Generics.:*: y)

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Instr.Product.GInstrGet name x path f, Michelson.Typed.Haskell.Value.GIsoValue y) => Michelson.Typed.Haskell.Instr.Product.GInstrGet name (x GHC.Generics.:*: y) ('Michelson.Typed.Haskell.Instr.Helpers.L : path) f

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Instr.Product.GInstrGet name y path f, Michelson.Typed.Haskell.Value.GIsoValue x) => Michelson.Typed.Haskell.Instr.Product.GInstrGet name (x GHC.Generics.:*: y) ('Michelson.Typed.Haskell.Instr.Helpers.R : path) f

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Instr.Product.GInstrSetField name x path f, Michelson.Typed.Haskell.Value.GIsoValue y) => Michelson.Typed.Haskell.Instr.Product.GInstrSetField name (x GHC.Generics.:*: y) ('Michelson.Typed.Haskell.Instr.Helpers.L : path) f

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Instr.Product.GInstrSetField name y path f, Michelson.Typed.Haskell.Value.GIsoValue x) => Michelson.Typed.Haskell.Instr.Product.GInstrSetField name (x GHC.Generics.:*: y) ('Michelson.Typed.Haskell.Instr.Helpers.R : path) f

- Michelson.Typed.Haskell.Instr.Product: instance (Michelson.Typed.Haskell.Value.IsoValue f, Michelson.Typed.Haskell.Value.ToT f GHC.Types.~ Michelson.Typed.Haskell.Value.ToT f') => Michelson.Typed.Haskell.Instr.Product.GInstrGet name (GHC.Generics.Rec0 f) '[] f'

- Michelson.Typed.Haskell.Instr.Product: instance (TypeError ...) => Michelson.Typed.Haskell.Instr.Product.GInstrConstruct GHC.Generics.V1

- Michelson.Typed.Haskell.Instr.Product: instance (TypeError ...) => Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct GHC.Generics.V1

- Michelson.Typed.Haskell.Instr.Product: instance GHC.Generics.Generic Michelson.Typed.Haskell.Instr.Product.MyType2

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Instr.Product.CastFieldConstructors '[] '[]

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Instr.Product.GInstrConstruct GHC.Generics.U1

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Instr.Product.GInstrConstruct x => Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (GHC.Generics.M1 t i x)

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct GHC.Generics.U1

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct x => Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct (GHC.Generics.M1 t i x)

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Instr.Product.GInstrGet name x path f => Michelson.Typed.Haskell.Instr.Product.GInstrGet name (GHC.Generics.M1 t i x) path f

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Instr.Product.GInstrSetField name x path f => Michelson.Typed.Haskell.Instr.Product.GInstrSetField name (GHC.Generics.M1 t i x) path f

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Haskell.Instr.Product.MyType2

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (GHC.Generics.Rec0 a)

- Michelson.Typed.Haskell.Instr.Product: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct (GHC.Generics.Rec0 a)

- Michelson.Typed.Haskell.Instr.Product: instrConstruct :: forall dt st. InstrConstructC dt => Rec (FieldConstructor st) (ConstructorFieldTypes dt) -> Instr st (ToT dt : st)

- Michelson.Typed.Haskell.Instr.Product: instrConstructStack :: forall dt stack st. (InstrConstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (stack ++ st) (ToT dt : st)

- Michelson.Typed.Haskell.Instr.Product: instrDeconstruct :: forall dt stack st. (InstrDeconstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (ToT dt : st) (stack ++ st)

- Michelson.Typed.Haskell.Instr.Product: instrSetField :: forall dt name st. InstrSetFieldC dt name => Label name -> Instr (ToT (GetFieldType dt name) : (ToT dt : st)) (ToT dt : st)

- Michelson.Typed.Haskell.Instr.Product: instrToField :: forall dt name st. InstrGetFieldC dt name => Label name -> Instr (ToT dt : st) (ToT (GetFieldType dt name) : st)

- Michelson.Typed.Haskell.Instr.Product: newtype FieldConstructor (st :: [k]) (field :: Type)

- Michelson.Typed.Haskell.Instr.Product: type ConstructorFieldNames dt = GFieldNames (Rep dt)

- Michelson.Typed.Haskell.Instr.Product: type ConstructorFieldTypes dt = GFieldTypes (Rep dt)

- Michelson.Typed.Haskell.Instr.Product: type GetFieldType dt name = LnrFieldType (GetNamed name dt)

- Michelson.Typed.Haskell.Instr.Product: type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (Rep dt))

- Michelson.Typed.Haskell.Instr.Product: type InstrDeconstructC dt = (GenericIsoValue dt, GInstrDeconstruct (Rep dt))

- Michelson.Typed.Haskell.Instr.Product: type InstrGetFieldC dt name = (GenericIsoValue dt, GInstrGet name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

- Michelson.Typed.Haskell.Instr.Product: type InstrSetFieldC dt name = (GenericIsoValue dt, GInstrSetField name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

- Michelson.Typed.Haskell.Instr.Sum: (//->) :: Label ("c" `AppendSymbol` ctor) -> RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

- Michelson.Typed.Haskell.Instr.Sum: CaseClauseParam :: Symbol -> CtorField -> CaseClauseParam

- Michelson.Typed.Haskell.Instr.Sum: L :: Branch

- Michelson.Typed.Haskell.Instr.Sum: NoFields :: CtorField

- Michelson.Typed.Haskell.Instr.Sum: OneField :: Type -> CtorField

- Michelson.Typed.Haskell.Instr.Sum: R :: Branch

- Michelson.Typed.Haskell.Instr.Sum: S :: Branch

- Michelson.Typed.Haskell.Instr.Sum: [CaseClause] :: RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

- Michelson.Typed.Haskell.Instr.Sum: appendCtorFieldAxiom :: (AppendCtorFieldAxiom ('OneField Word) '[Int], AppendCtorFieldAxiom 'NoFields '[Int]) => Dict (AppendCtorFieldAxiom cf st)

- Michelson.Typed.Haskell.Instr.Sum: data Branch

- Michelson.Typed.Haskell.Instr.Sum: data CaseClause (inp :: [T]) (out :: [T]) (param :: CaseClauseParam)

- Michelson.Typed.Haskell.Instr.Sum: data CaseClauseParam

- Michelson.Typed.Haskell.Instr.Sum: data CtorField

- Michelson.Typed.Haskell.Instr.Sum: data MyCompoundType

- Michelson.Typed.Haskell.Instr.Sum: hsUnwrap :: forall dt name. InstrUnwrapC dt name => Label name -> dt -> Maybe (CtorOnlyField name dt)

- Michelson.Typed.Haskell.Instr.Sum: hsWrap :: forall dt name. InstrWrapC dt name => Label name -> ExtractCtorField (GetCtorField dt name) -> dt

- Michelson.Typed.Haskell.Instr.Sum: infixr 8 //->

- Michelson.Typed.Haskell.Instr.Sum: instance (Michelson.Typed.Haskell.Instr.Sum.GInstrCase x, Michelson.Typed.Haskell.Instr.Sum.GInstrCase y, Util.Type.RSplit (Michelson.Typed.Haskell.Instr.Sum.GCaseClauses x) (Michelson.Typed.Haskell.Instr.Sum.GCaseClauses y)) => Michelson.Typed.Haskell.Instr.Sum.GInstrCase (x GHC.Generics.:+: y)

- Michelson.Typed.Haskell.Instr.Sum: instance (Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap x path e, Michelson.Typed.Haskell.Value.GIsoValue y, Data.Singletons.Internal.SingI (Michelson.Typed.Haskell.Value.GValueType y)) => Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (x GHC.Generics.:+: y) ('Michelson.Typed.Haskell.Instr.Helpers.L : path) e

- Michelson.Typed.Haskell.Instr.Sum: instance (Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap y path e, Michelson.Typed.Haskell.Value.GIsoValue x, Data.Singletons.Internal.SingI (Michelson.Typed.Haskell.Value.GValueType x)) => Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (x GHC.Generics.:+: y) ('Michelson.Typed.Haskell.Instr.Helpers.R : path) e

- Michelson.Typed.Haskell.Instr.Sum: instance (Michelson.Typed.Haskell.Instr.Sum.GInstrWrap x path e, Michelson.Typed.Haskell.Value.GIsoValue y, Data.Singletons.Internal.SingI (Michelson.Typed.Haskell.Value.GValueType y)) => Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (x GHC.Generics.:+: y) ('Michelson.Typed.Haskell.Instr.Helpers.L : path) e

- Michelson.Typed.Haskell.Instr.Sum: instance (Michelson.Typed.Haskell.Instr.Sum.GInstrWrap y path e, Michelson.Typed.Haskell.Value.GIsoValue x, Data.Singletons.Internal.SingI (Michelson.Typed.Haskell.Value.GValueType x)) => Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (x GHC.Generics.:+: y) ('Michelson.Typed.Haskell.Instr.Helpers.R : path) e

- Michelson.Typed.Haskell.Instr.Sum: instance (Michelson.Typed.Haskell.Value.GIsoValue x, Michelson.Typed.Haskell.Value.GIsoValue y, (TypeError ...)) => Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor (x GHC.Generics.:*: y)

- Michelson.Typed.Haskell.Instr.Sum: instance (path GHC.Types.~ (x : xs), Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.Rep sub) path e, Michelson.Typed.Haskell.Value.GenericIsoValue sub, Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.Rep sub)) => Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 sub))) ('Michelson.Typed.Haskell.Instr.Helpers.S : x : xs) e

- Michelson.Typed.Haskell.Instr.Sum: instance (path GHC.Types.~ (x : xs), Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.Rep sub) path e, Michelson.Typed.Haskell.Value.GenericIsoValue sub, Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.Rep sub)) => Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 sub))) ('Michelson.Typed.Haskell.Instr.Helpers.S : x : xs) e

- Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Michelson.Typed.Haskell.Instr.Sum.MyCompoundType

- Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Michelson.Typed.Haskell.Instr.Sum.MyEnum

- Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Michelson.Typed.Haskell.Instr.Sum.MyType

- Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Michelson.Typed.Haskell.Instr.Sum.MyType'

- Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Michelson.Typed.Haskell.Instr.Sum.MyTypeWithNamedField

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrCase GHC.Generics.V1

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrCase x => Michelson.Typed.Haskell.Instr.Sum.GInstrCase (GHC.Generics.D1 i x)

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor GHC.Generics.U1

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor x => Michelson.Typed.Haskell.Instr.Sum.GInstrCase (GHC.Generics.C1 ('GHC.Generics.MetaCons ctor _1 _2) x)

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor x => Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor (GHC.Generics.S1 i x)

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap x path e => Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.D1 i x) path e

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.C1 c GHC.Generics.U1) '[ 'Michelson.Typed.Haskell.Instr.Helpers.S] 'Michelson.Typed.Haskell.Instr.Sum.NoFields

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Instr.Sum.GInstrWrap x path e => Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.D1 i x) path e

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Haskell.Instr.Sum.MyCompoundType

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Haskell.Instr.Sum.MyEnum

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Haskell.Instr.Sum.MyType

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Haskell.Instr.Sum.MyType'

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Haskell.Instr.Sum.MyTypeWithNamedField

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor (GHC.Generics.Rec0 a)

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue e => Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 e))) '[ 'Michelson.Typed.Haskell.Instr.Helpers.S] e

- Michelson.Typed.Haskell.Instr.Sum: instance Michelson.Typed.Haskell.Value.IsoValue e => Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 e))) '[ 'Michelson.Typed.Haskell.Instr.Helpers.S] ('Michelson.Typed.Haskell.Instr.Sum.OneField e)

- Michelson.Typed.Haskell.Instr.Sum: instrCase :: forall dt out inp. InstrCaseC dt => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt : inp) out

- Michelson.Typed.Haskell.Instr.Sum: instrWrap :: forall dt name st. InstrWrapC dt name => Label name -> Instr (AppendCtorField (GetCtorField dt name) st) (ToT dt : st)

- Michelson.Typed.Haskell.Instr.Sum: instrWrapOne :: forall dt name st. InstrWrapOneC dt name => Label name -> Instr (ToT (CtorOnlyField name dt) : st) (ToT dt : st)

- Michelson.Typed.Haskell.Instr.Sum: type AppendCtorFieldAxiom (cf :: CtorField) (st :: [Type]) = ToTs (AppendCtorField cf st) ~ AppendCtorField cf (ToTs st)

- Michelson.Typed.Haskell.Instr.Sum: type CaseClauses a = GCaseClauses (Rep a)

- Michelson.Typed.Haskell.Instr.Sum: type CtorHasOnlyField ctor dt f = GetCtorField dt ctor ~ 'OneField f

- Michelson.Typed.Haskell.Instr.Sum: type CtorOnlyField name dt = RequireOneField name (GetCtorField dt name)

- Michelson.Typed.Haskell.Instr.Sum: type GetCtorField dt ctor = LnrFieldType (GetNamed ctor dt)

- Michelson.Typed.Haskell.Instr.Sum: type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (Rep dt))

- Michelson.Typed.Haskell.Instr.Sum: type InstrUnwrapC dt name = (GenericIsoValue dt, GInstrUnwrap (Rep dt) (LnrBranch (GetNamed name dt)) (CtorOnlyField name dt))

- Michelson.Typed.Haskell.Instr.Sum: type InstrWrapC dt name = (GenericIsoValue dt, GInstrWrap (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

- Michelson.Typed.Haskell.Instr.Sum: type InstrWrapOneC dt name = (InstrWrapC dt name, GetCtorField dt name ~ 'OneField (CtorOnlyField name dt))

- Michelson.Typed.Haskell.Instr.Sum: type Path = [Branch]

- Michelson.Typed.Haskell.Instr.Sum: type family IsPrimitiveValue (x :: Type) :: Bool

- Michelson.Typed.Haskell.Instr.Sum: unsafeInstrUnwrap :: forall dt name st. InstrUnwrapC dt name => Label name -> Instr (ToT dt : st) (ToT (CtorOnlyField name dt) : st)

- Michelson.Typed.Haskell.LooseSum: ComposeCtorNotFound :: ComposeResult a

- Michelson.Typed.Haskell.LooseSum: ComposeFieldTypeMismatch :: T -> T -> ComposeResult a

- Michelson.Typed.Haskell.LooseSum: ComposeOk :: a -> ComposeResult a

- Michelson.Typed.Haskell.LooseSum: data ComposeResult a

- Michelson.Typed.Haskell.LooseSum: fromTaggedVal :: LooseSumC dt => (Text, SomeValue) -> ComposeResult dt

- Michelson.Typed.Haskell.LooseSum: instance (Michelson.Typed.Haskell.LooseSum.GAccessField x, GHC.TypeLits.KnownSymbol ctor) => Michelson.Typed.Haskell.LooseSum.GLooseSum (GHC.Generics.C1 ('GHC.Generics.MetaCons ctor f o) x)

- Michelson.Typed.Haskell.LooseSum: instance (Michelson.Typed.Haskell.LooseSum.GLooseSum x, Michelson.Typed.Haskell.LooseSum.GLooseSum y) => Michelson.Typed.Haskell.LooseSum.GLooseSum (x GHC.Generics.:+: y)

- Michelson.Typed.Haskell.LooseSum: instance (TypeError ...) => Michelson.Typed.Haskell.LooseSum.GAccessField (x GHC.Generics.:*: y)

- Michelson.Typed.Haskell.LooseSum: instance GHC.Base.Functor Michelson.Typed.Haskell.LooseSum.ComposeResult

- Michelson.Typed.Haskell.LooseSum: instance GHC.Base.Monoid (Michelson.Typed.Haskell.LooseSum.ComposeResult a)

- Michelson.Typed.Haskell.LooseSum: instance GHC.Base.Semigroup (Michelson.Typed.Haskell.LooseSum.ComposeResult a)

- Michelson.Typed.Haskell.LooseSum: instance Michelson.Typed.Haskell.LooseSum.GAccessField GHC.Generics.U1

- Michelson.Typed.Haskell.LooseSum: instance Michelson.Typed.Haskell.LooseSum.GAccessField x => Michelson.Typed.Haskell.LooseSum.GAccessField (GHC.Generics.S1 i x)

- Michelson.Typed.Haskell.LooseSum: instance Michelson.Typed.Haskell.LooseSum.GLooseSum GHC.Generics.V1

- Michelson.Typed.Haskell.LooseSum: instance Michelson.Typed.Haskell.LooseSum.GLooseSum x => Michelson.Typed.Haskell.LooseSum.GLooseSum (GHC.Generics.D1 i x)

- Michelson.Typed.Haskell.LooseSum: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.LooseSum.GAccessField (GHC.Generics.Rec0 a)

- Michelson.Typed.Haskell.LooseSum: toTaggedVal :: LooseSumC dt => dt -> (Text, SomeValue)

- Michelson.Typed.Haskell.LooseSum: type LooseSumC dt = (Generic dt, GLooseSum (Rep dt))

- Michelson.Typed.Haskell.ValidateDescription: type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]

- Michelson.Typed.Haskell.ValidateDescription: type FieldDescriptionsV = Demote FieldDescriptions

- Michelson.Typed.Haskell.ValidateDescription: type family FieldDescriptionsValid (descr :: FieldDescriptions) (typ :: Type) :: Constraint

- Michelson.Typed.Haskell.Value: -- type.

- Michelson.Typed.Haskell.Value: -- | Type function that converts a regular Haskell type into a <tt>T</tt>

- Michelson.Typed.Haskell.Value: BigMap :: Maybe (BigMapId k v) -> Map k v -> BigMap k v

- Michelson.Typed.Haskell.Value: BigMapId :: Natural -> BigMapId k v

- Michelson.Typed.Haskell.Value: ContractRef :: Address -> SomeEntrypointCall arg -> ContractRef (arg :: Type)

- Michelson.Typed.Haskell.Value: Ticket :: Address -> arg -> Natural -> Ticket (arg :: Type)

- Michelson.Typed.Haskell.Value: [Dict] :: forall a. a => Dict a

- Michelson.Typed.Haskell.Value: [bmId] :: BigMap k v -> Maybe (BigMapId k v)

- Michelson.Typed.Haskell.Value: [bmMap] :: BigMap k v -> Map k v

- Michelson.Typed.Haskell.Value: [crAddress] :: ContractRef (arg :: Type) -> Address

- Michelson.Typed.Haskell.Value: [crEntrypoint] :: ContractRef (arg :: Type) -> SomeEntrypointCall arg

- Michelson.Typed.Haskell.Value: [tAmount] :: Ticket (arg :: Type) -> Natural

- Michelson.Typed.Haskell.Value: [tData] :: Ticket (arg :: Type) -> arg

- Michelson.Typed.Haskell.Value: [tTicketer] :: Ticket (arg :: Type) -> Address

- Michelson.Typed.Haskell.Value: [unBigMapId] :: BigMapId k v -> Natural

- Michelson.Typed.Haskell.Value: class SingI (GValueType x) => GIsoValue (x :: Type -> Type) where {

- Michelson.Typed.Haskell.Value: class (WellTypedToT a) => IsoValue a where {

- Michelson.Typed.Haskell.Value: class IsoValuesStack (ts :: [Type])

- Michelson.Typed.Haskell.Value: class (SingI t, WellTypedSuperC t) => WellTyped (t :: T)

- Michelson.Typed.Haskell.Value: coerceContractRef :: ToT a ~ ToT b => ContractRef a -> ContractRef b

- Michelson.Typed.Haskell.Value: contractRefToAddr :: ContractRef cp -> EpAddress

- Michelson.Typed.Haskell.Value: data BigMap k v

- Michelson.Typed.Haskell.Value: data ContractRef (arg :: Type)

- Michelson.Typed.Haskell.Value: data Dict a

- Michelson.Typed.Haskell.Value: data Ticket (arg :: Type)

- Michelson.Typed.Haskell.Value: fromVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => Value (ToT a) -> a

- Michelson.Typed.Haskell.Value: fromValStack :: IsoValuesStack ts => Rec Value (ToTs ts) -> Rec Identity ts

- Michelson.Typed.Haskell.Value: instance (Data.Data.Data k, Data.Data.Data v, GHC.Classes.Ord k) => Data.Data.Data (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance (GHC.Classes.Ord k, Formatting.Buildable.Buildable k, Formatting.Buildable.Buildable v) => Formatting.Buildable.Buildable (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance (GHC.Show.Show k, GHC.Show.Show v) => GHC.Show.Show (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.GIsoValue x, Michelson.Typed.Haskell.Value.GIsoValue y) => Michelson.Typed.Haskell.Value.GIsoValue (x GHC.Generics.:*: y)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.GIsoValue x, Michelson.Typed.Haskell.Value.GIsoValue y) => Michelson.Typed.Haskell.Value.GIsoValue (x GHC.Generics.:+: y)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.HasNoOpToT arg, Michelson.Typed.Haskell.Value.WellTypedToT arg) => Michelson.Typed.Haskell.Value.IsoValue (Michelson.Typed.Haskell.Value.ContractRef arg)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.IsoValue a, Michelson.Typed.Haskell.Value.IsoValue b) => Michelson.Typed.Haskell.Value.IsoValue (a, b)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.IsoValue a, Michelson.Typed.Haskell.Value.IsoValue b, Michelson.Typed.Haskell.Value.IsoValue c, Michelson.Typed.Haskell.Value.IsoValue d, Michelson.Typed.Haskell.Value.IsoValue e) => Michelson.Typed.Haskell.Value.IsoValue (a, b, c, d, e)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.IsoValue a, Michelson.Typed.Haskell.Value.IsoValue b, Michelson.Typed.Haskell.Value.IsoValue c, Michelson.Typed.Haskell.Value.IsoValue d, Michelson.Typed.Haskell.Value.IsoValue e, Michelson.Typed.Haskell.Value.IsoValue f) => Michelson.Typed.Haskell.Value.IsoValue (a, b, c, d, e, f)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.IsoValue a, Michelson.Typed.Haskell.Value.IsoValue b, Michelson.Typed.Haskell.Value.IsoValue c, Michelson.Typed.Haskell.Value.IsoValue d, Michelson.Typed.Haskell.Value.IsoValue e, Michelson.Typed.Haskell.Value.IsoValue f, Michelson.Typed.Haskell.Value.IsoValue g) => Michelson.Typed.Haskell.Value.IsoValue (a, b, c, d, e, f, g)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.IsoValue l, Michelson.Typed.Haskell.Value.IsoValue r) => Michelson.Typed.Haskell.Value.IsoValue (Data.Either.Either l r)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.IsoValue t, Michelson.Typed.Haskell.Value.IsoValuesStack st) => Michelson.Typed.Haskell.Value.IsoValuesStack (t : st)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.WellTyped t, Michelson.Typed.Scope.HasNoOp t) => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TContract t)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.WellTyped t, Michelson.Typed.Value.Comparable t) => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TTicket t)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Haskell.Value.WellTyped t1, Michelson.Typed.Haskell.Value.WellTyped t2) => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TLambda t1 t2)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Value.Comparable (Michelson.Typed.Haskell.Value.ToT a), Michelson.Typed.Haskell.Value.IsoValue a) => Michelson.Typed.Haskell.Value.IsoValue (Michelson.Typed.Haskell.Value.Ticket a)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Value.Comparable (Michelson.Typed.Haskell.Value.ToT c), GHC.Classes.Ord c, Michelson.Typed.Haskell.Value.IsoValue c) => Michelson.Typed.Haskell.Value.IsoValue (Data.Set.Internal.Set c)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Value.Comparable (Michelson.Typed.Haskell.Value.ToT k), GHC.Classes.Ord k, Michelson.Typed.Haskell.Value.IsoValue k, Michelson.Typed.Haskell.Value.IsoValue v) => Michelson.Typed.Haskell.Value.IsoValue (Data.Map.Internal.Map k v)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Value.Comparable (Michelson.Typed.Haskell.Value.ToT k), GHC.Classes.Ord k, Michelson.Typed.Haskell.Value.IsoValue k, Michelson.Typed.Haskell.Value.IsoValue v, Michelson.Typed.Haskell.Value.HasNoBigMapToT v, Michelson.Typed.Haskell.Value.HasNoOpToT v) => Michelson.Typed.Haskell.Value.IsoValue (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Value.Comparable k, Michelson.Typed.Haskell.Value.WellTyped k, Michelson.Typed.Haskell.Value.WellTyped v) => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TMap k v)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Value.Comparable k, Michelson.Typed.Haskell.Value.WellTyped k, Michelson.Typed.Haskell.Value.WellTyped v, Michelson.Typed.Scope.HasNoBigMap v, Michelson.Typed.Scope.HasNoOp v) => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TBigMap k v)

- Michelson.Typed.Haskell.Value: instance (Michelson.Typed.Value.Comparable t, Michelson.Typed.Haskell.Value.WellTyped t) => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TSet t)

- Michelson.Typed.Haskell.Value: instance Data.Default.Class.Default (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance Data.Foldable.Foldable (Michelson.Typed.Haskell.Value.BigMap k)

- Michelson.Typed.Haskell.Value: instance GHC.Classes.Eq (Michelson.Typed.Haskell.Value.ContractRef arg)

- Michelson.Typed.Haskell.Value: instance GHC.Classes.Eq arg => GHC.Classes.Eq (Michelson.Typed.Haskell.Value.Ticket arg)

- Michelson.Typed.Haskell.Value: instance GHC.Classes.Ord k => GHC.Base.Semigroup (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance GHC.Classes.Ord k => GHC.Exts.IsList (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance GHC.Generics.Generic (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance GHC.Show.Show (Michelson.Typed.Haskell.Value.ContractRef arg)

- Michelson.Typed.Haskell.Value: instance GHC.Show.Show arg => GHC.Show.Show (Michelson.Typed.Haskell.Value.Ticket arg)

- Michelson.Typed.Haskell.Value: instance Michelson.Text.DoNotUseTextError => Michelson.Typed.Haskell.Value.IsoValue Data.Text.Internal.Text

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.GIsoValue GHC.Generics.U1

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.GIsoValue GHC.Generics.V1

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.GIsoValue x => Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.M1 t i x)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue ()

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue (Michelson.Typed.Haskell.Value.ContractRef arg) => Formatting.Buildable.Buildable (Michelson.Typed.Haskell.Value.ContractRef arg)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Data.ByteString.Internal.ByteString

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Data.Void.Void

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue GHC.Integer.Type.Integer

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue GHC.Natural.Natural

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue GHC.Types.Bool

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Text.MText

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Aliases.Operation

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Michelson.Typed.Entrypoints.EpAddress

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Address.Address

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Core.ChainId

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Core.Mutez

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Core.Timestamp

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Crypto.BLS12381.Bls12381Fr

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Crypto.BLS12381.Bls12381G1

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Crypto.BLS12381.Bls12381G2

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Crypto.KeyHash

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Crypto.PublicKey

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue Tezos.Crypto.Signature

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.Rec0 a)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Value.IsoValue (Data.Functor.Identity.Identity a)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Value.IsoValue (GHC.Maybe.Maybe a)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Value.IsoValue (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Value.IsoValue (Named.Internal.NamedF GHC.Maybe.Maybe a name)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValue a => Michelson.Typed.Haskell.Value.IsoValue [a]

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.IsoValuesStack '[]

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TAddress

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TBls12381G1

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TBls12381G2

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TBool

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TBytes

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TChainId

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TInt

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TKey

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TKeyHash

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TMutez

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TNat

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TNever

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TOperation

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TSignature

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TString

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TTimestamp

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped 'Michelson.Typed.T.TUnit

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped t => Michelson.Typed.Haskell.Value.IsoValue (Michelson.Typed.Aliases.Value t)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped t => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TList t)

- Michelson.Typed.Haskell.Value: instance Michelson.Typed.Haskell.Value.WellTyped t => Michelson.Typed.Haskell.Value.WellTyped ('Michelson.Typed.T.TOption t)

- Michelson.Typed.Haskell.Value: instance Universum.Container.Class.Container (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance Universum.Container.Class.One (Michelson.Typed.Haskell.Value.BigMap k v)

- Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). (Data.Typeable.Internal.Typeable k2, Data.Typeable.Internal.Typeable v, Data.Typeable.Internal.Typeable k1, Data.Typeable.Internal.Typeable k3) => Data.Data.Data (Michelson.Typed.Haskell.Value.BigMapId k2 v)

- Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). Formatting.Buildable.Buildable (Michelson.Typed.Haskell.Value.BigMapId k2 v)

- Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). GHC.Num.Num (Michelson.Typed.Haskell.Value.BigMapId k2 v)

- Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). GHC.Show.Show (Michelson.Typed.Haskell.Value.BigMapId k2 v)

- Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). Michelson.Typed.Haskell.Value.IsoValue (Michelson.Typed.Haskell.Value.BigMapId k2 v)

- Michelson.Typed.Haskell.Value: mkBigMap :: Ord k => [(k, v)] -> BigMap k v

- Michelson.Typed.Haskell.Value: newtype BigMapId k v

- Michelson.Typed.Haskell.Value: toVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => a -> Value (ToT a)

- Michelson.Typed.Haskell.Value: toValStack :: IsoValuesStack ts => Rec Identity ts -> Rec Value (ToTs ts)

- Michelson.Typed.Haskell.Value: totsAppendLemma :: forall a b. KnownList a => Dict (ToTs (a ++ b) ~ (ToTs a ++ ToTs b))

- Michelson.Typed.Haskell.Value: totsKnownLemma :: forall s. KnownList s :- KnownList (ToTs s)

- Michelson.Typed.Haskell.Value: type EntrypointCall param arg = EntrypointCallT (ToT param) (ToT arg)

- Michelson.Typed.Haskell.Value: type GenericIsoValue t = (IsoValue t, Generic t, ToT t ~ GValueType (Rep t))

- Michelson.Typed.Haskell.Value: type HasNoOpToT a = HasNoOp (ToT a)

- Michelson.Typed.Haskell.Value: type KnownIsoT a = SingI (ToT a)

- Michelson.Typed.Haskell.Value: type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)

- Michelson.Typed.Haskell.Value: type ToT a = GValueType (Rep a);

- Michelson.Typed.Haskell.Value: type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)

- Michelson.Typed.Haskell.Value: type WellTypedToT a = WellTyped (ToT a)

- Michelson.Typed.Haskell.Value: type family ToTs' (t :: [k]) :: [T]

- Michelson.Typed.Haskell.Value: }

- Michelson.Typed.Instr: COMMENT_ITEM :: CommentType -> ExtInstr s

- Michelson.Typed.Instr: Contract :: ContractCode cp st -> ParamNotes cp -> Notes st -> EntriesOrder -> Contract cp st

- Michelson.Typed.Instr: DOC_ITEM :: SomeDocItem -> ExtInstr s

- Michelson.Typed.Instr: FunctionEnds :: Text -> CommentType

- Michelson.Typed.Instr: FunctionStarts :: Text -> CommentType

- Michelson.Typed.Instr: JustComment :: Text -> CommentType

- Michelson.Typed.Instr: PRINT :: PrintComment s -> ExtInstr s

- Michelson.Typed.Instr: PrintComment :: [Either Text (StackRef st)] -> PrintComment (st :: [T])

- Michelson.Typed.Instr: STACKTYPE :: StackTypePattern -> ExtInstr s

- Michelson.Typed.Instr: StackTypeComment :: Maybe [T] -> CommentType

- Michelson.Typed.Instr: StatementEnds :: Text -> CommentType

- Michelson.Typed.Instr: StatementStarts :: Text -> CommentType

- Michelson.Typed.Instr: TEST_ASSERT :: TestAssert s -> ExtInstr s

- Michelson.Typed.Instr: [ABS] :: UnaryArithOp Abs n => Instr (n : s) (UnaryArithRes Abs n : s)

- Michelson.Typed.Instr: [ADDRESS] :: Instr ('TContract a : s) ('TAddress : s)

- Michelson.Typed.Instr: [ADD] :: ArithOp Add n m => Instr (n : (m : s)) (ArithRes Add n m : s)

- Michelson.Typed.Instr: [AMOUNT] :: Instr s ('TMutez : s)

- Michelson.Typed.Instr: [AND] :: ArithOp And n m => Instr (n : (m : s)) (ArithRes And n m : s)

- Michelson.Typed.Instr: [APPLY] :: forall a b c s. (ConstantScope a, SingI b) => Instr (a : ('TLambda ('TPair a b) c : s)) ('TLambda b c : s)

- Michelson.Typed.Instr: [AnnCAR] :: VarAnn -> FieldAnn -> Instr ('TPair a b : s) (a : s)

- Michelson.Typed.Instr: [AnnCDR] :: VarAnn -> FieldAnn -> Instr ('TPair a b : s) (b : s)

- Michelson.Typed.Instr: [AnnLEFT] :: SingI b => TypeAnn -> FieldAnn -> FieldAnn -> Instr (a : s) ('TOr a b : s)

- Michelson.Typed.Instr: [AnnPAIR] :: TypeAnn -> FieldAnn -> FieldAnn -> Instr (a : (b : s)) ('TPair a b : s)

- Michelson.Typed.Instr: [AnnRIGHT] :: SingI a => TypeAnn -> FieldAnn -> FieldAnn -> Instr (b : s) ('TOr a b : s)

- Michelson.Typed.Instr: [AnnUNPAIR] :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> Instr ('TPair a b : s) (a : (b : s))

- Michelson.Typed.Instr: [BALANCE] :: Instr s ('TMutez : s)

- Michelson.Typed.Instr: [BLAKE2B] :: Instr ('TBytes : s) ('TBytes : s)

- Michelson.Typed.Instr: [CAST] :: forall a s. SingI a => Instr (a : s) (a : s)

- Michelson.Typed.Instr: [CHAIN_ID] :: Instr s ('TChainId : s)

- Michelson.Typed.Instr: [CHECK_SIGNATURE] :: Instr ('TKey : ('TSignature : ('TBytes : s))) ('TBool : s)

- Michelson.Typed.Instr: [COMPARE] :: (Comparable n, SingI n) => Instr (n : (n : s)) ('TInt : s)

- Michelson.Typed.Instr: [CONCAT'] :: ConcatOp c => Instr ('TList c : s) (c : s)

- Michelson.Typed.Instr: [CONCAT] :: ConcatOp c => Instr (c : (c : s)) (c : s)

- Michelson.Typed.Instr: [CONS] :: Instr (a : ('TList a : s)) ('TList a : s)

- Michelson.Typed.Instr: [CONTRACT] :: ParameterScope p => Notes p -> EpName -> Instr ('TAddress : s) ('TOption ('TContract p) : s)

- Michelson.Typed.Instr: [CREATE_CONTRACT] :: (ParameterScope p, StorageScope g) => Contract p g -> Instr ('TOption 'TKeyHash : ('TMutez : (g : s))) ('TOperation : ('TAddress : s))

- Michelson.Typed.Instr: [DIG] :: forall (n :: Peano) inp out a. (ConstraintDIG n inp out a, NFData (Sing n)) => PeanoNatural n -> Instr inp out

- Michelson.Typed.Instr: [DIPN] :: forall (n :: Peano) inp out s s'. (ConstraintDIPN n inp out s s', NFData (Sing n)) => PeanoNatural n -> Instr s s' -> Instr inp out

- Michelson.Typed.Instr: [DIP] :: Instr a c -> Instr (b : a) (b : c)

- Michelson.Typed.Instr: [DROPN] :: forall (n :: Peano) s. (RequireLongerOrSameLength s n, NFData (Sing n)) => PeanoNatural n -> Instr s (Drop n s)

- Michelson.Typed.Instr: [DROP] :: Instr (a : s) s

- Michelson.Typed.Instr: [DUG] :: forall (n :: Peano) inp out a. (ConstraintDUG n inp out a, NFData (Sing n)) => PeanoNatural n -> Instr inp out

- Michelson.Typed.Instr: [DUPN] :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, DupableScope a, NFData (Sing n)) => PeanoNatural n -> Instr inp out

- Michelson.Typed.Instr: [DUP] :: DupableScope a => Instr (a : s) (a : (a : s))

- Michelson.Typed.Instr: [DocGroup] :: DocGrouping -> Instr inp out -> Instr inp out

- Michelson.Typed.Instr: [EDIV] :: EDivOp n m => Instr (n : (m : s)) ('TOption ('TPair (EDivOpRes n m) (EModOpRes n m)) : s)

- Michelson.Typed.Instr: [EMPTY_BIG_MAP] :: (SingI a, SingI b, Comparable a, HasNoBigMap b) => Instr s ('TBigMap a b : s)

- Michelson.Typed.Instr: [EMPTY_MAP] :: (SingI a, SingI b, Comparable a) => Instr s ('TMap a b : s)

- Michelson.Typed.Instr: [EMPTY_SET] :: (SingI e, Comparable e) => Instr s ('TSet e : s)

- Michelson.Typed.Instr: [EQ] :: UnaryArithOp Eq' n => Instr (n : s) (UnaryArithRes Eq' n : s)

- Michelson.Typed.Instr: [EXEC] :: Instr (t1 : ('TLambda t1 t2 : s)) (t2 : s)

- Michelson.Typed.Instr: [Ext] :: ExtInstr s -> Instr s s

- Michelson.Typed.Instr: [FAILWITH] :: (SingI a, ConstantScope a) => Instr (a : s) t

- Michelson.Typed.Instr: [Fn] :: Text -> StackFn -> Instr inp out -> Instr inp out

- Michelson.Typed.Instr: [FrameInstr] :: forall a b s. (KnownList a, KnownList b) => Proxy s -> Instr a b -> Instr (a ++ s) (b ++ s)

- Michelson.Typed.Instr: [GETN] :: forall (ix :: Peano) (pair :: T) (s :: [T]). ConstraintGetN ix pair => PeanoNatural ix -> Instr (pair : s) (GetN ix pair : s)

- Michelson.Typed.Instr: [GET] :: (GetOp c, SingI (GetOpVal c)) => Instr (GetOpKey c : (c : s)) ('TOption (GetOpVal c) : s)

- Michelson.Typed.Instr: [GET_AND_UPDATE] :: (GetOp c, UpdOp c, SingI (GetOpVal c), UpdOpKey c ~ GetOpKey c) => Instr (UpdOpKey c : (UpdOpParams c : (c : s))) ('TOption (GetOpVal c) : (c : s))

- Michelson.Typed.Instr: [GE] :: UnaryArithOp Ge n => Instr (n : s) (UnaryArithRes Ge n : s)

- Michelson.Typed.Instr: [GT] :: UnaryArithOp Gt n => Instr (n : s) (UnaryArithRes Gt n : s)

- Michelson.Typed.Instr: [HASH_KEY] :: Instr ('TKey : s) ('TKeyHash : s)

- Michelson.Typed.Instr: [IF] :: Instr s s' -> Instr s s' -> Instr ('TBool : s) s'

- Michelson.Typed.Instr: [IF_CONS] :: Instr (a : ('TList a : s)) s' -> Instr s s' -> Instr ('TList a : s) s'

- Michelson.Typed.Instr: [IF_LEFT] :: Instr (a : s) s' -> Instr (b : s) s' -> Instr ('TOr a b : s) s'

- Michelson.Typed.Instr: [IF_NONE] :: Instr s s' -> Instr (a : s) s' -> Instr ('TOption a : s) s'

- Michelson.Typed.Instr: [IMPLICIT_ACCOUNT] :: Instr ('TKeyHash : s) ('TContract 'TUnit : s)

- Michelson.Typed.Instr: [INT] :: ToIntArithOp n => Instr (n : s) ('TInt : s)

- Michelson.Typed.Instr: [ISNAT] :: Instr ('TInt : s) ('TOption 'TNat : s)

- Michelson.Typed.Instr: [ITER] :: IterOp c => Instr (IterOpEl c : s) s -> Instr (c : s) s

- Michelson.Typed.Instr: [InstrWithNotes] :: forall a (topElems :: [T]) (s :: [T]). (RMap topElems, RecordToList topElems, ReifyConstraint Show Notes topElems, ReifyConstraint NFData Notes topElems, Each '[SingI] topElems) => Proxy s -> Rec Notes topElems -> Instr a (topElems ++ s) -> Instr a (topElems ++ s)

- Michelson.Typed.Instr: [InstrWithVarAnns] :: VarAnns -> Instr a b -> Instr a b

- Michelson.Typed.Instr: [InstrWithVarNotes] :: NonEmpty VarAnn -> Instr a b -> Instr a b

- Michelson.Typed.Instr: [JOIN_TICKETS] :: Instr ('TPair ('TTicket a) ('TTicket a) : s) ('TOption ('TTicket a) : s)

- Michelson.Typed.Instr: [KECCAK] :: Instr ('TBytes : s) ('TBytes : s)

- Michelson.Typed.Instr: [LAMBDA] :: forall i o s. (SingI i, SingI o) => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o : s)

- Michelson.Typed.Instr: [LEVEL] :: Instr s ('TNat : s)

- Michelson.Typed.Instr: [LE] :: UnaryArithOp Le n => Instr (n : s) (UnaryArithRes Le n : s)

- Michelson.Typed.Instr: [LOOP] :: Instr s ('TBool : s) -> Instr ('TBool : s) s

- Michelson.Typed.Instr: [LOOP_LEFT] :: Instr (a : s) ('TOr a b : s) -> Instr ('TOr a b : s) (b : s)

- Michelson.Typed.Instr: [LSL] :: ArithOp Lsl n m => Instr (n : (m : s)) (ArithRes Lsl n m : s)

- Michelson.Typed.Instr: [LSR] :: ArithOp Lsr n m => Instr (n : (m : s)) (ArithRes Lsr n m : s)

- Michelson.Typed.Instr: [LT] :: UnaryArithOp Lt n => Instr (n : s) (UnaryArithRes Lt n : s)

- Michelson.Typed.Instr: [MAP] :: (MapOp c, SingI b) => Instr (MapOpInp c : s) (b : s) -> Instr (c : s) (MapOpRes c b : s)

- Michelson.Typed.Instr: [MEM] :: MemOp c => Instr (MemOpKey c : (c : s)) ('TBool : s)

- Michelson.Typed.Instr: [MUL] :: ArithOp Mul n m => Instr (n : (m : s)) (ArithRes Mul n m : s)

- Michelson.Typed.Instr: [NEG] :: UnaryArithOp Neg n => Instr (n : s) (UnaryArithRes Neg n : s)

- Michelson.Typed.Instr: [NEQ] :: UnaryArithOp Neq n => Instr (n : s) (UnaryArithRes Neq n : s)

- Michelson.Typed.Instr: [NEVER] :: Instr ('TNever : s) t

- Michelson.Typed.Instr: [NIL] :: SingI p => Instr s ('TList p : s)

- Michelson.Typed.Instr: [NONE] :: forall a s. SingI a => Instr s ('TOption a : s)

- Michelson.Typed.Instr: [NOT] :: UnaryArithOp Not n => Instr (n : s) (UnaryArithRes Not n : s)

- Michelson.Typed.Instr: [NOW] :: Instr s ('TTimestamp : s)

- Michelson.Typed.Instr: [Nested] :: Instr inp out -> Instr inp out

- Michelson.Typed.Instr: [Nop] :: Instr s s

- Michelson.Typed.Instr: [OR] :: ArithOp Or n m => Instr (n : (m : s)) (ArithRes Or n m : s)

- Michelson.Typed.Instr: [PACK] :: PackedValScope a => Instr (a : s) ('TBytes : s)

- Michelson.Typed.Instr: [PAIRING_CHECK] :: Instr ('TList ('TPair 'TBls12381G1 'TBls12381G2) : s) ('TBool : s)

- Michelson.Typed.Instr: [PAIRN] :: forall n inp. ConstraintPairN n inp => PeanoNatural n -> Instr inp (PairN n inp)

- Michelson.Typed.Instr: [PUSH] :: forall t s. ConstantScope t => Value' Instr t -> Instr s (t : s)

- Michelson.Typed.Instr: [READ_TICKET] :: Instr ('TTicket a : s) (RightComb ['TAddress, a, 'TNat] : ('TTicket a : s))

- Michelson.Typed.Instr: [RENAME] :: Instr (a : s) (a : s)

- Michelson.Typed.Instr: [SELF] :: forall (arg :: T) s. ParameterScope arg => SomeEntrypointCallT arg -> Instr s ('TContract arg : s)

- Michelson.Typed.Instr: [SELF_ADDRESS] :: Instr s ('TAddress : s)

- Michelson.Typed.Instr: [SENDER] :: Instr s ('TAddress : s)

- Michelson.Typed.Instr: [SET_DELEGATE] :: Instr ('TOption 'TKeyHash : s) ('TOperation : s)

- Michelson.Typed.Instr: [SHA256] :: Instr ('TBytes : s) ('TBytes : s)

- Michelson.Typed.Instr: [SHA3] :: Instr ('TBytes : s) ('TBytes : s)

- Michelson.Typed.Instr: [SHA512] :: Instr ('TBytes : s) ('TBytes : s)

- Michelson.Typed.Instr: [SIZE] :: SizeOp c => Instr (c : s) ('TNat : s)

- Michelson.Typed.Instr: [SLICE] :: (SliceOp c, SingI c) => Instr ('TNat : ('TNat : (c : s))) ('TOption c : s)

- Michelson.Typed.Instr: [SOME] :: Instr (a : s) ('TOption a : s)

- Michelson.Typed.Instr: [SOURCE] :: Instr s ('TAddress : s)

- Michelson.Typed.Instr: [SPLIT_TICKET] :: Instr ('TTicket a : ('TPair 'TNat 'TNat : s)) ('TOption ('TPair ('TTicket a) ('TTicket a)) : s)

- Michelson.Typed.Instr: [SUB] :: ArithOp Sub n m => Instr (n : (m : s)) (ArithRes Sub n m : s)

- Michelson.Typed.Instr: [SWAP] :: Instr (a : (b : s)) (b : (a : s))

- Michelson.Typed.Instr: [Seq] :: Instr a b -> Instr b c -> Instr a c

- Michelson.Typed.Instr: [StackRef] :: RequireLongerThan st idx => PeanoNatural idx -> StackRef st

- Michelson.Typed.Instr: [TICKET] :: Comparable a => Instr (a : ('TNat : s)) ('TTicket a : s)

- Michelson.Typed.Instr: [TOTAL_VOTING_POWER] :: Instr s ('TNat : s)

- Michelson.Typed.Instr: [TRANSFER_TOKENS] :: ParameterScope p => Instr (p : ('TMutez : ('TContract p : s))) ('TOperation : s)

- Michelson.Typed.Instr: [TestAssert] :: SingI out => Text -> PrintComment inp -> Instr inp ('TBool : out) -> TestAssert inp

- Michelson.Typed.Instr: [UNIT] :: Instr s ('TUnit : s)

- Michelson.Typed.Instr: [UNPACK] :: (UnpackedValScope a, SingI a) => Instr ('TBytes : s) ('TOption a : s)

- Michelson.Typed.Instr: [UNPAIRN] :: forall (n :: Peano) (pair :: T) (s :: [T]). ConstraintUnpairN n pair => PeanoNatural n -> Instr (pair : s) (UnpairN n pair ++ s)

- Michelson.Typed.Instr: [UPDATEN] :: forall (ix :: Peano) (val :: T) (pair :: T) (s :: [T]). ConstraintUpdateN ix pair => PeanoNatural ix -> Instr (val : (pair : s)) (UpdateN ix val pair : s)

- Michelson.Typed.Instr: [UPDATE] :: UpdOp c => Instr (UpdOpKey c : (UpdOpParams c : (c : s))) (c : s)

- Michelson.Typed.Instr: [VOTING_POWER] :: Instr ('TKeyHash : s) ('TNat : s)

- Michelson.Typed.Instr: [WithLoc] :: InstrCallStack -> Instr a b -> Instr a b

- Michelson.Typed.Instr: [XOR] :: ArithOp Xor n m => Instr (n : (m : s)) (ArithRes Xor n m : s)

- Michelson.Typed.Instr: [cCode] :: Contract cp st -> ContractCode cp st

- Michelson.Typed.Instr: [cEntriesOrder] :: Contract cp st -> EntriesOrder

- Michelson.Typed.Instr: [cParamNotes] :: Contract cp st -> ParamNotes cp

- Michelson.Typed.Instr: [cStoreNotes] :: Contract cp st -> Notes st

- Michelson.Typed.Instr: [unPrintComment] :: PrintComment (st :: [T]) -> [Either Text (StackRef st)]

- Michelson.Typed.Instr: castInstr :: forall inp1 out1 inp2 out2. (SingI inp1, SingI out1, SingI inp2, SingI out2) => Instr inp1 out1 -> Maybe (Instr inp2 out2)

- Michelson.Typed.Instr: data CommentType

- Michelson.Typed.Instr: data Contract cp st

- Michelson.Typed.Instr: data ExtInstr s

- Michelson.Typed.Instr: data Instr (inp :: [T]) (out :: [T])

- Michelson.Typed.Instr: data StackRef (st :: [T])

- Michelson.Typed.Instr: data TestAssert (s :: [T])

- Michelson.Typed.Instr: defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode cp st -> Contract cp st

- Michelson.Typed.Instr: infixr 8 :#

- Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Michelson.Typed.Instr.Contract cp st)

- Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Michelson.Typed.Instr.ExtInstr s)

- Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Michelson.Typed.Instr.Instr inp out)

- Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Michelson.Typed.Instr.PrintComment st)

- Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Michelson.Typed.Instr.StackRef st)

- Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Michelson.Typed.Instr.TestAssert s)

- Michelson.Typed.Instr: instance Control.DeepSeq.NFData Michelson.Typed.Instr.CommentType

- Michelson.Typed.Instr: instance Data.String.IsString (Michelson.Typed.Instr.PrintComment st)

- Michelson.Typed.Instr: instance GHC.Base.Monoid (Michelson.Typed.Instr.Instr s s)

- Michelson.Typed.Instr: instance GHC.Base.Monoid (Michelson.Typed.Instr.PrintComment st)

- Michelson.Typed.Instr: instance GHC.Base.Semigroup (Michelson.Typed.Instr.Instr s s)

- Michelson.Typed.Instr: instance GHC.Base.Semigroup (Michelson.Typed.Instr.PrintComment st)

- Michelson.Typed.Instr: instance GHC.Classes.Eq (Michelson.Typed.Instr.ContractCode cp st) => GHC.Classes.Eq (Michelson.Typed.Instr.Contract cp st)

- Michelson.Typed.Instr: instance GHC.Classes.Eq (Michelson.Typed.Instr.PrintComment st)

- Michelson.Typed.Instr: instance GHC.Classes.Eq (Michelson.Typed.Instr.StackRef st)

- Michelson.Typed.Instr: instance GHC.Generics.Generic (Michelson.Typed.Instr.ExtInstr s)

- Michelson.Typed.Instr: instance GHC.Generics.Generic (Michelson.Typed.Instr.PrintComment st)

- Michelson.Typed.Instr: instance GHC.Generics.Generic Michelson.Typed.Instr.CommentType

- Michelson.Typed.Instr: instance GHC.Show.Show (Michelson.Typed.Instr.Contract cp st)

- Michelson.Typed.Instr: instance GHC.Show.Show (Michelson.Typed.Instr.ExtInstr s)

- Michelson.Typed.Instr: instance GHC.Show.Show (Michelson.Typed.Instr.Instr inp out)

- Michelson.Typed.Instr: instance GHC.Show.Show (Michelson.Typed.Instr.PrintComment st)

- Michelson.Typed.Instr: instance GHC.Show.Show (Michelson.Typed.Instr.StackRef st)

- Michelson.Typed.Instr: instance GHC.Show.Show (Michelson.Typed.Instr.TestAssert s)

- Michelson.Typed.Instr: instance GHC.Show.Show Michelson.Typed.Instr.CommentType

- Michelson.Typed.Instr: mapContractCode :: (ContractCode cp st -> ContractCode cp st) -> Contract cp st -> Contract cp st

- Michelson.Typed.Instr: mapEntriesOrdered :: Contract cp st -> (ParamNotes cp -> a) -> (Notes st -> a) -> (ContractCode cp st -> a) -> [a]

- Michelson.Typed.Instr: mkStackRef :: forall (gn :: Nat) st n. (n ~ ToPeano gn, SingI (ToPeano gn), RequireLongerThan st n) => StackRef st

- Michelson.Typed.Instr: newtype PrintComment (st :: [T])

- Michelson.Typed.Instr: pattern (:#) :: Instr a b -> Instr b c -> Instr a c

- Michelson.Typed.Instr: pattern UNPAIR :: () => (i ~ ('TPair a b : s), o ~ (a : (b : s))) => Instr i o

- Michelson.Typed.Instr: type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a

- Michelson.Typed.Instr: type ConstraintDIG' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) = (RequireLongerThan inp n, inp ~ (Take n inp ++ (a : Drop ('S n) inp)), out ~ (a : Take n inp ++ Drop ('S n) inp))

- Michelson.Typed.Instr: type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s'

- Michelson.Typed.Instr: type ConstraintDIPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (s :: [kind]) (s' :: [kind]) = (RequireLongerOrSameLength inp n, ((Take n inp) ++ s) ~ inp, ((Take n inp) ++ s') ~ out)

- Michelson.Typed.Instr: type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a

- Michelson.Typed.Instr: type ConstraintDUG' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) = (RequireLongerThan out n, inp ~ (a : Drop ('S 'Z) inp), out ~ (Take n (Drop ('S 'Z) inp) ++ (a : Drop ('S n) inp)))

- Michelson.Typed.Instr: type ConstraintDUPN n inp out a = ConstraintDUPN' T n inp out a

- Michelson.Typed.Instr: type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) = (RequireLongerOrSameLength inp n, n > 'Z ~ 'True, inp ~ (Take (Decrement n) inp ++ (a : Drop n inp)), out ~ (a : inp))

- Michelson.Typed.Instr: type ConstraintGetN (ix :: Peano) (pair :: T) = (TypeErrorUnless (CombedPairNodeIndexIsValid ix pair) (If (IsPair pair) ('Text "'GET " :<>: 'ShowType (FromPeano ix) :<>: 'Text "' expects a right-combed pair with at least " :<>: 'ShowType (FromPeano ix + 1) :<>: 'Text " nodes at the top of the stack," :$$: 'Text "but the pair only contains " :<>: 'ShowType (FromPeano (CombedPairNodeCount pair)) :<>: 'Text " nodes.") ('Text "Expected a pair at the top of the stack, but found: " :<>: 'ShowType pair)))

- Michelson.Typed.Instr: type ConstraintPairN (n :: Peano) (inp :: [T]) = (RequireLongerOrSameLength inp n, TypeErrorUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n \8805 2"))

- Michelson.Typed.Instr: type ConstraintUnpairN (n :: Peano) (pair :: T) = (TypeErrorUnless (n >= ToPeano 2) ('Text "'UNPAIR n' expects n \8805 2"), TypeErrorUnless (CombedPairLeafCountIsAtLeast n pair) (If (IsPair pair) ('Text "'UNPAIR " :<>: 'ShowType (FromPeano n) :<>: 'Text "' expects a right-combed pair with at least " :<>: 'ShowType (FromPeano n) :<>: 'Text " elements at the top of the stack," :$$: 'Text "but the pair only contains " :<>: 'ShowType (FromPeano (CombedPairLeafCount pair)) :<>: 'Text " elements.") ('Text "Expected a pair at the top of the stack, but found: " :<>: 'ShowType pair)))

- Michelson.Typed.Instr: type ConstraintUpdateN (ix :: Peano) (pair :: T) = (TypeErrorUnless (CombedPairNodeIndexIsValid ix pair) (If (IsPair pair) ('Text "'UPDATE " :<>: 'ShowType (FromPeano ix) :<>: 'Text "' expects the 2nd element of the stack to be a right-combed pair with at least " :<>: 'ShowType (FromPeano ix + 1) :<>: 'Text " nodes," :$$: 'Text "but the pair only contains " :<>: 'ShowType (FromPeano (CombedPairNodeCount pair)) :<>: 'Text " nodes.") ('Text "Expected the 2nd element of the stack to be a pair, but found: " :<>: 'ShowType pair)))

- Michelson.Typed.Instr: type ContractCode cp st = Instr (ContractInp cp st) (ContractOut st)

- Michelson.Typed.Instr: type PairN (n :: Peano) (s :: [T]) = (RightComb (Take n s) : Drop n s)

- Michelson.Typed.Instr: type family UpdateN (ix :: Peano) (val :: T) (pair :: T) :: T

- Michelson.Typed.OpSize: OpSize :: Word -> OpSize

- Michelson.Typed.OpSize: [unOpSize] :: OpSize -> Word

- Michelson.Typed.OpSize: contractOpSize :: Contract cp st -> OpSize

- Michelson.Typed.OpSize: instrOpSize :: Instr inp out -> OpSize

- Michelson.Typed.OpSize: newtype OpSize

- Michelson.Typed.OpSize: opSizeHardLimit :: OpSize

- Michelson.Typed.OpSize: smallTransferOpSize :: OpSize

- Michelson.Typed.OpSize: valueOpSize :: PrintedValScope t => Value t -> OpSize

- Michelson.Typed.Origination: OperationHash :: ByteString -> OperationHash

- Michelson.Typed.Origination: OriginationOperation :: Address -> Maybe KeyHash -> Mutez -> Value st -> Contract cp st -> OriginationOperation

- Michelson.Typed.Origination: [ooBalance] :: OriginationOperation -> Mutez

- Michelson.Typed.Origination: [ooContract] :: OriginationOperation -> Contract cp st

- Michelson.Typed.Origination: [ooDelegate] :: OriginationOperation -> Maybe KeyHash

- Michelson.Typed.Origination: [ooOriginator] :: OriginationOperation -> Address

- Michelson.Typed.Origination: [ooStorage] :: OriginationOperation -> Value st

- Michelson.Typed.Origination: [unOperationHash] :: OperationHash -> ByteString

- Michelson.Typed.Origination: data OriginationOperation

- Michelson.Typed.Origination: instance Control.DeepSeq.NFData Michelson.Typed.Origination.OperationHash

- Michelson.Typed.Origination: instance GHC.Classes.Eq Michelson.Typed.Origination.OperationHash

- Michelson.Typed.Origination: instance GHC.Classes.Ord Michelson.Typed.Origination.OperationHash

- Michelson.Typed.Origination: instance GHC.Generics.Generic Michelson.Typed.Origination.OperationHash

- Michelson.Typed.Origination: instance GHC.Show.Show Michelson.Typed.Origination.OperationHash

- Michelson.Typed.Origination: instance GHC.Show.Show Michelson.Typed.Origination.OriginationOperation

- Michelson.Typed.Origination: mkContractAddress :: OperationHash -> OriginationIndex -> GlobalCounter -> Address

- Michelson.Typed.Origination: mkOriginationOperationHash :: OriginationOperation -> OperationHash

- Michelson.Typed.Origination: newtype OperationHash

- Michelson.Typed.Polymorphic: class ConcatOp (c :: T)

- Michelson.Typed.Polymorphic: class EDivOp (n :: T) (m :: T) where {

- Michelson.Typed.Polymorphic: class GetOp (c :: T) where {

- Michelson.Typed.Polymorphic: class IterOp (c :: T) where {

- Michelson.Typed.Polymorphic: class MapOp (c :: T) where {

- Michelson.Typed.Polymorphic: class MemOp (c :: T) where {

- Michelson.Typed.Polymorphic: class SizeOp (c :: T)

- Michelson.Typed.Polymorphic: class SliceOp (c :: T)

- Michelson.Typed.Polymorphic: class UpdOp (c :: T) where {

- Michelson.Typed.Polymorphic: convergeEDiv :: EDivOp n m => Notes n -> Notes m -> Either AnnConvergeError (Notes ('TOption ('TPair (EDivOpRes n m) (EModOpRes n m))))

- Michelson.Typed.Polymorphic: divMich :: Integral a => a -> a -> a

- Michelson.Typed.Polymorphic: evalConcat :: ConcatOp c => Value' instr c -> Value' instr c -> Value' instr c

- Michelson.Typed.Polymorphic: evalConcat' :: ConcatOp c => [Value' instr c] -> Value' instr c

- Michelson.Typed.Polymorphic: evalEDivOp :: EDivOp n m => Value' instr n -> Value' instr m -> Value' instr ('TOption ('TPair (EDivOpRes n m) (EModOpRes n m)))

- Michelson.Typed.Polymorphic: evalGet :: GetOp c => Value' instr (GetOpKey c) -> Value' instr c -> Maybe (Value' instr (GetOpVal c))

- Michelson.Typed.Polymorphic: evalMem :: MemOp c => Value' instr (MemOpKey c) -> Value' instr c -> Bool

- Michelson.Typed.Polymorphic: evalSize :: SizeOp c => Value' instr c -> Int

- Michelson.Typed.Polymorphic: evalSlice :: SliceOp c => Natural -> Natural -> Value' instr c -> Maybe (Value' instr c)

- Michelson.Typed.Polymorphic: evalUpd :: UpdOp c => Value' instr (UpdOpKey c) -> Value' instr (UpdOpParams c) -> Value' instr c -> Value' instr c

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.ConcatOp 'Michelson.Typed.T.TBytes

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.ConcatOp 'Michelson.Typed.T.TString

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.EDivOp 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TInt

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.EDivOp 'Michelson.Typed.T.TInt 'Michelson.Typed.T.TNat

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.EDivOp 'Michelson.Typed.T.TMutez 'Michelson.Typed.T.TMutez

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.EDivOp 'Michelson.Typed.T.TMutez 'Michelson.Typed.T.TNat

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.EDivOp 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TInt

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.EDivOp 'Michelson.Typed.T.TNat 'Michelson.Typed.T.TNat

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.GetOp ('Michelson.Typed.T.TBigMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.GetOp ('Michelson.Typed.T.TMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.IterOp ('Michelson.Typed.T.TList e)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.IterOp ('Michelson.Typed.T.TMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.IterOp ('Michelson.Typed.T.TSet e)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.MapOp ('Michelson.Typed.T.TList e)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.MapOp ('Michelson.Typed.T.TMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.MemOp ('Michelson.Typed.T.TBigMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.MemOp ('Michelson.Typed.T.TMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.MemOp ('Michelson.Typed.T.TSet e)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.SizeOp 'Michelson.Typed.T.TBytes

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.SizeOp 'Michelson.Typed.T.TString

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.SizeOp ('Michelson.Typed.T.TList a)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.SizeOp ('Michelson.Typed.T.TMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.SizeOp ('Michelson.Typed.T.TSet a)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.SliceOp 'Michelson.Typed.T.TBytes

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.SliceOp 'Michelson.Typed.T.TString

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.UpdOp ('Michelson.Typed.T.TBigMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.UpdOp ('Michelson.Typed.T.TMap k v)

- Michelson.Typed.Polymorphic: instance Michelson.Typed.Polymorphic.UpdOp ('Michelson.Typed.T.TSet a)

- Michelson.Typed.Polymorphic: iterOpDetachOne :: IterOp c => Value' instr c -> (Maybe (Value' instr (IterOpEl c)), Value' instr c)

- Michelson.Typed.Polymorphic: iterOpNotes :: IterOp c => Notes c -> Notes (IterOpEl c)

- Michelson.Typed.Polymorphic: mapOpFromList :: (MapOp c, SingI b) => Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b)

- Michelson.Typed.Polymorphic: mapOpNotes :: MapOp c => Notes c -> Notes (MapOpInp c)

- Michelson.Typed.Polymorphic: mapOpToList :: MapOp c => Value' instr c -> [Value' instr (MapOpInp c)]

- Michelson.Typed.Polymorphic: modMich :: Integral a => a -> a -> a

- Michelson.Typed.Polymorphic: type family UpdOpParams c :: T;

- Michelson.Typed.Polymorphic: }

- Michelson.Typed.Scope: BigMapAbsent :: BigMapPresence (t :: T)

- Michelson.Typed.Scope: BigMapPresent :: BigMapPresence (t :: T)

- Michelson.Typed.Scope: BtHasBigMap :: BadTypeForScope

- Michelson.Typed.Scope: BtHasContract :: BadTypeForScope

- Michelson.Typed.Scope: BtHasNestedBigMap :: BadTypeForScope

- Michelson.Typed.Scope: BtHasTicket :: BadTypeForScope

- Michelson.Typed.Scope: BtIsOperation :: BadTypeForScope

- Michelson.Typed.Scope: BtNotComparable :: BadTypeForScope

- Michelson.Typed.Scope: ContractAbsent :: ContractPresence (t :: T)

- Michelson.Typed.Scope: ContractPresent :: ContractPresence (t :: T)

- Michelson.Typed.Scope: NestedBigMapsAbsent :: NestedBigMapsPresence (t :: T)

- Michelson.Typed.Scope: NestedBigMapsPresent :: NestedBigMapsPresence (t :: T)

- Michelson.Typed.Scope: OpAbsent :: OpPresence (t :: T)

- Michelson.Typed.Scope: OpPresent :: OpPresence (t :: T)

- Michelson.Typed.Scope: Sub :: (a => Dict b) -> (:-) a b

- Michelson.Typed.Scope: TicketAbsent :: TicketPresence (t :: T)

- Michelson.Typed.Scope: TicketPresent :: TicketPresence (t :: T)

- Michelson.Typed.Scope: bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t)

- Michelson.Typed.Scope: checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty

- Michelson.Typed.Scope: checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty

- Michelson.Typed.Scope: checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty

- Michelson.Typed.Scope: checkOpPresence :: Sing (ty :: T) -> OpPresence ty

- Michelson.Typed.Scope: checkScope :: CheckScope c => Either BadTypeForScope (Dict c)

- Michelson.Typed.Scope: checkTicketPresence :: Sing (ty :: T) -> TicketPresence ty

- Michelson.Typed.Scope: class CheckScope (c :: Constraint)

- Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t

- Michelson.Typed.Scope: class (SingI t, HasNoTicket t) => DupableScope t

- Michelson.Typed.Scope: class (ContainsBigMap t ~ 'False) => HasNoBigMap t

- Michelson.Typed.Scope: class (ContainsContract t ~ 'False) => HasNoContract t

- Michelson.Typed.Scope: class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t

- Michelson.Typed.Scope: class (ContainsOp t ~ 'False) => HasNoOp t

- Michelson.Typed.Scope: class (ContainsTicket t ~ 'False) => HasNoTicket t

- Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t

- Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t

- Michelson.Typed.Scope: class SingI (a :: k)

- Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t

- Michelson.Typed.Scope: class (PackedValScope t, ConstantScope t) => UnpackedValScope t

- Michelson.Typed.Scope: class WithDeMorganScope (c :: T -> Constraint) t a b

- Michelson.Typed.Scope: contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoContract t)

- Michelson.Typed.Scope: data BadTypeForScope

- Michelson.Typed.Scope: data BigMapPresence (t :: T)

- Michelson.Typed.Scope: data ContractPresence (t :: T)

- Michelson.Typed.Scope: data NestedBigMapsPresence (t :: T)

- Michelson.Typed.Scope: data OpPresence (t :: T)

- Michelson.Typed.Scope: data TicketPresence (t :: T)

- Michelson.Typed.Scope: forbiddenBigMap :: forall t a. (SingI t, ForbidBigMap t) => (HasNoBigMap t => a) -> a

- Michelson.Typed.Scope: forbiddenContractType :: forall t a. (SingI t, ForbidContract t) => (HasNoContract t => a) -> a

- Michelson.Typed.Scope: forbiddenNestedBigMaps :: forall t a. (SingI t, ForbidNestedBigMaps t) => (HasNoNestedBigMaps t => a) -> a

- Michelson.Typed.Scope: forbiddenOp :: forall t a. (SingI t, ForbidOp t) => (HasNoOp t => a) -> a

- Michelson.Typed.Scope: infixr 9 :-

- Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Michelson.Typed.Scope.HasNoOp t, Michelson.Typed.Scope.HasNoBigMap t, Michelson.Typed.Scope.HasNoContract t, Michelson.Typed.Scope.HasNoTicket t) => Michelson.Typed.Scope.ConstantScope t

- Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Michelson.Typed.Scope.HasNoOp t, Michelson.Typed.Scope.HasNoBigMap t, Michelson.Typed.Scope.HasNoTicket t) => Michelson.Typed.Scope.PackedValScope t

- Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Michelson.Typed.Scope.HasNoOp t, Michelson.Typed.Scope.HasNoNestedBigMaps t) => Michelson.Typed.Scope.ParameterScope t

- Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Michelson.Typed.Scope.HasNoOp t, Michelson.Typed.Scope.HasNoNestedBigMaps t, Michelson.Typed.Scope.HasNoContract t) => Michelson.Typed.Scope.StorageScope t

- Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Michelson.Typed.Scope.HasNoTicket t) => Michelson.Typed.Scope.DupableScope t

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.ContainsBigMap t GHC.Types.~ 'GHC.Types.False) => Michelson.Typed.Scope.HasNoBigMap t

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.ContainsContract t GHC.Types.~ 'GHC.Types.False) => Michelson.Typed.Scope.HasNoContract t

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.ContainsNestedBigMaps t GHC.Types.~ 'GHC.Types.False) => Michelson.Typed.Scope.HasNoNestedBigMaps t

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.ContainsOp t GHC.Types.~ 'GHC.Types.False) => Michelson.Typed.Scope.HasNoOp t

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.ContainsTicket t GHC.Types.~ 'GHC.Types.False) => Michelson.Typed.Scope.HasNoTicket t

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.PackedValScope t, Michelson.Typed.Scope.ConstantScope t) => Michelson.Typed.Scope.UnpackedValScope t

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoBigMap t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoContract t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoTicket t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.ConstantScope t a b

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoBigMap t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoTicket t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.PackedValScope t a b

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoNestedBigMaps t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.ParameterScope t a b

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoNestedBigMaps t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoContract t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.StorageScope t a b

- Michelson.Typed.Scope: instance (Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.PackedValScope t a b, Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.ConstantScope t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.UnpackedValScope t a b

- Michelson.Typed.Scope: instance Control.DeepSeq.NFData Michelson.Typed.Scope.BadTypeForScope

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoBigMap 'Michelson.Typed.T.TOr a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoBigMap 'Michelson.Typed.T.TPair a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoContract 'Michelson.Typed.T.TOr a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoContract 'Michelson.Typed.T.TPair a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoNestedBigMaps 'Michelson.Typed.T.TOr a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoNestedBigMaps 'Michelson.Typed.T.TPair a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp 'Michelson.Typed.T.TOr a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp 'Michelson.Typed.T.TPair a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoTicket 'Michelson.Typed.T.TOr a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoTicket 'Michelson.Typed.T.TPair a b

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI k => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp 'Michelson.Typed.T.TBigMap k v

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI k => Michelson.Typed.Scope.WithDeMorganScope Michelson.Typed.Scope.HasNoOp 'Michelson.Typed.T.TMap k v

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.ConstantScope t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.DupableScope t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.HasNoBigMap t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.HasNoContract t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.HasNoNestedBigMaps t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.HasNoOp t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.HasNoTicket t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.PackedValScope t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.ParameterScope t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.StorageScope t)

- Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Scope.UnpackedValScope t)

- Michelson.Typed.Scope: instance Formatting.Buildable.Buildable Michelson.Typed.Scope.BadTypeForScope

- Michelson.Typed.Scope: instance GHC.Classes.Eq Michelson.Typed.Scope.BadTypeForScope

- Michelson.Typed.Scope: instance GHC.Generics.Generic Michelson.Typed.Scope.BadTypeForScope

- Michelson.Typed.Scope: instance GHC.Show.Show Michelson.Typed.Scope.BadTypeForScope

- Michelson.Typed.Scope: instance Michelson.Printer.Util.RenderDoc Michelson.Typed.Scope.BadTypeForScope

- Michelson.Typed.Scope: nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoNestedBigMaps t)

- Michelson.Typed.Scope: newtype a :- b

- Michelson.Typed.Scope: opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)

- Michelson.Typed.Scope: properConstantEvi :: forall t. ProperConstantBetterErrors t :- ConstantScope t

- Michelson.Typed.Scope: properDupableEvi :: forall t. ProperDupableBetterErrors t :- DupableScope t

- Michelson.Typed.Scope: properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t

- Michelson.Typed.Scope: properParameterEvi :: forall t. ProperParameterBetterErrors t :- ParameterScope t

- Michelson.Typed.Scope: properPrintedValEvi :: forall t. ProperPrintedValBetterErrors t :- PrintedValScope t

- Michelson.Typed.Scope: properStorageEvi :: forall t. ProperStorageBetterErrors t :- StorageScope t

- Michelson.Typed.Scope: properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t

- Michelson.Typed.Scope: sing :: SingI a => Sing a

- Michelson.Typed.Scope: type ForbidBigMap t = FailOnBigMapFound (ContainsBigMap t)

- Michelson.Typed.Scope: type ForbidContract t = FailOnContractFound (ContainsContract t)

- Michelson.Typed.Scope: type ForbidNestedBigMaps t = FailOnNestedBigMapsFound (ContainsNestedBigMaps t)

- Michelson.Typed.Scope: type ForbidOp t = FailOnOperationFound (ContainsOp t)

- Michelson.Typed.Scope: type ForbidTicket t = FailOnTicketFound (ContainsTicket t)

- Michelson.Typed.Scope: type PrintedValScope t = (SingI t, HasNoOp t)

- Michelson.Typed.Scope: type ProperConstantBetterErrors t = (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t, ForbidTicket t)

- Michelson.Typed.Scope: type ProperDupableBetterErrors t = (SingI t, ForbidTicket t)

- Michelson.Typed.Scope: type ProperPackedValBetterErrors t = (SingI t, ForbidOp t, ForbidBigMap t, ForbidTicket t)

- Michelson.Typed.Scope: type ProperParameterBetterErrors t = (SingI t, ForbidOp t, ForbidNestedBigMaps t)

- Michelson.Typed.Scope: type ProperPrintedValBetterErrors t = (SingI t, ForbidOp t)

- Michelson.Typed.Scope: type ProperStorageBetterErrors t = (SingI t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)

- Michelson.Typed.Scope: type ProperUnpackedValBetterErrors t = (ProperPackedValBetterErrors t, ProperConstantBetterErrors t)

- Michelson.Typed.Scope: type family FailOnOperationFound (enabled :: Bool) :: Constraint

- Michelson.Typed.Scope: withDeMorganScope :: (WithDeMorganScope c t a b, c (t a b)) => ((c a, c b) => ret) -> ret

- Michelson.Typed.Scope: withDict :: HasDict c e => e -> (c => r) -> r

- Michelson.Typed.Sing: [STAddress] :: SingT ('TAddress :: T)

- Michelson.Typed.Sing: [STBigMap] :: forall (n_a1F1J :: T) (n_a1F1K :: T). () => Sing n_a1F1J -> Sing n_a1F1K -> SingT ('TBigMap n_a1F1J n_a1F1K :: T)

- Michelson.Typed.Sing: [STBls12381Fr] :: SingT ('TBls12381Fr :: T)

- Michelson.Typed.Sing: [STBls12381G1] :: SingT ('TBls12381G1 :: T)

- Michelson.Typed.Sing: [STBls12381G2] :: SingT ('TBls12381G2 :: T)

- Michelson.Typed.Sing: [STBool] :: SingT ('TBool :: T)

- Michelson.Typed.Sing: [STBytes] :: SingT ('TBytes :: T)

- Michelson.Typed.Sing: [STChainId] :: SingT ('TChainId :: T)

- Michelson.Typed.Sing: [STContract] :: forall (n_a1F1p :: T). () => Sing n_a1F1p -> SingT ('TContract n_a1F1p :: T)

- Michelson.Typed.Sing: [STInt] :: SingT ('TInt :: T)

- Michelson.Typed.Sing: [STKeyHash] :: SingT ('TKeyHash :: T)

- Michelson.Typed.Sing: [STKey] :: SingT ('TKey :: T)

- Michelson.Typed.Sing: [STLambda] :: forall (n_a1F1B :: T) (n_a1F1C :: T). () => Sing n_a1F1B -> Sing n_a1F1C -> SingT ('TLambda n_a1F1B n_a1F1C :: T)

- Michelson.Typed.Sing: [STList] :: forall (n_a1F1l :: T). () => Sing n_a1F1l -> SingT ('TList n_a1F1l :: T)

- Michelson.Typed.Sing: [STMap] :: forall (n_a1F1F :: T) (n_a1F1G :: T). () => Sing n_a1F1F -> Sing n_a1F1G -> SingT ('TMap n_a1F1F n_a1F1G :: T)

- Michelson.Typed.Sing: [STMutez] :: SingT ('TMutez :: T)

- Michelson.Typed.Sing: [STNat] :: SingT ('TNat :: T)

- Michelson.Typed.Sing: [STNever] :: SingT ('TNever :: T)

- Michelson.Typed.Sing: [STOperation] :: SingT ('TOperation :: T)

- Michelson.Typed.Sing: [STOption] :: forall (n_a1F1j :: T). () => Sing n_a1F1j -> SingT ('TOption n_a1F1j :: T)

- Michelson.Typed.Sing: [STOr] :: forall (n_a1F1x :: T) (n_a1F1y :: T). () => Sing n_a1F1x -> Sing n_a1F1y -> SingT ('TOr n_a1F1x n_a1F1y :: T)

- Michelson.Typed.Sing: [STPair] :: forall (n_a1F1t :: T) (n_a1F1u :: T). () => Sing n_a1F1t -> Sing n_a1F1u -> SingT ('TPair n_a1F1t n_a1F1u :: T)

- Michelson.Typed.Sing: [STSet] :: forall (n_a1F1n :: T). () => Sing n_a1F1n -> SingT ('TSet n_a1F1n :: T)

- Michelson.Typed.Sing: [STSignature] :: SingT ('TSignature :: T)

- Michelson.Typed.Sing: [STString] :: SingT ('TString :: T)

- Michelson.Typed.Sing: [STTicket] :: forall (n_a1F1r :: T). () => Sing n_a1F1r -> SingT ('TTicket n_a1F1r :: T)

- Michelson.Typed.Sing: [STTimestamp] :: SingT ('TTimestamp :: T)

- Michelson.Typed.Sing: [STUnit] :: SingT ('TUnit :: T)

- Michelson.Typed.Sing: castM :: forall (a :: T) (b :: T) t m. (SingI a, SingI b, Monad m) => t a -> (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x) -> m (t b)

- Michelson.Typed.Sing: castSingE :: forall (a :: T) (b :: T) t. (SingI a, SingI b) => t a -> Either Text (t b)

- Michelson.Typed.Sing: data SingT z_a1F2y

- Michelson.Typed.Sing: eqP :: forall (a :: T) (b :: T). (SingI a, SingI b) => Proxy a -> Proxy b -> Maybe (a :~: b)

- Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TBigMap n1 n2)

- Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TLambda n1 n2)

- Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TMap n1 n2)

- Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TOr n1 n2)

- Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TPair n1 n2)

- Michelson.Typed.Sing: instance Data.Singletons.Decide.SDecide Michelson.Typed.T.T => Data.Singletons.Decide.SDecide Michelson.Typed.T.T

- Michelson.Typed.Sing: instance Data.Singletons.Decide.SDecide Michelson.Typed.T.T => Data.Type.Coercion.TestCoercion Michelson.Typed.Sing.SingT

- Michelson.Typed.Sing: instance Data.Singletons.Decide.SDecide Michelson.Typed.T.T => Data.Type.Equality.TestEquality Michelson.Typed.Sing.SingT

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TAddress

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TBls12381Fr

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TBls12381G1

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TBls12381G2

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TBool

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TBytes

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TChainId

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TInt

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TKey

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TKeyHash

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TMutez

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TNat

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TNever

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TOperation

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TSignature

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TString

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TTimestamp

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Michelson.Typed.T.TUnit

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TBigMapSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TContractSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TLambdaSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TListSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TMapSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TOptionSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TOrSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TPairSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TSetSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Michelson.Typed.Sing.TTicketSym0

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Michelson.Typed.Sing.TBigMapSym1 d)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Michelson.Typed.Sing.TLambdaSym1 d)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Michelson.Typed.Sing.TMapSym1 d)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Michelson.Typed.Sing.TOrSym1 d)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Michelson.Typed.Sing.TPairSym1 d)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI k => Util.Sing.SingI1 ('Michelson.Typed.T.TMap k)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TContract n)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TList n)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TOption n)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TSet n)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Michelson.Typed.T.TTicket n)

- Michelson.Typed.Sing: instance Data.Singletons.Internal.SingKind Michelson.Typed.T.T

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Michelson.Typed.Sing.TBigMapSym1 a6989586621679405790)

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Michelson.Typed.Sing.TLambdaSym1 a6989586621679405784)

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Michelson.Typed.Sing.TMapSym1 a6989586621679405787)

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Michelson.Typed.Sing.TOrSym1 a6989586621679405781)

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Michelson.Typed.Sing.TPairSym1 a6989586621679405778)

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TBigMapSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TContractSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TLambdaSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TListSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TMapSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TOptionSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TOrSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TPairSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TSetSym0

- Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Michelson.Typed.Sing.TTicketSym0

- Michelson.Typed.Sing: instance Util.Sing.SingI1 'Michelson.Typed.T.TList

- Michelson.Typed.Sing: requireEq :: forall (a :: T) (b :: T) m. (SingI a, SingI b, Monad m) => (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x) -> m (a :~: b)

- Michelson.Typed.T: TAddress :: T

- Michelson.Typed.T: TBigMap :: T -> T -> T

- Michelson.Typed.T: TBls12381Fr :: T

- Michelson.Typed.T: TBls12381G1 :: T

- Michelson.Typed.T: TBls12381G2 :: T

- Michelson.Typed.T: TBool :: T

- Michelson.Typed.T: TBytes :: T

- Michelson.Typed.T: TChainId :: T

- Michelson.Typed.T: TContract :: T -> T

- Michelson.Typed.T: TInt :: T

- Michelson.Typed.T: TKey :: T

- Michelson.Typed.T: TKeyHash :: T

- Michelson.Typed.T: TLambda :: T -> T -> T

- Michelson.Typed.T: TList :: T -> T

- Michelson.Typed.T: TMap :: T -> T -> T

- Michelson.Typed.T: TMutez :: T

- Michelson.Typed.T: TNat :: T

- Michelson.Typed.T: TNever :: T

- Michelson.Typed.T: TOperation :: T

- Michelson.Typed.T: TOption :: T -> T

- Michelson.Typed.T: TOr :: T -> T -> T

- Michelson.Typed.T: TPair :: T -> T -> T

- Michelson.Typed.T: TSet :: T -> T

- Michelson.Typed.T: TSignature :: T

- Michelson.Typed.T: TString :: T

- Michelson.Typed.T: TTicket :: T -> T

- Michelson.Typed.T: TTimestamp :: T

- Michelson.Typed.T: TUnit :: T

- Michelson.Typed.T: buildStack :: [T] -> Builder

- Michelson.Typed.T: data T

- Michelson.Typed.T: instance Control.DeepSeq.NFData Michelson.Typed.T.T

- Michelson.Typed.T: instance Formatting.Buildable.Buildable Michelson.Typed.T.T

- Michelson.Typed.T: instance GHC.Classes.Eq Michelson.Typed.T.T

- Michelson.Typed.T: instance GHC.Generics.Generic Michelson.Typed.T.T

- Michelson.Typed.T: instance GHC.Show.Show Michelson.Typed.T.T

- Michelson.Typed.T: instance Michelson.Printer.Util.RenderDoc Michelson.Typed.T.T

- Michelson.Typed.T: toUType :: T -> Ty

- Michelson.Typed.TypeLevel: type family CombedPairNodeIndexIsValid (nodeIndex :: Peano) (pair :: T) :: Bool

- Michelson.Typed.Util: CtorEffectsApp :: Text -> (forall i o. Semigroup x => x -> x -> Instr i o -> (Instr i o, x)) -> CtorEffectsApp x

- Michelson.Typed.Util: DfsSettings :: Bool -> CtorEffectsApp x -> DfsSettings x

- Michelson.Typed.Util: [ConstantStorage] :: ConstantScope st => Value st -> PushableStorageSplit s st

- Michelson.Typed.Util: [PartlyPushableStorage] :: (StorageScope heavy, StorageScope st) => Value heavy -> Instr (heavy : s) (st : s) -> PushableStorageSplit s st

- Michelson.Typed.Util: [PushableValueStorage] :: StorageScope st => Instr s (st : s) -> PushableStorageSplit s st

- Michelson.Typed.Util: [ceaApplyEffects] :: CtorEffectsApp x -> forall i o. Semigroup x => x -> x -> Instr i o -> (Instr i o, x)

- Michelson.Typed.Util: [ceaName] :: CtorEffectsApp x -> Text

- Michelson.Typed.Util: [dsCtorEffectsApp] :: DfsSettings x -> CtorEffectsApp x

- Michelson.Typed.Util: [dsGoToValues] :: DfsSettings x -> Bool

- Michelson.Typed.Util: allAtomicValues :: forall t a. (forall t'. Value t' -> Maybe a) -> Value t -> [a]

- Michelson.Typed.Util: ceaBottomToTop :: CtorEffectsApp x

- Michelson.Typed.Util: data CtorEffectsApp x

- Michelson.Typed.Util: data DfsSettings x

- Michelson.Typed.Util: data PushableStorageSplit s st

- Michelson.Typed.Util: dfsFoldInstr :: forall x inp out. Semigroup x => DfsSettings x -> (forall i o. Instr i o -> x) -> Instr inp out -> x

- Michelson.Typed.Util: dfsFoldMapValue :: Monoid x => (forall t'. Value t' -> x) -> Value t -> x

- Michelson.Typed.Util: dfsFoldMapValueM :: (Monoid x, Monad m) => (forall t'. Value t' -> m x) -> Value t -> m x

- Michelson.Typed.Util: dfsInstr :: forall x inp out. Semigroup x => DfsSettings x -> (forall i o. Instr i o -> (Instr i o, x)) -> Instr inp out -> (Instr inp out, x)

- Michelson.Typed.Util: dfsMapValue :: forall t. (forall t'. Value t' -> Value t') -> Value t -> Value t

- Michelson.Typed.Util: dfsModifyInstr :: DfsSettings () -> (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr inp out

- Michelson.Typed.Util: dfsTraverseValue :: forall t m. Monad m => (forall t'. Value t' -> m (Value t')) -> Value t -> m (Value t)

- Michelson.Typed.Util: instance Data.Default.Class.Default (Michelson.Typed.Util.DfsSettings x)

- Michelson.Typed.Util: instance GHC.Show.Show (Michelson.Typed.Util.CtorEffectsApp x)

- Michelson.Typed.Util: instance GHC.Show.Show (Michelson.Typed.Util.DfsSettings x)

- Michelson.Typed.Util: isBytesValue :: Value t -> Maybe ByteString

- Michelson.Typed.Util: isStringValue :: Value t -> Maybe MText

- Michelson.Typed.Util: linearizeLeft :: Instr inp out -> Instr inp out

- Michelson.Typed.Util: linearizeLeftDeep :: Instr inp out -> Instr inp out

- Michelson.Typed.Util: splitPushableStorage :: StorageScope t => Value t -> PushableStorageSplit s t

- Michelson.Typed.Value: CreateContract :: Address -> Maybe KeyHash -> Mutez -> Value' instr st -> instr (ContractInp cp st) (ContractOut st) -> CreateContract instr cp st

- Michelson.Typed.Value: SetDelegate :: Maybe KeyHash -> SetDelegate

- Michelson.Typed.Value: TransferTokens :: Value' instr p -> Mutez -> Value' instr ('TContract p) -> TransferTokens instr p

- Michelson.Typed.Value: [CanBeCompared] :: Comparable t => Comparability t

- Michelson.Typed.Value: [CannotBeCompared] :: IsComparable t ~ 'False => Comparability t

- Michelson.Typed.Value: [OpCreateContract] :: (Show (instr (ContractInp cp st) (ContractOut st)), NFData (instr (ContractInp cp st) (ContractOut st)), Typeable instr, ParameterScope cp, StorageScope st) => CreateContract instr cp st -> Operation' instr

- Michelson.Typed.Value: [OpSetDelegate] :: SetDelegate -> Operation' instr

- Michelson.Typed.Value: [OpTransferTokens] :: ParameterScope p => TransferTokens instr p -> Operation' instr

- Michelson.Typed.Value: [RfAlwaysFails] :: (forall o'. instr i o') -> RemFail instr i o

- Michelson.Typed.Value: [RfNormal] :: instr i o -> RemFail instr i o

- Michelson.Typed.Value: [VAddress] :: EpAddress -> Value' instr 'TAddress

- Michelson.Typed.Value: [VBigMap] :: forall k v instr. (SingI k, SingI v, Comparable k, HasNoBigMap v) => Maybe Natural -> Map (Value' instr k) (Value' instr v) -> Value' instr ('TBigMap k v)

- Michelson.Typed.Value: [VBls12381Fr] :: Bls12381Fr -> Value' instr 'TBls12381Fr

- Michelson.Typed.Value: [VBls12381G1] :: Bls12381G1 -> Value' instr 'TBls12381G1

- Michelson.Typed.Value: [VBls12381G2] :: Bls12381G2 -> Value' instr 'TBls12381G2

- Michelson.Typed.Value: [VBool] :: Bool -> Value' instr 'TBool

- Michelson.Typed.Value: [VBytes] :: ByteString -> Value' instr 'TBytes

- Michelson.Typed.Value: [VChainId] :: ChainId -> Value' instr 'TChainId

- Michelson.Typed.Value: [VContract] :: forall arg instr. (SingI arg, HasNoOp arg) => Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)

- Michelson.Typed.Value: [VInt] :: Integer -> Value' instr 'TInt

- Michelson.Typed.Value: [VKeyHash] :: KeyHash -> Value' instr 'TKeyHash

- Michelson.Typed.Value: [VKey] :: PublicKey -> Value' instr 'TKey

- Michelson.Typed.Value: [VLam] :: forall inp out instr. (SingI inp, SingI out, forall i o. Show (instr i o), forall i o. Eq (instr i o), forall i o. NFData (instr i o)) => RemFail instr (inp : '[]) (out : '[]) -> Value' instr ('TLambda inp out)

- Michelson.Typed.Value: [VList] :: forall t instr. SingI t => [Value' instr t] -> Value' instr ('TList t)

- Michelson.Typed.Value: [VMap] :: forall k v instr. (SingI k, SingI v, Comparable k) => Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v)

- Michelson.Typed.Value: [VMutez] :: Mutez -> Value' instr 'TMutez

- Michelson.Typed.Value: [VNat] :: Natural -> Value' instr 'TNat

- Michelson.Typed.Value: [VOp] :: Operation' instr -> Value' instr 'TOperation

- Michelson.Typed.Value: [VOption] :: forall t instr. SingI t => Maybe (Value' instr t) -> Value' instr ('TOption t)

- Michelson.Typed.Value: [VOr] :: forall l r instr. (SingI l, SingI r) => Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)

- Michelson.Typed.Value: [VPair] :: forall l r instr. (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)

- Michelson.Typed.Value: [VSet] :: forall t instr. (SingI t, Comparable t) => Set (Value' instr t) -> Value' instr ('TSet t)

- Michelson.Typed.Value: [VSignature] :: Signature -> Value' instr 'TSignature

- Michelson.Typed.Value: [VString] :: MText -> Value' instr 'TString

- Michelson.Typed.Value: [VTicket] :: forall arg instr. Comparable arg => Address -> Value' instr arg -> Natural -> Value' instr ('TTicket arg)

- Michelson.Typed.Value: [VTimestamp] :: Timestamp -> Value' instr 'TTimestamp

- Michelson.Typed.Value: [VUnit] :: Value' instr 'TUnit

- Michelson.Typed.Value: [ccBalance] :: CreateContract instr cp st -> Mutez

- Michelson.Typed.Value: [ccContractCode] :: CreateContract instr cp st -> instr (ContractInp cp st) (ContractOut st)

- Michelson.Typed.Value: [ccDelegate] :: CreateContract instr cp st -> Maybe KeyHash

- Michelson.Typed.Value: [ccOriginator] :: CreateContract instr cp st -> Address

- Michelson.Typed.Value: [ccStorageVal] :: CreateContract instr cp st -> Value' instr st

- Michelson.Typed.Value: [sdMbKeyHash] :: SetDelegate -> Maybe KeyHash

- Michelson.Typed.Value: [ttAmount] :: TransferTokens instr p -> Mutez

- Michelson.Typed.Value: [ttContract] :: TransferTokens instr p -> Value' instr ('TContract p)

- Michelson.Typed.Value: [ttTransferArgument] :: TransferTokens instr p -> Value' instr p

- Michelson.Typed.Value: addressToVContract :: forall t instr. (ParameterScope t, ForbidOr t) => Address -> Value' instr ('TContract t)

- Michelson.Typed.Value: buildVContract :: Value' instr ('TContract arg) -> Builder

- Michelson.Typed.Value: checkComparability :: Sing t -> Comparability t

- Michelson.Typed.Value: class (IsComparable t ~ 'True) => Comparable t

- Michelson.Typed.Value: comparabilityPresence :: Sing t -> Maybe (Dict $ Comparable t)

- Michelson.Typed.Value: compileEpLiftSequence :: EpLiftSequence arg param -> Value' instr arg -> Value' instr param

- Michelson.Typed.Value: data Comparability t

- Michelson.Typed.Value: data CreateContract instr cp st

- Michelson.Typed.Value: data Operation' instr

- Michelson.Typed.Value: data RemFail (instr :: k -> k -> Type) (i :: k) (o :: k)

- Michelson.Typed.Value: data SetDelegate

- Michelson.Typed.Value: data TransferTokens instr p

- Michelson.Typed.Value: data Value' instr t

- Michelson.Typed.Value: eqValueExt :: Value' instr t1 -> Value' instr t2 -> Bool

- Michelson.Typed.Value: getComparableProofS :: Sing (a :: T) -> Maybe (Dict (Comparable a))

- Michelson.Typed.Value: instance (Michelson.Typed.Value.Comparable e1, Michelson.Typed.Value.Comparable e2) => Michelson.Typed.Value.Comparable ('Michelson.Typed.T.TOr e1 e2)

- Michelson.Typed.Value: instance (Michelson.Typed.Value.Comparable e1, Michelson.Typed.Value.Comparable e2) => Michelson.Typed.Value.Comparable ('Michelson.Typed.T.TPair e1 e2)

- Michelson.Typed.Value: instance Control.DeepSeq.NFData (Michelson.Typed.Value.Operation' instr)

- Michelson.Typed.Value: instance Control.DeepSeq.NFData (Michelson.Typed.Value.TransferTokens instr p)

- Michelson.Typed.Value: instance Control.DeepSeq.NFData (Michelson.Typed.Value.Value' instr t)

- Michelson.Typed.Value: instance Control.DeepSeq.NFData (instr (Michelson.Typed.Value.ContractInp cp st) (Michelson.Typed.Value.ContractOut st)) => Control.DeepSeq.NFData (Michelson.Typed.Value.CreateContract instr cp st)

- Michelson.Typed.Value: instance Control.DeepSeq.NFData Michelson.Typed.Value.SetDelegate

- Michelson.Typed.Value: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Value.ComparabilityScope t)

- Michelson.Typed.Value: instance Data.Singletons.Internal.SingI t => Michelson.Typed.Scope.CheckScope (Michelson.Typed.Value.Comparable t)

- Michelson.Typed.Value: instance Formatting.Buildable.Buildable (Michelson.Typed.Value.CreateContract instr cp st)

- Michelson.Typed.Value: instance Formatting.Buildable.Buildable (Michelson.Typed.Value.Operation' instr)

- Michelson.Typed.Value: instance Formatting.Buildable.Buildable (Michelson.Typed.Value.TransferTokens instr p)

- Michelson.Typed.Value: instance Formatting.Buildable.Buildable Michelson.Typed.Value.SetDelegate

- Michelson.Typed.Value: instance GHC.Classes.Eq (Michelson.Typed.Value.CreateContract instr cp st)

- Michelson.Typed.Value: instance GHC.Classes.Eq (Michelson.Typed.Value.Operation' instr)

- Michelson.Typed.Value: instance GHC.Classes.Eq (Michelson.Typed.Value.TransferTokens instr p)

- Michelson.Typed.Value: instance GHC.Classes.Eq (Michelson.Typed.Value.Value' instr t)

- Michelson.Typed.Value: instance GHC.Classes.Eq Michelson.Typed.Value.SetDelegate

- Michelson.Typed.Value: instance GHC.Generics.Generic (Michelson.Typed.Value.TransferTokens instr p)

- Michelson.Typed.Value: instance GHC.Generics.Generic Michelson.Typed.Value.SetDelegate

- Michelson.Typed.Value: instance GHC.Show.Show (Michelson.Typed.Value.CreateContract instr cp st)

- Michelson.Typed.Value: instance GHC.Show.Show (Michelson.Typed.Value.Operation' instr)

- Michelson.Typed.Value: instance GHC.Show.Show (Michelson.Typed.Value.TransferTokens instr p)

- Michelson.Typed.Value: instance GHC.Show.Show (Michelson.Typed.Value.Value' instr t)

- Michelson.Typed.Value: instance GHC.Show.Show Michelson.Typed.Value.SetDelegate

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TAddress

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TBool

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TBytes

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TChainId

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TInt

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TKey

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TKeyHash

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TMutez

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TNat

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TNever

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TSignature

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TString

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TTimestamp

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable 'Michelson.Typed.T.TUnit

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable e => GHC.Classes.Ord (Michelson.Typed.Value.Value' instr e)

- Michelson.Typed.Value: instance Michelson.Typed.Value.Comparable e => Michelson.Typed.Value.Comparable ('Michelson.Typed.T.TOption e)

- Michelson.Typed.Value: instance forall k (instr :: k -> k -> *) (i :: k) (o :: k). (forall (o' :: k). Control.DeepSeq.NFData (instr i o')) => Control.DeepSeq.NFData (Michelson.Typed.Value.RemFail instr i o)

- Michelson.Typed.Value: instance forall k (instr :: k -> k -> *) (i :: k) (o :: k). (forall (o' :: k). GHC.Show.Show (instr i o')) => GHC.Show.Show (Michelson.Typed.Value.RemFail instr i o)

- Michelson.Typed.Value: instance forall k (instr :: k -> k -> *) (i :: k) (o :: k). GHC.Classes.Eq (instr i o) => GHC.Classes.Eq (Michelson.Typed.Value.RemFail instr i o)

- Michelson.Typed.Value: liftCallArg :: EntrypointCallT param arg -> Value' instr arg -> Value' instr param

- Michelson.Typed.Value: rfAnyInstr :: RemFail instr i o -> instr i o

- Michelson.Typed.Value: rfMapAnyInstr :: (forall o'. instr i1 o' -> instr i2 o') -> RemFail instr i1 o -> RemFail instr i2 o

- Michelson.Typed.Value: rfMerge :: (forall o'. instr i1 o' -> instr i2 o' -> instr i3 o') -> RemFail instr i1 o -> RemFail instr i2 o -> RemFail instr i3 o

- Michelson.Typed.Value: type ComparabilityScope t = (SingI t, Comparable t)

- Michelson.Typed.Value: type ContractInp param st = '[ContractInp1 param st]

- Michelson.Typed.Value: type ContractInp1 param st = 'TPair param st

- Michelson.Typed.Value: type ContractOut st = '[ContractOut1 st]

- Michelson.Typed.Value: type ContractOut1 st = 'TPair ('TList 'TOperation) st

- Michelson.Typed.Value: valueTypeSanity :: Value' instr t -> Dict (SingI t)

- Michelson.Typed.Value: withValueTypeSanity :: Value' instr t -> (SingI t => a) -> a

- Michelson.Untyped.Aliases: type Contract = Contract' ExpandedOp

- Michelson.Untyped.Aliases: type ExpandedExtInstr = ExtInstrAbstract ExpandedOp

- Michelson.Untyped.Aliases: type Value = Value' ExpandedOp

- Michelson.Untyped.Annotation: AnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet

- Michelson.Untyped.Annotation: OneVarAnn :: VarAnn -> VarAnns

- Michelson.Untyped.Annotation: TwoVarAnns :: VarAnn -> VarAnn -> VarAnns

- Michelson.Untyped.Annotation: UnsafeAnnotation :: Text -> Annotation tag

- Michelson.Untyped.Annotation: [asFields] :: AnnotationSet -> [FieldAnn]

- Michelson.Untyped.Annotation: [asTypes] :: AnnotationSet -> [TypeAnn]

- Michelson.Untyped.Annotation: [asVars] :: AnnotationSet -> [VarAnn]

- Michelson.Untyped.Annotation: [unAnnotation] :: Annotation tag -> Text

- Michelson.Untyped.Annotation: annPrefix :: KnownAnnTag tag => Text

- Michelson.Untyped.Annotation: annQ :: QuasiQuoter

- Michelson.Untyped.Annotation: annsCount :: AnnotationSet -> (Int, Int, Int)

- Michelson.Untyped.Annotation: class Typeable (tag :: Type) => KnownAnnTag tag

- Michelson.Untyped.Annotation: convAnn :: Annotation tag1 -> Annotation tag2

- Michelson.Untyped.Annotation: convergeVarAnns :: VarAnn -> VarAnn -> VarAnn

- Michelson.Untyped.Annotation: data AnnotationSet

- Michelson.Untyped.Annotation: data FieldTag

- Michelson.Untyped.Annotation: data TypeTag

- Michelson.Untyped.Annotation: data VarAnns

- Michelson.Untyped.Annotation: data VarTag

- Michelson.Untyped.Annotation: emptyAnnSet :: AnnotationSet

- Michelson.Untyped.Annotation: fieldAnnQ :: QuasiQuoter

- Michelson.Untyped.Annotation: firstAnn :: KnownAnnTag tag => AnnotationSet -> Annotation tag

- Michelson.Untyped.Annotation: fullAnnSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet

- Michelson.Untyped.Annotation: ifAnnUnified :: Annotation tag -> Annotation tag -> Bool

- Michelson.Untyped.Annotation: instance Control.DeepSeq.NFData Michelson.Untyped.Annotation.VarAnns

- Michelson.Untyped.Annotation: instance Formatting.Buildable.Buildable Michelson.Untyped.Annotation.AnnotationSet

- Michelson.Untyped.Annotation: instance GHC.Base.Functor Michelson.Untyped.Annotation.Annotation

- Michelson.Untyped.Annotation: instance GHC.Base.Monoid Michelson.Untyped.Annotation.AnnotationSet

- Michelson.Untyped.Annotation: instance GHC.Base.Monoid Michelson.Untyped.Annotation.VarAnn

- Michelson.Untyped.Annotation: instance GHC.Base.Semigroup Michelson.Untyped.Annotation.AnnotationSet

- Michelson.Untyped.Annotation: instance GHC.Base.Semigroup Michelson.Untyped.Annotation.VarAnn

- Michelson.Untyped.Annotation: instance GHC.Classes.Eq Michelson.Untyped.Annotation.AnnotationSet

- Michelson.Untyped.Annotation: instance GHC.Generics.Generic Michelson.Untyped.Annotation.VarAnns

- Michelson.Untyped.Annotation: instance GHC.Show.Show Michelson.Untyped.Annotation.AnnotationSet

- Michelson.Untyped.Annotation: instance GHC.Show.Show Michelson.Untyped.Annotation.VarAnns

- Michelson.Untyped.Annotation: instance Michelson.Printer.Util.RenderDoc Michelson.Untyped.Annotation.AnnotationSet

- Michelson.Untyped.Annotation: instance Michelson.Untyped.Annotation.KnownAnnTag Michelson.Untyped.Annotation.FieldTag

- Michelson.Untyped.Annotation: instance Michelson.Untyped.Annotation.KnownAnnTag Michelson.Untyped.Annotation.TypeTag

- Michelson.Untyped.Annotation: instance Michelson.Untyped.Annotation.KnownAnnTag Michelson.Untyped.Annotation.VarTag

- Michelson.Untyped.Annotation: instance Michelson.Untyped.Annotation.KnownAnnTag tag => Formatting.Buildable.Buildable (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance Michelson.Untyped.Annotation.KnownAnnTag tag => GHC.Show.Show (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance Michelson.Untyped.Annotation.KnownAnnTag tag => Michelson.Printer.Util.RenderDoc (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). (Data.Typeable.Internal.Typeable tag, Data.Typeable.Internal.Typeable k) => Data.Data.Data (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). Control.DeepSeq.NFData (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). Data.Aeson.Types.FromJSON.FromJSON (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). Data.Aeson.Types.ToJSON.ToJSON (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). Data.Default.Class.Default (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). GHC.Classes.Eq (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). GHC.Generics.Generic (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: instance forall k (tag :: k). Language.Haskell.TH.Syntax.Lift (Michelson.Untyped.Annotation.Annotation tag)

- Michelson.Untyped.Annotation: isNoAnnSet :: AnnotationSet -> Bool

- Michelson.Untyped.Annotation: isValidAnnBodyChar :: Char -> Bool

- Michelson.Untyped.Annotation: isValidAnnStart :: Char -> Bool

- Michelson.Untyped.Annotation: minAnnSetSize :: AnnotationSet -> Int

- Michelson.Untyped.Annotation: minimizeAnnSet :: AnnotationSet -> AnnotationSet

- Michelson.Untyped.Annotation: mkAnnotation :: Text -> Either Text (Annotation a)

- Michelson.Untyped.Annotation: newtype Annotation tag

- Michelson.Untyped.Annotation: noAnn :: Annotation a

- Michelson.Untyped.Annotation: orAnn :: Annotation t -> Annotation t -> Annotation t

- Michelson.Untyped.Annotation: pattern Annotation :: Text -> Annotation tag

- Michelson.Untyped.Annotation: pattern WithAnn :: Annotation tag -> Annotation tag

- Michelson.Untyped.Annotation: secondAnn :: KnownAnnTag tag => AnnotationSet -> Annotation tag

- Michelson.Untyped.Annotation: singleAnnSet :: forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet

- Michelson.Untyped.Annotation: singleGroupAnnSet :: forall tag. KnownAnnTag tag => [Annotation tag] -> AnnotationSet

- Michelson.Untyped.Annotation: specialFieldAnn :: Text

- Michelson.Untyped.Annotation: specialVarAnns :: [Text]

- Michelson.Untyped.Annotation: type FieldAnn = Annotation FieldTag

- Michelson.Untyped.Annotation: type RootAnn = Annotation FieldTag

- Michelson.Untyped.Annotation: type SomeAnn = Annotation SomeTag

- Michelson.Untyped.Annotation: type TypeAnn = Annotation TypeTag

- Michelson.Untyped.Annotation: type VarAnn = Annotation VarTag

- Michelson.Untyped.Annotation: typeAnnQ :: QuasiQuoter

- Michelson.Untyped.Annotation: unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)

- Michelson.Untyped.Annotation: unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn

- Michelson.Untyped.Annotation: unsafeMkAnnotation :: HasCallStack => Text -> Annotation a

- Michelson.Untyped.Annotation: varAnnQ :: QuasiQuoter

- Michelson.Untyped.Contract: CBCode :: [op] -> ContractBlock op

- Michelson.Untyped.Contract: CBParam :: ParameterType -> ContractBlock op

- Michelson.Untyped.Contract: CBStorage :: Ty -> ContractBlock op

- Michelson.Untyped.Contract: CPS :: EntriesOrder

- Michelson.Untyped.Contract: CSP :: EntriesOrder

- Michelson.Untyped.Contract: Contract :: ParameterType -> Storage -> [op] -> EntriesOrder -> Contract' op

- Michelson.Untyped.Contract: PCS :: EntriesOrder

- Michelson.Untyped.Contract: PSC :: EntriesOrder

- Michelson.Untyped.Contract: SCP :: EntriesOrder

- Michelson.Untyped.Contract: SPC :: EntriesOrder

- Michelson.Untyped.Contract: [contractCode] :: Contract' op -> [op]

- Michelson.Untyped.Contract: [contractParameter] :: Contract' op -> ParameterType

- Michelson.Untyped.Contract: [contractStorage] :: Contract' op -> Storage

- Michelson.Untyped.Contract: [entriesOrder] :: Contract' op -> EntriesOrder

- Michelson.Untyped.Contract: canonicalEntriesOrder :: EntriesOrder

- Michelson.Untyped.Contract: data Contract' op

- Michelson.Untyped.Contract: data ContractBlock op

- Michelson.Untyped.Contract: data EntriesOrder

- Michelson.Untyped.Contract: entriesOrderToInt :: EntriesOrder -> (Int, Int, Int)

- Michelson.Untyped.Contract: instance Control.DeepSeq.NFData Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance Data.Data.Data Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance Data.Data.Data op => Data.Data.Data (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance Data.Default.Class.Default Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance GHC.Base.Functor Michelson.Untyped.Contract.Contract'

- Michelson.Untyped.Contract: instance GHC.Classes.Eq Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance GHC.Classes.Eq op => GHC.Classes.Eq (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance GHC.Classes.Eq op => GHC.Classes.Eq (Michelson.Untyped.Contract.ContractBlock op)

- Michelson.Untyped.Contract: instance GHC.Enum.Bounded Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance GHC.Enum.Enum Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance GHC.Generics.Generic (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance GHC.Generics.Generic Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance GHC.Show.Show Michelson.Untyped.Contract.EntriesOrder

- Michelson.Untyped.Contract: instance GHC.Show.Show op => GHC.Show.Show (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance GHC.Show.Show op => GHC.Show.Show (Michelson.Untyped.Contract.ContractBlock op)

- Michelson.Untyped.Contract: instance Michelson.Printer.Util.RenderDoc op => Formatting.Buildable.Buildable (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: instance Michelson.Printer.Util.RenderDoc op => Michelson.Printer.Util.RenderDoc (Michelson.Untyped.Contract.Contract' op)

- Michelson.Untyped.Contract: mapEntriesOrdered :: Contract' op -> (ParameterType -> a) -> (Storage -> a) -> ([op] -> a) -> [a]

- Michelson.Untyped.Contract: orderContractBlock :: (ContractBlock op, ContractBlock op, ContractBlock op) -> Maybe (Contract' op)

- Michelson.Untyped.Contract: type Storage = Ty

- Michelson.Untyped.Entrypoints: InEpNameBadAnnotation :: FieldAnn -> EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: UnsafeEpName :: Text -> EpName

- Michelson.Untyped.Entrypoints: [unEpName] :: EpName -> Text

- Michelson.Untyped.Entrypoints: buildEpName :: Text -> Either String EpName

- Michelson.Untyped.Entrypoints: data EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: epNameFromParamAnn :: FieldAnn -> Maybe EpName

- Michelson.Untyped.Entrypoints: epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName

- Michelson.Untyped.Entrypoints: epNameFromSelfAnn :: FieldAnn -> EpName

- Michelson.Untyped.Entrypoints: epNameToParamAnn :: EpName -> FieldAnn

- Michelson.Untyped.Entrypoints: epNameToRefAnn :: EpName -> FieldAnn

- Michelson.Untyped.Entrypoints: instance Control.DeepSeq.NFData Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance Control.DeepSeq.NFData Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance Formatting.Buildable.Buildable Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance Formatting.Buildable.Buildable Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: instance GHC.Classes.Eq Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance GHC.Classes.Eq Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: instance GHC.Classes.Ord Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance GHC.Generics.Generic Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance GHC.Generics.Generic Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: instance GHC.Show.Show Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: instance GHC.Show.Show Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: instance Michelson.Printer.Util.RenderDoc Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

- Michelson.Untyped.Entrypoints: instance Util.CLI.HasCLReader Michelson.Untyped.Entrypoints.EpName

- Michelson.Untyped.Entrypoints: isDefEpName :: EpName -> Bool

- Michelson.Untyped.Entrypoints: mkEntrypointsMap :: ParameterType -> Map EpName Ty

- Michelson.Untyped.Entrypoints: newtype EpName

- Michelson.Untyped.Entrypoints: pattern DefEpName :: EpName

- Michelson.Untyped.Entrypoints: unsafeBuildEpName :: HasCallStack => Text -> EpName

- Michelson.Untyped.Ext: FN :: Text -> StackFn -> [op] -> ExtInstrAbstract op

- Michelson.Untyped.Ext: PrintComment :: [Either Text StackRef] -> PrintComment

- Michelson.Untyped.Ext: STACKTYPE :: StackTypePattern -> ExtInstrAbstract op

- Michelson.Untyped.Ext: StackFn :: Maybe (Set Var) -> StackTypePattern -> StackTypePattern -> StackFn

- Michelson.Untyped.Ext: StackRef :: Natural -> StackRef

- Michelson.Untyped.Ext: StkCons :: TyVar -> StackTypePattern -> StackTypePattern

- Michelson.Untyped.Ext: StkEmpty :: StackTypePattern

- Michelson.Untyped.Ext: StkRest :: StackTypePattern

- Michelson.Untyped.Ext: TestAssert :: Text -> PrintComment -> [op] -> TestAssert op

- Michelson.Untyped.Ext: TyCon :: Ty -> TyVar

- Michelson.Untyped.Ext: UCOMMENT :: Text -> ExtInstrAbstract op

- Michelson.Untyped.Ext: UPRINT :: PrintComment -> ExtInstrAbstract op

- Michelson.Untyped.Ext: UTEST_ASSERT :: TestAssert op -> ExtInstrAbstract op

- Michelson.Untyped.Ext: Var :: Text -> Var

- Michelson.Untyped.Ext: VarID :: Var -> TyVar

- Michelson.Untyped.Ext: [sfnInPattern] :: StackFn -> StackTypePattern

- Michelson.Untyped.Ext: [sfnOutPattern] :: StackFn -> StackTypePattern

- Michelson.Untyped.Ext: [sfnQuantifiedVars] :: StackFn -> Maybe (Set Var)

- Michelson.Untyped.Ext: [tassComment] :: TestAssert op -> PrintComment

- Michelson.Untyped.Ext: [tassInstrs] :: TestAssert op -> [op]

- Michelson.Untyped.Ext: [tassName] :: TestAssert op -> Text

- Michelson.Untyped.Ext: [unUPrintComment] :: PrintComment -> [Either Text StackRef]

- Michelson.Untyped.Ext: data ExtInstrAbstract op

- Michelson.Untyped.Ext: data StackFn

- Michelson.Untyped.Ext: data StackTypePattern

- Michelson.Untyped.Ext: data TestAssert op

- Michelson.Untyped.Ext: data TyVar

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Michelson.Untyped.Ext.TestAssert op)

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Michelson.Untyped.Ext.TestAssert op)

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Michelson.Untyped.Ext.TestAssert op)

- Michelson.Untyped.Ext: instance Data.Data.Data Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance Data.Data.Data Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance Data.Data.Data Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance Data.Data.Data Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance Data.Data.Data Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance Data.Data.Data Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance Data.Data.Data op => Data.Data.Data (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance Data.Data.Data op => Data.Data.Data (Michelson.Untyped.Ext.TestAssert op)

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable code => Formatting.Buildable.Buildable (Michelson.Untyped.Ext.TestAssert code)

- Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable op => Formatting.Buildable.Buildable (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance GHC.Base.Functor Michelson.Untyped.Ext.ExtInstrAbstract

- Michelson.Untyped.Ext: instance GHC.Base.Functor Michelson.Untyped.Ext.TestAssert

- Michelson.Untyped.Ext: instance GHC.Classes.Eq Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance GHC.Classes.Eq Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance GHC.Classes.Eq Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance GHC.Classes.Eq Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance GHC.Classes.Eq Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance GHC.Classes.Eq Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance GHC.Classes.Eq op => GHC.Classes.Eq (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance GHC.Classes.Eq op => GHC.Classes.Eq (Michelson.Untyped.Ext.TestAssert op)

- Michelson.Untyped.Ext: instance GHC.Classes.Ord Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance GHC.Generics.Generic (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance GHC.Generics.Generic (Michelson.Untyped.Ext.TestAssert op)

- Michelson.Untyped.Ext: instance GHC.Generics.Generic Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance GHC.Generics.Generic Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance GHC.Generics.Generic Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance GHC.Generics.Generic Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance GHC.Generics.Generic Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance GHC.Generics.Generic Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance GHC.Show.Show Michelson.Untyped.Ext.PrintComment

- Michelson.Untyped.Ext: instance GHC.Show.Show Michelson.Untyped.Ext.StackFn

- Michelson.Untyped.Ext: instance GHC.Show.Show Michelson.Untyped.Ext.StackRef

- Michelson.Untyped.Ext: instance GHC.Show.Show Michelson.Untyped.Ext.StackTypePattern

- Michelson.Untyped.Ext: instance GHC.Show.Show Michelson.Untyped.Ext.TyVar

- Michelson.Untyped.Ext: instance GHC.Show.Show Michelson.Untyped.Ext.Var

- Michelson.Untyped.Ext: instance GHC.Show.Show op => GHC.Show.Show (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: instance GHC.Show.Show op => GHC.Show.Show (Michelson.Untyped.Ext.TestAssert op)

- Michelson.Untyped.Ext: instance Michelson.Printer.Util.RenderDoc op => Michelson.Printer.Util.RenderDoc (Michelson.Untyped.Ext.ExtInstrAbstract op)

- Michelson.Untyped.Ext: newtype PrintComment

- Michelson.Untyped.Ext: newtype StackRef

- Michelson.Untyped.Ext: newtype Var

- Michelson.Untyped.Ext: stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)

- Michelson.Untyped.Ext: varSet :: StackTypePattern -> Set Var

- Michelson.Untyped.Instr: ABS :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: ADD :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: ADDRESS :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: AMOUNT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: AND :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: APPLY :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: BALANCE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: BLAKE2B :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: CAR :: VarAnn -> FieldAnn -> InstrAbstract op

- Michelson.Untyped.Instr: CAST :: VarAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: CDR :: VarAnn -> FieldAnn -> InstrAbstract op

- Michelson.Untyped.Instr: CHAIN_ID :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: CHECK_SIGNATURE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: COMPARE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: CONCAT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: CONS :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: CONTRACT :: VarAnn -> FieldAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: CREATE_CONTRACT :: VarAnn -> VarAnn -> Contract' op -> InstrAbstract op

- Michelson.Untyped.Instr: DIG :: Word -> InstrAbstract op

- Michelson.Untyped.Instr: DIP :: [op] -> InstrAbstract op

- Michelson.Untyped.Instr: DIPN :: Word -> [op] -> InstrAbstract op

- Michelson.Untyped.Instr: DROP :: InstrAbstract op

- Michelson.Untyped.Instr: DROPN :: Word -> InstrAbstract op

- Michelson.Untyped.Instr: DUG :: Word -> InstrAbstract op

- Michelson.Untyped.Instr: DUP :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: DUPN :: VarAnn -> Word -> InstrAbstract op

- Michelson.Untyped.Instr: EDIV :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: EMPTY_BIG_MAP :: TypeAnn -> VarAnn -> Ty -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: EMPTY_MAP :: TypeAnn -> VarAnn -> Ty -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: EMPTY_SET :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: EQ :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: EXEC :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: EXT :: ExtInstrAbstract op -> InstrAbstract op

- Michelson.Untyped.Instr: FAILWITH :: InstrAbstract op

- Michelson.Untyped.Instr: GE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: GET :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: GETN :: VarAnn -> Word -> InstrAbstract op

- Michelson.Untyped.Instr: GET_AND_UPDATE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: GT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: HASH_KEY :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: IF :: [op] -> [op] -> InstrAbstract op

- Michelson.Untyped.Instr: IF_CONS :: [op] -> [op] -> InstrAbstract op

- Michelson.Untyped.Instr: IF_LEFT :: [op] -> [op] -> InstrAbstract op

- Michelson.Untyped.Instr: IF_NONE :: [op] -> [op] -> InstrAbstract op

- Michelson.Untyped.Instr: IMPLICIT_ACCOUNT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: INT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: ISNAT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: ITER :: [op] -> InstrAbstract op

- Michelson.Untyped.Instr: JOIN_TICKETS :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: KECCAK :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: LAMBDA :: VarAnn -> Ty -> Ty -> [op] -> InstrAbstract op

- Michelson.Untyped.Instr: LE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: LEFT :: TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: LEVEL :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: LOOP :: [op] -> InstrAbstract op

- Michelson.Untyped.Instr: LOOP_LEFT :: [op] -> InstrAbstract op

- Michelson.Untyped.Instr: LSL :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: LSR :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: LT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: MAP :: VarAnn -> [op] -> InstrAbstract op

- Michelson.Untyped.Instr: MEM :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: MUL :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: NEG :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: NEQ :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: NEVER :: InstrAbstract op

- Michelson.Untyped.Instr: NIL :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: NONE :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: NOT :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: NOW :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: OR :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: PACK :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: PAIR :: TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> InstrAbstract op

- Michelson.Untyped.Instr: PAIRING_CHECK :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: PAIRN :: VarAnn -> Word -> InstrAbstract op

- Michelson.Untyped.Instr: PUSH :: VarAnn -> Ty -> Value' op -> InstrAbstract op

- Michelson.Untyped.Instr: PrimEx :: ExpandedInstr -> ExpandedOp

- Michelson.Untyped.Instr: READ_TICKET :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: RENAME :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: RIGHT :: TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: SELF :: VarAnn -> FieldAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SELF_ADDRESS :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SENDER :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SET_DELEGATE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SHA256 :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SHA3 :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SHA512 :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SIZE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SLICE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SOME :: TypeAnn -> VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SOURCE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SPLIT_TICKET :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SUB :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: SWAP :: InstrAbstract op

- Michelson.Untyped.Instr: SeqEx :: [ExpandedOp] -> ExpandedOp

- Michelson.Untyped.Instr: TICKET :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: TOTAL_VOTING_POWER :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: TRANSFER_TOKENS :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: UNIT :: TypeAnn -> VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: UNPACK :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

- Michelson.Untyped.Instr: UNPAIR :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> InstrAbstract op

- Michelson.Untyped.Instr: UNPAIRN :: Word -> InstrAbstract op

- Michelson.Untyped.Instr: UPDATE :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: UPDATEN :: VarAnn -> Word -> InstrAbstract op

- Michelson.Untyped.Instr: VOTING_POWER :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: WithSrcEx :: InstrCallStack -> ExpandedOp -> ExpandedOp

- Michelson.Untyped.Instr: XOR :: VarAnn -> InstrAbstract op

- Michelson.Untyped.Instr: data ExpandedOp

- Michelson.Untyped.Instr: data InstrAbstract op

- Michelson.Untyped.Instr: flattenExpandedOp :: ExpandedOp -> [ExpandedInstr]

- Michelson.Untyped.Instr: instance (Michelson.Printer.Util.RenderDoc op, Formatting.Buildable.Buildable op) => Formatting.Buildable.Buildable (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance Control.DeepSeq.NFData Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance Data.Data.Data Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance Data.Data.Data op => Data.Data.Data (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance Formatting.Buildable.Buildable Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance GHC.Base.Functor Michelson.Untyped.Instr.InstrAbstract

- Michelson.Untyped.Instr: instance GHC.Classes.Eq Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance GHC.Classes.Eq op => GHC.Classes.Eq (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance GHC.Generics.Generic (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance GHC.Generics.Generic Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance GHC.Show.Show Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance Michelson.Printer.Util.RenderDoc (Michelson.Untyped.Instr.InstrAbstract op) => GHC.Show.Show (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: instance Michelson.Printer.Util.RenderDoc Michelson.Untyped.Instr.ExpandedOp

- Michelson.Untyped.Instr: instance Michelson.Printer.Util.RenderDoc op => Michelson.Printer.Util.RenderDoc (Michelson.Untyped.Instr.InstrAbstract op)

- Michelson.Untyped.Instr: type ExpandedInstr = InstrAbstract ExpandedOp

- Michelson.Untyped.OpSize: OpSize :: Word -> OpSize

- Michelson.Untyped.OpSize: [unOpSize] :: OpSize -> Word

- Michelson.Untyped.OpSize: expandedInstrsOpSize :: [ExpandedOp] -> OpSize

- Michelson.Untyped.OpSize: instance (Michelson.Untyped.Annotation.KnownAnnTag t, Michelson.Untyped.OpSize.AnnsOpSizeVararg x) => Michelson.Untyped.OpSize.AnnsOpSizeVararg (Michelson.Untyped.Annotation.Annotation t -> x)

- Michelson.Untyped.OpSize: instance Formatting.Buildable.Buildable Michelson.Untyped.OpSize.OpSize

- Michelson.Untyped.OpSize: instance GHC.Base.Monoid Michelson.Untyped.OpSize.OpSize

- Michelson.Untyped.OpSize: instance GHC.Base.Semigroup Michelson.Untyped.OpSize.OpSize

- Michelson.Untyped.OpSize: instance GHC.Classes.Eq Michelson.Untyped.OpSize.OpSize

- Michelson.Untyped.OpSize: instance GHC.Classes.Ord Michelson.Untyped.OpSize.OpSize

- Michelson.Untyped.OpSize: instance GHC.Show.Show Michelson.Untyped.OpSize.OpSize

- Michelson.Untyped.OpSize: instance Michelson.Untyped.OpSize.AnnsOpSizeVararg Michelson.Untyped.OpSize.OpSize

- Michelson.Untyped.OpSize: instrOpSize :: InstrAbstract ExpandedOp -> OpSize

- Michelson.Untyped.OpSize: newtype OpSize

- Michelson.Untyped.OpSize: opSizeHardLimit :: OpSize

- Michelson.Untyped.OpSize: smallTransferOpSize :: OpSize

- Michelson.Untyped.OpSize: valueOpSize :: Value -> OpSize

- Michelson.Untyped.Type: ParameterType :: Ty -> RootAnn -> ParameterType

- Michelson.Untyped.Type: TAddress :: T

- Michelson.Untyped.Type: TBigMap :: Ty -> Ty -> T

- Michelson.Untyped.Type: TBls12381Fr :: T

- Michelson.Untyped.Type: TBls12381G1 :: T

- Michelson.Untyped.Type: TBls12381G2 :: T

- Michelson.Untyped.Type: TBool :: T

- Michelson.Untyped.Type: TBytes :: T

- Michelson.Untyped.Type: TChainId :: T

- Michelson.Untyped.Type: TContract :: Ty -> T

- Michelson.Untyped.Type: TInt :: T

- Michelson.Untyped.Type: TKey :: T

- Michelson.Untyped.Type: TKeyHash :: T

- Michelson.Untyped.Type: TLambda :: Ty -> Ty -> T

- Michelson.Untyped.Type: TList :: Ty -> T

- Michelson.Untyped.Type: TMap :: Ty -> Ty -> T

- Michelson.Untyped.Type: TMutez :: T

- Michelson.Untyped.Type: TNat :: T

- Michelson.Untyped.Type: TNever :: T

- Michelson.Untyped.Type: TOperation :: T

- Michelson.Untyped.Type: TOption :: Ty -> T

- Michelson.Untyped.Type: TOr :: FieldAnn -> FieldAnn -> Ty -> Ty -> T

- Michelson.Untyped.Type: TPair :: FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> Ty -> Ty -> T

- Michelson.Untyped.Type: TSet :: Ty -> T

- Michelson.Untyped.Type: TSignature :: T

- Michelson.Untyped.Type: TString :: T

- Michelson.Untyped.Type: TTicket :: Ty -> T

- Michelson.Untyped.Type: TTimestamp :: T

- Michelson.Untyped.Type: TUnit :: T

- Michelson.Untyped.Type: Ty :: ~T -> TypeAnn -> Ty

- Michelson.Untyped.Type: data ParameterType

- Michelson.Untyped.Type: data T

- Michelson.Untyped.Type: data Ty

- Michelson.Untyped.Type: instance Control.DeepSeq.NFData Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance Control.DeepSeq.NFData Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance Control.DeepSeq.NFData Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance Data.Data.Data Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance Data.Data.Data Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance Data.Data.Data Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance Formatting.Buildable.Buildable Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance Formatting.Buildable.Buildable Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance Formatting.Buildable.Buildable Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance GHC.Classes.Eq Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance GHC.Classes.Eq Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance GHC.Classes.Eq Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance GHC.Generics.Generic Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance GHC.Generics.Generic Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance GHC.Generics.Generic Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance GHC.Show.Show Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance GHC.Show.Show Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance GHC.Show.Show Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance Language.Haskell.TH.Syntax.Lift Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance Language.Haskell.TH.Syntax.Lift Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance Language.Haskell.TH.Syntax.Lift Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: instance Michelson.Printer.Util.RenderDoc (Michelson.Printer.Util.Prettier Michelson.Untyped.Type.ParameterType)

- Michelson.Untyped.Type: instance Michelson.Printer.Util.RenderDoc (Michelson.Printer.Util.Prettier Michelson.Untyped.Type.Ty)

- Michelson.Untyped.Type: instance Michelson.Printer.Util.RenderDoc Michelson.Untyped.Type.ParameterType

- Michelson.Untyped.Type: instance Michelson.Printer.Util.RenderDoc Michelson.Untyped.Type.T

- Michelson.Untyped.Type: instance Michelson.Printer.Util.RenderDoc Michelson.Untyped.Type.Ty

- Michelson.Untyped.Type: isAtomicType :: Ty -> Bool

- Michelson.Untyped.Type: isBool :: Ty -> Bool

- Michelson.Untyped.Type: isBytes :: Ty -> Bool

- Michelson.Untyped.Type: isComparable :: Ty -> Bool

- Michelson.Untyped.Type: isInt :: Ty -> Bool

- Michelson.Untyped.Type: isInteger :: Ty -> Bool

- Michelson.Untyped.Type: isKey :: Ty -> Bool

- Michelson.Untyped.Type: isKeyHash :: Ty -> Bool

- Michelson.Untyped.Type: isMutez :: Ty -> Bool

- Michelson.Untyped.Type: isNat :: Ty -> Bool

- Michelson.Untyped.Type: isSignature :: Ty -> Bool

- Michelson.Untyped.Type: isString :: Ty -> Bool

- Michelson.Untyped.Type: isTimestamp :: Ty -> Bool

- Michelson.Untyped.Type: renderType :: T -> Bool -> RenderContext -> AnnotationSet -> Doc

- Michelson.Untyped.Type: toption :: Ty -> T

- Michelson.Untyped.Type: tor :: Ty -> Ty -> T

- Michelson.Untyped.Type: tpair :: Ty -> Ty -> T

- Michelson.Untyped.Type: tyImplicitAccountParam :: Ty

- Michelson.Untyped.Type: tybool :: Ty

- Michelson.Untyped.Type: tyint :: Ty

- Michelson.Untyped.Type: tynat :: Ty

- Michelson.Untyped.Type: tyor :: Ty -> Ty -> Ty

- Michelson.Untyped.Type: typair :: Ty -> Ty -> Ty

- Michelson.Untyped.Type: tyunit :: Ty

- Michelson.Untyped.Type: unwrapT :: Ty -> T

- Michelson.Untyped.Value: Elt :: Value' op -> Value' op -> Elt op

- Michelson.Untyped.Value: InternalByteString :: ByteString -> InternalByteString

- Michelson.Untyped.Value: ValueBytes :: InternalByteString -> Value' op

- Michelson.Untyped.Value: ValueFalse :: Value' op

- Michelson.Untyped.Value: ValueInt :: Integer -> Value' op

- Michelson.Untyped.Value: ValueLambda :: NonEmpty op -> Value' op

- Michelson.Untyped.Value: ValueLeft :: Value' op -> Value' op

- Michelson.Untyped.Value: ValueMap :: (NonEmpty $ Elt op) -> Value' op

- Michelson.Untyped.Value: ValueNil :: Value' op

- Michelson.Untyped.Value: ValueNone :: Value' op

- Michelson.Untyped.Value: ValuePair :: Value' op -> Value' op -> Value' op

- Michelson.Untyped.Value: ValueRight :: Value' op -> Value' op

- Michelson.Untyped.Value: ValueSeq :: (NonEmpty $ Value' op) -> Value' op

- Michelson.Untyped.Value: ValueSome :: Value' op -> Value' op

- Michelson.Untyped.Value: ValueString :: MText -> Value' op

- Michelson.Untyped.Value: ValueTrue :: Value' op

- Michelson.Untyped.Value: ValueUnit :: Value' op

- Michelson.Untyped.Value: data Elt op

- Michelson.Untyped.Value: data Value' op

- Michelson.Untyped.Value: instance Control.DeepSeq.NFData Michelson.Untyped.Value.InternalByteString

- Michelson.Untyped.Value: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance Data.Aeson.Types.FromJSON.FromJSON Michelson.Untyped.Value.InternalByteString

- Michelson.Untyped.Value: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance Data.Aeson.Types.ToJSON.ToJSON Michelson.Untyped.Value.InternalByteString

- Michelson.Untyped.Value: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance Data.Data.Data Michelson.Untyped.Value.InternalByteString

- Michelson.Untyped.Value: instance Data.Data.Data op => Data.Data.Data (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance Data.Data.Data op => Data.Data.Data (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance GHC.Base.Functor Michelson.Untyped.Value.Elt

- Michelson.Untyped.Value: instance GHC.Base.Functor Michelson.Untyped.Value.Value'

- Michelson.Untyped.Value: instance GHC.Classes.Eq Michelson.Untyped.Value.InternalByteString

- Michelson.Untyped.Value: instance GHC.Classes.Eq op => GHC.Classes.Eq (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance GHC.Classes.Eq op => GHC.Classes.Eq (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance GHC.Generics.Generic (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance GHC.Generics.Generic (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance GHC.Generics.Generic Michelson.Untyped.Value.InternalByteString

- Michelson.Untyped.Value: instance GHC.Show.Show Michelson.Untyped.Value.InternalByteString

- Michelson.Untyped.Value: instance GHC.Show.Show op => GHC.Show.Show (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance GHC.Show.Show op => GHC.Show.Show (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance Michelson.Printer.Util.RenderDoc op => Formatting.Buildable.Buildable (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance Michelson.Printer.Util.RenderDoc op => Formatting.Buildable.Buildable (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: instance Michelson.Printer.Util.RenderDoc op => Michelson.Printer.Util.RenderDoc (Michelson.Untyped.Value.Elt op)

- Michelson.Untyped.Value: instance Michelson.Printer.Util.RenderDoc op => Michelson.Printer.Util.RenderDoc (Michelson.Untyped.Value.Value' op)

- Michelson.Untyped.Value: linearizeRightCombValuePair :: Value' op -> NonEmpty (Value' op)

- Michelson.Untyped.Value: newtype InternalByteString

- Michelson.Untyped.Value: unInternalByteString :: InternalByteString -> ByteString

- Morley.CLI: instance Util.CLI.HasCLReader Michelson.Untyped.Aliases.Value

- Morley.Micheline.Class: instance (Data.Singletons.Internal.SingI inp, Data.Singletons.Internal.SingI out) => Morley.Micheline.Class.FromExpression (Michelson.Typed.Instr.Instr '[inp] '[out])

- Morley.Micheline.Class: instance (Data.Singletons.Internal.SingI t, Michelson.Typed.Scope.HasNoOp t) => Morley.Micheline.Class.ToExpression (Michelson.Typed.Aliases.Value t)

- Morley.Micheline.Class: instance Data.Singletons.Internal.SingI t => Morley.Micheline.Class.FromExpression (Michelson.Typed.Aliases.Value t)

- Morley.Micheline.Class: instance Data.Singletons.Internal.SingI t => Morley.Micheline.Class.ToExpression (Michelson.Typed.Annotation.Notes t)

- Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Michelson.Typed.T.T

- Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Michelson.Untyped.Aliases.Contract

- Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Michelson.Untyped.Aliases.Value

- Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Michelson.Untyped.Instr.ExpandedInstr

- Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Michelson.Untyped.Instr.ExpandedOp

- Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Michelson.Untyped.Type.T

- Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Michelson.Untyped.Type.Ty

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression (Michelson.Typed.Instr.Contract cp st)

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression (Michelson.Typed.Instr.Instr inp out)

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Michelson.Typed.T.T

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Michelson.Untyped.Aliases.Contract

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Michelson.Untyped.Aliases.Value

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Michelson.Untyped.Instr.ExpandedInstr

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Michelson.Untyped.Instr.ExpandedOp

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Michelson.Untyped.Type.T

- Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Michelson.Untyped.Type.Ty

- Tezos.Address: ContractAddress :: ContractHash -> Address

- Tezos.Address: ContractHash :: ByteString -> ContractHash

- Tezos.Address: GlobalCounter :: Word64 -> GlobalCounter

- Tezos.Address: KeyAddress :: KeyHash -> Address

- Tezos.Address: OriginationIndex :: Int32 -> OriginationIndex

- Tezos.Address: ParseAddressBothFailed :: CryptoParseError -> ParseContractAddressError -> ParseAddressError

- Tezos.Address: ParseAddressRawInvalidPrefix :: ByteString -> ParseAddressRawError

- Tezos.Address: ParseAddressRawMalformedSeparator :: ByteString -> ParseAddressRawError

- Tezos.Address: ParseAddressRawWrongSize :: ByteString -> ParseAddressRawError

- Tezos.Address: ParseAddressWrongBase58Check :: ParseAddressError

- Tezos.Address: ParseContractAddressWrongBase58Check :: ParseContractAddressError

- Tezos.Address: ParseContractAddressWrongPrefix :: ByteString -> ParseContractAddressError

- Tezos.Address: ParseContractAddressWrongSize :: ByteString -> ParseContractAddressError

- Tezos.Address: [unGlobalCounter] :: GlobalCounter -> Word64

- Tezos.Address: [unOriginationIndex] :: OriginationIndex -> Int32

- Tezos.Address: data Address

- Tezos.Address: data ParseAddressError

- Tezos.Address: data ParseAddressRawError

- Tezos.Address: data ParseContractAddressError

- Tezos.Address: detGenKeyAddress :: ByteString -> Address

- Tezos.Address: formatAddress :: Address -> Text

- Tezos.Address: instance (TypeError ...) => Data.String.IsString Tezos.Address.Address

- Tezos.Address: instance Control.DeepSeq.NFData Tezos.Address.Address

- Tezos.Address: instance Control.DeepSeq.NFData Tezos.Address.ContractHash

- Tezos.Address: instance Control.DeepSeq.NFData Tezos.Address.GlobalCounter

- Tezos.Address: instance Control.DeepSeq.NFData Tezos.Address.OriginationIndex

- Tezos.Address: instance Control.DeepSeq.NFData Tezos.Address.ParseAddressError

- Tezos.Address: instance Control.DeepSeq.NFData Tezos.Address.ParseAddressRawError

- Tezos.Address: instance Control.DeepSeq.NFData Tezos.Address.ParseContractAddressError

- Tezos.Address: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Address.Address

- Tezos.Address: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Address.GlobalCounter

- Tezos.Address: instance Data.Aeson.Types.FromJSON.FromJSONKey Tezos.Address.Address

- Tezos.Address: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Address.Address

- Tezos.Address: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Address.GlobalCounter

- Tezos.Address: instance Data.Aeson.Types.ToJSON.ToJSONKey Tezos.Address.Address

- Tezos.Address: instance Formatting.Buildable.Buildable Tezos.Address.Address

- Tezos.Address: instance Formatting.Buildable.Buildable Tezos.Address.ParseAddressError

- Tezos.Address: instance Formatting.Buildable.Buildable Tezos.Address.ParseAddressRawError

- Tezos.Address: instance Formatting.Buildable.Buildable Tezos.Address.ParseContractAddressError

- Tezos.Address: instance GHC.Classes.Eq Tezos.Address.Address

- Tezos.Address: instance GHC.Classes.Eq Tezos.Address.ContractHash

- Tezos.Address: instance GHC.Classes.Eq Tezos.Address.GlobalCounter

- Tezos.Address: instance GHC.Classes.Eq Tezos.Address.OriginationIndex

- Tezos.Address: instance GHC.Classes.Eq Tezos.Address.ParseAddressError

- Tezos.Address: instance GHC.Classes.Eq Tezos.Address.ParseAddressRawError

- Tezos.Address: instance GHC.Classes.Eq Tezos.Address.ParseContractAddressError

- Tezos.Address: instance GHC.Classes.Ord Tezos.Address.Address

- Tezos.Address: instance GHC.Classes.Ord Tezos.Address.ContractHash

- Tezos.Address: instance GHC.Classes.Ord Tezos.Address.OriginationIndex

- Tezos.Address: instance GHC.Generics.Generic Tezos.Address.Address

- Tezos.Address: instance GHC.Generics.Generic Tezos.Address.ContractHash

- Tezos.Address: instance GHC.Generics.Generic Tezos.Address.GlobalCounter

- Tezos.Address: instance GHC.Generics.Generic Tezos.Address.OriginationIndex

- Tezos.Address: instance GHC.Generics.Generic Tezos.Address.ParseAddressError

- Tezos.Address: instance GHC.Generics.Generic Tezos.Address.ParseAddressRawError

- Tezos.Address: instance GHC.Generics.Generic Tezos.Address.ParseContractAddressError

- Tezos.Address: instance GHC.Num.Num Tezos.Address.GlobalCounter

- Tezos.Address: instance GHC.Show.Show Tezos.Address.Address

- Tezos.Address: instance GHC.Show.Show Tezos.Address.ContractHash

- Tezos.Address: instance GHC.Show.Show Tezos.Address.GlobalCounter

- Tezos.Address: instance GHC.Show.Show Tezos.Address.OriginationIndex

- Tezos.Address: instance GHC.Show.Show Tezos.Address.ParseAddressError

- Tezos.Address: instance GHC.Show.Show Tezos.Address.ParseAddressRawError

- Tezos.Address: instance GHC.Show.Show Tezos.Address.ParseContractAddressError

- Tezos.Address: instance Language.Haskell.TH.Syntax.Lift Tezos.Address.Address

- Tezos.Address: instance Language.Haskell.TH.Syntax.Lift Tezos.Address.ContractHash

- Tezos.Address: instance Michelson.Printer.Util.RenderDoc Tezos.Address.ParseAddressError

- Tezos.Address: instance Michelson.Printer.Util.RenderDoc Tezos.Address.ParseAddressRawError

- Tezos.Address: instance Michelson.Printer.Util.RenderDoc Tezos.Address.ParseContractAddressError

- Tezos.Address: instance Util.CLI.HasCLReader Tezos.Address.Address

- Tezos.Address: mformatAddress :: Address -> MText

- Tezos.Address: mkContractHashHack :: ByteString -> ContractHash

- Tezos.Address: mkKeyAddress :: PublicKey -> Address

- Tezos.Address: newtype ContractHash

- Tezos.Address: newtype GlobalCounter

- Tezos.Address: newtype OriginationIndex

- Tezos.Address: parseAddress :: Text -> Either ParseAddressError Address

- Tezos.Address: parseAddressRaw :: ByteString -> Either ParseAddressRawError Address

- Tezos.Address: parseContractHash :: Text -> Either ParseContractAddressError ContractHash

- Tezos.Address: ta :: QuasiQuoter

- Tezos.Address: unsafeParseAddress :: HasCallStack => Text -> Address

- Tezos.Address: unsafeParseAddressRaw :: ByteString -> Address

- Tezos.Address: unsafeParseContractHash :: HasCallStack => Text -> ContractHash

- Tezos.Core: Timestamp :: POSIXTime -> Timestamp

- Tezos.Core: UnsafeChainId :: ByteString -> ChainId

- Tezos.Core: UnsafeMutez :: Word64 -> Mutez

- Tezos.Core: [unChainId] :: ChainId -> ByteString

- Tezos.Core: [unMutez] :: Mutez -> Word64

- Tezos.Core: [unTimestamp] :: Timestamp -> POSIXTime

- Tezos.Core: addMutez :: Mutez -> Mutez -> Maybe Mutez

- Tezos.Core: chainIdLength :: Int

- Tezos.Core: divModMutez :: Mutez -> Mutez -> Maybe (Word64, Mutez)

- Tezos.Core: divModMutezInt :: Integral a => Mutez -> a -> Maybe (Mutez, Mutez)

- Tezos.Core: dummyChainId :: ChainId

- Tezos.Core: farFuture :: Timestamp

- Tezos.Core: farPast :: Timestamp

- Tezos.Core: formatChainId :: ChainId -> Text

- Tezos.Core: formatTimestamp :: Timestamp -> Text

- Tezos.Core: getCurrentTime :: IO Timestamp

- Tezos.Core: instance Control.DeepSeq.NFData Tezos.Core.ChainId

- Tezos.Core: instance Control.DeepSeq.NFData Tezos.Core.Mutez

- Tezos.Core: instance Control.DeepSeq.NFData Tezos.Core.Timestamp

- Tezos.Core: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Core.ChainId

- Tezos.Core: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Core.Mutez

- Tezos.Core: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Core.Timestamp

- Tezos.Core: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Core.ChainId

- Tezos.Core: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Core.Mutez

- Tezos.Core: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Core.Timestamp

- Tezos.Core: instance Data.Data.Data Tezos.Core.Mutez

- Tezos.Core: instance Data.Data.Data Tezos.Core.Timestamp

- Tezos.Core: instance Formatting.Buildable.Buildable Tezos.Core.ChainId

- Tezos.Core: instance Formatting.Buildable.Buildable Tezos.Core.Mutez

- Tezos.Core: instance Formatting.Buildable.Buildable Tezos.Core.ParseChainIdError

- Tezos.Core: instance Formatting.Buildable.Buildable Tezos.Core.Timestamp

- Tezos.Core: instance GHC.Classes.Eq Tezos.Core.ChainId

- Tezos.Core: instance GHC.Classes.Eq Tezos.Core.Mutez

- Tezos.Core: instance GHC.Classes.Eq Tezos.Core.ParseChainIdError

- Tezos.Core: instance GHC.Classes.Eq Tezos.Core.Timestamp

- Tezos.Core: instance GHC.Classes.Ord Tezos.Core.ChainId

- Tezos.Core: instance GHC.Classes.Ord Tezos.Core.Mutez

- Tezos.Core: instance GHC.Classes.Ord Tezos.Core.Timestamp

- Tezos.Core: instance GHC.Enum.Bounded Tezos.Core.Mutez

- Tezos.Core: instance GHC.Enum.Enum Tezos.Core.Mutez

- Tezos.Core: instance GHC.Exception.Type.Exception Tezos.Core.ParseChainIdError

- Tezos.Core: instance GHC.Generics.Generic Tezos.Core.ChainId

- Tezos.Core: instance GHC.Generics.Generic Tezos.Core.Mutez

- Tezos.Core: instance GHC.Generics.Generic Tezos.Core.Timestamp

- Tezos.Core: instance GHC.Show.Show Tezos.Core.ChainId

- Tezos.Core: instance GHC.Show.Show Tezos.Core.Mutez

- Tezos.Core: instance GHC.Show.Show Tezos.Core.ParseChainIdError

- Tezos.Core: instance GHC.Show.Show Tezos.Core.Timestamp

- Tezos.Core: instance Util.CLI.HasCLReader Tezos.Core.Mutez

- Tezos.Core: mformatChainId :: ChainId -> MText

- Tezos.Core: mkChainId :: ByteString -> Maybe ChainId

- Tezos.Core: mkMutez :: Word64 -> Maybe Mutez

- Tezos.Core: mkMutez' :: Integral i => i -> Either Text Mutez

- Tezos.Core: mulMutez :: Integral a => Mutez -> a -> Maybe Mutez

- Tezos.Core: mutezToInt64 :: Mutez -> Int64

- Tezos.Core: newtype ChainId

- Tezos.Core: newtype Mutez

- Tezos.Core: newtype Timestamp

- Tezos.Core: oneMutez :: Mutez

- Tezos.Core: parseChainId :: Text -> Either ParseChainIdError ChainId

- Tezos.Core: parseTimestamp :: Text -> Maybe Timestamp

- Tezos.Core: prettyTez :: Mutez -> Text

- Tezos.Core: subMutez :: Mutez -> Mutez -> Maybe Mutez

- Tezos.Core: timestampFromSeconds :: Integer -> Timestamp

- Tezos.Core: timestampFromUTCTime :: UTCTime -> Timestamp

- Tezos.Core: timestampPlusSeconds :: Timestamp -> Integer -> Timestamp

- Tezos.Core: timestampQuote :: QuasiQuoter

- Tezos.Core: timestampToSeconds :: Integral a => Timestamp -> a

- Tezos.Core: timestampToUTCTime :: Timestamp -> UTCTime

- Tezos.Core: toMutez :: Word32 -> Mutez

- Tezos.Core: unsafeAddMutez :: HasCallStack => Mutez -> Mutez -> Mutez

- Tezos.Core: unsafeMkChainId :: HasCallStack => ByteString -> ChainId

- Tezos.Core: unsafeMkMutez :: HasCallStack => Word64 -> Mutez

- Tezos.Core: unsafeMulMutez :: Mutez -> Natural -> Mutez

- Tezos.Core: unsafeSubMutez :: HasCallStack => Mutez -> Mutez -> Mutez

- Tezos.Core: zeroMutez :: Mutez

- Tezos.Crypto: B58CheckWithPrefixWrongEncoding :: B58CheckWithPrefixError

- Tezos.Crypto: B58CheckWithPrefixWrongPrefix :: ByteString -> B58CheckWithPrefixError

- Tezos.Crypto: CryptoParseBinaryError :: Text -> CryptoParseError

- Tezos.Crypto: CryptoParseCryptoError :: CryptoError -> CryptoParseError

- Tezos.Crypto: CryptoParseUnexpectedLength :: Builder -> Int -> CryptoParseError

- Tezos.Crypto: CryptoParseWrongBase58Check :: CryptoParseError

- Tezos.Crypto: CryptoParseWrongTag :: ByteString -> CryptoParseError

- Tezos.Crypto: KeyHash :: KeyHashTag -> ByteString -> KeyHash

- Tezos.Crypto: KeyHashEd25519 :: KeyHashTag

- Tezos.Crypto: KeyHashP256 :: KeyHashTag

- Tezos.Crypto: KeyHashSecp256k1 :: KeyHashTag

- Tezos.Crypto: PublicKeyEd25519 :: PublicKey -> PublicKey

- Tezos.Crypto: PublicKeyP256 :: PublicKey -> PublicKey

- Tezos.Crypto: PublicKeySecp256k1 :: PublicKey -> PublicKey

- Tezos.Crypto: SecretKeyEd25519 :: SecretKey -> SecretKey

- Tezos.Crypto: SecretKeyP256 :: SecretKey -> SecretKey

- Tezos.Crypto: SecretKeySecp256k1 :: SecretKey -> SecretKey

- Tezos.Crypto: SignatureEd25519 :: Signature -> Signature

- Tezos.Crypto: SignatureGeneric :: ByteString -> Signature

- Tezos.Crypto: SignatureP256 :: Signature -> Signature

- Tezos.Crypto: SignatureSecp256k1 :: Signature -> Signature

- Tezos.Crypto: [khBytes] :: KeyHash -> ByteString

- Tezos.Crypto: [khTag] :: KeyHash -> KeyHashTag

- Tezos.Crypto: blake2b :: ByteString -> ByteString

- Tezos.Crypto: blake2b160 :: ByteString -> ByteString

- Tezos.Crypto: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

- Tezos.Crypto: data B58CheckWithPrefixError

- Tezos.Crypto: data Bls12381Fr

- Tezos.Crypto: data Bls12381G1

- Tezos.Crypto: data Bls12381G2

- Tezos.Crypto: data CryptoParseError

- Tezos.Crypto: data KeyHash

- Tezos.Crypto: data KeyHashTag

- Tezos.Crypto: data PublicKey

- Tezos.Crypto: data SecretKey

- Tezos.Crypto: data Signature

- Tezos.Crypto: decodeBase58Check :: Text -> Maybe ByteString

- Tezos.Crypto: decodeBase58CheckWithPrefix :: ByteString -> Text -> Either B58CheckWithPrefixError ByteString

- Tezos.Crypto: detSecretKey :: HasCallStack => ByteString -> SecretKey

- Tezos.Crypto: encodeBase58Check :: ByteString -> Text

- Tezos.Crypto: formatKeyHash :: KeyHash -> Text

- Tezos.Crypto: formatPublicKey :: PublicKey -> Text

- Tezos.Crypto: formatSecretKey :: SecretKey -> Text

- Tezos.Crypto: formatSignature :: Signature -> Text

- Tezos.Crypto: hashKey :: PublicKey -> KeyHash

- Tezos.Crypto: instance Control.DeepSeq.NFData Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Control.DeepSeq.NFData Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance Control.DeepSeq.NFData Tezos.Crypto.PublicKey

- Tezos.Crypto: instance Control.DeepSeq.NFData Tezos.Crypto.SecretKey

- Tezos.Crypto: instance Control.DeepSeq.NFData Tezos.Crypto.Signature

- Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Crypto.PublicKey

- Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSON Tezos.Crypto.Signature

- Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSONKey Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Crypto.PublicKey

- Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSON Tezos.Crypto.Signature

- Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSONKey Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Formatting.Buildable.Buildable Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Formatting.Buildable.Buildable Tezos.Crypto.ParseSignatureRawError

- Tezos.Crypto: instance Formatting.Buildable.Buildable Tezos.Crypto.PublicKey

- Tezos.Crypto: instance Formatting.Buildable.Buildable Tezos.Crypto.SecretKey

- Tezos.Crypto: instance Formatting.Buildable.Buildable Tezos.Crypto.Signature

- Tezos.Crypto: instance GHC.Classes.Eq Tezos.Crypto.KeyHash

- Tezos.Crypto: instance GHC.Classes.Eq Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance GHC.Classes.Eq Tezos.Crypto.ParseSignatureRawError

- Tezos.Crypto: instance GHC.Classes.Eq Tezos.Crypto.PublicKey

- Tezos.Crypto: instance GHC.Classes.Eq Tezos.Crypto.SecretKey

- Tezos.Crypto: instance GHC.Classes.Eq Tezos.Crypto.Signature

- Tezos.Crypto: instance GHC.Classes.Ord Tezos.Crypto.KeyHash

- Tezos.Crypto: instance GHC.Classes.Ord Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance GHC.Classes.Ord Tezos.Crypto.PublicKey

- Tezos.Crypto: instance GHC.Classes.Ord Tezos.Crypto.Signature

- Tezos.Crypto: instance GHC.Enum.Bounded Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance GHC.Enum.Enum Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance GHC.Generics.Generic Tezos.Crypto.KeyHash

- Tezos.Crypto: instance GHC.Generics.Generic Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance GHC.Generics.Generic Tezos.Crypto.ParseSignatureRawError

- Tezos.Crypto: instance GHC.Generics.Generic Tezos.Crypto.PublicKey

- Tezos.Crypto: instance GHC.Generics.Generic Tezos.Crypto.SecretKey

- Tezos.Crypto: instance GHC.Generics.Generic Tezos.Crypto.Signature

- Tezos.Crypto: instance GHC.Show.Show Tezos.Crypto.KeyHash

- Tezos.Crypto: instance GHC.Show.Show Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance GHC.Show.Show Tezos.Crypto.ParseSignatureRawError

- Tezos.Crypto: instance GHC.Show.Show Tezos.Crypto.PublicKey

- Tezos.Crypto: instance GHC.Show.Show Tezos.Crypto.SecretKey

- Tezos.Crypto: instance GHC.Show.Show Tezos.Crypto.Signature

- Tezos.Crypto: instance Language.Haskell.TH.Syntax.Lift Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Language.Haskell.TH.Syntax.Lift Tezos.Crypto.KeyHashTag

- Tezos.Crypto: instance Util.CLI.HasCLReader Tezos.Crypto.KeyHash

- Tezos.Crypto: instance Util.CLI.HasCLReader Tezos.Crypto.SecretKey

- Tezos.Crypto: keccak :: ByteString -> ByteString

- Tezos.Crypto: keyDecoders :: [TaggedDecoder PublicKey]

- Tezos.Crypto: keyHashDecoders :: [TaggedDecoder KeyHash]

- Tezos.Crypto: keyHashLengthBytes :: Integral n => n

- Tezos.Crypto: mformatKeyHash :: KeyHash -> MText

- Tezos.Crypto: mformatPublicKey :: PublicKey -> MText

- Tezos.Crypto: mformatSignature :: Signature -> MText

- Tezos.Crypto: mkSignature :: ByteArray ba => ba -> Maybe Signature

- Tezos.Crypto: parseKeyHash :: Text -> Either CryptoParseError KeyHash

- Tezos.Crypto: parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash

- Tezos.Crypto: parsePublicKey :: Text -> Either CryptoParseError PublicKey

- Tezos.Crypto: parsePublicKeyRaw :: ByteString -> Either Text PublicKey

- Tezos.Crypto: parseSecretKey :: Text -> Either CryptoParseError SecretKey

- Tezos.Crypto: parseSignature :: Text -> Either CryptoParseError Signature

- Tezos.Crypto: parseSignatureRaw :: ByteString -> Either ParseSignatureRawError Signature

- Tezos.Crypto: sha256 :: ByteString -> ByteString

- Tezos.Crypto: sha3 :: ByteString -> ByteString

- Tezos.Crypto: sha512 :: ByteString -> ByteString

- Tezos.Crypto: sign :: MonadRandom m => SecretKey -> ByteString -> m Signature

- Tezos.Crypto: signatureLengthBytes :: HasCallStack => Integral n => n

- Tezos.Crypto: signatureToBytes :: ByteArray ba => Signature -> ba

- Tezos.Crypto: toPublic :: SecretKey -> PublicKey

- Tezos.Crypto: unsafeParseKeyHash :: HasCallStack => Text -> KeyHash

- Tezos.Crypto.BLS12381: CompressedFormIsNotSupported :: DeserializationError

- Tezos.Crypto.BLS12381: PointNotOnCurve :: ByteString -> DeserializationError

- Tezos.Crypto.BLS12381: TooLargeLength :: ("limit" :! Int) -> ("given" :! Int) -> DeserializationError

- Tezos.Crypto.BLS12381: UnexpectedLength :: ("expected" :! Int) -> ("given" :! Int) -> DeserializationError

- Tezos.Crypto.BLS12381: ValueOutsideOfField :: Integer -> DeserializationError

- Tezos.Crypto.BLS12381: add :: CurveObject a => a -> a -> a

- Tezos.Crypto.BLS12381: checkPairing :: [(Bls12381G1, Bls12381G2)] -> Bool

- Tezos.Crypto.BLS12381: class CurveObject a

- Tezos.Crypto.BLS12381: class MultiplyPoint scalar point

- Tezos.Crypto.BLS12381: data Bls12381Fr

- Tezos.Crypto.BLS12381: data Bls12381G1

- Tezos.Crypto.BLS12381: data Bls12381G2

- Tezos.Crypto.BLS12381: data DeserializationError

- Tezos.Crypto.BLS12381: fromMichelsonBytes :: CurveObject a => ByteString -> Either DeserializationError a

- Tezos.Crypto.BLS12381: g1One :: Bls12381G1

- Tezos.Crypto.BLS12381: g2One :: Bls12381G2

- Tezos.Crypto.BLS12381: generate :: (CurveObject a, MonadRandom m) => m a

- Tezos.Crypto.BLS12381: generateFrom :: CurveObject a => Int -> a

- Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Tezos.Crypto.BLS12381.Bls12381G1

- Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Tezos.Crypto.BLS12381.Bls12381G2

- Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Tezos.Crypto.BLS12381.DeserializationError

- Tezos.Crypto.BLS12381: instance Formatting.Buildable.Buildable Tezos.Crypto.BLS12381.DeserializationError

- Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Tezos.Crypto.BLS12381.Bls12381G1

- Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Tezos.Crypto.BLS12381.Bls12381G2

- Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Tezos.Crypto.BLS12381.DeserializationError

- Tezos.Crypto.BLS12381: instance GHC.Classes.Ord Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Enum.Bounded Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Enum.Enum Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Generics.Generic Tezos.Crypto.BLS12381.DeserializationError

- Tezos.Crypto.BLS12381: instance GHC.Num.Num Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Real.Fractional Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Real.Integral Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Real.Real Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Show.Show Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance GHC.Show.Show Tezos.Crypto.BLS12381.Bls12381G1

- Tezos.Crypto.BLS12381: instance GHC.Show.Show Tezos.Crypto.BLS12381.Bls12381G2

- Tezos.Crypto.BLS12381: instance GHC.Show.Show Tezos.Crypto.BLS12381.DeserializationError

- Tezos.Crypto.BLS12381: instance Michelson.Printer.Util.RenderDoc Tezos.Crypto.BLS12381.DeserializationError

- Tezos.Crypto.BLS12381: instance Tezos.Crypto.BLS12381.CurveObject Tezos.Crypto.BLS12381.Bls12381Fr

- Tezos.Crypto.BLS12381: instance Tezos.Crypto.BLS12381.CurveObject Tezos.Crypto.BLS12381.Bls12381G1

- Tezos.Crypto.BLS12381: instance Tezos.Crypto.BLS12381.CurveObject Tezos.Crypto.BLS12381.Bls12381G2

- Tezos.Crypto.BLS12381: instance Tezos.Crypto.BLS12381.MultiplyPoint GHC.Integer.Type.Integer Tezos.Crypto.BLS12381.Bls12381G1

- Tezos.Crypto.BLS12381: instance Tezos.Crypto.BLS12381.MultiplyPoint GHC.Integer.Type.Integer Tezos.Crypto.BLS12381.Bls12381G2

- Tezos.Crypto.BLS12381: instance Tezos.Crypto.BLS12381.MultiplyPoint Tezos.Crypto.BLS12381.Bls12381Fr Tezos.Crypto.BLS12381.Bls12381G1

- Tezos.Crypto.BLS12381: instance Tezos.Crypto.BLS12381.MultiplyPoint Tezos.Crypto.BLS12381.Bls12381Fr Tezos.Crypto.BLS12381.Bls12381G2

- Tezos.Crypto.BLS12381: multiply :: MultiplyPoint scalar point => scalar -> point -> point

- Tezos.Crypto.BLS12381: negate :: CurveObject a => a -> a

- Tezos.Crypto.BLS12381: toMichelsonBytes :: CurveObject a => a -> ByteString

- Tezos.Crypto.BLS12381: unsafeFromMichelsonBytes :: (CurveObject a, HasCallStack) => ByteString -> a

- Tezos.Crypto.BLS12381: unsafeReadFromHex :: (CurveObject a, HasCallStack) => String -> a

- Tezos.Crypto.BLS12381: zero :: CurveObject a => a

- Tezos.Crypto.Ed25519: PublicKey :: PublicKey -> PublicKey

- Tezos.Crypto.Ed25519: Signature :: Signature -> Signature

- Tezos.Crypto.Ed25519: [unPublicKey] :: PublicKey -> PublicKey

- Tezos.Crypto.Ed25519: [unSignature] :: Signature -> Signature

- Tezos.Crypto.Ed25519: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

- Tezos.Crypto.Ed25519: data SecretKey

- Tezos.Crypto.Ed25519: detSecretKey :: ByteString -> SecretKey

- Tezos.Crypto.Ed25519: formatPublicKey :: PublicKey -> Text

- Tezos.Crypto.Ed25519: formatSecretKey :: SecretKey -> Text

- Tezos.Crypto.Ed25519: formatSignature :: Signature -> Text

- Tezos.Crypto.Ed25519: instance Control.DeepSeq.NFData Tezos.Crypto.Ed25519.PublicKey

- Tezos.Crypto.Ed25519: instance Control.DeepSeq.NFData Tezos.Crypto.Ed25519.SecretKey

- Tezos.Crypto.Ed25519: instance Control.DeepSeq.NFData Tezos.Crypto.Ed25519.Signature

- Tezos.Crypto.Ed25519: instance Formatting.Buildable.Buildable Tezos.Crypto.Ed25519.PublicKey

- Tezos.Crypto.Ed25519: instance Formatting.Buildable.Buildable Tezos.Crypto.Ed25519.SecretKey

- Tezos.Crypto.Ed25519: instance Formatting.Buildable.Buildable Tezos.Crypto.Ed25519.Signature

- Tezos.Crypto.Ed25519: instance GHC.Classes.Eq Tezos.Crypto.Ed25519.PublicKey

- Tezos.Crypto.Ed25519: instance GHC.Classes.Eq Tezos.Crypto.Ed25519.SecretKey

- Tezos.Crypto.Ed25519: instance GHC.Classes.Eq Tezos.Crypto.Ed25519.Signature

- Tezos.Crypto.Ed25519: instance GHC.Classes.Ord Tezos.Crypto.Ed25519.PublicKey

- Tezos.Crypto.Ed25519: instance GHC.Generics.Generic Tezos.Crypto.Ed25519.PublicKey

- Tezos.Crypto.Ed25519: instance GHC.Generics.Generic Tezos.Crypto.Ed25519.SecretKey

- Tezos.Crypto.Ed25519: instance GHC.Generics.Generic Tezos.Crypto.Ed25519.Signature

- Tezos.Crypto.Ed25519: instance GHC.Show.Show Tezos.Crypto.Ed25519.PublicKey

- Tezos.Crypto.Ed25519: instance GHC.Show.Show Tezos.Crypto.Ed25519.SecretKey

- Tezos.Crypto.Ed25519: instance GHC.Show.Show Tezos.Crypto.Ed25519.Signature

- Tezos.Crypto.Ed25519: mformatPublicKey :: PublicKey -> MText

- Tezos.Crypto.Ed25519: mformatSignature :: Signature -> MText

- Tezos.Crypto.Ed25519: mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey

- Tezos.Crypto.Ed25519: mkSignature :: ByteArrayAccess ba => ba -> Either CryptoParseError Signature

- Tezos.Crypto.Ed25519: newtype PublicKey

- Tezos.Crypto.Ed25519: newtype Signature

- Tezos.Crypto.Ed25519: parsePublicKey :: Text -> Either CryptoParseError PublicKey

- Tezos.Crypto.Ed25519: parseSecretKey :: Text -> Either CryptoParseError SecretKey

- Tezos.Crypto.Ed25519: parseSignature :: Text -> Either CryptoParseError Signature

- Tezos.Crypto.Ed25519: publicKeyLengthBytes :: Integral n => n

- Tezos.Crypto.Ed25519: publicKeyToBytes :: ByteArray ba => PublicKey -> ba

- Tezos.Crypto.Ed25519: sign :: SecretKey -> ByteString -> Signature

- Tezos.Crypto.Ed25519: signatureLengthBytes :: Integral n => n

- Tezos.Crypto.Ed25519: signatureToBytes :: ByteArray ba => Signature -> ba

- Tezos.Crypto.Ed25519: toPublic :: SecretKey -> PublicKey

- Tezos.Crypto.Hash: blake2b :: ByteString -> ByteString

- Tezos.Crypto.Hash: blake2b160 :: ByteString -> ByteString

- Tezos.Crypto.Hash: keccak :: ByteString -> ByteString

- Tezos.Crypto.Hash: sha256 :: ByteString -> ByteString

- Tezos.Crypto.Hash: sha3 :: ByteString -> ByteString

- Tezos.Crypto.Hash: sha512 :: ByteString -> ByteString

- Tezos.Crypto.P256: PublicKey :: PublicKey -> PublicKey

- Tezos.Crypto.P256: Signature :: Signature -> Signature

- Tezos.Crypto.P256: [unPublicKey] :: PublicKey -> PublicKey

- Tezos.Crypto.P256: [unSignature] :: Signature -> Signature

- Tezos.Crypto.P256: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

- Tezos.Crypto.P256: data SecretKey

- Tezos.Crypto.P256: detSecretKey :: ByteString -> SecretKey

- Tezos.Crypto.P256: detSecretKeyDo :: MonadRandom m => m SecretKey

- Tezos.Crypto.P256: formatPublicKey :: PublicKey -> Text

- Tezos.Crypto.P256: formatSecretKey :: SecretKey -> Text

- Tezos.Crypto.P256: formatSignature :: Signature -> Text

- Tezos.Crypto.P256: instance Control.DeepSeq.NFData Tezos.Crypto.P256.PublicKey

- Tezos.Crypto.P256: instance Control.DeepSeq.NFData Tezos.Crypto.P256.SecretKey

- Tezos.Crypto.P256: instance Control.DeepSeq.NFData Tezos.Crypto.P256.Signature

- Tezos.Crypto.P256: instance Formatting.Buildable.Buildable Tezos.Crypto.P256.PublicKey

- Tezos.Crypto.P256: instance Formatting.Buildable.Buildable Tezos.Crypto.P256.SecretKey

- Tezos.Crypto.P256: instance Formatting.Buildable.Buildable Tezos.Crypto.P256.Signature

- Tezos.Crypto.P256: instance GHC.Classes.Eq Tezos.Crypto.P256.PublicKey

- Tezos.Crypto.P256: instance GHC.Classes.Eq Tezos.Crypto.P256.SecretKey

- Tezos.Crypto.P256: instance GHC.Classes.Eq Tezos.Crypto.P256.Signature

- Tezos.Crypto.P256: instance GHC.Classes.Ord Tezos.Crypto.P256.PublicKey

- Tezos.Crypto.P256: instance GHC.Generics.Generic Tezos.Crypto.P256.PublicKey

- Tezos.Crypto.P256: instance GHC.Generics.Generic Tezos.Crypto.P256.SecretKey

- Tezos.Crypto.P256: instance GHC.Generics.Generic Tezos.Crypto.P256.Signature

- Tezos.Crypto.P256: instance GHC.Show.Show Tezos.Crypto.P256.PublicKey

- Tezos.Crypto.P256: instance GHC.Show.Show Tezos.Crypto.P256.SecretKey

- Tezos.Crypto.P256: instance GHC.Show.Show Tezos.Crypto.P256.Signature

- Tezos.Crypto.P256: mformatPublicKey :: PublicKey -> MText

- Tezos.Crypto.P256: mformatSignature :: Signature -> MText

- Tezos.Crypto.P256: mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey

- Tezos.Crypto.P256: mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature

- Tezos.Crypto.P256: newtype PublicKey

- Tezos.Crypto.P256: newtype Signature

- Tezos.Crypto.P256: parsePublicKey :: Text -> Either CryptoParseError PublicKey

- Tezos.Crypto.P256: parseSecretKey :: Text -> Either CryptoParseError SecretKey

- Tezos.Crypto.P256: parseSignature :: Text -> Either CryptoParseError Signature

- Tezos.Crypto.P256: publicKeyLengthBytes :: Integral n => n

- Tezos.Crypto.P256: publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba

- Tezos.Crypto.P256: sign :: MonadRandom m => SecretKey -> ByteString -> m Signature

- Tezos.Crypto.P256: signatureLengthBytes :: Integral n => n

- Tezos.Crypto.P256: signatureToBytes :: ByteArray ba => Signature -> ba

- Tezos.Crypto.P256: toPublic :: SecretKey -> PublicKey

- Tezos.Crypto.Secp256k1: PublicKey :: PublicKey -> PublicKey

- Tezos.Crypto.Secp256k1: Signature :: Signature -> Signature

- Tezos.Crypto.Secp256k1: [unPublicKey] :: PublicKey -> PublicKey

- Tezos.Crypto.Secp256k1: [unSignature] :: Signature -> Signature

- Tezos.Crypto.Secp256k1: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

- Tezos.Crypto.Secp256k1: data SecretKey

- Tezos.Crypto.Secp256k1: detSecretKey :: ByteString -> SecretKey

- Tezos.Crypto.Secp256k1: detSecretKeyDo :: MonadRandom m => m SecretKey

- Tezos.Crypto.Secp256k1: formatPublicKey :: PublicKey -> Text

- Tezos.Crypto.Secp256k1: formatSecretKey :: SecretKey -> Text

- Tezos.Crypto.Secp256k1: formatSignature :: Signature -> Text

- Tezos.Crypto.Secp256k1: instance Control.DeepSeq.NFData Tezos.Crypto.Secp256k1.PublicKey

- Tezos.Crypto.Secp256k1: instance Control.DeepSeq.NFData Tezos.Crypto.Secp256k1.SecretKey

- Tezos.Crypto.Secp256k1: instance Control.DeepSeq.NFData Tezos.Crypto.Secp256k1.Signature

- Tezos.Crypto.Secp256k1: instance Formatting.Buildable.Buildable Tezos.Crypto.Secp256k1.PublicKey

- Tezos.Crypto.Secp256k1: instance Formatting.Buildable.Buildable Tezos.Crypto.Secp256k1.SecretKey

- Tezos.Crypto.Secp256k1: instance Formatting.Buildable.Buildable Tezos.Crypto.Secp256k1.Signature

- Tezos.Crypto.Secp256k1: instance GHC.Classes.Eq Tezos.Crypto.Secp256k1.PublicKey

- Tezos.Crypto.Secp256k1: instance GHC.Classes.Eq Tezos.Crypto.Secp256k1.SecretKey

- Tezos.Crypto.Secp256k1: instance GHC.Classes.Eq Tezos.Crypto.Secp256k1.Signature

- Tezos.Crypto.Secp256k1: instance GHC.Classes.Ord Tezos.Crypto.Secp256k1.PublicKey

- Tezos.Crypto.Secp256k1: instance GHC.Generics.Generic Tezos.Crypto.Secp256k1.PublicKey

- Tezos.Crypto.Secp256k1: instance GHC.Generics.Generic Tezos.Crypto.Secp256k1.SecretKey

- Tezos.Crypto.Secp256k1: instance GHC.Generics.Generic Tezos.Crypto.Secp256k1.Signature

- Tezos.Crypto.Secp256k1: instance GHC.Show.Show Tezos.Crypto.Secp256k1.PublicKey

- Tezos.Crypto.Secp256k1: instance GHC.Show.Show Tezos.Crypto.Secp256k1.SecretKey

- Tezos.Crypto.Secp256k1: instance GHC.Show.Show Tezos.Crypto.Secp256k1.Signature

- Tezos.Crypto.Secp256k1: mformatPublicKey :: PublicKey -> MText

- Tezos.Crypto.Secp256k1: mformatSignature :: Signature -> MText

- Tezos.Crypto.Secp256k1: mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey

- Tezos.Crypto.Secp256k1: mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature

- Tezos.Crypto.Secp256k1: newtype PublicKey

- Tezos.Crypto.Secp256k1: newtype Signature

- Tezos.Crypto.Secp256k1: parsePublicKey :: Text -> Either CryptoParseError PublicKey

- Tezos.Crypto.Secp256k1: parseSecretKey :: Text -> Either CryptoParseError SecretKey

- Tezos.Crypto.Secp256k1: parseSignature :: Text -> Either CryptoParseError Signature

- Tezos.Crypto.Secp256k1: publicKeyLengthBytes :: Integral n => n

- Tezos.Crypto.Secp256k1: publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba

- Tezos.Crypto.Secp256k1: sign :: MonadRandom m => SecretKey -> ByteString -> m Signature

- Tezos.Crypto.Secp256k1: signatureLengthBytes :: Integral n => n

- Tezos.Crypto.Secp256k1: signatureToBytes :: ByteArray ba => Signature -> ba

- Tezos.Crypto.Secp256k1: toPublic :: SecretKey -> PublicKey

- Tezos.Crypto.Util: B58CheckWithPrefixWrongEncoding :: B58CheckWithPrefixError

- Tezos.Crypto.Util: B58CheckWithPrefixWrongPrefix :: ByteString -> B58CheckWithPrefixError

- Tezos.Crypto.Util: CryptoParseBinaryError :: Text -> CryptoParseError

- Tezos.Crypto.Util: CryptoParseCryptoError :: CryptoError -> CryptoParseError

- Tezos.Crypto.Util: CryptoParseUnexpectedLength :: Builder -> Int -> CryptoParseError

- Tezos.Crypto.Util: CryptoParseWrongBase58Check :: CryptoParseError

- Tezos.Crypto.Util: CryptoParseWrongTag :: ByteString -> CryptoParseError

- Tezos.Crypto.Util: data B58CheckWithPrefixError

- Tezos.Crypto.Util: data CryptoParseError

- Tezos.Crypto.Util: decodeBase58Check :: Text -> Maybe ByteString

- Tezos.Crypto.Util: decodeBase58CheckWithPrefix :: ByteString -> Text -> Either B58CheckWithPrefixError ByteString

- Tezos.Crypto.Util: deterministic :: ByteString -> MonadPseudoRandom ChaChaDRG a -> a

- Tezos.Crypto.Util: encodeBase58Check :: ByteString -> Text

- Tezos.Crypto.Util: firstRight :: NonEmpty (Either e a) -> Either e a

- Tezos.Crypto.Util: formatImpl :: ByteArrayAccess x => ByteString -> x -> Text

- Tezos.Crypto.Util: instance Control.DeepSeq.NFData Tezos.Crypto.Util.CryptoParseError

- Tezos.Crypto.Util: instance Formatting.Buildable.Buildable Tezos.Crypto.Util.CryptoParseError

- Tezos.Crypto.Util: instance GHC.Classes.Eq Tezos.Crypto.Util.CryptoParseError

- Tezos.Crypto.Util: instance GHC.Show.Show Tezos.Crypto.Util.B58CheckWithPrefixError

- Tezos.Crypto.Util: instance GHC.Show.Show Tezos.Crypto.Util.CryptoParseError

- Tezos.Crypto.Util: instance Michelson.Printer.Util.RenderDoc Tezos.Crypto.Util.CryptoParseError

- Tezos.Crypto.Util: mkPublicKey_ :: ByteArrayAccess ba => Curve -> ba -> Either CryptoParseError PublicKey

- Tezos.Crypto.Util: mkSecretKey_ :: ByteArray ba => Curve -> ba -> KeyPair

- Tezos.Crypto.Util: mkSignature_ :: ByteArray ba => Curve -> ba -> Either CryptoParseError Signature

- Tezos.Crypto.Util: parseImpl :: ByteString -> (ByteString -> Either CryptoParseError res) -> Text -> Either CryptoParseError res

- Tezos.Crypto.Util: publicKeyLengthBytes_ :: Integral n => Curve -> n

- Tezos.Crypto.Util: publicKeyToBytes_ :: forall ba. (ByteArray ba, HasCallStack) => Curve -> PublicKey -> ba

- Tezos.Crypto.Util: rnfCurve :: Curve -> ()

- Tezos.Crypto.Util: secretKeyToBytes_ :: ByteArray ba => KeyPair -> ba

- Tezos.Crypto.Util: signatureLengthBytes_ :: Integral n => Curve -> n

- Tezos.Crypto.Util: signatureToBytes_ :: ByteArray ba => Curve -> Signature -> ba

- Util.Aeson: morleyAesonOptions :: Options

- Util.Alternative: someNE :: Alternative f => f a -> f (NonEmpty a)

- Util.Binary: (#:) :: Word8 -> Get a -> TaggedDecoder a

- Util.Binary: TaggedDecoder :: Word8 -> Get a -> TaggedDecoder a

- Util.Binary: UnpackError :: Text -> UnpackError

- Util.Binary: [tdDecoder] :: TaggedDecoder a -> Get a

- Util.Binary: [tdTag] :: TaggedDecoder a -> Word8

- Util.Binary: [unUnpackError] :: UnpackError -> Text

- Util.Binary: data TaggedDecoder a

- Util.Binary: decodeBytesLike :: Buildable err => String -> (ByteString -> Either err a) -> Get a

- Util.Binary: decodeWithTag :: String -> [TaggedDecoder a] -> Get a

- Util.Binary: ensureEnd :: Get ()

- Util.Binary: getByteStringCopy :: Int -> Get ByteString

- Util.Binary: getRemainingByteStringCopy :: Get ByteString

- Util.Binary: infixr 0 #:

- Util.Binary: instance Formatting.Buildable.Buildable Util.Binary.UnpackError

- Util.Binary: instance GHC.Classes.Eq Util.Binary.UnpackError

- Util.Binary: instance GHC.Exception.Type.Exception Util.Binary.UnpackError

- Util.Binary: instance GHC.Show.Show Util.Binary.UnpackError

- Util.Binary: launchGet :: Get a -> LByteString -> Either UnpackError a

- Util.Binary: newtype UnpackError

- Util.Binary: unknownTag :: String -> Word8 -> Get a

- Util.ByteString: HexJSONByteString :: ByteString -> HexJSONByteString

- Util.ByteString: [unHexJSONByteString] :: HexJSONByteString -> ByteString

- Util.ByteString: instance Control.DeepSeq.NFData Util.ByteString.HexJSONByteString

- Util.ByteString: instance Data.Aeson.Types.FromJSON.FromJSON Util.ByteString.HexJSONByteString

- Util.ByteString: instance Data.Aeson.Types.ToJSON.ToJSON Util.ByteString.HexJSONByteString

- Util.ByteString: instance Data.Hashable.Class.Hashable Util.ByteString.HexJSONByteString

- Util.ByteString: instance GHC.Classes.Eq Util.ByteString.HexJSONByteString

- Util.ByteString: instance GHC.Classes.Ord Util.ByteString.HexJSONByteString

- Util.ByteString: instance GHC.Generics.Generic Util.ByteString.HexJSONByteString

- Util.ByteString: instance GHC.Show.Show Util.ByteString.HexJSONByteString

- Util.ByteString: newtype HexJSONByteString

- Util.CLI: class HasCLReader a

- Util.CLI: eitherReader :: (String -> Either String a) -> ReadM a

- Util.CLI: getMetavar :: HasCLReader a => String

- Util.CLI: getReader :: HasCLReader a => ReadM a

- Util.CLI: instance Util.CLI.HasCLReader Data.Text.Internal.Text

- Util.CLI: instance Util.CLI.HasCLReader GHC.Base.String

- Util.CLI: instance Util.CLI.HasCLReader GHC.Int.Int16

- Util.CLI: instance Util.CLI.HasCLReader GHC.Int.Int32

- Util.CLI: instance Util.CLI.HasCLReader GHC.Int.Int64

- Util.CLI: instance Util.CLI.HasCLReader GHC.Int.Int8

- Util.CLI: instance Util.CLI.HasCLReader GHC.Integer.Type.Integer

- Util.CLI: instance Util.CLI.HasCLReader GHC.Natural.Natural

- Util.CLI: instance Util.CLI.HasCLReader GHC.Types.Int

- Util.CLI: instance Util.CLI.HasCLReader GHC.Types.Word

- Util.CLI: instance Util.CLI.HasCLReader GHC.Word.Word16

- Util.CLI: instance Util.CLI.HasCLReader GHC.Word.Word32

- Util.CLI: instance Util.CLI.HasCLReader GHC.Word.Word64

- Util.CLI: instance Util.CLI.HasCLReader GHC.Word.Word8

- Util.CLI: integralReader :: Integral a => ReadM a

- Util.CLI: maybeAddDefault :: HasValue f => (a -> String) -> Maybe a -> Mod f a

- Util.CLI: mkCLArgumentParser :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("help" :! String) -> Parser a

- Util.CLI: mkCLArgumentParserExt :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("help" :! String) -> [Mod ArgumentFields a] -> Parser a

- Util.CLI: mkCLOptionParser :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a

- Util.CLI: mkCLOptionParserExt :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("name" :! String) -> ("help" :! String) -> [Mod OptionFields a] -> Parser a

- Util.CLI: mkCommandParser :: String -> Parser a -> String -> Mod CommandFields a

- Util.CLI: namedParser :: forall (a :: Type) (name :: Symbol). (Buildable a, HasCLReader a, KnownSymbol name) => Maybe a -> String -> Parser (name :! a)

- Util.CLI: outputOption :: Parser (Maybe FilePath)

- Util.CLI: readerError :: String -> ReadM a

- Util.CustomGeneric: alphabetically :: EntriesReorder

- Util.CustomGeneric: cstr :: forall n. KnownNat n => [Natural] -> CstrDepth

- Util.CustomGeneric: customGeneric :: String -> GenericStrategy -> Q [Dec]

- Util.CustomGeneric: customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]

- Util.CustomGeneric: data GenericStrategy

- Util.CustomGeneric: deriveFullType :: Name -> Maybe Kind -> [TyVarBndr] -> TypeQ

- Util.CustomGeneric: fld :: forall n. KnownNat n => Natural

- Util.CustomGeneric: forbidUnnamedFields :: UnnamedEntriesReorder

- Util.CustomGeneric: fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy

- Util.CustomGeneric: haskellBalanced :: GenericStrategy

- Util.CustomGeneric: leaveUnnamedFields :: UnnamedEntriesReorder

- Util.CustomGeneric: leftBalanced :: GenericStrategy

- Util.CustomGeneric: leftComb :: GenericStrategy

- Util.CustomGeneric: reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])

- Util.CustomGeneric: reorderingConstrs :: EntriesReorder -> GenericStrategy -> GenericStrategy

- Util.CustomGeneric: reorderingData :: UnnamedEntriesReorder -> EntriesReorder -> GenericStrategy -> GenericStrategy

- Util.CustomGeneric: reorderingFields :: UnnamedEntriesReorder -> EntriesReorder -> GenericStrategy -> GenericStrategy

- Util.CustomGeneric: rightBalanced :: GenericStrategy

- Util.CustomGeneric: rightComb :: GenericStrategy

- Util.CustomGeneric: withDepths :: [CstrDepth] -> GenericStrategy

- Util.Default: class Default a

- Util.Default: def :: Default a => a

- Util.Default: permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a, b)

- Util.Default: permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) => f a -> f b -> f c -> f (a, b, c)

- Util.Exception: throwLeft :: (MonadThrow m, Exception e) => m (Either e a) -> m a

- Util.Fcf: data (<|>) :: f a -> f a -> Exp (f a)

- Util.Fcf: data ApplyConstraints :: [a -> Constraint] -> a -> Exp Constraint

- Util.Fcf: data Over2 :: (a -> b -> Exp r) -> (x -> Exp a) -> (x -> Exp b) -> x -> Exp r

- Util.Fcf: data TyEqSing :: a -> b -> Exp Bool

- Util.Fcf: type family Eval (e :: Exp a) :: a

- Util.Generic: mkGenericTree :: (Natural -> a -> a -> a) -> NonEmpty a -> a

- Util.Generic: mkGenericTreeVec :: HasCallStack => (a -> b) -> (Natural -> b -> b -> b) -> Vector a -> b

- Util.Generic: type GenericTypeName a = GTypeName (Rep a)

- Util.Instances: instance Data.Default.Class.Default GHC.Natural.Natural

- Util.Instances: instance Formatting.Buildable.Buildable GHC.Natural.Natural

- Util.Instances: instance Formatting.Buildable.Buildable a => Formatting.Buildable.Buildable (Data.Functor.Identity.Identity a)

- Util.Instances: instance forall u (f :: u -> *) (xs :: [u]). Data.Vinyl.Core.ReifyConstraint Control.DeepSeq.NFData f xs => Control.DeepSeq.NFData (Data.Vinyl.Core.Rec f xs)

- Util.Label: [Label] :: KnownSymbol name => Label name

- Util.Label: class IsLabel (x :: Symbol) a

- Util.Label: data Label (name :: Symbol)

- Util.Label: fromLabel :: IsLabel x a => a

- Util.Label: instance (GHC.TypeLits.KnownSymbol name, s GHC.Types.~ name) => GHC.OverloadedLabels.IsLabel s (Util.Label.Label name)

- Util.Label: instance Formatting.Buildable.Buildable (Util.Label.Label name)

- Util.Label: instance GHC.Classes.Eq (Util.Label.Label name)

- Util.Label: instance GHC.Show.Show (Util.Label.Label name)

- Util.Label: labelToText :: Label name -> Text

- Util.Lens: makeLensesWith :: LensRules -> Name -> DecsQ

- Util.Lens: postfixLFields :: LensRules

- Util.Main: wrapMain :: IO () -> IO ()

- Util.Markdown: Anchor :: Text -> Anchor

- Util.Markdown: HeaderLevel :: Int -> HeaderLevel

- Util.Markdown: [unAnchor] :: Anchor -> Text

- Util.Markdown: class ToAnchor anchor

- Util.Markdown: instance Data.String.IsString Util.Markdown.Anchor

- Util.Markdown: instance Util.Markdown.ToAnchor Data.Text.Internal.Text

- Util.Markdown: instance Util.Markdown.ToAnchor Util.Markdown.Anchor

- Util.Markdown: md :: QuasiQuoter

- Util.Markdown: mdAnchor :: ToAnchor anchor => anchor -> Markdown

- Util.Markdown: mdBold :: Markdown -> Markdown

- Util.Markdown: mdComment :: Builder -> Builder

- Util.Markdown: mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown

- Util.Markdown: mdHeader :: HeaderLevel -> Markdown -> Markdown

- Util.Markdown: mdItalic :: Markdown -> Markdown

- Util.Markdown: mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown

- Util.Markdown: mdRef :: Markdown -> Markdown -> Markdown

- Util.Markdown: mdSeparator :: Markdown

- Util.Markdown: mdSpoiler :: Markdown -> Markdown -> Markdown

- Util.Markdown: mdSubsection :: Markdown -> Markdown -> Markdown

- Util.Markdown: mdSubsectionTitle :: Markdown -> Markdown

- Util.Markdown: mdTicked :: Markdown -> Markdown

- Util.Markdown: mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown

- Util.Markdown: newtype Anchor

- Util.Markdown: newtype HeaderLevel

- Util.Markdown: nextHeaderLevel :: HeaderLevel -> HeaderLevel

- Util.Markdown: toAnchor :: ToAnchor anchor => anchor -> Anchor

- Util.Markdown: type Markdown = Builder

- Util.Named: (.!) :: Name name -> a -> NamedF Identity a name

- Util.Named: (.?) :: Name name -> Maybe a -> NamedF Maybe a name

- Util.Named: (<.!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)

- Util.Named: (<.?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)

- Util.Named: class KnownNamedFunctor f

- Util.Named: infixl 4 <.?>

- Util.Named: instance (Data.Typeable.Internal.Typeable f, Data.Typeable.Internal.Typeable a, GHC.TypeLits.KnownSymbol name, Data.Data.Data (f a)) => Data.Data.Data (Named.Internal.NamedF f a name)

- Util.Named: instance (GHC.Show.Show a, GHC.TypeLits.KnownSymbol name) => GHC.Show.Show (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

- Util.Named: instance (GHC.TypeLits.KnownSymbol name, Formatting.Buildable.Buildable (f a)) => Formatting.Buildable.Buildable (Named.Internal.NamedF f a name)

- Util.Named: instance Control.DeepSeq.NFData (f a) => Control.DeepSeq.NFData (Named.Internal.NamedF f a name)

- Util.Named: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

- Util.Named: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Named.Internal.NamedF GHC.Maybe.Maybe a name)

- Util.Named: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

- Util.Named: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Named.Internal.NamedF GHC.Maybe.Maybe a name)

- Util.Named: instance GHC.Classes.Eq (f a) => GHC.Classes.Eq (Named.Internal.NamedF f a name)

- Util.Named: instance GHC.Classes.Ord (f a) => GHC.Classes.Ord (Named.Internal.NamedF f a name)

- Util.Named: instance Util.Named.KnownNamedFunctor Data.Functor.Identity.Identity

- Util.Named: instance Util.Named.KnownNamedFunctor GHC.Maybe.Maybe

- Util.Named: namedL :: KnownNamedFunctor f => Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a)

- Util.Named: type (name :: Symbol) :? a = NamedF Maybe a name

- Util.Named: type family NamedInner (n :: Type)

- Util.Num: fromIntegralChecked :: (Integral a, Integral b) => a -> Either Text b

- Util.Peano: S :: !Nat -> Nat

- Util.Peano: Z :: Nat

- Util.Peano: [SS] :: !SingNat n -> SingNat ('S n)

- Util.Peano: [SZ] :: SingNat 'Z

- Util.Peano: class (RequireLongerOrSameLength' l a, LongerOrSameLength l a) => RequireLongerOrSameLength (l :: [k]) (a :: Peano)

- Util.Peano: class (RequireLongerThan' l a, LongerThan l a) => RequireLongerThan (l :: [k]) (a :: Peano)

- Util.Peano: data Nat

- Util.Peano: data SingNat (n :: Nat)

- Util.Peano: instance Control.DeepSeq.NFData (Util.Peano.SingNat n)

- Util.Peano: instance Data.Singletons.Internal.SingI 'Data.Vinyl.TypeLevel.Z

- Util.Peano: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Data.Vinyl.TypeLevel.S n)

- Util.Peano: instance GHC.Classes.Eq (Util.Peano.SingNat n)

- Util.Peano: instance GHC.Show.Show (Util.Peano.SingNat n)

- Util.Peano: instance forall k (l :: [k]) (a :: Data.Vinyl.TypeLevel.Nat). (Util.Peano.RequireLongerThan' l a, Util.Peano.LongerThan l a) => Util.Peano.RequireLongerThan l a

- Util.Peano: instance forall k (l :: [k]) (a :: Util.Peano.Peano). (Util.Peano.RequireLongerOrSameLength' l a, Util.Peano.LongerOrSameLength l a) => Util.Peano.RequireLongerOrSameLength l a

- Util.Peano: instance forall k (l :: [k]) (a :: Util.Peano.Peano). Util.Type.MockableConstraint (Util.Peano.RequireLongerOrSameLength l a)

- Util.Peano: instance forall k (l :: [k]) (a :: Util.Peano.Peano). Util.Type.MockableConstraint (Util.Peano.RequireLongerThan l a)

- Util.Peano: isGreaterEqualThan :: Sing a -> Sing b -> Maybe (Dict ((a >= b) ~ 'True))

- Util.Peano: isGreaterThan :: Sing a -> Sing b -> Maybe (Dict ((a > b) ~ 'True))

- Util.Peano: peanoSing :: forall (n :: Nat). SingI (ToPeano n) => SingNat (ToPeano n)

- Util.Peano: peanoSingDecrement :: Sing n -> Maybe (Sing (Decrement n))

- Util.Peano: requireLongerOrSameLength :: Rec any stk -> Sing n -> Maybe (Dict (RequireLongerOrSameLength stk n))

- Util.Peano: requireLongerThan :: Rec any stk -> Sing n -> Maybe (Dict (RequireLongerThan stk n))

- Util.Peano: type LongerOrSameLength l a = IsLongerOrSameLength l a ~ 'True

- Util.Peano: type LongerThan l a = IsLongerThan l a ~ 'True

- Util.Peano: type Peano = Nat

- Util.Peano: type family IsLongerOrSameLength (l :: [k]) (a :: Peano) :: Bool

- Util.PeanoNatural: data PeanoNatural (n :: Nat)

- Util.PeanoNatural: fromPeanoNatural :: forall n. PeanoNatural n -> Natural

- Util.PeanoNatural: instance Control.DeepSeq.NFData (Util.PeanoNatural.PeanoNatural n)

- Util.PeanoNatural: instance GHC.Classes.Eq (Util.PeanoNatural.PeanoNatural n)

- Util.PeanoNatural: instance GHC.Show.Show (Util.PeanoNatural.PeanoNatural n)

- Util.PeanoNatural: instance Michelson.Printer.Util.RenderDoc (Util.PeanoNatural.PeanoNatural n)

- Util.PeanoNatural: pattern Two :: () => n ~ 'S ('S 'Z) => PeanoNatural n

- Util.PeanoNatural: singPeanoVal :: forall (n :: Nat). SingNat n -> Natural

- Util.PeanoNatural: toPeanoNatural :: forall n. SingI n => PeanoNatural n

- Util.PeanoNatural: toPeanoNatural' :: forall (n :: Nat). SingI (ToPeano n) => PeanoNatural (ToPeano n)

- Util.Positive: UnsafePositive :: Natural -> Positive

- Util.Positive: [unPositive] :: Positive -> Natural

- Util.Positive: instance Control.DeepSeq.NFData Util.Positive.Positive

- Util.Positive: instance Data.Aeson.Types.FromJSON.FromJSON Util.Positive.Positive

- Util.Positive: instance Data.Aeson.Types.ToJSON.ToJSON Util.Positive.Positive

- Util.Positive: instance Data.Data.Data Util.Positive.Positive

- Util.Positive: instance Formatting.Buildable.Buildable Util.Positive.Positive

- Util.Positive: instance GHC.Classes.Eq Util.Positive.Positive

- Util.Positive: instance GHC.Classes.Ord Util.Positive.Positive

- Util.Positive: instance GHC.Generics.Generic Util.Positive.Positive

- Util.Positive: instance GHC.Show.Show Util.Positive.Positive

- Util.Positive: lengthNE :: NonEmpty a -> Positive

- Util.Positive: mkPositive :: (Integral i, Buildable i) => i -> Either Text Positive

- Util.Positive: newtype Positive

- Util.Positive: replicateNE :: Positive -> a -> NonEmpty a

- Util.Sing: castSing :: forall a b t. (SingI a, SingI b, SDecide (KindOf a)) => t a -> Maybe (t b)

- Util.Sing: class SingI1 f

- Util.Sing: eqI :: forall a b. (SingI a, SingI b, TestEquality (Sing @(KindOf a))) => Maybe (a :~: b)

- Util.Sing: eqParamSing :: forall a1 a2 t. (SingI a1, SingI a2, SDecide (KindOf a1), Eq (t a1)) => t a1 -> t a2 -> Bool

- Util.Sing: eqParamSing2 :: forall a1 a2 b1 b2 t. (SingI a1, SingI a2, SingI b1, SingI b2, SDecide (KindOf a1), SDecide (KindOf b1), Eq (t a1 b2)) => t a1 b1 -> t a2 b2 -> Bool

- Util.Sing: eqParamSing3 :: forall instr1 instr2 a1 a2 b1 b2 t. (Typeable instr1, Typeable instr2, SingI a1, SingI a2, SingI b1, SingI b2, SDecide (KindOf a1), SDecide (KindOf b1), Eq (t instr1 a1 b1)) => t instr1 a1 b1 -> t instr2 a2 b2 -> Bool

- Util.Sing: withSingI1 :: forall x r. (SingI1 f, SingI x) => (SingI (f x) => r) -> r

- Util.TH: deriveGADTNFData :: Name -> Q [Dec]

- Util.TH: lookupTypeNameOrFail :: String -> Q Name

- Util.Text: headToLower :: HasCallStack => Text -> Text

- Util.Text: surround :: Semigroup a => a -> a -> a -> a

- Util.Type: Some1 :: f a -> Some1 (f :: k -> Type)

- Util.Type: [KCons] :: KnownList xs => Proxy x -> Proxy xs -> KList (x : xs)

- Util.Type: [KNil] :: KList '[]

- Util.Type: class KnownList l

- Util.Type: class MockableConstraint (c :: Constraint)

- Util.Type: class ReifyList (c :: k -> Constraint) (l :: [k])

- Util.Type: data KList (l :: [k])

- Util.Type: data Some1 (f :: k -> Type)

- Util.Type: failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True)

- Util.Type: failWhenEvi :: forall cond msg. FailWhen cond msg :- (cond ~ 'False)

- Util.Type: infix 4 ==

- Util.Type: instance (Util.Type.MockableConstraint c1, Util.Type.MockableConstraint c2) => Util.Type.MockableConstraint (c1, c2)

- Util.Type: instance (Util.Type.MockableConstraint c1, Util.Type.MockableConstraint c2, Util.Type.MockableConstraint c3) => Util.Type.MockableConstraint (c1, c2, c3)

- Util.Type: instance (Util.Type.MockableConstraint c1, Util.Type.MockableConstraint c2, Util.Type.MockableConstraint c3, Util.Type.MockableConstraint c4) => Util.Type.MockableConstraint (c1, c2, c3, c4)

- Util.Type: instance (Util.Type.MockableConstraint c1, Util.Type.MockableConstraint c2, Util.Type.MockableConstraint c3, Util.Type.MockableConstraint c4, Util.Type.MockableConstraint c5) => Util.Type.MockableConstraint (c1, c2, c3, c4, c5)

- Util.Type: instance Util.Type.KnownList '[]

- Util.Type: instance forall a (c :: a -> GHC.Types.Constraint) (x :: a) (xs :: [a]). (c x, Util.Type.ReifyList c xs) => Util.Type.ReifyList c (x : xs)

- Util.Type: instance forall k (a :: k) (b :: k). Util.Type.MockableConstraint (a GHC.Types.~ b)

- Util.Type: instance forall k (c :: k -> GHC.Types.Constraint) (a :: k). c a => Util.Type.MockableConstraint (c a)

- Util.Type: instance forall k (c :: k -> GHC.Types.Constraint). Util.Type.ReifyList c '[]

- Util.Type: instance forall k (f :: k -> *). (forall (a :: k). GHC.Show.Show (f a)) => GHC.Show.Show (Util.Type.Some1 f)

- Util.Type: instance forall k (xs :: [k]) (x :: k). Util.Type.KnownList xs => Util.Type.KnownList (x : xs)

- Util.Type: klist :: KnownList l => KList l

- Util.Type: listOfTypesConcatAssociativityAxiom :: forall a b c. Dict (ConcatListOfTypesAssociativity a b c)

- Util.Type: onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c

- Util.Type: recordToSomeList :: Rec f l -> [Some1 f]

- Util.Type: reifyList :: ReifyList c l => (forall a. c a => Proxy a -> r) -> [r]

- Util.Type: reifyTypeEquality :: forall a b x. (a == b) ~ 'True => (a ~ b => x) -> x

- Util.Type: rsplit :: forall k (l :: [k]) (r :: [k]) f. RSplit l r => Rec f (l ++ r) -> (Rec f l, Rec f r)

- Util.Type: type ConcatListOfTypesAssociativity a b c = ((a ++ b) ++ c) ~ (a ++ (b ++ c))

- Util.Type: type FailWhen cond msg = FailUnless (Not cond) msg

- Util.Type: type RSplit l r = KnownList l

- Util.Type: type RequireAllUnique desc l = RequireAllUnique' desc l l

- Util.Type: type family PatternMatchL (l :: [k]) :: Constraint

- Util.Type: unsafeProvideConstraint :: MockableConstraint c => Dict c

- Util.TypeLits: (:$$:) :: ErrorMessage -> ErrorMessage -> ErrorMessage

- Util.TypeLits: (:<>:) :: ErrorMessage -> ErrorMessage -> ErrorMessage

- Util.TypeLits: ShowType :: t -> ErrorMessage

- Util.TypeLits: Text :: Symbol -> ErrorMessage

- Util.TypeLits: class KnownSymbol (n :: Symbol)

- Util.TypeLits: data ErrorMessage

- Util.TypeLits: data Symbol

- Util.TypeLits: infixl 5 :$$:

- Util.TypeLits: infixl 6 :<>:

- Util.TypeLits: symbolVal :: forall (n :: Symbol) proxy. KnownSymbol n => proxy n -> String

- Util.TypeLits: symbolValT :: forall s. KnownSymbol s => Proxy s -> Text

- Util.TypeLits: symbolValT' :: forall s. KnownSymbol s => Text

- Util.TypeLits: type AssertTypesEqual a b (err :: ErrorMessage) = (TypeErrorUnlessHelper (a == b) err, a ~ b)

- Util.TypeLits: type TypeErrorUnless (cond :: Bool) (err :: ErrorMessage) = (TypeErrorUnlessHelper cond err, cond ~ 'True)

- Util.TypeLits: type family TypeError (a :: ErrorMessage) :: b

- Util.TypeTuple: class RecFromTuple r where {

- Util.TypeTuple: recFromTuple :: RecFromTuple r => IsoRecTuple r -> r

- Util.TypeTuple: type family IsoRecTuple r :: Type;

- Util.TypeTuple: }

- Util.TypeTuple.Class: class RecFromTuple r where {

- Util.TypeTuple.Class: recFromTuple :: RecFromTuple r => IsoRecTuple r -> r

- Util.TypeTuple.Class: type family IsoRecTuple r :: Type;

- Util.TypeTuple.Class: }

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (a :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[a])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u) (x23 :: u) (x24 :: u) (x25 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u) (x23 :: u) (x24 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u) (x23 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2])

- Util.TypeTuple.Instances: instance forall u (f :: u -> *). Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[])

- Util.TypeTuple.TH: deriveRecFromTuple :: Word -> Q [Dec]

- Util.Typeable: [Refl] :: forall k (a :: k). a :~: a

- Util.Typeable: castIgnoringPhantom :: forall c x. (Typeable x, Typeable c, forall phantom1 phantom2. Coercible (c phantom1) (c phantom2)) => x -> Maybe (c DummyPhantomType)

- Util.Typeable: compareExt :: forall a1 a2. (Typeable a1, Typeable a2, Ord a1) => a1 -> a2 -> Ordering

- Util.Typeable: data (a :: k) :~: (b :: k)

- Util.Typeable: eqExt :: forall a1 a2. (Typeable a1, Typeable a2, Eq a1) => a1 -> a2 -> Bool

- Util.Typeable: eqParam1 :: forall a1 a2 t. (Typeable a1, Typeable a2, Eq (t a1)) => t a1 -> t a2 -> Bool

- Util.Typeable: eqParam2 :: forall a1 a2 b1 b2 t. (Typeable a1, Typeable a2, Typeable b1, Typeable b2, Eq (t a1 b2)) => t a1 b1 -> t a2 b2 -> Bool

- Util.Typeable: eqParam3 :: forall a1 a2 b1 b2 c1 c2 t. (Typeable a1, Typeable a2, Typeable b1, Typeable b2, Typeable c1, Typeable c2, Eq (t a1 b1 c1)) => t a1 b1 c1 -> t a2 b2 c2 -> Bool

- Util.Typeable: eqT :: forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b)

- Util.Typeable: eqTypeIgnoringPhantom :: forall c x r. (Typeable x, Typeable c) => (forall a. Typeable a => (c a :~: x) -> Proxy a -> r) -> Maybe r

- Util.Typeable: infix 4 :~:

+ Morley.CLI: instance Morley.Util.CLI.HasCLReader Morley.Michelson.Untyped.Aliases.Value

+ Morley.Micheline.Class: instance (Data.Singletons.Internal.SingI inp, Data.Singletons.Internal.SingI out) => Morley.Micheline.Class.FromExpression (Morley.Michelson.Typed.Instr.Instr '[inp] '[out])

+ Morley.Micheline.Class: instance Data.Singletons.Internal.SingI t => Morley.Micheline.Class.FromExpression (Morley.Michelson.Typed.Aliases.Value t)

+ Morley.Micheline.Class: instance Data.Singletons.Internal.SingI t => Morley.Micheline.Class.ToExpression (Morley.Michelson.Typed.Annotation.Notes t)

+ Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Morley.Michelson.Typed.T.T

+ Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Morley.Michelson.Untyped.Aliases.Contract

+ Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Morley.Michelson.Untyped.Aliases.Value

+ Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Morley.Michelson.Untyped.Instr.ExpandedInstr

+ Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Morley.Michelson.Untyped.Type.T

+ Morley.Micheline.Class: instance Morley.Micheline.Class.FromExpression Morley.Michelson.Untyped.Type.Ty

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression (Morley.Michelson.Typed.Instr.Contract cp st)

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Morley.Michelson.Typed.T.T

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Morley.Michelson.Untyped.Aliases.Contract

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Morley.Michelson.Untyped.Aliases.Value

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Morley.Michelson.Untyped.Instr.ExpandedInstr

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Morley.Michelson.Untyped.Type.T

+ Morley.Micheline.Class: instance Morley.Micheline.Class.ToExpression Morley.Michelson.Untyped.Type.Ty

+ Morley.Micheline.Class: instance Morley.Michelson.Typed.Scope.HasNoOp t => Morley.Micheline.Class.ToExpression (Morley.Michelson.Typed.Aliases.Value t)

+ Morley.Michelson.Analyzer: AnalyzerRes :: HashMap MText Word -> HashMap ByteString Word -> HashMap MText Word -> AnalyzerRes

+ Morley.Michelson.Analyzer: [arConstBytes] :: AnalyzerRes -> HashMap ByteString Word

+ Morley.Michelson.Analyzer: [arConstStrings] :: AnalyzerRes -> HashMap MText Word

+ Morley.Michelson.Analyzer: [arErrorTags] :: AnalyzerRes -> HashMap MText Word

+ Morley.Michelson.Analyzer: analyze :: Instr inp out -> AnalyzerRes

+ Morley.Michelson.Analyzer: data AnalyzerRes

+ Morley.Michelson.Analyzer: instance Formatting.Buildable.Buildable Morley.Michelson.Analyzer.AnalyzerRes

+ Morley.Michelson.Analyzer: instance GHC.Base.Monoid Morley.Michelson.Analyzer.AnalyzerRes

+ Morley.Michelson.Analyzer: instance GHC.Base.Semigroup Morley.Michelson.Analyzer.AnalyzerRes

+ Morley.Michelson.Analyzer: instance GHC.Classes.Eq Morley.Michelson.Analyzer.AnalyzerRes

+ Morley.Michelson.Analyzer: instance GHC.Show.Show Morley.Michelson.Analyzer.AnalyzerRes

+ Morley.Michelson.Doc: --

+ Morley.Michelson.Doc: -- Inline right here (default behaviour); 2. Put into definitions

+ Morley.Michelson.Doc: -- Note that we require all doc items with "in definitions" placement to

+ Morley.Michelson.Doc: -- have <a>Eq</a> and <a>Ord</a> instances which comply the following

+ Morley.Michelson.Doc: -- law: if two documentation items describe the same entity or property,

+ Morley.Michelson.Doc: -- section.

+ Morley.Michelson.Doc: -- they should be considered equal.

+ Morley.Michelson.Doc: -- | Defines where given doc item should be put. There are two options: 1.

+ Morley.Michelson.Doc: ContractDoc :: DocBlock -> DocBlock -> Set SomeDocDefinitionItem -> Set DocItemId -> ContractDoc

+ Morley.Michelson.Doc: DAnchor :: Anchor -> DAnchor

+ Morley.Michelson.Doc: DComment :: Text -> DComment

+ Morley.Michelson.Doc: DConversionInfo :: DConversionInfo

+ Morley.Michelson.Doc: DDescription :: Markdown -> DDescription

+ Morley.Michelson.Doc: DGeneralInfoSection :: SubDoc -> DGeneralInfoSection

+ Morley.Michelson.Doc: DGitRevisionKnown :: DGitRevisionInfo -> DGitRevision

+ Morley.Michelson.Doc: DGitRevisionUnknown :: DGitRevision

+ Morley.Michelson.Doc: DName :: Text -> SubDoc -> DName

+ Morley.Michelson.Doc: DToc :: Markdown -> DToc

+ Morley.Michelson.Doc: DocElem :: d -> Maybe SubDoc -> DocElem d

+ Morley.Michelson.Doc: DocItemId :: Text -> DocItemId

+ Morley.Michelson.Doc: DocItemInDefinitions :: DocItemPlacementKind

+ Morley.Michelson.Doc: DocItemInlined :: DocItemPlacementKind

+ Morley.Michelson.Doc: DocItemPos :: (Natural, Text) -> DocItemPos

+ Morley.Michelson.Doc: DocSection :: (NonEmpty $ DocElem d) -> DocSection

+ Morley.Michelson.Doc: DocSectionNameBig :: DocSectionNameStyle

+ Morley.Michelson.Doc: DocSectionNameSmall :: DocSectionNameStyle

+ Morley.Michelson.Doc: GitRepoSettings :: (Text -> Text) -> GitRepoSettings

+ Morley.Michelson.Doc: SubDoc :: DocBlock -> SubDoc

+ Morley.Michelson.Doc: WithFinalizedDoc :: Identity a -> WithFinalizedDoc a

+ Morley.Michelson.Doc: [DocItemNoRef] :: DocItemRef 'DocItemInlined 'False

+ Morley.Michelson.Doc: [DocItemRefInlined] :: DocItemId -> DocItemRef 'DocItemInlined 'True

+ Morley.Michelson.Doc: [DocItemRef] :: DocItemId -> DocItemRef 'DocItemInDefinitions 'True

+ Morley.Michelson.Doc: [SomeDocDefinitionItem] :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) => d -> SomeDocDefinitionItem

+ Morley.Michelson.Doc: [SomeDocItem] :: DocItem d => d -> SomeDocItem

+ Morley.Michelson.Doc: [cdContents] :: ContractDoc -> DocBlock

+ Morley.Michelson.Doc: [cdDefinitionIds] :: ContractDoc -> Set DocItemId

+ Morley.Michelson.Doc: [cdDefinitionsSet] :: ContractDoc -> Set SomeDocDefinitionItem

+ Morley.Michelson.Doc: [cdDefinitions] :: ContractDoc -> DocBlock

+ Morley.Michelson.Doc: [deItem] :: DocElem d -> d

+ Morley.Michelson.Doc: [deSub] :: DocElem d -> Maybe SubDoc

+ Morley.Michelson.Doc: [grsMkGitRevision] :: GitRepoSettings -> Text -> Text

+ Morley.Michelson.Doc: attachDocCommons :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a

+ Morley.Michelson.Doc: attachGitInfo :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a

+ Morley.Michelson.Doc: attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a

+ Morley.Michelson.Doc: buildDoc :: ContainsDoc a => WithFinalizedDoc a -> ContractDoc

+ Morley.Michelson.Doc: buildDocUnfinalized :: ContainsDoc a => a -> ContractDoc

+ Morley.Michelson.Doc: buildMarkdownDoc :: ContainsDoc a => WithFinalizedDoc a -> LText

+ Morley.Michelson.Doc: cdContentsL :: Lens' ContractDoc DocBlock

+ Morley.Michelson.Doc: cdDefinitionIdsL :: Lens' ContractDoc (Set DocItemId)

+ Morley.Michelson.Doc: cdDefinitionsL :: Lens' ContractDoc DocBlock

+ Morley.Michelson.Doc: cdDefinitionsSetL :: Lens' ContractDoc (Set SomeDocDefinitionItem)

+ Morley.Michelson.Doc: class ContainsDoc a

+ Morley.Michelson.Doc: class ContainsDoc a => ContainsUpdateableDoc a

+ Morley.Michelson.Doc: class (Typeable d, DOrd d) => DocItem d where {

+ Morley.Michelson.Doc: contractDocToMarkdown :: ContractDoc -> LText

+ Morley.Michelson.Doc: contractDocToToc :: ContractDoc -> Markdown

+ Morley.Michelson.Doc: data ContractDoc

+ Morley.Michelson.Doc: data DAnchor

+ Morley.Michelson.Doc: data DComment

+ Morley.Michelson.Doc: data DConversionInfo

+ Morley.Michelson.Doc: data DDescription

+ Morley.Michelson.Doc: data DGitRevision

+ Morley.Michelson.Doc: data DName

+ Morley.Michelson.Doc: data DToc

+ Morley.Michelson.Doc: data DocElem d

+ Morley.Michelson.Doc: data DocItemPlacementKind

+ Morley.Michelson.Doc: data DocItemRef (p :: DocItemPlacementKind) (r :: DocItemReferencedKind)

+ Morley.Michelson.Doc: data DocSection

+ Morley.Michelson.Doc: data DocSectionNameStyle

+ Morley.Michelson.Doc: data SomeDocDefinitionItem

+ Morley.Michelson.Doc: data SomeDocItem

+ Morley.Michelson.Doc: deIsAtomic :: DocElem d -> Bool

+ Morley.Michelson.Doc: docDefinitionRef :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) => Markdown -> d -> Markdown

+ Morley.Michelson.Doc: docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc

+ Morley.Michelson.Doc: docItemDependencies :: DocItem d => d -> [SomeDocDefinitionItem]

+ Morley.Michelson.Doc: docItemPos :: DocItem d => Natural

+ Morley.Michelson.Doc: docItemPosition :: forall d. DocItem d => DocItemPos

+ Morley.Michelson.Doc: docItemRef :: (DocItem d, DocItemPlacement d ~ 'DocItemInlined, DocItemReferenced d ~ 'False) => d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)

+ Morley.Michelson.Doc: docItemSectionDescription :: DocItem d => Maybe Markdown

+ Morley.Michelson.Doc: docItemSectionName :: DocItem d => Maybe Text

+ Morley.Michelson.Doc: docItemSectionNameStyle :: DocItem d => DocSectionNameStyle

+ Morley.Michelson.Doc: docItemSectionRef :: forall di. DocItem di => Maybe Markdown

+ Morley.Michelson.Doc: docItemToBlock :: forall di. DocItem di => di -> DocBlock

+ Morley.Michelson.Doc: docItemToMarkdown :: DocItem d => HeaderLevel -> d -> Markdown

+ Morley.Michelson.Doc: docItemToToc :: DocItem d => HeaderLevel -> d -> Markdown

+ Morley.Michelson.Doc: docItemsOrder :: DocItem d => [d] -> [d]

+ Morley.Michelson.Doc: finalizedAsIs :: a -> WithFinalizedDoc a

+ Morley.Michelson.Doc: instance (di GHC.Types.~ Morley.Michelson.Doc.DName) => Data.String.IsString (Morley.Michelson.Doc.SubDoc -> di)

+ Morley.Michelson.Doc: instance Control.DeepSeq.NFData Morley.Michelson.Doc.SomeDocItem

+ Morley.Michelson.Doc: instance Formatting.Buildable.Buildable Morley.Michelson.Doc.DocItemPos

+ Morley.Michelson.Doc: instance GHC.Base.Applicative Morley.Michelson.Doc.WithFinalizedDoc

+ Morley.Michelson.Doc: instance GHC.Base.Functor Morley.Michelson.Doc.WithFinalizedDoc

+ Morley.Michelson.Doc: instance GHC.Base.Monad Morley.Michelson.Doc.WithFinalizedDoc

+ Morley.Michelson.Doc: instance GHC.Base.Monoid Morley.Michelson.Doc.ContractDoc

+ Morley.Michelson.Doc: instance GHC.Base.Semigroup Morley.Michelson.Doc.ContractDoc

+ Morley.Michelson.Doc: instance GHC.Classes.Eq Morley.Michelson.Doc.DocItemId

+ Morley.Michelson.Doc: instance GHC.Classes.Eq Morley.Michelson.Doc.DocItemPos

+ Morley.Michelson.Doc: instance GHC.Classes.Eq Morley.Michelson.Doc.SomeDocDefinitionItem

+ Morley.Michelson.Doc: instance GHC.Classes.Ord Morley.Michelson.Doc.DocItemId

+ Morley.Michelson.Doc: instance GHC.Classes.Ord Morley.Michelson.Doc.DocItemPos

+ Morley.Michelson.Doc: instance GHC.Classes.Ord Morley.Michelson.Doc.SomeDocDefinitionItem

+ Morley.Michelson.Doc: instance GHC.Show.Show Morley.Michelson.Doc.DocGrouping

+ Morley.Michelson.Doc: instance GHC.Show.Show Morley.Michelson.Doc.DocItemId

+ Morley.Michelson.Doc: instance GHC.Show.Show Morley.Michelson.Doc.DocItemPos

+ Morley.Michelson.Doc: instance GHC.Show.Show Morley.Michelson.Doc.DocSection

+ Morley.Michelson.Doc: instance GHC.Show.Show Morley.Michelson.Doc.SomeDocItem

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DAnchor

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DComment

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DConversionInfo

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DDescription

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DGeneralInfoSection

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DGitRevision

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DName

+ Morley.Michelson.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Doc.DToc

+ Morley.Michelson.Doc: instance Morley.Util.Markdown.ToAnchor (Morley.Michelson.Doc.DocItemRef d 'GHC.Types.True)

+ Morley.Michelson.Doc: instance Morley.Util.Markdown.ToAnchor Morley.Michelson.Doc.DocItemId

+ Morley.Michelson.Doc: instance Morley.Util.Markdown.ToAnchor Morley.Michelson.Doc.SectionAnchor

+ Morley.Michelson.Doc: lookupDocBlockSection :: forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)

+ Morley.Michelson.Doc: mdTocFromRef :: (DocItem d, DocItemReferenced d ~ 'True) => HeaderLevel -> Markdown -> d -> Markdown

+ Morley.Michelson.Doc: mkDGitRevision :: ExpQ

+ Morley.Michelson.Doc: modifyDoc :: (ContainsUpdateableDoc a, DocItem i1, DocItem i2) => (i1 -> Maybe i2) -> a -> a

+ Morley.Michelson.Doc: modifyDocEntirely :: ContainsUpdateableDoc a => (SomeDocItem -> SomeDocItem) -> a -> a

+ Morley.Michelson.Doc: morleyRepoSettings :: GitRepoSettings

+ Morley.Michelson.Doc: newtype DGeneralInfoSection

+ Morley.Michelson.Doc: newtype DocItemId

+ Morley.Michelson.Doc: newtype DocItemPos

+ Morley.Michelson.Doc: newtype GitRepoSettings

+ Morley.Michelson.Doc: newtype SubDoc

+ Morley.Michelson.Doc: newtype WithFinalizedDoc a

+ Morley.Michelson.Doc: subDocToMarkdown :: HeaderLevel -> SubDoc -> Markdown

+ Morley.Michelson.Doc: type DocBlock = Map DocItemPos DocSection

+ Morley.Michelson.Doc: type DocGrouping = SubDoc -> SomeDocItem

+ Morley.Michelson.Doc: type DocItemPlacement _ = 'DocItemInlined;

+ Morley.Michelson.Doc: type DocItemReferenced _ = 'False;

+ Morley.Michelson.Doc: type DocItemReferencedKind = Bool

+ Morley.Michelson.Doc: type family DocItemReferenced d :: DocItemReferencedKind;

+ Morley.Michelson.Doc: }

+ Morley.Michelson.ErrorPos: InstrCallStack :: LetCallStack -> SrcPos -> InstrCallStack

+ Morley.Michelson.ErrorPos: LetName :: Text -> LetName

+ Morley.Michelson.ErrorPos: Pos :: Word -> Pos

+ Morley.Michelson.ErrorPos: SrcPos :: Pos -> Pos -> SrcPos

+ Morley.Michelson.ErrorPos: [icsCallStack] :: InstrCallStack -> LetCallStack

+ Morley.Michelson.ErrorPos: [icsSrcPos] :: InstrCallStack -> SrcPos

+ Morley.Michelson.ErrorPos: [srcCol] :: SrcPos -> Pos

+ Morley.Michelson.ErrorPos: [srcLine] :: SrcPos -> Pos

+ Morley.Michelson.ErrorPos: [unPos] :: Pos -> Word

+ Morley.Michelson.ErrorPos: data InstrCallStack

+ Morley.Michelson.ErrorPos: data SrcPos

+ Morley.Michelson.ErrorPos: instance Control.DeepSeq.NFData Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance Control.DeepSeq.NFData Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance Control.DeepSeq.NFData Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance Control.DeepSeq.NFData Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance Data.Data.Data Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance Data.Data.Data Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance Data.Data.Data Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance Data.Data.Data Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance Data.Default.Class.Default Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance Data.Default.Class.Default Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance Data.Default.Class.Default Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance Formatting.Buildable.Buildable Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance Formatting.Buildable.Buildable Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance Formatting.Buildable.Buildable Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Eq Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Eq Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Eq Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Eq Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Ord Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Ord Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Ord Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance GHC.Classes.Ord Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance GHC.Generics.Generic Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance GHC.Generics.Generic Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance GHC.Generics.Generic Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance GHC.Generics.Generic Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance GHC.Show.Show Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: instance GHC.Show.Show Morley.Michelson.ErrorPos.LetName

+ Morley.Michelson.ErrorPos: instance GHC.Show.Show Morley.Michelson.ErrorPos.Pos

+ Morley.Michelson.ErrorPos: instance GHC.Show.Show Morley.Michelson.ErrorPos.SrcPos

+ Morley.Michelson.ErrorPos: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.ErrorPos.InstrCallStack

+ Morley.Michelson.ErrorPos: mkPos :: Int -> Maybe Pos

+ Morley.Michelson.ErrorPos: newtype LetName

+ Morley.Michelson.ErrorPos: newtype Pos

+ Morley.Michelson.ErrorPos: srcPos :: Word -> Word -> SrcPos

+ Morley.Michelson.ErrorPos: type LetCallStack = [LetName]

+ Morley.Michelson.ErrorPos: unsafeMkPos :: Int -> Pos

+ Morley.Michelson.FailPattern: data TypicalFailWith

+ Morley.Michelson.FailPattern: isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith

+ Morley.Michelson.FailPattern: modifyTypicalFailWith :: HasCallStack => (MText -> SomeConstrainedValue ConstantScope) -> Instr inp out -> Instr inp out

+ Morley.Michelson.FailPattern: typicalFailWithTag :: TypicalFailWith -> MText

+ Morley.Michelson.Interpret: ContractEnv :: Timestamp -> RemainingSteps -> Mutez -> TcOriginatedContracts -> Address -> Address -> Address -> Mutez -> VotingPowers -> ChainId -> Maybe OperationHash -> Natural -> InstrCallStack -> ContractEnv

+ Morley.Michelson.Interpret: InterpretError :: (MichelsonFailureWithStack, MorleyLogs) -> InterpretError

+ Morley.Michelson.Interpret: InterpreterState :: RemainingSteps -> GlobalCounter -> BigMapCounter -> InterpreterState

+ Morley.Michelson.Interpret: MichelsonFailureWithStack :: MichelsonFailed -> InstrCallStack -> MichelsonFailureWithStack

+ Morley.Michelson.Interpret: MorleyLogs :: [Text] -> MorleyLogs

+ Morley.Michelson.Interpret: MorleyLogsBuilder :: Endo [Text] -> MorleyLogsBuilder

+ Morley.Michelson.Interpret: RemainingSteps :: Word64 -> RemainingSteps

+ Morley.Michelson.Interpret: StkEl :: Value t -> VarAnn -> Notes t -> StkEl t

+ Morley.Michelson.Interpret: [InterpretResult] :: StorageScope st => {iurOps :: [Operation], iurNewStorage :: Value st, iurNewState :: InterpreterState, iurMorleyLogs :: MorleyLogs} -> InterpretResult

+ Morley.Michelson.Interpret: [MichelsonArithError] :: (Typeable n, Typeable m, Typeable instr) => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed

+ Morley.Michelson.Interpret: [MichelsonFailedTestAssert] :: Text -> MichelsonFailed

+ Morley.Michelson.Interpret: [MichelsonFailedWith] :: (SingI t, ConstantScope t) => Value t -> MichelsonFailed

+ Morley.Michelson.Interpret: [MichelsonGasExhaustion] :: MichelsonFailed

+ Morley.Michelson.Interpret: [SomeItStack] :: ExtInstr inp -> Rec StkEl inp -> SomeItStack

+ Morley.Michelson.Interpret: [ceAmount] :: ContractEnv -> Mutez

+ Morley.Michelson.Interpret: [ceBalance] :: ContractEnv -> Mutez

+ Morley.Michelson.Interpret: [ceChainId] :: ContractEnv -> ChainId

+ Morley.Michelson.Interpret: [ceContracts] :: ContractEnv -> TcOriginatedContracts

+ Morley.Michelson.Interpret: [ceInstrCallStack] :: ContractEnv -> InstrCallStack

+ Morley.Michelson.Interpret: [ceLevel] :: ContractEnv -> Natural

+ Morley.Michelson.Interpret: [ceMaxSteps] :: ContractEnv -> RemainingSteps

+ Morley.Michelson.Interpret: [ceNow] :: ContractEnv -> Timestamp

+ Morley.Michelson.Interpret: [ceOperationHash] :: ContractEnv -> Maybe OperationHash

+ Morley.Michelson.Interpret: [ceSelf] :: ContractEnv -> Address

+ Morley.Michelson.Interpret: [ceSender] :: ContractEnv -> Address

+ Morley.Michelson.Interpret: [ceSource] :: ContractEnv -> Address

+ Morley.Michelson.Interpret: [ceVotingPowers] :: ContractEnv -> VotingPowers

+ Morley.Michelson.Interpret: [isBigMapCounter] :: InterpreterState -> BigMapCounter

+ Morley.Michelson.Interpret: [isGlobalCounter] :: InterpreterState -> GlobalCounter

+ Morley.Michelson.Interpret: [isRemainingSteps] :: InterpreterState -> RemainingSteps

+ Morley.Michelson.Interpret: [mfwsFailed] :: MichelsonFailureWithStack -> MichelsonFailed

+ Morley.Michelson.Interpret: [mfwsInstrCallStack] :: MichelsonFailureWithStack -> InstrCallStack

+ Morley.Michelson.Interpret: [seNotes] :: StkEl t -> Notes t

+ Morley.Michelson.Interpret: [seValue] :: StkEl t -> Value t

+ Morley.Michelson.Interpret: [seVarAnn] :: StkEl t -> VarAnn

+ Morley.Michelson.Interpret: [unMorleyLogs] :: MorleyLogs -> [Text]

+ Morley.Michelson.Interpret: _MorleyLogs :: Iso' MorleyLogs [Text]

+ Morley.Michelson.Interpret: assignBigMapIds :: MonadState BigMapCounter m => Value t -> m (Value t)

+ Morley.Michelson.Interpret: buildMorleyLogs :: MorleyLogsBuilder -> MorleyLogs

+ Morley.Michelson.Interpret: class Monad m => InterpreterStateMonad m

+ Morley.Michelson.Interpret: data ContractEnv

+ Morley.Michelson.Interpret: data InterpretResult

+ Morley.Michelson.Interpret: data InterpreterState

+ Morley.Michelson.Interpret: data MichelsonFailed

+ Morley.Michelson.Interpret: data MichelsonFailureWithStack

+ Morley.Michelson.Interpret: data SomeItStack

+ Morley.Michelson.Interpret: data StkEl t

+ Morley.Michelson.Interpret: fromFinalStack :: Rec StkEl (ContractOut st) -> ([Operation], Value st)

+ Morley.Michelson.Interpret: getInterpreterState :: InterpreterStateMonad m => m InterpreterState

+ Morley.Michelson.Interpret: handleContractReturn :: StorageScope st => ContractReturn st -> Either InterpretError InterpretResult

+ Morley.Michelson.Interpret: initInterpreterState :: GlobalCounter -> BigMapCounter -> ContractEnv -> InterpreterState

+ Morley.Michelson.Interpret: instance (GHC.Base.Monad m, GHC.Base.Monoid w) => Morley.Michelson.Interpret.InterpreterStateMonad (Control.Monad.Trans.RWS.Strict.RWST r w Morley.Michelson.Interpret.InterpreterState m)

+ Morley.Michelson.Interpret: instance (Morley.Michelson.Interpret.InterpreterStateMonad m, GHC.Base.Monoid w) => Morley.Michelson.Interpret.InterpreterStateMonad (Control.Monad.Trans.RWS.Strict.RWST r w s m)

+ Morley.Michelson.Interpret: instance Control.DeepSeq.NFData Morley.Michelson.Interpret.InterpreterState

+ Morley.Michelson.Interpret: instance Control.DeepSeq.NFData Morley.Michelson.Interpret.MichelsonFailed

+ Morley.Michelson.Interpret: instance Control.DeepSeq.NFData Morley.Michelson.Interpret.MichelsonFailureWithStack

+ Morley.Michelson.Interpret: instance Control.DeepSeq.NFData Morley.Michelson.Interpret.MorleyLogs

+ Morley.Michelson.Interpret: instance Control.DeepSeq.NFData Morley.Michelson.Interpret.RemainingSteps

+ Morley.Michelson.Interpret: instance Data.Default.Class.Default Morley.Michelson.Interpret.MorleyLogsBuilder

+ Morley.Michelson.Interpret: instance Formatting.Buildable.Buildable Morley.Michelson.Interpret.InterpretError

+ Morley.Michelson.Interpret: instance Formatting.Buildable.Buildable Morley.Michelson.Interpret.MichelsonFailed

+ Morley.Michelson.Interpret: instance Formatting.Buildable.Buildable Morley.Michelson.Interpret.MichelsonFailureWithStack

+ Morley.Michelson.Interpret: instance Formatting.Buildable.Buildable Morley.Michelson.Interpret.MorleyLogs

+ Morley.Michelson.Interpret: instance Formatting.Buildable.Buildable Morley.Michelson.Interpret.RemainingSteps

+ Morley.Michelson.Interpret: instance GHC.Base.Monad m => Morley.Michelson.Interpret.InterpreterStateMonad (Control.Monad.Trans.State.Strict.StateT Morley.Michelson.Interpret.InterpreterState m)

+ Morley.Michelson.Interpret: instance GHC.Base.Monoid Morley.Michelson.Interpret.MorleyLogs

+ Morley.Michelson.Interpret: instance GHC.Base.Monoid Morley.Michelson.Interpret.MorleyLogsBuilder

+ Morley.Michelson.Interpret: instance GHC.Base.Semigroup Morley.Michelson.Interpret.MorleyLogs

+ Morley.Michelson.Interpret: instance GHC.Base.Semigroup Morley.Michelson.Interpret.MorleyLogsBuilder

+ Morley.Michelson.Interpret: instance GHC.Classes.Eq (Morley.Michelson.Interpret.StkEl t)

+ Morley.Michelson.Interpret: instance GHC.Classes.Eq Morley.Michelson.Interpret.MichelsonFailed

+ Morley.Michelson.Interpret: instance GHC.Classes.Eq Morley.Michelson.Interpret.MichelsonFailureWithStack

+ Morley.Michelson.Interpret: instance GHC.Classes.Eq Morley.Michelson.Interpret.MorleyLogs

+ Morley.Michelson.Interpret: instance GHC.Classes.Eq Morley.Michelson.Interpret.RemainingSteps

+ Morley.Michelson.Interpret: instance GHC.Classes.Ord Morley.Michelson.Interpret.RemainingSteps

+ Morley.Michelson.Interpret: instance GHC.Generics.Generic Morley.Michelson.Interpret.InterpretError

+ Morley.Michelson.Interpret: instance GHC.Generics.Generic Morley.Michelson.Interpret.InterpreterState

+ Morley.Michelson.Interpret: instance GHC.Generics.Generic Morley.Michelson.Interpret.MichelsonFailureWithStack

+ Morley.Michelson.Interpret: instance GHC.Generics.Generic Morley.Michelson.Interpret.MorleyLogs

+ Morley.Michelson.Interpret: instance GHC.Generics.Generic Morley.Michelson.Interpret.MorleyLogsBuilder

+ Morley.Michelson.Interpret: instance GHC.Generics.Generic Morley.Michelson.Interpret.RemainingSteps

+ Morley.Michelson.Interpret: instance GHC.Num.Num Morley.Michelson.Interpret.RemainingSteps

+ Morley.Michelson.Interpret: instance GHC.Show.Show (Morley.Michelson.Interpret.StkEl t)

+ Morley.Michelson.Interpret: instance GHC.Show.Show Morley.Michelson.Interpret.InterpretError

+ Morley.Michelson.Interpret: instance GHC.Show.Show Morley.Michelson.Interpret.InterpretResult

+ Morley.Michelson.Interpret: instance GHC.Show.Show Morley.Michelson.Interpret.InterpreterState

+ Morley.Michelson.Interpret: instance GHC.Show.Show Morley.Michelson.Interpret.MichelsonFailed

+ Morley.Michelson.Interpret: instance GHC.Show.Show Morley.Michelson.Interpret.MichelsonFailureWithStack

+ Morley.Michelson.Interpret: instance GHC.Show.Show Morley.Michelson.Interpret.MorleyLogs

+ Morley.Michelson.Interpret: instance GHC.Show.Show Morley.Michelson.Interpret.RemainingSteps

+ Morley.Michelson.Interpret: instance Morley.Michelson.Interpret.InterpreterStateMonad m => Morley.Michelson.Interpret.InterpreterStateMonad (Control.Monad.Trans.Except.ExceptT e m)

+ Morley.Michelson.Interpret: instance Morley.Michelson.Interpret.InterpreterStateMonad m => Morley.Michelson.Interpret.InterpreterStateMonad (Control.Monad.Trans.Reader.ReaderT r m)

+ Morley.Michelson.Interpret: instance Morley.Michelson.Interpret.InterpreterStateMonad m => Morley.Michelson.Interpret.InterpreterStateMonad (Control.Monad.Trans.State.Strict.StateT w m)

+ Morley.Michelson.Interpret: instance Universum.Container.Class.One Morley.Michelson.Interpret.MorleyLogsBuilder

+ Morley.Michelson.Interpret: interpret :: Contract cp st -> EntrypointCallT cp arg -> Value arg -> Value st -> GlobalCounter -> BigMapCounter -> ContractEnv -> ContractReturn st

+ Morley.Michelson.Interpret: interpretInstr :: ContractEnv -> Instr inp out -> Rec Value inp -> Either MichelsonFailureWithStack (Rec Value out)

+ Morley.Michelson.Interpret: interpretInstrAnnotated :: ContractEnv -> Instr inp out -> Rec Value inp -> Either MichelsonFailureWithStack (Rec StkEl out)

+ Morley.Michelson.Interpret: mkInitStack :: Value param -> ParamNotes param -> Value st -> Notes st -> Rec StkEl (ContractInp param st)

+ Morley.Michelson.Interpret: modifyInterpreterState :: InterpreterStateMonad m => (InterpreterState -> InterpreterState) -> m ()

+ Morley.Michelson.Interpret: newtype InterpretError

+ Morley.Michelson.Interpret: newtype MorleyLogs

+ Morley.Michelson.Interpret: newtype MorleyLogsBuilder

+ Morley.Michelson.Interpret: newtype RemainingSteps

+ Morley.Michelson.Interpret: putInterpreterState :: InterpreterStateMonad m => InterpreterState -> m ()

+ Morley.Michelson.Interpret: runInstr :: EvalM m => InstrRunner m

+ Morley.Michelson.Interpret: runInstrImpl :: forall m. EvalM m => InstrRunner m -> InstrRunner m

+ Morley.Michelson.Interpret: runInstrNoGas :: EvalM m => InstrRunner m

+ Morley.Michelson.Interpret: runUnpack :: forall t. UnpackedValScope t => ByteString -> Either UnpackError (Value t)

+ Morley.Michelson.Interpret: starNotesStkEl :: forall t. Value t -> StkEl t

+ Morley.Michelson.Interpret: stateInterpreterState :: InterpreterStateMonad m => (InterpreterState -> (a, InterpreterState)) -> m a

+ Morley.Michelson.Interpret: type ContractReturn st = (Either MichelsonFailureWithStack ([Operation], Value st), (InterpreterState, MorleyLogs))

+ Morley.Michelson.Interpret: type EvalM m = (MonadReader ContractEnv m, InterpreterStateMonad m, MonadWriter MorleyLogsBuilder m, MonadError MichelsonFailureWithStack m)

+ Morley.Michelson.Interpret: type InstrRunner m = forall inp out. Instr inp out -> Rec StkEl inp -> m (Rec StkEl out)

+ Morley.Michelson.Interpret.Pack: packValue :: PackedValScope t => Value t -> LByteString

+ Morley.Michelson.Interpret.Pack: packValue' :: PackedValScope t => Value t -> ByteString

+ Morley.Michelson.Interpret.Pack: packValuePrefix :: IsString s => s

+ Morley.Michelson.Interpret.Pack: toBinary :: ToExpression a => a -> LByteString

+ Morley.Michelson.Interpret.Pack: toBinary' :: ToExpression a => a -> ByteString

+ Morley.Michelson.Interpret.Unpack: UnpackError :: Text -> UnpackError

+ Morley.Michelson.Interpret.Unpack: [unUnpackError] :: UnpackError -> Text

+ Morley.Michelson.Interpret.Unpack: newtype UnpackError

+ Morley.Michelson.Interpret.Unpack: unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]

+ Morley.Michelson.Interpret.Unpack: unpackUValue' :: ByteString -> Either UnpackError Value

+ Morley.Michelson.Interpret.Unpack: unpackValue' :: forall t. UnpackedValScope t => ByteString -> Either UnpackError (Value t)

+ Morley.Michelson.Interpret.Utils: encodeZarithNumber :: Integer -> NonEmpty Word8

+ Morley.Michelson.Let: LetType :: Text -> Ty -> LetType

+ Morley.Michelson.Let: LetValue :: Text -> Ty -> Value' ParsedOp -> LetValue

+ Morley.Michelson.Let: [ltName] :: LetType -> Text

+ Morley.Michelson.Let: [ltSig] :: LetType -> Ty

+ Morley.Michelson.Let: [lvName] :: LetValue -> Text

+ Morley.Michelson.Let: [lvSig] :: LetValue -> Ty

+ Morley.Michelson.Let: [lvVal] :: LetValue -> Value' ParsedOp

+ Morley.Michelson.Let: data LetType

+ Morley.Michelson.Let: data LetValue

+ Morley.Michelson.Let: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Let.LetType

+ Morley.Michelson.Let: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Let.LetValue

+ Morley.Michelson.Let: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Let.LetType

+ Morley.Michelson.Let: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Let.LetValue

+ Morley.Michelson.Let: instance GHC.Classes.Eq Morley.Michelson.Let.LetType

+ Morley.Michelson.Let: instance GHC.Classes.Eq Morley.Michelson.Let.LetValue

+ Morley.Michelson.Let: instance GHC.Show.Show Morley.Michelson.Let.LetType

+ Morley.Michelson.Let: instance GHC.Show.Show Morley.Michelson.Let.LetValue

+ Morley.Michelson.Macro: A :: CadrStruct

+ Morley.Michelson.Macro: ACCESS :: Natural -> Positive -> Macro

+ Morley.Michelson.Macro: ASSERT :: Macro

+ Morley.Michelson.Macro: ASSERTX :: ParsedInstr -> Macro

+ Morley.Michelson.Macro: ASSERT_CMP :: ParsedInstr -> Macro

+ Morley.Michelson.Macro: ASSERT_LEFT :: Macro

+ Morley.Michelson.Macro: ASSERT_NONE :: Macro

+ Morley.Michelson.Macro: ASSERT_RIGHT :: Macro

+ Morley.Michelson.Macro: ASSERT_SOME :: Macro

+ Morley.Michelson.Macro: CADR :: [CadrStruct] -> VarAnn -> FieldAnn -> Macro

+ Morley.Michelson.Macro: CARN :: VarAnn -> Word -> Macro

+ Morley.Michelson.Macro: CASE :: NonEmpty [ParsedOp] -> Macro

+ Morley.Michelson.Macro: CDRN :: VarAnn -> Word -> Macro

+ Morley.Michelson.Macro: CMP :: ParsedInstr -> VarAnn -> Macro

+ Morley.Michelson.Macro: CONSTRUCT :: NonEmpty [ParsedOp] -> Macro

+ Morley.Michelson.Macro: D :: CadrStruct

+ Morley.Michelson.Macro: DIIP :: Word -> [ParsedOp] -> Macro

+ Morley.Michelson.Macro: DUUP :: Word -> VarAnn -> Macro

+ Morley.Michelson.Macro: F :: FieldAnn -> PairStruct

+ Morley.Michelson.Macro: FAIL :: Macro

+ Morley.Michelson.Macro: IFCMP :: ParsedInstr -> VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro

+ Morley.Michelson.Macro: IFX :: ParsedInstr -> [ParsedOp] -> [ParsedOp] -> Macro

+ Morley.Michelson.Macro: IF_RIGHT :: [ParsedOp] -> [ParsedOp] -> Macro

+ Morley.Michelson.Macro: IF_SOME :: [ParsedOp] -> [ParsedOp] -> Macro

+ Morley.Michelson.Macro: LMac :: LetMacro -> SrcPos -> ParsedOp

+ Morley.Michelson.Macro: LetMacro :: Text -> StackFn -> [ParsedOp] -> LetMacro

+ Morley.Michelson.Macro: MAP_CADR :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> Macro

+ Morley.Michelson.Macro: Mac :: Macro -> SrcPos -> ParsedOp

+ Morley.Michelson.Macro: P :: PairStruct -> PairStruct -> PairStruct

+ Morley.Michelson.Macro: PAPAIR :: PairStruct -> TypeAnn -> VarAnn -> Macro

+ Morley.Michelson.Macro: Prim :: ParsedInstr -> SrcPos -> ParsedOp

+ Morley.Michelson.Macro: SET :: Natural -> Positive -> Macro

+ Morley.Michelson.Macro: SET_CADR :: [CadrStruct] -> VarAnn -> FieldAnn -> Macro

+ Morley.Michelson.Macro: Seq :: [ParsedOp] -> SrcPos -> ParsedOp

+ Morley.Michelson.Macro: TAG :: Natural -> NonEmpty Ty -> Macro

+ Morley.Michelson.Macro: UF :: UnpairStruct

+ Morley.Michelson.Macro: UNPAPAIR :: UnpairStruct -> Macro

+ Morley.Michelson.Macro: UP :: UnpairStruct -> UnpairStruct -> UnpairStruct

+ Morley.Michelson.Macro: VIEW :: [ParsedOp] -> Macro

+ Morley.Michelson.Macro: VOID :: [ParsedOp] -> Macro

+ Morley.Michelson.Macro: [lmExpr] :: LetMacro -> [ParsedOp]

+ Morley.Michelson.Macro: [lmName] :: LetMacro -> Text

+ Morley.Michelson.Macro: [lmSig] :: LetMacro -> StackFn

+ Morley.Michelson.Macro: data CadrStruct

+ Morley.Michelson.Macro: data LetMacro

+ Morley.Michelson.Macro: data Macro

+ Morley.Michelson.Macro: data PairStruct

+ Morley.Michelson.Macro: data ParsedOp

+ Morley.Michelson.Macro: data UnpairStruct

+ Morley.Michelson.Macro: expand :: LetCallStack -> ParsedOp -> ExpandedOp

+ Morley.Michelson.Macro: expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]

+ Morley.Michelson.Macro: expandContract :: Contract' ParsedOp -> Contract

+ Morley.Michelson.Macro: expandList :: [ParsedOp] -> [ExpandedOp]

+ Morley.Michelson.Macro: expandMacro :: InstrCallStack -> Macro -> [ExpandedOp]

+ Morley.Michelson.Macro: expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp]

+ Morley.Michelson.Macro: expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp]

+ Morley.Michelson.Macro: expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]

+ Morley.Michelson.Macro: expandUnpapair :: InstrCallStack -> UnpairStruct -> [ExpandedOp]

+ Morley.Michelson.Macro: expandValue :: ParsedValue -> Value

+ Morley.Michelson.Macro: instance Control.DeepSeq.NFData Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance Control.DeepSeq.NFData Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance Control.DeepSeq.NFData Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance Control.DeepSeq.NFData Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance Control.DeepSeq.NFData Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance Control.DeepSeq.NFData Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance Data.Data.Data Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance Data.Data.Data Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance Data.Data.Data Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance Data.Data.Data Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance Data.Data.Data Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance Data.Data.Data Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance Formatting.Buildable.Buildable Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance Formatting.Buildable.Buildable Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance Formatting.Buildable.Buildable Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance Formatting.Buildable.Buildable Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance Formatting.Buildable.Buildable Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance Formatting.Buildable.Buildable Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance GHC.Classes.Eq Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance GHC.Classes.Eq Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance GHC.Classes.Eq Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance GHC.Classes.Eq Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance GHC.Classes.Eq Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance GHC.Classes.Eq Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance GHC.Generics.Generic Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance GHC.Generics.Generic Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance GHC.Generics.Generic Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance GHC.Generics.Generic Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance GHC.Generics.Generic Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance GHC.Generics.Generic Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance GHC.Show.Show Morley.Michelson.Macro.CadrStruct

+ Morley.Michelson.Macro: instance GHC.Show.Show Morley.Michelson.Macro.LetMacro

+ Morley.Michelson.Macro: instance GHC.Show.Show Morley.Michelson.Macro.Macro

+ Morley.Michelson.Macro: instance GHC.Show.Show Morley.Michelson.Macro.PairStruct

+ Morley.Michelson.Macro: instance GHC.Show.Show Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: instance GHC.Show.Show Morley.Michelson.Macro.UnpairStruct

+ Morley.Michelson.Macro: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Macro.ParsedOp

+ Morley.Michelson.Macro: mapPairLeaves :: [FieldAnn] -> PairStruct -> PairStruct

+ Morley.Michelson.Macro: type ParsedInstr = InstrAbstract ParsedOp

+ Morley.Michelson.Macro: type ParsedUExtInstr = ExtInstrAbstract ParsedOp

+ Morley.Michelson.Macro: type ParsedValue = Value' ParsedOp

+ Morley.Michelson.Optimizer: OptimizerConf :: Bool -> [Rule] -> OptimizerConf

+ Morley.Michelson.Optimizer: [ocGotoValues] :: OptimizerConf -> Bool

+ Morley.Michelson.Optimizer: [ocRuleset] :: OptimizerConf -> [Rule]

+ Morley.Michelson.Optimizer: data OptimizerConf

+ Morley.Michelson.Optimizer: data Rule

+ Morley.Michelson.Optimizer: defaultOptimizerConf :: OptimizerConf

+ Morley.Michelson.Optimizer: defaultRules :: [Rule]

+ Morley.Michelson.Optimizer: defaultRulesAndPushPack :: [Rule]

+ Morley.Michelson.Optimizer: instance Data.Default.Class.Default Morley.Michelson.Optimizer.OptimizerConf

+ Morley.Michelson.Optimizer: ocGotoValuesL :: Lens' OptimizerConf Bool

+ Morley.Michelson.Optimizer: optimize :: Instr inp out -> Instr inp out

+ Morley.Michelson.Optimizer: optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out

+ Morley.Michelson.Optimizer: orRule :: (Rule -> Rule) -> (Rule -> Rule) -> Rule -> Rule

+ Morley.Michelson.Optimizer: orSimpleRule :: (Rule -> Rule) -> Rule -> Rule -> Rule

+ Morley.Michelson.Parser: ExcessFieldAnnotation :: CustomParserException

+ Morley.Michelson.Parser: InvalidChar :: Char -> StringLiteralParserException

+ Morley.Michelson.Parser: InvalidEscapeSequence :: Char -> StringLiteralParserException

+ Morley.Michelson.Parser: MSCode :: SrcLoc -> MichelsonSource

+ Morley.Michelson.Parser: MSFile :: FilePath -> MichelsonSource

+ Morley.Michelson.Parser: MSName :: Text -> MichelsonSource

+ Morley.Michelson.Parser: MSUnspecified :: MichelsonSource

+ Morley.Michelson.Parser: MultiRootAnnotationException :: CustomParserException

+ Morley.Michelson.Parser: OddNumberBytesException :: CustomParserException

+ Morley.Michelson.Parser: ParserException :: ParseErrorBundle Text CustomParserException -> ParserException

+ Morley.Michelson.Parser: StringLiteralException :: StringLiteralParserException -> CustomParserException

+ Morley.Michelson.Parser: WrongAccessArgs :: Natural -> Positive -> CustomParserException

+ Morley.Michelson.Parser: WrongSetArgs :: Natural -> Positive -> CustomParserException

+ Morley.Michelson.Parser: WrongTagArgs :: Natural -> Positive -> CustomParserException

+ Morley.Michelson.Parser: bytesLiteral :: Parser (Value' op)

+ Morley.Michelson.Parser: codeEntry :: Parser [ParsedOp]

+ Morley.Michelson.Parser: codeSrc :: HasCallStack => MichelsonSource

+ Morley.Michelson.Parser: data CustomParserException

+ Morley.Michelson.Parser: data MichelsonSource

+ Morley.Michelson.Parser: data ParseErrorBundle s e

+ Morley.Michelson.Parser: data ParserException

+ Morley.Michelson.Parser: data StringLiteralParserException

+ Morley.Michelson.Parser: errorBundlePretty :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String

+ Morley.Michelson.Parser: intLiteral :: Parser (Value' op)

+ Morley.Michelson.Parser: letInner :: Parser ParsedOp -> Parser LetEnv

+ Morley.Michelson.Parser: letType :: Parser LetType

+ Morley.Michelson.Parser: ops :: Parser [ParsedOp]

+ Morley.Michelson.Parser: parseExpandValue :: MichelsonSource -> Text -> Either ParserException Value

+ Morley.Michelson.Parser: parseNoEnv :: Parser a -> MichelsonSource -> Text -> Either (ParseErrorBundle Text CustomParserException) a

+ Morley.Michelson.Parser: parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue

+ Morley.Michelson.Parser: parsedOp :: Parser ParsedOp

+ Morley.Michelson.Parser: pattern MSCli :: MichelsonSource

+ Morley.Michelson.Parser: pattern MSStdin :: MichelsonSource

+ Morley.Michelson.Parser: printComment :: Parser PrintComment

+ Morley.Michelson.Parser: program :: Parsec CustomParserException Text (Contract' ParsedOp)

+ Morley.Michelson.Parser: stringLiteral :: Parser ParsedValue

+ Morley.Michelson.Parser: type Parser = ReaderT LetEnv (Parsec CustomParserException Text)

+ Morley.Michelson.Parser: type_ :: Parser Ty

+ Morley.Michelson.Parser: uparamTypeQ :: QuasiQuoter

+ Morley.Michelson.Parser: utypeQ :: QuasiQuoter

+ Morley.Michelson.Parser: value :: Parser ParsedValue

+ Morley.Michelson.Parser.Annotations: fieldType :: Default a => Parser a -> Parser (a, TypeAnn)

+ Morley.Michelson.Parser.Annotations: note :: forall tag. KnownAnnTag tag => Parser (Annotation tag)

+ Morley.Michelson.Parser.Annotations: noteDef :: KnownAnnTag tag => Parser (Annotation tag)

+ Morley.Michelson.Parser.Annotations: noteF :: Parser FieldAnn

+ Morley.Michelson.Parser.Annotations: noteV :: Parser VarAnn

+ Morley.Michelson.Parser.Annotations: noteV2Def :: Parser (VarAnn, VarAnn)

+ Morley.Michelson.Parser.Annotations: notesTF :: Parser (TypeAnn, FieldAnn)

+ Morley.Michelson.Parser.Annotations: notesTV :: Parser (TypeAnn, VarAnn)

+ Morley.Michelson.Parser.Annotations: notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn)

+ Morley.Michelson.Parser.Annotations: notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))

+ Morley.Michelson.Parser.Annotations: notesVF :: Parser (VarAnn, FieldAnn)

+ Morley.Michelson.Parser.Annotations: notesVVFF :: Parser ((VarAnn, VarAnn), (FieldAnn, FieldAnn))

+ Morley.Michelson.Parser.Annotations: permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a, b)

+ Morley.Michelson.Parser.Annotations: permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) => f a -> f b -> f c -> f (a, b, c)

+ Morley.Michelson.Parser.Error: ExcessFieldAnnotation :: CustomParserException

+ Morley.Michelson.Parser.Error: InvalidChar :: Char -> StringLiteralParserException

+ Morley.Michelson.Parser.Error: InvalidEscapeSequence :: Char -> StringLiteralParserException

+ Morley.Michelson.Parser.Error: MultiRootAnnotationException :: CustomParserException

+ Morley.Michelson.Parser.Error: OddNumberBytesException :: CustomParserException

+ Morley.Michelson.Parser.Error: ParserException :: ParseErrorBundle Text CustomParserException -> ParserException

+ Morley.Michelson.Parser.Error: StringLiteralException :: StringLiteralParserException -> CustomParserException

+ Morley.Michelson.Parser.Error: WrongAccessArgs :: Natural -> Positive -> CustomParserException

+ Morley.Michelson.Parser.Error: WrongSetArgs :: Natural -> Positive -> CustomParserException

+ Morley.Michelson.Parser.Error: WrongTagArgs :: Natural -> Positive -> CustomParserException

+ Morley.Michelson.Parser.Error: data CustomParserException

+ Morley.Michelson.Parser.Error: data ParseErrorBundle s e

+ Morley.Michelson.Parser.Error: data ParserException

+ Morley.Michelson.Parser.Error: data StringLiteralParserException

+ Morley.Michelson.Parser.Error: instance Control.DeepSeq.NFData Morley.Michelson.Parser.Error.CustomParserException

+ Morley.Michelson.Parser.Error: instance Control.DeepSeq.NFData Morley.Michelson.Parser.Error.StringLiteralParserException

+ Morley.Michelson.Parser.Error: instance Data.Data.Data Morley.Michelson.Parser.Error.CustomParserException

+ Morley.Michelson.Parser.Error: instance Data.Data.Data Morley.Michelson.Parser.Error.StringLiteralParserException

+ Morley.Michelson.Parser.Error: instance Formatting.Buildable.Buildable Morley.Michelson.Parser.Error.ParserException

+ Morley.Michelson.Parser.Error: instance GHC.Classes.Eq Morley.Michelson.Parser.Error.CustomParserException

+ Morley.Michelson.Parser.Error: instance GHC.Classes.Eq Morley.Michelson.Parser.Error.ParserException

+ Morley.Michelson.Parser.Error: instance GHC.Classes.Eq Morley.Michelson.Parser.Error.StringLiteralParserException

+ Morley.Michelson.Parser.Error: instance GHC.Classes.Ord Morley.Michelson.Parser.Error.CustomParserException

+ Morley.Michelson.Parser.Error: instance GHC.Classes.Ord Morley.Michelson.Parser.Error.StringLiteralParserException

+ Morley.Michelson.Parser.Error: instance GHC.Exception.Type.Exception Morley.Michelson.Parser.Error.ParserException

+ Morley.Michelson.Parser.Error: instance GHC.Generics.Generic Morley.Michelson.Parser.Error.CustomParserException

+ Morley.Michelson.Parser.Error: instance GHC.Generics.Generic Morley.Michelson.Parser.Error.StringLiteralParserException

+ Morley.Michelson.Parser.Error: instance GHC.Show.Show Morley.Michelson.Parser.Error.CustomParserException

+ Morley.Michelson.Parser.Error: instance GHC.Show.Show Morley.Michelson.Parser.Error.ParserException

+ Morley.Michelson.Parser.Error: instance GHC.Show.Show Morley.Michelson.Parser.Error.StringLiteralParserException

+ Morley.Michelson.Parser.Error: instance Text.Megaparsec.Error.ShowErrorComponent Morley.Michelson.Parser.Error.CustomParserException

+ Morley.Michelson.Parser.Error: instance Text.Megaparsec.Error.ShowErrorComponent Morley.Michelson.Parser.Error.StringLiteralParserException

+ Morley.Michelson.Parser.Ext: extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr

+ Morley.Michelson.Parser.Ext: printComment :: Parser PrintComment

+ Morley.Michelson.Parser.Ext: stackType :: Parser StackTypePattern

+ Morley.Michelson.Parser.Helpers: mkParser :: (a -> Text) -> a -> Parser a

+ Morley.Michelson.Parser.Helpers: parseDef :: Default a => Parser a -> Parser a

+ Morley.Michelson.Parser.Helpers: positive :: Parser Positive

+ Morley.Michelson.Parser.Helpers: sepBy1 :: MonadPlus f => f a -> f sep -> f (NonEmpty a)

+ Morley.Michelson.Parser.Helpers: sepBy2 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)

+ Morley.Michelson.Parser.Helpers: sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)

+ Morley.Michelson.Parser.Helpers: some' :: MonadPlus f => f a -> f (NonEmpty a)

+ Morley.Michelson.Parser.Instr: carOp :: Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: cdrOp :: Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: cmpOp :: Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: dupOp :: Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: mapOp :: Parser ParsedOp -> Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: ops' :: Parser ParsedOp -> Parser [ParsedOp]

+ Morley.Michelson.Parser.Instr: pairNOp :: Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: pairOp :: Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr

+ Morley.Michelson.Parser.Instr: unpairOp :: Parser ParsedInstr

+ Morley.Michelson.Parser.Let: letBlock :: Parser ParsedOp -> Parser LetEnv

+ Morley.Michelson.Parser.Let: letInner :: Parser ParsedOp -> Parser LetEnv

+ Morley.Michelson.Parser.Let: letType :: Parser LetType

+ Morley.Michelson.Parser.Let: mkLetMac :: Map Text LetMacro -> Parser LetMacro

+ Morley.Michelson.Parser.Lexer: braces :: Parser a -> Parser a

+ Morley.Michelson.Parser.Lexer: brackets :: Parser a -> Parser a

+ Morley.Michelson.Parser.Lexer: brackets' :: Parser a -> Parser a

+ Morley.Michelson.Parser.Lexer: comma :: Parser ()

+ Morley.Michelson.Parser.Lexer: lexeme :: Parser a -> Parser a

+ Morley.Michelson.Parser.Lexer: mSpace :: Parser ()

+ Morley.Michelson.Parser.Lexer: parens :: Parser a -> Parser a

+ Morley.Michelson.Parser.Lexer: semicolon :: Parser ()

+ Morley.Michelson.Parser.Lexer: string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text

+ Morley.Michelson.Parser.Lexer: symbol :: Tokens Text -> Parser ()

+ Morley.Michelson.Parser.Lexer: symbol' :: Text -> Parser ()

+ Morley.Michelson.Parser.Lexer: varID :: Parser Var

+ Morley.Michelson.Parser.Lexer: word :: Tokens Text -> a -> Parser a

+ Morley.Michelson.Parser.Lexer: word' :: Tokens Text -> a -> Parser a

+ Morley.Michelson.Parser.Macro: cadrMac :: Parser Macro

+ Morley.Michelson.Parser.Macro: carnMac :: Parser Macro

+ Morley.Michelson.Parser.Macro: cdrnMac :: Parser Macro

+ Morley.Michelson.Parser.Macro: duupMac :: Parser Macro

+ Morley.Michelson.Parser.Macro: ifCmpMac :: Parser ParsedOp -> Parser Macro

+ Morley.Michelson.Parser.Macro: macro :: Parser ParsedOp -> Parser Macro

+ Morley.Michelson.Parser.Macro: mapCadrMac :: Parser ParsedOp -> Parser Macro

+ Morley.Michelson.Parser.Macro: pairMac :: Parser Macro

+ Morley.Michelson.Parser.Type: field :: Parser (FieldAnn, Ty)

+ Morley.Michelson.Parser.Type: type_ :: Parser Ty

+ Morley.Michelson.Parser.Types: LetEnv :: Map Text LetMacro -> Map Text LetValue -> Map Text LetType -> LetEnv

+ Morley.Michelson.Parser.Types: MSCode :: SrcLoc -> MichelsonSource

+ Morley.Michelson.Parser.Types: MSFile :: FilePath -> MichelsonSource

+ Morley.Michelson.Parser.Types: MSName :: Text -> MichelsonSource

+ Morley.Michelson.Parser.Types: MSUnspecified :: MichelsonSource

+ Morley.Michelson.Parser.Types: [letMacros] :: LetEnv -> Map Text LetMacro

+ Morley.Michelson.Parser.Types: [letTypes] :: LetEnv -> Map Text LetType

+ Morley.Michelson.Parser.Types: [letValues] :: LetEnv -> Map Text LetValue

+ Morley.Michelson.Parser.Types: codeSrc :: HasCallStack => MichelsonSource

+ Morley.Michelson.Parser.Types: data LetEnv

+ Morley.Michelson.Parser.Types: data MichelsonSource

+ Morley.Michelson.Parser.Types: instance Data.Default.Class.Default a => Data.Default.Class.Default (Morley.Michelson.Parser.Types.Parser a)

+ Morley.Michelson.Parser.Types: instance Data.String.IsString Morley.Michelson.Parser.Types.MichelsonSource

+ Morley.Michelson.Parser.Types: instance Formatting.Buildable.Buildable Morley.Michelson.Parser.Types.MichelsonSource

+ Morley.Michelson.Parser.Types: instance GHC.Classes.Eq Morley.Michelson.Parser.Types.LetEnv

+ Morley.Michelson.Parser.Types: instance GHC.Classes.Eq Morley.Michelson.Parser.Types.MichelsonSource

+ Morley.Michelson.Parser.Types: instance GHC.Show.Show Morley.Michelson.Parser.Types.LetEnv

+ Morley.Michelson.Parser.Types: instance GHC.Show.Show Morley.Michelson.Parser.Types.MichelsonSource

+ Morley.Michelson.Parser.Types: noLetEnv :: LetEnv

+ Morley.Michelson.Parser.Types: pattern MSCli :: MichelsonSource

+ Morley.Michelson.Parser.Types: pattern MSStdin :: MichelsonSource

+ Morley.Michelson.Parser.Types: type Parser = ReaderT LetEnv (Parsec CustomParserException Text)

+ Morley.Michelson.Parser.Value: bytesLiteral :: Parser (Value' op)

+ Morley.Michelson.Parser.Value: intLiteral :: Parser (Value' op)

+ Morley.Michelson.Parser.Value: mkLetVal :: Map Text LetValue -> Parser LetValue

+ Morley.Michelson.Parser.Value: stringLiteral :: Parser ParsedValue

+ Morley.Michelson.Parser.Value: value' :: Parser ParsedOp -> Parser ParsedValue

+ Morley.Michelson.Preprocess: transformBytes :: Bool -> (ByteString -> ByteString) -> Instr inp out -> Instr inp out

+ Morley.Michelson.Preprocess: transformStrings :: Bool -> (MText -> MText) -> Instr inp out -> Instr inp out

+ Morley.Michelson.Printer: class RenderDoc a

+ Morley.Michelson.Printer: isRenderable :: RenderDoc a => a -> Bool

+ Morley.Michelson.Printer: printDoc :: Bool -> Doc -> Text

+ Morley.Michelson.Printer: printSomeContract :: Bool -> SomeContract -> Text

+ Morley.Michelson.Printer: printTypedContract :: Bool -> Contract p s -> Text

+ Morley.Michelson.Printer: printTypedContractCode :: (SingI p, SingI s) => Bool -> ContractCode p s -> Text

+ Morley.Michelson.Printer: printTypedValue :: forall t. ProperUntypedValBetterErrors t => Bool -> Value t -> Text

+ Morley.Michelson.Printer: printUntypedContract :: RenderDoc op => Bool -> Contract' op -> Text

+ Morley.Michelson.Printer: printUntypedValue :: RenderDoc op => Bool -> Value' op -> Text

+ Morley.Michelson.Printer: renderAnyBuildable :: Buildable a => a -> Doc

+ Morley.Michelson.Printer: renderDoc :: RenderDoc a => RenderContext -> a -> Doc

+ Morley.Michelson.Printer.Util: Prettier :: a -> Prettier a

+ Morley.Michelson.Printer.Util: addParens :: RenderContext -> Doc -> Doc

+ Morley.Michelson.Printer.Util: assertParensNotNeeded :: RenderContext -> a -> a

+ Morley.Michelson.Printer.Util: buildRenderDoc :: RenderDoc a => a -> Builder

+ Morley.Michelson.Printer.Util: buildRenderDocExtended :: RenderDoc a => a -> Builder

+ Morley.Michelson.Printer.Util: class RenderDoc a

+ Morley.Michelson.Printer.Util: data RenderContext

+ Morley.Michelson.Printer.Util: doesntNeedParens :: RenderContext

+ Morley.Michelson.Printer.Util: isRenderable :: RenderDoc a => a -> Bool

+ Morley.Michelson.Printer.Util: needsParens :: RenderContext

+ Morley.Michelson.Printer.Util: newtype Prettier a

+ Morley.Michelson.Printer.Util: printDoc :: Bool -> Doc -> Text

+ Morley.Michelson.Printer.Util: printDocB :: Bool -> Doc -> Builder

+ Morley.Michelson.Printer.Util: printDocS :: Bool -> Doc -> String

+ Morley.Michelson.Printer.Util: renderAnyBuildable :: Buildable a => a -> Doc

+ Morley.Michelson.Printer.Util: renderDoc :: RenderDoc a => RenderContext -> a -> Doc

+ Morley.Michelson.Printer.Util: renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc

+ Morley.Michelson.Printer.Util: renderOps :: RenderDoc op => Bool -> NonEmpty op -> Doc

+ Morley.Michelson.Printer.Util: renderOpsList :: RenderDoc op => Bool -> [op] -> Doc

+ Morley.Michelson.Printer.Util: renderOpsListNoBraces :: RenderDoc op => Bool -> [op] -> Doc

+ Morley.Michelson.Printer.Util: spaces :: Int -> Doc

+ Morley.Michelson.Printer.Util: wrapInParens :: RenderContext -> NonEmpty Doc -> Doc

+ Morley.Michelson.Runtime: ASContract :: ContractState -> AddressState

+ Morley.Michelson.Runtime: ASSimple :: Mutez -> AddressState

+ Morley.Michelson.Runtime: ContractState :: Mutez -> Contract cp st -> Value st -> Maybe KeyHash -> ContractState

+ Morley.Michelson.Runtime: EEAlreadyOriginated :: a -> ContractState -> ExecutorError' a

+ Morley.Michelson.Runtime: EEFailedToApplyUpdates :: GStateUpdateError -> ExecutorError' a

+ Morley.Michelson.Runtime: EEIllTypedParameter :: a -> TCError -> ExecutorError' a

+ Morley.Michelson.Runtime: EEInterpreterFailed :: a -> InterpretError -> ExecutorError' a

+ Morley.Michelson.Runtime: EENotEnoughFunds :: a -> Mutez -> ExecutorError' a

+ Morley.Michelson.Runtime: EEOperationReplay :: ExecutorOp -> ExecutorError' a

+ Morley.Michelson.Runtime: EETransactionFromContract :: a -> Mutez -> ExecutorError' a

+ Morley.Michelson.Runtime: EEUnexpectedParameterType :: a -> T -> T -> ExecutorError' a

+ Morley.Michelson.Runtime: EEUnknownContract :: a -> ExecutorError' a

+ Morley.Michelson.Runtime: EEUnknownEntrypoint :: EpName -> ExecutorError' a

+ Morley.Michelson.Runtime: EEUnknownManager :: a -> ExecutorError' a

+ Morley.Michelson.Runtime: EEUnknownSender :: a -> ExecutorError' a

+ Morley.Michelson.Runtime: EEWrongParameterType :: a -> ExecutorError' a

+ Morley.Michelson.Runtime: EEZeroTransaction :: a -> ExecutorError' a

+ Morley.Michelson.Runtime: ExecutorRes :: GState -> [GStateUpdate] -> [(Address, InterpretResult)] -> RemainingSteps -> ExecutorRes

+ Morley.Michelson.Runtime: OriginateOp :: OriginationOperation -> ExecutorOp

+ Morley.Michelson.Runtime: SetDelegateOp :: SetDelegateOperation -> ExecutorOp

+ Morley.Michelson.Runtime: TransferOp :: TransferOperation -> ExecutorOp

+ Morley.Michelson.Runtime: TxData :: Address -> TxParam -> EpName -> Mutez -> TxData

+ Morley.Michelson.Runtime: [TxTypedParam] :: forall t. ParameterScope t => Value t -> TxParam

+ Morley.Michelson.Runtime: [TxUntypedParam] :: Value -> TxParam

+ Morley.Michelson.Runtime: [_erGState] :: ExecutorRes -> GState

+ Morley.Michelson.Runtime: [_erInterpretResults] :: ExecutorRes -> [(Address, InterpretResult)]

+ Morley.Michelson.Runtime: [_erRemainingSteps] :: ExecutorRes -> RemainingSteps

+ Morley.Michelson.Runtime: [_erUpdates] :: ExecutorRes -> [GStateUpdate]

+ Morley.Michelson.Runtime: [csBalance] :: ContractState -> Mutez

+ Morley.Michelson.Runtime: [csContract] :: ContractState -> Contract cp st

+ Morley.Michelson.Runtime: [csDelegate] :: ContractState -> Maybe KeyHash

+ Morley.Michelson.Runtime: [csStorage] :: ContractState -> Value st

+ Morley.Michelson.Runtime: [tdAmount] :: TxData -> Mutez

+ Morley.Michelson.Runtime: [tdEntrypoint] :: TxData -> EpName

+ Morley.Michelson.Runtime: [tdParameter] :: TxData -> TxParam

+ Morley.Michelson.Runtime: [tdSenderAddress] :: TxData -> Address

+ Morley.Michelson.Runtime: data AddressState

+ Morley.Michelson.Runtime: data ContractState

+ Morley.Michelson.Runtime: data ExecutorError' a

+ Morley.Michelson.Runtime: data ExecutorOp

+ Morley.Michelson.Runtime: data ExecutorRes

+ Morley.Michelson.Runtime: data TxData

+ Morley.Michelson.Runtime: data TxParam

+ Morley.Michelson.Runtime: data VotingPowers

+ Morley.Michelson.Runtime: elInterpreterResults :: Lens' ExecutorLog [(Address, InterpretResult)]

+ Morley.Michelson.Runtime: elUpdates :: Lens' ExecutorLog [GStateUpdate]

+ Morley.Michelson.Runtime: erGState :: Lens' ExecutorRes GState

+ Morley.Michelson.Runtime: erInterpretResults :: Lens' ExecutorRes [(Address, InterpretResult)]

+ Morley.Michelson.Runtime: erRemainingSteps :: Lens' ExecutorRes RemainingSteps

+ Morley.Michelson.Runtime: erUpdates :: Lens' ExecutorRes [GStateUpdate]

+ Morley.Michelson.Runtime: executeGlobalOperations :: TypeCheckOptions -> [ExecutorOp] -> ExecutorM ()

+ Morley.Michelson.Runtime: executeGlobalOrigination :: OriginationOperation -> ExecutorM Address

+ Morley.Michelson.Runtime: executeOrigination :: ("isGlobalOp" :! Bool) -> OriginationOperation -> ExecutorM Address

+ Morley.Michelson.Runtime: executeTransfer :: ("isGlobalOp" :! Bool) -> TypeCheckOptions -> TransferOperation -> ExecutorM [ExecutorOp]

+ Morley.Michelson.Runtime: instance (Data.Typeable.Internal.Typeable a, GHC.Show.Show a, Formatting.Buildable.Buildable a) => GHC.Exception.Type.Exception (Morley.Michelson.Runtime.ExecutorError' a)

+ Morley.Michelson.Runtime: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.ExecutorOp

+ Morley.Michelson.Runtime: instance Formatting.Buildable.Buildable a => Formatting.Buildable.Buildable (Morley.Michelson.Runtime.ExecutorError' a)

+ Morley.Michelson.Runtime: instance GHC.Base.Functor Morley.Michelson.Runtime.ExecutorError'

+ Morley.Michelson.Runtime: instance GHC.Base.Monoid Morley.Michelson.Runtime.ExecutorLog

+ Morley.Michelson.Runtime: instance GHC.Base.Semigroup Morley.Michelson.Runtime.ExecutorLog

+ Morley.Michelson.Runtime: instance GHC.Generics.Generic Morley.Michelson.Runtime.ExecutorEnv

+ Morley.Michelson.Runtime: instance GHC.Generics.Generic Morley.Michelson.Runtime.ExecutorLog

+ Morley.Michelson.Runtime: instance GHC.Generics.Generic Morley.Michelson.Runtime.ExecutorState

+ Morley.Michelson.Runtime: instance GHC.Show.Show Morley.Michelson.Runtime.ExecutorEnv

+ Morley.Michelson.Runtime: instance GHC.Show.Show Morley.Michelson.Runtime.ExecutorLog

+ Morley.Michelson.Runtime: instance GHC.Show.Show Morley.Michelson.Runtime.ExecutorOp

+ Morley.Michelson.Runtime: instance GHC.Show.Show Morley.Michelson.Runtime.ExecutorRes

+ Morley.Michelson.Runtime: instance GHC.Show.Show Morley.Michelson.Runtime.ExecutorState

+ Morley.Michelson.Runtime: instance GHC.Show.Show a => GHC.Show.Show (Morley.Michelson.Runtime.ExecutorError' a)

+ Morley.Michelson.Runtime: mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers

+ Morley.Michelson.Runtime: mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers

+ Morley.Michelson.Runtime: originateContract :: FilePath -> TypeCheckOptions -> Address -> Maybe KeyHash -> Mutez -> Value -> Contract -> ("verbose" :! Bool) -> IO Address

+ Morley.Michelson.Runtime: parseContract :: MichelsonSource -> Text -> Either ParserException (Contract' ParsedOp)

+ Morley.Michelson.Runtime: parseExpandContract :: MichelsonSource -> Text -> Either ParserException Contract

+ Morley.Michelson.Runtime: prepareContract :: Maybe FilePath -> IO Contract

+ Morley.Michelson.Runtime: readAndParseContract :: Maybe FilePath -> IO (Contract' ParsedOp)

+ Morley.Michelson.Runtime: runContract :: Maybe Timestamp -> Maybe Natural -> Word64 -> Mutez -> FilePath -> TypeCheckOptions -> Value -> Contract -> TxData -> ("verbose" :! Bool) -> ("dryRun" :! Bool) -> IO SomeStorage

+ Morley.Michelson.Runtime: runExecutorM :: Timestamp -> Natural -> RemainingSteps -> GState -> ExecutorM a -> Either ExecutorError (ExecutorRes, a)

+ Morley.Michelson.Runtime: runExecutorMWithDB :: Maybe Timestamp -> Maybe Natural -> FilePath -> RemainingSteps -> ("verbose" :! Bool) -> ("dryRun" :? Bool) -> ExecutorM a -> IO (ExecutorRes, a)

+ Morley.Michelson.Runtime: transfer :: Maybe Timestamp -> Maybe Natural -> Word64 -> FilePath -> TypeCheckOptions -> Address -> TxData -> ("verbose" :! Bool) -> ("dryRun" :? Bool) -> IO ()

+ Morley.Michelson.Runtime: type ExecutorError = ExecutorError' Address

+ Morley.Michelson.Runtime: type ExecutorM = ReaderT ExecutorEnv (StateT ExecutorState (Except ExecutorError))

+ Morley.Michelson.Runtime.Dummy: dummyBigMapCounter :: BigMapCounter

+ Morley.Michelson.Runtime.Dummy: dummyContractEnv :: ContractEnv

+ Morley.Michelson.Runtime.Dummy: dummyGlobalCounter :: GlobalCounter

+ Morley.Michelson.Runtime.Dummy: dummyLevel :: Natural

+ Morley.Michelson.Runtime.Dummy: dummyMaxSteps :: RemainingSteps

+ Morley.Michelson.Runtime.Dummy: dummyNow :: Timestamp

+ Morley.Michelson.Runtime.Dummy: dummyOrigination :: (ParameterScope cp, StorageScope st) => Value st -> Contract cp st -> GlobalCounter -> OriginationOperation

+ Morley.Michelson.Runtime.Dummy: dummyVotingPowers :: VotingPowers

+ Morley.Michelson.Runtime.GState: ASContract :: ContractState -> AddressState

+ Morley.Michelson.Runtime.GState: ASSimple :: Mutez -> AddressState

+ Morley.Michelson.Runtime.GState: BigMapCounter :: Natural -> BigMapCounter

+ Morley.Michelson.Runtime.GState: ContractState :: Mutez -> Contract cp st -> Value st -> Maybe KeyHash -> ContractState

+ Morley.Michelson.Runtime.GState: GState :: ChainId -> Map Address AddressState -> VotingPowers -> GlobalCounter -> BigMapCounter -> GState

+ Morley.Michelson.Runtime.GState: GStateAddressExists :: Address -> GStateUpdateError

+ Morley.Michelson.Runtime.GState: GStateNotContract :: Address -> GStateUpdateError

+ Morley.Michelson.Runtime.GState: GStateStorageNotMatch :: Address -> GStateUpdateError

+ Morley.Michelson.Runtime.GState: GStateUnknownAddress :: Address -> GStateUpdateError

+ Morley.Michelson.Runtime.GState: VotingPowers :: Map KeyHash Natural -> VotingPowers

+ Morley.Michelson.Runtime.GState: [GSAddAddress] :: Address -> AddressState -> GStateUpdate

+ Morley.Michelson.Runtime.GState: [GSIncrementCounter] :: GStateUpdate

+ Morley.Michelson.Runtime.GState: [GSSetBalance] :: Address -> Mutez -> GStateUpdate

+ Morley.Michelson.Runtime.GState: [GSSetBigMapCounter] :: BigMapCounter -> GStateUpdate

+ Morley.Michelson.Runtime.GState: [GSSetDelegate] :: Address -> Maybe KeyHash -> GStateUpdate

+ Morley.Michelson.Runtime.GState: [GSSetStorageValue] :: StorageScope st => Address -> Value st -> GStateUpdate

+ Morley.Michelson.Runtime.GState: [GSUpdateCounter] :: GlobalCounter -> GStateUpdate

+ Morley.Michelson.Runtime.GState: [_bigMapCounter] :: BigMapCounter -> Natural

+ Morley.Michelson.Runtime.GState: [csBalance] :: ContractState -> Mutez

+ Morley.Michelson.Runtime.GState: [csContract] :: ContractState -> Contract cp st

+ Morley.Michelson.Runtime.GState: [csDelegate] :: ContractState -> Maybe KeyHash

+ Morley.Michelson.Runtime.GState: [csStorage] :: ContractState -> Value st

+ Morley.Michelson.Runtime.GState: [gsAddresses] :: GState -> Map Address AddressState

+ Morley.Michelson.Runtime.GState: [gsBigMapCounter] :: GState -> BigMapCounter

+ Morley.Michelson.Runtime.GState: [gsChainId] :: GState -> ChainId

+ Morley.Michelson.Runtime.GState: [gsCounter] :: GState -> GlobalCounter

+ Morley.Michelson.Runtime.GState: [gsVotingPowers] :: GState -> VotingPowers

+ Morley.Michelson.Runtime.GState: applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState

+ Morley.Michelson.Runtime.GState: applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState

+ Morley.Michelson.Runtime.GState: asBalance :: AddressState -> Mutez

+ Morley.Michelson.Runtime.GState: bigMapCounter :: Iso' BigMapCounter Natural

+ Morley.Michelson.Runtime.GState: data AddressState

+ Morley.Michelson.Runtime.GState: data ContractState

+ Morley.Michelson.Runtime.GState: data GState

+ Morley.Michelson.Runtime.GState: data GStateUpdate

+ Morley.Michelson.Runtime.GState: data GStateUpdateError

+ Morley.Michelson.Runtime.GState: dummyVotingPowers :: VotingPowers

+ Morley.Michelson.Runtime.GState: extractAllContracts :: GState -> TcOriginatedContracts

+ Morley.Michelson.Runtime.GState: genesisAddress :: Address

+ Morley.Michelson.Runtime.GState: genesisAddress1 :: Address

+ Morley.Michelson.Runtime.GState: genesisAddress2 :: Address

+ Morley.Michelson.Runtime.GState: genesisAddress3 :: Address

+ Morley.Michelson.Runtime.GState: genesisAddress4 :: Address

+ Morley.Michelson.Runtime.GState: genesisAddress5 :: Address

+ Morley.Michelson.Runtime.GState: genesisAddress6 :: Address

+ Morley.Michelson.Runtime.GState: genesisAddresses :: NonEmpty Address

+ Morley.Michelson.Runtime.GState: genesisKeyHash :: KeyHash

+ Morley.Michelson.Runtime.GState: genesisKeyHashes :: NonEmpty KeyHash

+ Morley.Michelson.Runtime.GState: genesisSecretKey :: SecretKey

+ Morley.Michelson.Runtime.GState: genesisSecrets :: NonEmpty SecretKey

+ Morley.Michelson.Runtime.GState: gsAddressesL :: Lens' GState (Map Address AddressState)

+ Morley.Michelson.Runtime.GState: gsBigMapCounterL :: Lens' GState BigMapCounter

+ Morley.Michelson.Runtime.GState: gsChainIdL :: Lens' GState ChainId

+ Morley.Michelson.Runtime.GState: gsCounterL :: Lens' GState GlobalCounter

+ Morley.Michelson.Runtime.GState: gsVotingPowersL :: Lens' GState VotingPowers

+ Morley.Michelson.Runtime.GState: initGState :: GState

+ Morley.Michelson.Runtime.GState: instance Control.DeepSeq.NFData Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Runtime.GState.AddressState

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Runtime.GState.ContractState

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Runtime.GState.GState

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Runtime.GState.VotingPowers

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Runtime.GState.AddressState

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Runtime.GState.ContractState

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Runtime.GState.GState

+ Morley.Michelson.Runtime.GState: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Runtime.GState.VotingPowers

+ Morley.Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.GState.AddressState

+ Morley.Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.GState.ContractState

+ Morley.Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.GState.GStateUpdate

+ Morley.Michelson.Runtime.GState: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.GState.GStateUpdateError

+ Morley.Michelson.Runtime.GState: instance GHC.Classes.Eq Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance GHC.Exception.Type.Exception Morley.Michelson.Runtime.GState.GStateParseError

+ Morley.Michelson.Runtime.GState: instance GHC.Generics.Generic Morley.Michelson.Runtime.GState.AddressState

+ Morley.Michelson.Runtime.GState: instance GHC.Generics.Generic Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance GHC.Num.Num Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.AddressState

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.BigMapCounter

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.ContractState

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.GState

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.GStateParseError

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.GStateUpdate

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.GStateUpdateError

+ Morley.Michelson.Runtime.GState: instance GHC.Show.Show Morley.Michelson.Runtime.GState.VotingPowers

+ Morley.Michelson.Runtime.GState: mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers

+ Morley.Michelson.Runtime.GState: mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers

+ Morley.Michelson.Runtime.GState: newtype BigMapCounter

+ Morley.Michelson.Runtime.GState: newtype VotingPowers

+ Morley.Michelson.Runtime.GState: readGState :: FilePath -> IO GState

+ Morley.Michelson.Runtime.GState: vpPick :: KeyHash -> VotingPowers -> Natural

+ Morley.Michelson.Runtime.GState: vpTotal :: VotingPowers -> Natural

+ Morley.Michelson.Runtime.GState: writeGState :: FilePath -> GState -> IO ()

+ Morley.Michelson.Runtime.Import: CREParse :: MichelsonSource -> ParserException -> ContractReadError

+ Morley.Michelson.Runtime.Import: CRETypeCheck :: MichelsonSource -> TCError -> ContractReadError

+ Morley.Michelson.Runtime.Import: MSCode :: SrcLoc -> MichelsonSource

+ Morley.Michelson.Runtime.Import: MSFile :: FilePath -> MichelsonSource

+ Morley.Michelson.Runtime.Import: MSName :: Text -> MichelsonSource

+ Morley.Michelson.Runtime.Import: MSUnspecified :: MichelsonSource

+ Morley.Michelson.Runtime.Import: VREParse :: MichelsonSource -> ParserException -> ValueReadError

+ Morley.Michelson.Runtime.Import: VRETypeCheck :: MichelsonSource -> TCError -> ValueReadError

+ Morley.Michelson.Runtime.Import: data ContractReadError

+ Morley.Michelson.Runtime.Import: data MichelsonSource

+ Morley.Michelson.Runtime.Import: data ValueReadError

+ Morley.Michelson.Runtime.Import: importContract :: forall cp st. Each '[SingI] [cp, st] => FilePath -> IO (Contract cp st)

+ Morley.Michelson.Runtime.Import: importSomeContract :: FilePath -> IO SomeContract

+ Morley.Michelson.Runtime.Import: importSomeValue :: Ty -> FilePath -> IO SomeValue

+ Morley.Michelson.Runtime.Import: importUntypedContract :: FilePath -> IO Contract

+ Morley.Michelson.Runtime.Import: importUntypedValue :: FilePath -> IO Value

+ Morley.Michelson.Runtime.Import: importUsing :: Exception e => (MichelsonSource -> Text -> Either e a) -> FilePath -> IO a

+ Morley.Michelson.Runtime.Import: importValue :: forall t. SingI t => FilePath -> IO (Value t)

+ Morley.Michelson.Runtime.Import: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.Import.ContractReadError

+ Morley.Michelson.Runtime.Import: instance Formatting.Buildable.Buildable Morley.Michelson.Runtime.Import.ValueReadError

+ Morley.Michelson.Runtime.Import: instance GHC.Classes.Eq Morley.Michelson.Runtime.Import.ContractReadError

+ Morley.Michelson.Runtime.Import: instance GHC.Classes.Eq Morley.Michelson.Runtime.Import.ValueReadError

+ Morley.Michelson.Runtime.Import: instance GHC.Exception.Type.Exception Morley.Michelson.Runtime.Import.ContractReadError

+ Morley.Michelson.Runtime.Import: instance GHC.Exception.Type.Exception Morley.Michelson.Runtime.Import.ValueReadError

+ Morley.Michelson.Runtime.Import: instance GHC.Show.Show Morley.Michelson.Runtime.Import.ContractReadError

+ Morley.Michelson.Runtime.Import: instance GHC.Show.Show Morley.Michelson.Runtime.Import.ValueReadError

+ Morley.Michelson.Runtime.Import: pattern MSCli :: MichelsonSource

+ Morley.Michelson.Runtime.Import: pattern MSStdin :: MichelsonSource

+ Morley.Michelson.Runtime.Import: readContract :: forall cp st. Each '[SingI] [cp, st] => MichelsonSource -> Text -> Either ContractReadError (Contract cp st)

+ Morley.Michelson.Runtime.Import: readSomeContract :: MichelsonSource -> Text -> Either ContractReadError SomeContract

+ Morley.Michelson.Runtime.Import: readUntypedContract :: MichelsonSource -> Text -> Either ContractReadError Contract

+ Morley.Michelson.Runtime.Import: readValue :: forall t. SingI t => MichelsonSource -> Text -> Either ValueReadError (Value t)

+ Morley.Michelson.Runtime.TxData: TxData :: Address -> TxParam -> EpName -> Mutez -> TxData

+ Morley.Michelson.Runtime.TxData: [TxTypedParam] :: forall t. ParameterScope t => Value t -> TxParam

+ Morley.Michelson.Runtime.TxData: [TxUntypedParam] :: Value -> TxParam

+ Morley.Michelson.Runtime.TxData: [tdAmount] :: TxData -> Mutez

+ Morley.Michelson.Runtime.TxData: [tdEntrypoint] :: TxData -> EpName

+ Morley.Michelson.Runtime.TxData: [tdParameter] :: TxData -> TxParam

+ Morley.Michelson.Runtime.TxData: [tdSenderAddress] :: TxData -> Address

+ Morley.Michelson.Runtime.TxData: data TxData

+ Morley.Michelson.Runtime.TxData: data TxParam

+ Morley.Michelson.Runtime.TxData: instance GHC.Show.Show Morley.Michelson.Runtime.TxData.TxData

+ Morley.Michelson.Runtime.TxData: instance GHC.Show.Show Morley.Michelson.Runtime.TxData.TxParam

+ Morley.Michelson.Runtime.TxData: tdAmountL :: Lens' TxData Mutez

+ Morley.Michelson.Runtime.TxData: tdEntrypointL :: Lens' TxData EpName

+ Morley.Michelson.Runtime.TxData: tdParameterL :: Lens' TxData TxParam

+ Morley.Michelson.Runtime.TxData: tdSenderAddressL :: Lens' TxData Address

+ Morley.Michelson.Text: UnsafeMText :: Text -> MText

+ Morley.Michelson.Text: [unMText] :: MText -> Text

+ Morley.Michelson.Text: dropMText :: Int -> MText -> MText

+ Morley.Michelson.Text: instance Control.DeepSeq.NFData Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Data.Data.Data Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Data.Hashable.Class.Hashable Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Formatting.Buildable.Buildable Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance GHC.Base.Monoid Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance GHC.Base.Semigroup Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance GHC.Classes.Eq Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance GHC.Classes.Ord Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance GHC.Generics.Generic Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance GHC.Show.Show Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Morley.Util.CLI.HasCLReader Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Universum.Container.Class.Container Morley.Michelson.Text.MText

+ Morley.Michelson.Text: instance Universum.String.Conversion.ToText Morley.Michelson.Text.MText

+ Morley.Michelson.Text: isMChar :: Char -> Bool

+ Morley.Michelson.Text: labelToMText :: Label name -> MText

+ Morley.Michelson.Text: maxBoundMChar :: Int

+ Morley.Michelson.Text: minBoundMChar :: Int

+ Morley.Michelson.Text: mkMText :: Text -> Either Text MText

+ Morley.Michelson.Text: mkMTextCut :: Text -> MText

+ Morley.Michelson.Text: mt :: QuasiQuoter

+ Morley.Michelson.Text: mtextHeadToUpper :: HasCallStack => MText -> MText

+ Morley.Michelson.Text: newtype MText

+ Morley.Michelson.Text: qqMText :: String -> Either Text String

+ Morley.Michelson.Text: symbolToMText :: forall name. KnownSymbol name => MText

+ Morley.Michelson.Text: takeMText :: Int -> MText -> MText

+ Morley.Michelson.Text: type family DoNotUseTextError

+ Morley.Michelson.Text: unsafeMkMText :: HasCallStack => Text -> MText

+ Morley.Michelson.Text: writeMText :: MText -> Text

+ Morley.Michelson.TypeCheck: eqType :: forall (a :: T) (b :: T). Each '[SingI] [a, b] => Either TCTypeError (a :~: b)

+ Morley.Michelson.TypeCheck: matchTypes :: forall t1 t2. Each '[SingI] [t1, t2] => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)

+ Morley.Michelson.TypeCheck: typeCheckContract :: Contract -> TypeCheckResult SomeContract

+ Morley.Michelson.TypeCheck: typeCheckContractAndStorage :: Contract -> Value -> TypeCheckResult SomeContractAndStorage

+ Morley.Michelson.TypeCheck: typeCheckExt :: forall s. SingI s => TcInstrHandler -> ExpandedExtInstr -> HST s -> TypeCheckInstrNoExcept (TypeCheckedSeq s)

+ Morley.Michelson.TypeCheck: typeCheckInstr :: TcInstrHandler

+ Morley.Michelson.TypeCheck: typeCheckList :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheck (SomeInstr inp)

+ Morley.Michelson.TypeCheck: typeCheckListNoExcept :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)

+ Morley.Michelson.TypeCheck: typeCheckParameter :: TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

+ Morley.Michelson.TypeCheck: typeCheckStorage :: Ty -> Value -> TypeCheckResult SomeValue

+ Morley.Michelson.TypeCheck: typeCheckTopLevelType :: Maybe TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

+ Morley.Michelson.TypeCheck: typeCheckValue :: forall t. SingI t => Value -> TypeCheckInstr (Value t)

+ Morley.Michelson.TypeCheck: typeVerifyContract :: forall cp st. (SingI cp, SingI st) => Contract -> TypeCheckResult (Contract cp st)

+ Morley.Michelson.TypeCheck: typeVerifyParameter :: SingI t => TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

+ Morley.Michelson.TypeCheck: typeVerifyStorage :: SingI t => Value -> TypeCheckResult (Value t)

+ Morley.Michelson.TypeCheck: typeVerifyTopLevelType :: forall t. SingI t => Maybe TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

+ Morley.Michelson.TypeCheck.Error: AnnError :: AnnConvergeError -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: AnyError :: TCTypeError

+ Morley.Michelson.TypeCheck.Error: ArithmeticOperation :: TypeContext

+ Morley.Michelson.TypeCheck.Error: CarArgument :: TypeContext

+ Morley.Michelson.TypeCheck.Error: Cast :: TypeContext

+ Morley.Michelson.TypeCheck.Error: CdrArgument :: TypeContext

+ Morley.Michelson.TypeCheck.Error: CodeAlwaysFails :: TCTypeError

+ Morley.Michelson.TypeCheck.Error: ComparisonArguments :: TypeContext

+ Morley.Michelson.TypeCheck.Error: ConcatArgument :: TypeContext

+ Morley.Michelson.TypeCheck.Error: ConsArgument :: TypeContext

+ Morley.Michelson.TypeCheck.Error: ContainerKeyType :: TypeContext

+ Morley.Michelson.TypeCheck.Error: ContainerValueType :: TypeContext

+ Morley.Michelson.TypeCheck.Error: ContractParameter :: TypeContext

+ Morley.Michelson.TypeCheck.Error: ContractStorage :: TypeContext

+ Morley.Michelson.TypeCheck.Error: DipCode :: TypeContext

+ Morley.Michelson.TypeCheck.Error: EmptyCode :: TCTypeError

+ Morley.Michelson.TypeCheck.Error: EntrypointNotFound :: EpName -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: FailwithArgument :: TypeContext

+ Morley.Michelson.TypeCheck.Error: If :: TypeContext

+ Morley.Michelson.TypeCheck.Error: IllegalEntrypoint :: EpNameFromRefAnnError -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: IllegalParamDecl :: ParamEpError -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: InvalidAddress :: ParseEpAddressError -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: InvalidBls12381Object :: DeserializationError -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: InvalidInstruction :: ExpandedInstr -> Text -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: InvalidKeyHash :: CryptoParseError -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: InvalidStackReference :: StackRef -> StackSize -> ExtError

+ Morley.Michelson.TypeCheck.Error: InvalidTimestamp :: TCTypeError

+ Morley.Michelson.TypeCheck.Error: InvalidValueType :: T -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: Iteration :: TypeContext

+ Morley.Michelson.TypeCheck.Error: LambdaArgument :: TypeContext

+ Morley.Michelson.TypeCheck.Error: LambdaCode :: TypeContext

+ Morley.Michelson.TypeCheck.Error: LengthMismatch :: StackTypePattern -> ExtError

+ Morley.Michelson.TypeCheck.Error: MutezOverflow :: TCTypeError

+ Morley.Michelson.TypeCheck.Error: NegativeNat :: TCTypeError

+ Morley.Michelson.TypeCheck.Error: NotEnoughItemsOnStack :: TCTypeError

+ Morley.Michelson.TypeCheck.Error: NotNumericTypes :: T -> T -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: StackEqError :: [T] -> [T] -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: StackSize :: Natural -> StackSize

+ Morley.Michelson.TypeCheck.Error: StkRestMismatch :: StackTypePattern -> SomeHST -> SomeHST -> TCTypeError -> ExtError

+ Morley.Michelson.TypeCheck.Error: TCContractError :: Text -> Maybe TCTypeError -> TCError

+ Morley.Michelson.TypeCheck.Error: TCExtError :: SomeHST -> InstrCallStack -> ExtError -> TCError

+ Morley.Michelson.TypeCheck.Error: TCFailedOnInstr :: ExpandedInstr -> SomeHST -> InstrCallStack -> Maybe TypeContext -> Maybe TCTypeError -> TCError

+ Morley.Michelson.TypeCheck.Error: TCFailedOnValue :: Value -> T -> Text -> InstrCallStack -> Maybe TCTypeError -> TCError

+ Morley.Michelson.TypeCheck.Error: TCIncompletelyTyped :: TCError -> Contract' TypeCheckedOp -> TCError

+ Morley.Michelson.TypeCheck.Error: TCUnreachableCode :: InstrCallStack -> NonEmpty ExpandedOp -> TCError

+ Morley.Michelson.TypeCheck.Error: TestAssertError :: Text -> ExtError

+ Morley.Michelson.TypeCheck.Error: TicketsJoin :: TypeContext

+ Morley.Michelson.TypeCheck.Error: TltParameterType :: TopLevelType

+ Morley.Michelson.TypeCheck.Error: TltStorageType :: TopLevelType

+ Morley.Michelson.TypeCheck.Error: TyVarMismatch :: Var -> Ty -> StackTypePattern -> Int -> TCTypeError -> ExtError

+ Morley.Michelson.TypeCheck.Error: TypeEqError :: T -> T -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: TypeMismatch :: StackTypePattern -> Int -> TCTypeError -> ExtError

+ Morley.Michelson.TypeCheck.Error: UnexpectedTopLevelType :: TopLevelType -> ("expected" :! T) -> ("got" :! T) -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: UnexpectedType :: NonEmpty (NonEmpty Text) -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: UnknownContract :: Address -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: UnpairArgument :: TypeContext

+ Morley.Michelson.TypeCheck.Error: UnsupportedTypeForScope :: T -> BadTypeForScope -> TCTypeError

+ Morley.Michelson.TypeCheck.Error: VarError :: Text -> StackFn -> ExtError

+ Morley.Michelson.TypeCheck.Error: data ExtError

+ Morley.Michelson.TypeCheck.Error: data TCError

+ Morley.Michelson.TypeCheck.Error: data TCTypeError

+ Morley.Michelson.TypeCheck.Error: data TopLevelType

+ Morley.Michelson.TypeCheck.Error: data TypeContext

+ Morley.Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.Error.ExtError

+ Morley.Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.Error.StackSize

+ Morley.Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.Error.TCError

+ Morley.Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.Error.TCTypeError

+ Morley.Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.Error.TopLevelType

+ Morley.Michelson.TypeCheck.Error: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.Error.TypeContext

+ Morley.Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Morley.Michelson.TypeCheck.Error.ExtError

+ Morley.Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Morley.Michelson.TypeCheck.Error.TCError

+ Morley.Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Morley.Michelson.TypeCheck.Error.TCTypeError

+ Morley.Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Morley.Michelson.TypeCheck.Error.TopLevelType

+ Morley.Michelson.TypeCheck.Error: instance Formatting.Buildable.Buildable Morley.Michelson.TypeCheck.Error.TypeContext

+ Morley.Michelson.TypeCheck.Error: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.Error.ExtError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.Error.StackSize

+ Morley.Michelson.TypeCheck.Error: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.Error.TCError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.Error.TCTypeError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.Error.TopLevelType

+ Morley.Michelson.TypeCheck.Error: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.Error.TypeContext

+ Morley.Michelson.TypeCheck.Error: instance GHC.Exception.Type.Exception Morley.Michelson.TypeCheck.Error.TCError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Generics.Generic Morley.Michelson.TypeCheck.Error.ExtError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Generics.Generic Morley.Michelson.TypeCheck.Error.StackSize

+ Morley.Michelson.TypeCheck.Error: instance GHC.Generics.Generic Morley.Michelson.TypeCheck.Error.TCError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Generics.Generic Morley.Michelson.TypeCheck.Error.TCTypeError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Generics.Generic Morley.Michelson.TypeCheck.Error.TopLevelType

+ Morley.Michelson.TypeCheck.Error: instance GHC.Generics.Generic Morley.Michelson.TypeCheck.Error.TypeContext

+ Morley.Michelson.TypeCheck.Error: instance GHC.Show.Show Morley.Michelson.TypeCheck.Error.StackSize

+ Morley.Michelson.TypeCheck.Error: instance GHC.Show.Show Morley.Michelson.TypeCheck.Error.TCError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Show.Show Morley.Michelson.TypeCheck.Error.TCTypeError

+ Morley.Michelson.TypeCheck.Error: instance GHC.Show.Show Morley.Michelson.TypeCheck.Error.TopLevelType

+ Morley.Michelson.TypeCheck.Error: instance GHC.Show.Show Morley.Michelson.TypeCheck.Error.TypeContext

+ Morley.Michelson.TypeCheck.Error: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.TypeCheck.Error.TCError

+ Morley.Michelson.TypeCheck.Error: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.TypeCheck.Error.TCTypeError

+ Morley.Michelson.TypeCheck.Error: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.TypeCheck.Error.TopLevelType

+ Morley.Michelson.TypeCheck.Error: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.TypeCheck.Error.TypeContext

+ Morley.Michelson.TypeCheck.Error: newtype StackSize

+ Morley.Michelson.TypeCheck.Error: pairWithElems :: Word -> Text

+ Morley.Michelson.TypeCheck.Error: pairWithNodeIndex :: Word -> Text

+ Morley.Michelson.TypeCheck.Ext: typeCheckExt :: forall s. SingI s => TcInstrHandler -> ExpandedExtInstr -> HST s -> TypeCheckInstrNoExcept (TypeCheckedSeq s)

+ Morley.Michelson.TypeCheck.Helpers: addImpl :: forall a b inp rs m. (Each '[SingI] [a, b], inp ~ (a : (b : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: arithImpl :: forall aop inp m n s t. (ArithOp aop n m, WellTyped (ArithRes aop n m), inp ~ (n : (m : s)), MonadReader InstrCallStack t, MonadError TCError t) => Instr inp (ArithRes aop n m : s) -> HST inp -> VarAnn -> ExpandedInstr -> t (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: concatImpl :: (ConcatOp c, inp ~ (c : (c : rs)), WellTyped c, MonadReader InstrCallStack m, MonadError TCError m) => HST inp -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: concatImpl' :: (ConcatOp c, WellTyped c, inp ~ ('TList c : rs), Monad m) => HST inp -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: convergeHST :: HST ts -> HST ts -> Either AnnConvergeError (HST ts)

+ Morley.Michelson.TypeCheck.Helpers: convergeHSTEl :: (Notes t, Dict (WellTyped t), VarAnn) -> (Notes t, Dict (WellTyped t), VarAnn) -> Either AnnConvergeError (Notes t, Dict (WellTyped t), VarAnn)

+ Morley.Michelson.TypeCheck.Helpers: deriveNsOption :: Notes ('TOption a) -> VarAnn -> (Notes a, VarAnn)

+ Morley.Michelson.TypeCheck.Helpers: deriveNsOr :: Notes ('TOr a b) -> VarAnn -> (Notes a, Notes b, VarAnn, VarAnn)

+ Morley.Michelson.TypeCheck.Helpers: deriveSpecialFNs :: FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn -> (VarAnn, FieldAnn, FieldAnn)

+ Morley.Michelson.TypeCheck.Helpers: deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn

+ Morley.Michelson.TypeCheck.Helpers: deriveVN :: VarAnn -> VarAnn -> VarAnn

+ Morley.Michelson.TypeCheck.Helpers: edivImpl :: forall a b inp rs m. (SingI rs, Each '[SingI] [a, b], inp ~ (a : (b : rs)), MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: ensureDistinctAsc :: (Ord b, Show a) => (a -> b) -> [a] -> Either Text [a]

+ Morley.Michelson.TypeCheck.Helpers: eqHST :: forall as bs. (SingI as, SingI bs) => HST as -> HST bs -> Either TCTypeError (as :~: bs)

+ Morley.Michelson.TypeCheck.Helpers: eqHST1 :: forall t st. (SingI st, WellTyped t) => HST st -> Either TCTypeError (st :~: '[t])

+ Morley.Michelson.TypeCheck.Helpers: eqType :: forall (a :: T) (b :: T). Each '[SingI] [a, b] => Either TCTypeError (a :~: b)

+ Morley.Michelson.TypeCheck.Helpers: getImpl :: forall c getKey rs inp m. (GetOp c, SingI (GetOpKey c), WellTyped (GetOpVal c), inp ~ (getKey : (c : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Notes (GetOpKey c) -> HST inp -> Notes (GetOpVal c) -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: getUpdImpl :: forall c updKey updParams rs inp m. (UpdOp c, GetOp c, SingI (UpdOpKey c), SingI (GetOpVal c), inp ~ (updKey : (updParams : (c : rs))), SingI rs, GetOpKey c ~ UpdOpKey c, UpdOpParams c ~ 'TOption (GetOpVal c), MonadReader InstrCallStack m, MonadError TCError m) => Notes (UpdOpKey c) -> HST inp -> Notes (UpdOpParams c) -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: hstToTs :: HST st -> [T]

+ Morley.Michelson.TypeCheck.Helpers: lengthHST :: HST xs -> Natural

+ Morley.Michelson.TypeCheck.Helpers: matchTypes :: forall t1 t2. Each '[SingI] [t1, t2] => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)

+ Morley.Michelson.TypeCheck.Helpers: memImpl :: forall c memKey rs inp m. (MemOp c, SingI (MemOpKey c), inp ~ (memKey : (c : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Notes (MemOpKey c) -> HST inp -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: mulImpl :: forall a b inp rs m. (Each '[SingI] [a, b], inp ~ (a : (b : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: onScopeCheckInstrErr :: forall (t :: T) m a. (MonadReader InstrCallStack m, MonadError TCError m, SingI t) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> Either BadTypeForScope a -> m a

+ Morley.Michelson.TypeCheck.Helpers: onTypeCheckInstrAnnErr :: (MonadReader InstrCallStack m, MonadError TCError m, SingI ts) => ExpandedInstr -> HST ts -> Maybe TypeContext -> Either AnnConvergeError a -> m a

+ Morley.Michelson.TypeCheck.Helpers: onTypeCheckInstrErr :: (MonadReader InstrCallStack m, MonadError TCError m) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> Either TCTypeError a -> m a

+ Morley.Michelson.TypeCheck.Helpers: sizeImpl :: (SizeOp c, inp ~ (c : rs), Monad m) => HST inp -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: sliceImpl :: (SliceOp c, inp ~ ('TNat : ('TNat : (c : rs))), Monad m) => HST inp -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: subImpl :: forall a b inp rs m. (Each '[SingI] [a, b], inp ~ (a : (b : rs)), SingI rs, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> Sing b -> HST inp -> VarAnn -> ExpandedInstr -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: typeCheckImpl :: forall inp. SingI inp => TcInstrHandler -> [ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

+ Morley.Michelson.TypeCheck.Helpers: typeCheckImplStripped :: forall inp. SingI inp => TcInstrHandler -> [ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

+ Morley.Michelson.TypeCheck.Helpers: typeCheckInstrErr :: (MonadReader InstrCallStack m, MonadError TCError m) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> m a

+ Morley.Michelson.TypeCheck.Helpers: typeCheckInstrErr' :: (MonadReader InstrCallStack m, MonadError TCError m) => ExpandedInstr -> SomeHST -> Maybe TypeContext -> TCTypeError -> m a

+ Morley.Michelson.TypeCheck.Helpers: unaryArithImpl :: (WellTyped (UnaryArithRes aop n), inp ~ (n : s), Monad t) => Instr inp (UnaryArithRes aop n : s) -> HST inp -> VarAnn -> t (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: unaryArithImplAnnotated :: (WellTyped (UnaryArithRes aop n), inp ~ (n : s), Monad t, n ~ UnaryArithRes aop n) => Instr inp (UnaryArithRes aop n : s) -> HST inp -> VarAnn -> t (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: updImpl :: forall c updKey updParams rs inp m. (UpdOp c, SingI (UpdOpKey c), SingI (UpdOpParams c), SingI rs, inp ~ (updKey : (updParams : (c : rs))), MonadReader InstrCallStack m, MonadError TCError m) => Notes (UpdOpKey c) -> HST inp -> Notes (UpdOpParams c) -> VarAnn -> m (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Helpers: withCompareableCheck :: forall a m v ts. (SingI ts, MonadReader InstrCallStack m, MonadError TCError m) => Sing a -> ExpandedInstr -> HST ts -> (Comparable a => v) -> m v

+ Morley.Michelson.TypeCheck.Instr: typeCheckContract :: Contract -> TypeCheckResult SomeContract

+ Morley.Michelson.TypeCheck.Instr: typeCheckContractAndStorage :: Contract -> Value -> TypeCheckResult SomeContractAndStorage

+ Morley.Michelson.TypeCheck.Instr: typeCheckInstr :: TcInstrHandler

+ Morley.Michelson.TypeCheck.Instr: typeCheckList :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheck (SomeInstr inp)

+ Morley.Michelson.TypeCheck.Instr: typeCheckListNoExcept :: SingI inp => [ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)

+ Morley.Michelson.TypeCheck.Instr: typeCheckParameter :: TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

+ Morley.Michelson.TypeCheck.Instr: typeCheckStorage :: Ty -> Value -> TypeCheckResult SomeValue

+ Morley.Michelson.TypeCheck.Instr: typeCheckTopLevelType :: Maybe TcOriginatedContracts -> Ty -> Value -> TypeCheckResult SomeValue

+ Morley.Michelson.TypeCheck.Instr: typeCheckValue :: forall t. SingI t => Value -> TypeCheckInstr (Value t)

+ Morley.Michelson.TypeCheck.Instr: typeVerifyContract :: forall cp st. (SingI cp, SingI st) => Contract -> TypeCheckResult (Contract cp st)

+ Morley.Michelson.TypeCheck.Instr: typeVerifyParameter :: SingI t => TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

+ Morley.Michelson.TypeCheck.Instr: typeVerifyStorage :: SingI t => Value -> TypeCheckResult (Value t)

+ Morley.Michelson.TypeCheck.Instr: typeVerifyTopLevelType :: forall t. SingI t => Maybe TcOriginatedContracts -> Value -> TypeCheckResult (Value t)

+ Morley.Michelson.TypeCheck.TypeCheck: SomeParamType :: Sing t -> ParamNotes t -> SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheck: TypeCheckContract :: SomeParamType -> TypeCheckMode

+ Morley.Michelson.TypeCheck.TypeCheck: TypeCheckEnv :: ~TcExtFrames -> ~TypeCheckMode -> TypeCheckEnv

+ Morley.Michelson.TypeCheck.TypeCheck: TypeCheckOptions :: Bool -> Bool -> TypeCheckOptions

+ Morley.Michelson.TypeCheck.TypeCheck: TypeCheckPack :: TypeCheckMode

+ Morley.Michelson.TypeCheck.TypeCheck: TypeCheckTest :: TypeCheckMode

+ Morley.Michelson.TypeCheck.TypeCheck: TypeCheckValue :: (Value, T) -> TypeCheckMode

+ Morley.Michelson.TypeCheck.TypeCheck: [tcExtFrames] :: TypeCheckEnv -> ~TcExtFrames

+ Morley.Michelson.TypeCheck.TypeCheck: [tcMode] :: TypeCheckEnv -> ~TypeCheckMode

+ Morley.Michelson.TypeCheck.TypeCheck: [tcStrict] :: TypeCheckOptions -> Bool

+ Morley.Michelson.TypeCheck.TypeCheck: [tcVerbose] :: TypeCheckOptions -> Bool

+ Morley.Michelson.TypeCheck.TypeCheck: data SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheck: data TypeCheckEnv

+ Morley.Michelson.TypeCheck.TypeCheck: data TypeCheckMode

+ Morley.Michelson.TypeCheck.TypeCheck: data TypeCheckOptions

+ Morley.Michelson.TypeCheck.TypeCheck: guarding :: ExpandedInstr -> TypeCheckInstr a -> (a -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

+ Morley.Michelson.TypeCheck.TypeCheck: guarding_ :: ExpandedInstr -> TypeCheckInstr a -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

+ Morley.Michelson.TypeCheck.TypeCheck: instance Data.Default.Class.Default Morley.Michelson.TypeCheck.TypeCheck.TypeCheckOptions

+ Morley.Michelson.TypeCheck.TypeCheck: instance Formatting.Buildable.Buildable Morley.Michelson.TypeCheck.TypeCheck.SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheck: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.TypeCheck.SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheck: instance GHC.Show.Show Morley.Michelson.TypeCheck.TypeCheck.SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheck: liftNoExcept :: TypeCheckInstrNoExcept a -> TypeCheckInstr a

+ Morley.Michelson.TypeCheck.TypeCheck: liftNoExcept' :: TypeCheckNoExcept a -> TypeCheck a

+ Morley.Michelson.TypeCheck.TypeCheck: mkSomeParamType :: ParameterType -> Either TCError SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheck: preserving :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> ([TypeCheckedOp] -> TypeCheckedInstr) -> (SomeInstr inp -> TypeCheckInstr (SomeInstr inp')) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')

+ Morley.Michelson.TypeCheck.TypeCheck: preserving' :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> ([TypeCheckedOp] -> TypeCheckedInstr) -> (SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')) -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')

+ Morley.Michelson.TypeCheck.TypeCheck: runTypeCheck :: TypeCheckMode -> TypeCheck a -> TypeCheckResult a

+ Morley.Michelson.TypeCheck.TypeCheck: runTypeCheckInstrIsolated :: TypeCheckInstr a -> TypeCheckResult a

+ Morley.Michelson.TypeCheck.TypeCheck: runTypeCheckIsolated :: TypeCheck a -> TypeCheckResult a

+ Morley.Michelson.TypeCheck.TypeCheck: tcEither :: (TCError -> TypeCheckInstrNoExcept a) -> (b -> TypeCheckInstrNoExcept a) -> TypeCheckInstr b -> TypeCheckInstrNoExcept a

+ Morley.Michelson.TypeCheck.TypeCheck: tcExtFramesL :: Lens' TypeCheckEnv TcExtFrames

+ Morley.Michelson.TypeCheck.TypeCheck: tcModeL :: Lens' TypeCheckEnv TypeCheckMode

+ Morley.Michelson.TypeCheck.TypeCheck: throwingTCError :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> TypeCheckInstr (SomeInstr inp)

+ Morley.Michelson.TypeCheck.TypeCheck: throwingTCError' :: TypeCheckNoExcept (TypeCheckedSeq inp) -> TypeCheck (SomeInstr inp)

+ Morley.Michelson.TypeCheck.TypeCheck: type TcInstrHandler = forall inp. (SingI inp, HasCallStack) => ExpandedInstr -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

+ Morley.Michelson.TypeCheck.TypeCheck: type TcOriginatedContracts = Map ContractHash SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheck: type TypeCheck = (ReaderT TypeCheckOptions (ExceptT TCError (State TypeCheckEnv)))

+ Morley.Michelson.TypeCheck.TypeCheck: type TypeCheckInstr = ReaderT InstrCallStack TypeCheck

+ Morley.Michelson.TypeCheck.TypeCheck: type TypeCheckInstrNoExcept = ReaderT InstrCallStack TypeCheckNoExcept

+ Morley.Michelson.TypeCheck.TypeCheck: type TypeCheckNoExcept = (ReaderT TypeCheckOptions (State TypeCheckEnv))

+ Morley.Michelson.TypeCheck.TypeCheck: type TypeCheckResult = (ReaderT TypeCheckOptions (Except TCError))

+ Morley.Michelson.TypeCheck.TypeCheck: typeCheckingWith :: TypeCheckOptions -> TypeCheckResult a -> Either TCError a

+ Morley.Michelson.TypeCheck.TypeCheck: unsafeMkSomeParamType :: HasCallStack => ParameterType -> SomeParamType

+ Morley.Michelson.TypeCheck.TypeCheckedOp: NonTypedInstr :: ExpandedOp -> IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedOp: SemiTypedInstr :: TypeCheckedInstr -> IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedOp: [IllTypedOp] :: IllTypedInstr -> TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedOp: [WellTypedOp] :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedOp: data IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedOp: data TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedOp: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedOp: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp => Control.DeepSeq.NFData Morley.Michelson.TypeCheck.TypeCheckedOp.IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedOp: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.TypeCheckedOp.IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedOp: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedOp: instance GHC.Generics.Generic Morley.Michelson.TypeCheck.TypeCheckedOp.IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedOp: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.TypeCheck.TypeCheckedOp.TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedOp: someInstrToOp :: SomeInstr inp -> TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedOp: type TypeCheckedInstr = InstrAbstract TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: IllTypedSeq :: TCError -> [IllTypedInstr] -> TypeCheckedSeq inp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: MixedSeq :: SomeInstr inp -> TCError -> [IllTypedInstr] -> TypeCheckedSeq inp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: NonTypedInstr :: ExpandedOp -> IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: SemiTypedInstr :: TypeCheckedInstr -> IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: WellTypedSeq :: SomeInstr inp -> TypeCheckedSeq inp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: [IllTypedOp] :: IllTypedInstr -> TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: [WellTypedOp] :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: data IllTypedInstr

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: data TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: data TypeCheckedSeq inp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: seqToOps :: TypeCheckedSeq inp -> [TypeCheckedOp]

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: someInstrToOp :: SomeInstr inp -> TypeCheckedOp

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: tcsEither :: ([TypeCheckedOp] -> TCError -> a) -> (SomeInstr inp -> a) -> TypeCheckedSeq inp -> a

+ Morley.Michelson.TypeCheck.TypeCheckedSeq: type TypeCheckedInstr = InstrAbstract TypeCheckedOp

+ Morley.Michelson.TypeCheck.Types: (-:&) :: (WellTyped x, SingI xs) => Sing x -> HST xs -> HST (x : xs)

+ Morley.Michelson.TypeCheck.Types: BoundVars :: Map Var Ty -> Maybe SomeHST -> BoundVars

+ Morley.Michelson.TypeCheck.Types: NotWellTyped :: T -> BadTypeForScope -> NotWellTyped

+ Morley.Michelson.TypeCheck.Types: [:/] :: HST inp -> SomeInstrOut inp -> SomeInstr inp

+ Morley.Michelson.TypeCheck.Types: [::&] :: (SingI x, SingI xs) => (Notes x, Dict (WellTyped x), VarAnn) -> HST xs -> HST (x : xs)

+ Morley.Michelson.TypeCheck.Types: [:::] :: SingI out => Instr inp out -> HST out -> SomeInstrOut inp

+ Morley.Michelson.TypeCheck.Types: [AnyOutInstr] :: (forall out. Instr inp out) -> SomeInstrOut inp

+ Morley.Michelson.TypeCheck.Types: [SNil] :: HST '[]

+ Morley.Michelson.TypeCheck.Types: [SomeHST] :: SingI ts => HST ts -> SomeHST

+ Morley.Michelson.TypeCheck.Types: [nwtBadType] :: NotWellTyped -> T

+ Morley.Michelson.TypeCheck.Types: [nwtCause] :: NotWellTyped -> BadTypeForScope

+ Morley.Michelson.TypeCheck.Types: data BoundVars

+ Morley.Michelson.TypeCheck.Types: data HST (ts :: [T])

+ Morley.Michelson.TypeCheck.Types: data NotWellTyped

+ Morley.Michelson.TypeCheck.Types: data SomeHST

+ Morley.Michelson.TypeCheck.Types: data SomeInstr inp

+ Morley.Michelson.TypeCheck.Types: data SomeInstrOut inp

+ Morley.Michelson.TypeCheck.Types: getWTP :: forall t. SingI t => Either NotWellTyped (Dict (WellTyped t))

+ Morley.Michelson.TypeCheck.Types: getWTP' :: Sing t -> Either NotWellTyped (Dict (WellTyped t))

+ Morley.Michelson.TypeCheck.Types: infix 8 :/

+ Morley.Michelson.TypeCheck.Types: infix 9 :::

+ Morley.Michelson.TypeCheck.Types: infixr 7 ::&+

+ Morley.Michelson.TypeCheck.Types: instance Control.DeepSeq.NFData (Morley.Michelson.TypeCheck.Types.HST ts)

+ Morley.Michelson.TypeCheck.Types: instance Control.DeepSeq.NFData Morley.Michelson.TypeCheck.Types.SomeHST

+ Morley.Michelson.TypeCheck.Types: instance Formatting.Buildable.Buildable (Morley.Michelson.TypeCheck.Types.HST ts)

+ Morley.Michelson.TypeCheck.Types: instance Formatting.Buildable.Buildable Morley.Michelson.TypeCheck.Types.NotWellTyped

+ Morley.Michelson.TypeCheck.Types: instance GHC.Classes.Eq (Morley.Michelson.TypeCheck.Types.HST ts)

+ Morley.Michelson.TypeCheck.Types: instance GHC.Classes.Eq Morley.Michelson.TypeCheck.Types.SomeHST

+ Morley.Michelson.TypeCheck.Types: instance GHC.Show.Show (Morley.Michelson.TypeCheck.Types.HST ts)

+ Morley.Michelson.TypeCheck.Types: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.ExtInstr inp) => GHC.Show.Show (Morley.Michelson.TypeCheck.Types.SomeInstr inp)

+ Morley.Michelson.TypeCheck.Types: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.ExtInstr inp) => GHC.Show.Show (Morley.Michelson.TypeCheck.Types.SomeInstrOut inp)

+ Morley.Michelson.TypeCheck.Types: instance GHC.Show.Show Morley.Michelson.TypeCheck.Types.SomeHST

+ Morley.Michelson.TypeCheck.Types: instance Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.TypeCheck.Types.HST ts)

+ Morley.Michelson.TypeCheck.Types: mapSomeContract :: (forall inp out. Instr inp out -> Instr inp out) -> SomeContract -> SomeContract

+ Morley.Michelson.TypeCheck.Types: mapSomeInstr :: (forall out. Instr inp out -> Instr inp out) -> SomeInstr inp -> SomeInstr inp

+ Morley.Michelson.TypeCheck.Types: mapSomeInstrOut :: (forall out. Instr inp out -> Instr inp' out) -> SomeInstrOut inp -> SomeInstrOut inp'

+ Morley.Michelson.TypeCheck.Types: noBoundVars :: BoundVars

+ Morley.Michelson.TypeCheck.Types: pattern (::&+) :: () => (ys ~ (x : xs), SingI x, SingI xs) => (Sing x, Notes x, Dict (WellTyped x), VarAnn) -> HST xs -> HST ys

+ Morley.Michelson.TypeCheck.Types: type TcExtFrames = [BoundVars]

+ Morley.Michelson.TypeCheck.Types: unsafeWithWTP :: forall t a. SingI t => (WellTyped t => a) -> a

+ Morley.Michelson.TypeCheck.Types: withWTPm :: forall t m a. (MonadFail m, SingI t) => (WellTyped t => m a) -> m a

+ Morley.Michelson.TypeCheck.Value: tcFailedOnValue :: Value -> T -> Text -> Maybe TCTypeError -> TypeCheckInstr a

+ Morley.Michelson.TypeCheck.Value: typeCheckValImpl :: forall ty. SingI ty => Maybe TcOriginatedContracts -> TcInstrHandler -> Value -> TypeCheckInstr (Value ty)

+ Morley.Michelson.Typed.Aliases: type Operation = Operation' Instr

+ Morley.Michelson.Typed.Aliases: type Value = Value' Instr

+ Morley.Michelson.Typed.Annotation: [AnnConvergeError] :: forall (tag :: Type). (Buildable (Annotation tag), Show (Annotation tag), Typeable tag) => Annotation tag -> Annotation tag -> AnnConvergeError

+ Morley.Michelson.Typed.Annotation: [NTAddress] :: TypeAnn -> Notes 'TAddress

+ Morley.Michelson.Typed.Annotation: [NTBigMap] :: TypeAnn -> Notes k -> Notes v -> Notes ('TBigMap k v)

+ Morley.Michelson.Typed.Annotation: [NTBls12381Fr] :: TypeAnn -> Notes 'TBls12381Fr

+ Morley.Michelson.Typed.Annotation: [NTBls12381G1] :: TypeAnn -> Notes 'TBls12381G1

+ Morley.Michelson.Typed.Annotation: [NTBls12381G2] :: TypeAnn -> Notes 'TBls12381G2

+ Morley.Michelson.Typed.Annotation: [NTBool] :: TypeAnn -> Notes 'TBool

+ Morley.Michelson.Typed.Annotation: [NTBytes] :: TypeAnn -> Notes 'TBytes

+ Morley.Michelson.Typed.Annotation: [NTChainId] :: TypeAnn -> Notes 'TChainId

+ Morley.Michelson.Typed.Annotation: [NTContract] :: TypeAnn -> Notes t -> Notes ('TContract t)

+ Morley.Michelson.Typed.Annotation: [NTInt] :: TypeAnn -> Notes 'TInt

+ Morley.Michelson.Typed.Annotation: [NTKeyHash] :: TypeAnn -> Notes 'TKeyHash

+ Morley.Michelson.Typed.Annotation: [NTKey] :: TypeAnn -> Notes 'TKey

+ Morley.Michelson.Typed.Annotation: [NTLambda] :: TypeAnn -> Notes p -> Notes q -> Notes ('TLambda p q)

+ Morley.Michelson.Typed.Annotation: [NTList] :: TypeAnn -> Notes t -> Notes ('TList t)

+ Morley.Michelson.Typed.Annotation: [NTMap] :: TypeAnn -> Notes k -> Notes v -> Notes ('TMap k v)

+ Morley.Michelson.Typed.Annotation: [NTMutez] :: TypeAnn -> Notes 'TMutez

+ Morley.Michelson.Typed.Annotation: [NTNat] :: TypeAnn -> Notes 'TNat

+ Morley.Michelson.Typed.Annotation: [NTNever] :: TypeAnn -> Notes 'TNever

+ Morley.Michelson.Typed.Annotation: [NTOperation] :: TypeAnn -> Notes 'TOperation

+ Morley.Michelson.Typed.Annotation: [NTOption] :: TypeAnn -> Notes t -> Notes ('TOption t)

+ Morley.Michelson.Typed.Annotation: [NTOr] :: TypeAnn -> FieldAnn -> FieldAnn -> Notes p -> Notes q -> Notes ('TOr p q)

+ Morley.Michelson.Typed.Annotation: [NTPair] :: TypeAnn -> FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> Notes p -> Notes q -> Notes ('TPair p q)

+ Morley.Michelson.Typed.Annotation: [NTSet] :: TypeAnn -> Notes t -> Notes ('TSet t)

+ Morley.Michelson.Typed.Annotation: [NTSignature] :: TypeAnn -> Notes 'TSignature

+ Morley.Michelson.Typed.Annotation: [NTString] :: TypeAnn -> Notes 'TString

+ Morley.Michelson.Typed.Annotation: [NTTicket] :: TypeAnn -> Notes t -> Notes ('TTicket t)

+ Morley.Michelson.Typed.Annotation: [NTTimestamp] :: TypeAnn -> Notes 'TTimestamp

+ Morley.Michelson.Typed.Annotation: [NTUnit] :: TypeAnn -> Notes 'TUnit

+ Morley.Michelson.Typed.Annotation: converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t)

+ Morley.Michelson.Typed.Annotation: convergeAnns :: forall (tag :: Type). (Buildable (Annotation tag), Show (Annotation tag), Typeable tag) => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)

+ Morley.Michelson.Typed.Annotation: convergeDestrAnns :: FieldAnn -> FieldAnn -> Either AnnConvergeError FieldAnn

+ Morley.Michelson.Typed.Annotation: data AnnConvergeError

+ Morley.Michelson.Typed.Annotation: data Notes t

+ Morley.Michelson.Typed.Annotation: insertTypeAnn :: forall (b :: T). TypeAnn -> Notes b -> Notes b

+ Morley.Michelson.Typed.Annotation: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Annotation.Notes t)

+ Morley.Michelson.Typed.Annotation: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Annotation.AnnConvergeError

+ Morley.Michelson.Typed.Annotation: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Annotation.Notes t)

+ Morley.Michelson.Typed.Annotation: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Annotation.AnnConvergeError

+ Morley.Michelson.Typed.Annotation: instance GHC.Classes.Eq (Morley.Michelson.Typed.Annotation.Notes t)

+ Morley.Michelson.Typed.Annotation: instance GHC.Classes.Eq Morley.Michelson.Typed.Annotation.AnnConvergeError

+ Morley.Michelson.Typed.Annotation: instance GHC.Show.Show (Morley.Michelson.Typed.Annotation.Notes t)

+ Morley.Michelson.Typed.Annotation: instance GHC.Show.Show Morley.Michelson.Typed.Annotation.AnnConvergeError

+ Morley.Michelson.Typed.Annotation: instance Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Typed.Annotation.Notes t)

+ Morley.Michelson.Typed.Annotation: isStar :: SingI t => Notes t -> Bool

+ Morley.Michelson.Typed.Annotation: notesSing :: SingI t => Notes t -> Sing t

+ Morley.Michelson.Typed.Annotation: notesT :: SingI t => Notes t -> T

+ Morley.Michelson.Typed.Annotation: starNotes :: forall t. SingI t => Notes t

+ Morley.Michelson.Typed.Arith: --

+ Morley.Michelson.Typed.Arith: -- <tt>m</tt>.

+ Morley.Michelson.Typed.Arith: -- CInt = CInt</tt>.

+ Morley.Michelson.Typed.Arith: -- For instance, adding integer to natural produces integer, which is

+ Morley.Michelson.Typed.Arith: -- computing operation <tt>op</tt> from operands of types <tt>n</tt> and

+ Morley.Michelson.Typed.Arith: -- reflected in following instance of type family: <tt>ArithRes Add CNat

+ Morley.Michelson.Typed.Arith: -- | Type family <tt>ArithRes</tt> denotes the type resulting from

+ Morley.Michelson.Typed.Arith: AddOverflow :: MutezArithErrorType

+ Morley.Michelson.Typed.Arith: LslOverflow :: ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: LsrUnderflow :: ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: MulOverflow :: MutezArithErrorType

+ Morley.Michelson.Typed.Arith: MutezArithError :: MutezArithErrorType -> n -> m -> ArithError n m

+ Morley.Michelson.Typed.Arith: ShiftArithError :: ShiftArithErrorType -> n -> m -> ArithError n m

+ Morley.Michelson.Typed.Arith: SubUnderflow :: MutezArithErrorType

+ Morley.Michelson.Typed.Arith: class (Typeable n, Typeable m) => ArithOp aop (n :: T) (m :: T) where {

+ Morley.Michelson.Typed.Arith: class ToIntArithOp (n :: T)

+ Morley.Michelson.Typed.Arith: class UnaryArithOp aop (n :: T) where {

+ Morley.Michelson.Typed.Arith: commutativityProof :: ArithOp aop n m => Maybe $ Dict (ArithRes aop n m ~ ArithRes aop m n, ArithOp aop m n)

+ Morley.Michelson.Typed.Arith: compareOp :: Comparable t => Value' i t -> Value' i t -> Integer

+ Morley.Michelson.Typed.Arith: convergeArith :: ArithOp aop n m => proxy aop -> Notes n -> Notes m -> Either AnnConvergeError (Notes (ArithRes aop n m))

+ Morley.Michelson.Typed.Arith: data Abs

+ Morley.Michelson.Typed.Arith: data Add

+ Morley.Michelson.Typed.Arith: data And

+ Morley.Michelson.Typed.Arith: data ArithError n m

+ Morley.Michelson.Typed.Arith: data Compare

+ Morley.Michelson.Typed.Arith: data EDiv

+ Morley.Michelson.Typed.Arith: data Eq'

+ Morley.Michelson.Typed.Arith: data Ge

+ Morley.Michelson.Typed.Arith: data Gt

+ Morley.Michelson.Typed.Arith: data Le

+ Morley.Michelson.Typed.Arith: data Lsl

+ Morley.Michelson.Typed.Arith: data Lsr

+ Morley.Michelson.Typed.Arith: data Lt

+ Morley.Michelson.Typed.Arith: data Mul

+ Morley.Michelson.Typed.Arith: data MutezArithErrorType

+ Morley.Michelson.Typed.Arith: data Neg

+ Morley.Michelson.Typed.Arith: data Neq

+ Morley.Michelson.Typed.Arith: data Not

+ Morley.Michelson.Typed.Arith: data Or

+ Morley.Michelson.Typed.Arith: data ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: data Sub

+ Morley.Michelson.Typed.Arith: data Xor

+ Morley.Michelson.Typed.Arith: evalOp :: ArithOp aop n m => proxy aop -> Value' instr n -> Value' instr m -> Either (ArithError (Value' instr n) (Value' instr m)) (Value' instr (ArithRes aop n m))

+ Morley.Michelson.Typed.Arith: evalToIntOp :: ToIntArithOp n => Value' instr n -> Value' instr 'TInt

+ Morley.Michelson.Typed.Arith: evalUnaryArithOp :: UnaryArithOp aop n => proxy aop -> Value' instr n -> Value' instr (UnaryArithRes aop n)

+ Morley.Michelson.Typed.Arith: instance (Control.DeepSeq.NFData n, Control.DeepSeq.NFData m) => Control.DeepSeq.NFData (Morley.Michelson.Typed.Arith.ArithError n m)

+ Morley.Michelson.Typed.Arith: instance (GHC.Classes.Eq n, GHC.Classes.Eq m) => GHC.Classes.Eq (Morley.Michelson.Typed.Arith.ArithError n m)

+ Morley.Michelson.Typed.Arith: instance (GHC.Classes.Ord n, GHC.Classes.Ord m) => GHC.Classes.Ord (Morley.Michelson.Typed.Arith.ArithError n m)

+ Morley.Michelson.Typed.Arith: instance (GHC.Show.Show n, GHC.Show.Show m) => Formatting.Buildable.Buildable (Morley.Michelson.Typed.Arith.ArithError n m)

+ Morley.Michelson.Typed.Arith: instance (GHC.Show.Show n, GHC.Show.Show m) => GHC.Show.Show (Morley.Michelson.Typed.Arith.ArithError n m)

+ Morley.Michelson.Typed.Arith: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Arith.MutezArithErrorType

+ Morley.Michelson.Typed.Arith: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Arith.ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Arith.MutezArithErrorType

+ Morley.Michelson.Typed.Arith: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Arith.ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Classes.Eq Morley.Michelson.Typed.Arith.MutezArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Classes.Eq Morley.Michelson.Typed.Arith.ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Classes.Ord Morley.Michelson.Typed.Arith.MutezArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Classes.Ord Morley.Michelson.Typed.Arith.ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Generics.Generic (Morley.Michelson.Typed.Arith.ArithError n m)

+ Morley.Michelson.Typed.Arith: instance GHC.Generics.Generic Morley.Michelson.Typed.Arith.MutezArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Generics.Generic Morley.Michelson.Typed.Arith.ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Show.Show Morley.Michelson.Typed.Arith.MutezArithErrorType

+ Morley.Michelson.Typed.Arith: instance GHC.Show.Show Morley.Michelson.Typed.Arith.ShiftArithErrorType

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TBls12381Fr 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TBls12381G1 'Morley.Michelson.Typed.T.TBls12381G1

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TBls12381G2 'Morley.Michelson.Typed.T.TBls12381G2

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TTimestamp

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TMutez 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Add 'Morley.Michelson.Typed.T.TTimestamp 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.And 'Morley.Michelson.Typed.T.TBool 'Morley.Michelson.Typed.T.TBool

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.And 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.And 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.EDiv 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.EDiv 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.EDiv 'Morley.Michelson.Typed.T.TMutez 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.EDiv 'Morley.Michelson.Typed.T.TMutez 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.EDiv 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.EDiv 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Lsl 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Lsr 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TBls12381Fr 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TBls12381Fr 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TBls12381Fr 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TBls12381G1 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TBls12381G2 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TMutez 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Or 'Morley.Michelson.Typed.T.TBool 'Morley.Michelson.Typed.T.TBool

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Or 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Sub 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Sub 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Sub 'Morley.Michelson.Typed.T.TMutez 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Sub 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Sub 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Sub 'Morley.Michelson.Typed.T.TTimestamp 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Sub 'Morley.Michelson.Typed.T.TTimestamp 'Morley.Michelson.Typed.T.TTimestamp

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Xor 'Morley.Michelson.Typed.T.TBool 'Morley.Michelson.Typed.T.TBool

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Xor 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.Bls12381MulBadOrder Morley.Tezos.Crypto.BLS12381.Bls12381Fr Morley.Tezos.Crypto.BLS12381.Bls12381G1 => Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TBls12381Fr 'Morley.Michelson.Typed.T.TBls12381G1

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.Bls12381MulBadOrder Morley.Tezos.Crypto.BLS12381.Bls12381Fr Morley.Tezos.Crypto.BLS12381.Bls12381G2 => Morley.Michelson.Typed.Arith.ArithOp Morley.Michelson.Typed.Arith.Mul 'Morley.Michelson.Typed.T.TBls12381Fr 'Morley.Michelson.Typed.T.TBls12381G2

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ToIntArithOp 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.ToIntArithOp 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Abs 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Eq' 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Ge 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Gt 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Le 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Lt 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Neg 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Neg 'Morley.Michelson.Typed.T.TBls12381G1

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Neg 'Morley.Michelson.Typed.T.TBls12381G2

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Neg 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Neg 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Neq 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Not 'Morley.Michelson.Typed.T.TBool

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Not 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Arith: instance Morley.Michelson.Typed.Arith.UnaryArithOp Morley.Michelson.Typed.Arith.Not 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Arith: type family Bls12381MulBadOrder a1 a2

+ Morley.Michelson.Typed.Arith: }

+ Morley.Michelson.Typed.Convert: convertContract :: Contract param store -> Contract

+ Morley.Michelson.Typed.Convert: convertContractCode :: forall param store. (SingI param, SingI store) => ContractCode param store -> Contract

+ Morley.Michelson.Typed.Convert: convertParamNotes :: SingI cp => ParamNotes cp -> ParameterType

+ Morley.Michelson.Typed.Convert: flattenEntrypoints :: SingI t => ParamNotes t -> Map EpName Ty

+ Morley.Michelson.Typed.Convert: instance Data.Singletons.Internal.SingI s => GHC.Classes.Eq (Morley.Michelson.Typed.Instr.TestAssert s)

+ Morley.Michelson.Typed.Convert: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Michelson.Typed.Convert: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Value.Value' Morley.Michelson.Typed.Instr.Instr t)

+ Morley.Michelson.Typed.Convert: instance GHC.Classes.Eq (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Michelson.Typed.Convert: instance GHC.Classes.Eq Morley.Michelson.Typed.Convert.UntypingOptions

+ Morley.Michelson.Typed.Convert: instance GHC.Show.Show Morley.Michelson.Typed.Convert.UntypingOptions

+ Morley.Michelson.Typed.Convert: instance Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Michelson.Typed.Convert: instance Morley.Michelson.Typed.Scope.HasNoOp t => Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Typed.Value.Value' Morley.Michelson.Typed.Instr.Instr t)

+ Morley.Michelson.Typed.Convert: instrToOps :: HasCallStack => Instr inp out -> [ExpandedOp]

+ Morley.Michelson.Typed.Convert: instrToOpsOptimized :: HasCallStack => Instr inp out -> [ExpandedOp]

+ Morley.Michelson.Typed.Convert: sampleTypedValue :: Sing t -> Maybe (Value t)

+ Morley.Michelson.Typed.Convert: untypeDemoteT :: forall (t :: T). SingI t => Ty

+ Morley.Michelson.Typed.Convert: untypeValue :: HasNoOp t => Value' Instr t -> Value

+ Morley.Michelson.Typed.Convert: untypeValueHashable :: HasNoOp t => Value' Instr t -> Value

+ Morley.Michelson.Typed.Convert: untypeValueOptimized :: HasNoOp t => Value' Instr t -> Value

+ Morley.Michelson.Typed.Doc: buildInstrDoc :: Instr inp out -> ContractDoc

+ Morley.Michelson.Typed.Doc: buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc

+ Morley.Michelson.Typed.Doc: cutInstrNonDoc :: (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr s s

+ Morley.Michelson.Typed.Doc: docInstr :: DocItem di => di -> Instr s s

+ Morley.Michelson.Typed.Doc: instance Morley.Michelson.Doc.ContainsDoc (Morley.Michelson.Typed.Instr.Contract cp st)

+ Morley.Michelson.Typed.Doc: instance Morley.Michelson.Doc.ContainsDoc (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Michelson.Typed.Doc: instance Morley.Michelson.Doc.ContainsUpdateableDoc (Morley.Michelson.Typed.Instr.Contract cp st)

+ Morley.Michelson.Typed.Doc: instance Morley.Michelson.Doc.ContainsUpdateableDoc (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Michelson.Typed.Doc: modifyInstrAllDoc :: (SomeDocItem -> SomeDocItem) -> Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Doc: modifyInstrDoc :: (DocItem i1, DocItem i2) => (i1 -> Maybe i2) -> Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Entrypoints: AcLeft :: ArmCoord

+ Morley.Michelson.Typed.Entrypoints: AcRight :: ArmCoord

+ Morley.Michelson.Typed.Entrypoints: EntrypointCall :: EpName -> Proxy param -> EpLiftSequence arg param -> EntrypointCallT (param :: T) (arg :: T)

+ Morley.Michelson.Typed.Entrypoints: EpAddress :: Address -> EpName -> EpAddress

+ Morley.Michelson.Typed.Entrypoints: InEpNameBadAnnotation :: FieldAnn -> EpNameFromRefAnnError

+ Morley.Michelson.Typed.Entrypoints: ParamEpDuplicatedNames :: NonEmpty EpName -> ParamEpError

+ Morley.Michelson.Typed.Entrypoints: ParamEpUncallableArm :: ArmCoords -> ParamEpError

+ Morley.Michelson.Typed.Entrypoints: ParseEpAddressBadAddress :: ParseAddressError -> ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: ParseEpAddressBadEntryopint :: ByteString -> UnicodeException -> ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: ParseEpAddressBadRefAnn :: Text -> ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: ParseEpAddressInvalidLength :: Int -> ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: ParseEpAddressRawBadAddress :: ParseAddressRawError -> ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: ParseEpAddressRefAnnError :: EpNameFromRefAnnError -> ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: SomeEpc :: EntrypointCallT param arg -> SomeEntrypointCallT (arg :: T)

+ Morley.Michelson.Typed.Entrypoints: UnsafeEpName :: Text -> EpName

+ Morley.Michelson.Typed.Entrypoints: UnsafeParamNotes :: Notes t -> RootAnn -> ParamNotes (t :: T)

+ Morley.Michelson.Typed.Entrypoints: [EplArgHere] :: EpLiftSequence arg arg

+ Morley.Michelson.Typed.Entrypoints: [EplWrapLeft] :: (SingI subparam, SingI r) => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)

+ Morley.Michelson.Typed.Entrypoints: [EplWrapRight] :: (SingI l, SingI subparam) => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)

+ Morley.Michelson.Typed.Entrypoints: [MkEntrypointCallRes] :: ParameterScope arg => Notes arg -> EntrypointCallT param arg -> MkEntrypointCallRes param

+ Morley.Michelson.Typed.Entrypoints: [eaAddress] :: EpAddress -> Address

+ Morley.Michelson.Typed.Entrypoints: [eaEntrypoint] :: EpAddress -> EpName

+ Morley.Michelson.Typed.Entrypoints: [epcLiftSequence] :: EntrypointCallT (param :: T) (arg :: T) -> EpLiftSequence arg param

+ Morley.Michelson.Typed.Entrypoints: [epcName] :: EntrypointCallT (param :: T) (arg :: T) -> EpName

+ Morley.Michelson.Typed.Entrypoints: [epcParamProxy] :: EntrypointCallT (param :: T) (arg :: T) -> Proxy param

+ Morley.Michelson.Typed.Entrypoints: [pnNotes] :: ParamNotes (t :: T) -> Notes t

+ Morley.Michelson.Typed.Entrypoints: [pnRootAnn] :: ParamNotes (t :: T) -> RootAnn

+ Morley.Michelson.Typed.Entrypoints: [unEpName] :: EpName -> Text

+ Morley.Michelson.Typed.Entrypoints: data ArmCoord

+ Morley.Michelson.Typed.Entrypoints: data EntrypointCallT (param :: T) (arg :: T)

+ Morley.Michelson.Typed.Entrypoints: data EpAddress

+ Morley.Michelson.Typed.Entrypoints: data EpLiftSequence (arg :: T) (param :: T)

+ Morley.Michelson.Typed.Entrypoints: data EpNameFromRefAnnError

+ Morley.Michelson.Typed.Entrypoints: data MkEntrypointCallRes param

+ Morley.Michelson.Typed.Entrypoints: data ParamEpError

+ Morley.Michelson.Typed.Entrypoints: data ParamNotes (t :: T)

+ Morley.Michelson.Typed.Entrypoints: data ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: data SomeEntrypointCallT (arg :: T)

+ Morley.Michelson.Typed.Entrypoints: epNameFromParamAnn :: FieldAnn -> Maybe EpName

+ Morley.Michelson.Typed.Entrypoints: epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName

+ Morley.Michelson.Typed.Entrypoints: epNameToParamAnn :: EpName -> FieldAnn

+ Morley.Michelson.Typed.Entrypoints: epNameToRefAnn :: EpName -> FieldAnn

+ Morley.Michelson.Typed.Entrypoints: epcPrimitive :: forall p. (ParameterScope p, ForbidOr p) => EntrypointCallT p p

+ Morley.Michelson.Typed.Entrypoints: formatEpAddress :: EpAddress -> Text

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Entrypoints.EntrypointCallT param arg)

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Entrypoints.EpLiftSequence arg param)

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Entrypoints.ParamNotes t)

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Entrypoints.ArmCoord

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Entrypoints.ParamEpError

+ Morley.Michelson.Typed.Entrypoints: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Entrypoints.ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Entrypoints.EntrypointCallT param arg)

+ Morley.Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Entrypoints.EpLiftSequence arg param)

+ Morley.Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

+ Morley.Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Entrypoints.ArmCoord

+ Morley.Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Entrypoints.ParamEpError

+ Morley.Michelson.Typed.Entrypoints: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Entrypoints.ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Morley.Michelson.Typed.Entrypoints.EntrypointCallT param arg)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Morley.Michelson.Typed.Entrypoints.EpLiftSequence arg param)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Morley.Michelson.Typed.Entrypoints.ParamNotes t)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq (Morley.Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Morley.Michelson.Typed.Entrypoints.ArmCoord

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Morley.Michelson.Typed.Entrypoints.ParamEpError

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Eq Morley.Michelson.Typed.Entrypoints.ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Classes.Ord Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Generics.Generic (Morley.Michelson.Typed.Entrypoints.ParamNotes t)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Morley.Michelson.Typed.Entrypoints.ArmCoord

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Morley.Michelson.Typed.Entrypoints.ParamEpError

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Generics.Generic Morley.Michelson.Typed.Entrypoints.ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show (Morley.Michelson.Typed.Entrypoints.EntrypointCallT param arg)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show (Morley.Michelson.Typed.Entrypoints.EpLiftSequence arg param)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show (Morley.Michelson.Typed.Entrypoints.ParamNotes t)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show (Morley.Michelson.Typed.Entrypoints.SomeEntrypointCallT arg)

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show Morley.Michelson.Typed.Entrypoints.ArmCoord

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show Morley.Michelson.Typed.Entrypoints.ParamEpError

+ Morley.Michelson.Typed.Entrypoints: instance GHC.Show.Show Morley.Michelson.Typed.Entrypoints.ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Typed.Entrypoints.ArmCoord

+ Morley.Michelson.Typed.Entrypoints: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Typed.Entrypoints.ParamEpError

+ Morley.Michelson.Typed.Entrypoints: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Typed.Entrypoints.ParseEpAddressError

+ Morley.Michelson.Typed.Entrypoints: mformatEpAddress :: EpAddress -> MText

+ Morley.Michelson.Typed.Entrypoints: mkEntrypointCall :: ParameterScope param => EpName -> ParamNotes param -> Maybe (MkEntrypointCallRes param)

+ Morley.Michelson.Typed.Entrypoints: mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)

+ Morley.Michelson.Typed.Entrypoints: newtype EpName

+ Morley.Michelson.Typed.Entrypoints: parseEpAddress :: Text -> Either ParseEpAddressError EpAddress

+ Morley.Michelson.Typed.Entrypoints: parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress

+ Morley.Michelson.Typed.Entrypoints: pattern DefEpName :: EpName

+ Morley.Michelson.Typed.Entrypoints: pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t

+ Morley.Michelson.Typed.Entrypoints: sepcName :: SomeEntrypointCallT arg -> EpName

+ Morley.Michelson.Typed.Entrypoints: sepcPrimitive :: forall t. (ParameterScope t, ForbidOr t) => SomeEntrypointCallT t

+ Morley.Michelson.Typed.Entrypoints: starParamNotes :: SingI t => ParamNotes t

+ Morley.Michelson.Typed.Entrypoints: tyImplicitAccountParam :: ParamNotes 'TUnit

+ Morley.Michelson.Typed.Entrypoints: type ArmCoords = [ArmCoord]

+ Morley.Michelson.Typed.Entrypoints: type family ForbidOr (t :: T) :: Constraint

+ Morley.Michelson.Typed.Entrypoints: unsafeEpcCallRoot :: ParameterScope param => EntrypointCallT param param

+ Morley.Michelson.Typed.Entrypoints: unsafeParseEpAddress :: HasCallStack => Text -> EpAddress

+ Morley.Michelson.Typed.Entrypoints: unsafeParseEpAddressRaw :: ByteString -> EpAddress

+ Morley.Michelson.Typed.Entrypoints: unsafeSepcCallRoot :: ParameterScope param => SomeEntrypointCallT param

+ Morley.Michelson.Typed.Existential: [SomeConstant] :: (ConstantScope t, SingI t) => Value t -> SomeConstant

+ Morley.Michelson.Typed.Existential: [SomeConstrainedValue] :: forall (t :: T) (c :: T -> Constraint). c t => Value t -> SomeConstrainedValue c

+ Morley.Michelson.Typed.Existential: [SomeContractAndStorage] :: forall cp st. (StorageScope st, ParameterScope cp) => Contract cp st -> Value st -> SomeContractAndStorage

+ Morley.Michelson.Typed.Existential: [SomeContract] :: Contract cp st -> SomeContract

+ Morley.Michelson.Typed.Existential: [SomeIsoValue] :: KnownIsoT a => a -> SomeIsoValue

+ Morley.Michelson.Typed.Existential: [SomeStorage] :: forall st. StorageScope st => Value st -> SomeStorage

+ Morley.Michelson.Typed.Existential: [SomeValue] :: SingI t => Value t -> SomeValue

+ Morley.Michelson.Typed.Existential: data SomeConstant

+ Morley.Michelson.Typed.Existential: data SomeConstrainedValue (c :: T -> Constraint)

+ Morley.Michelson.Typed.Existential: data SomeContract

+ Morley.Michelson.Typed.Existential: data SomeContractAndStorage

+ Morley.Michelson.Typed.Existential: data SomeIsoValue

+ Morley.Michelson.Typed.Existential: data SomeStorage

+ Morley.Michelson.Typed.Existential: data SomeValue

+ Morley.Michelson.Typed.Existential: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Existential.SomeContract

+ Morley.Michelson.Typed.Existential: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Existential.SomeConstant

+ Morley.Michelson.Typed.Existential: instance GHC.Classes.Eq Morley.Michelson.Typed.Existential.SomeValue

+ Morley.Michelson.Typed.Existential: instance GHC.Show.Show (Morley.Michelson.Typed.Existential.SomeConstrainedValue c)

+ Morley.Michelson.Typed.Existential: instance GHC.Show.Show Morley.Michelson.Typed.Existential.SomeContract

+ Morley.Michelson.Typed.Existential: instance GHC.Show.Show Morley.Michelson.Typed.Existential.SomeContractAndStorage

+ Morley.Michelson.Typed.Existential: instance GHC.Show.Show Morley.Michelson.Typed.Existential.SomeStorage

+ Morley.Michelson.Typed.Existential: instance GHC.Show.Show Morley.Michelson.Typed.Existential.SomeValue

+ Morley.Michelson.Typed.Existential: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Typed.Existential.SomeConstant

+ Morley.Michelson.Typed.Extract: fromUType :: Ty -> T

+ Morley.Michelson.Typed.Extract: mkUType :: SingI x => Notes x -> Ty

+ Morley.Michelson.Typed.Extract: mkUType' :: (Sing x, Notes x) -> Ty

+ Morley.Michelson.Typed.Extract: pattern AsUType :: () => SingI t => Notes t -> Ty

+ Morley.Michelson.Typed.Extract: pattern AsUTypeExt :: () => SingI t => Sing t -> Notes t -> Ty

+ Morley.Michelson.Typed.Extract: toUType :: T -> Ty

+ Morley.Michelson.Typed.Extract: withUType :: Ty -> (forall t. SingI t => Notes t -> r) -> r

+ Morley.Michelson.Typed.Haskell: (//->) :: Label ("c" `AppendSymbol` ctor) -> RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

+ Morley.Michelson.Typed.Haskell: --

+ Morley.Michelson.Typed.Haskell: -- Descriptions will be checked at compile time to make sure that only

+ Morley.Michelson.Typed.Haskell: -- For implementation of the check see <a>FieldDescriptionsValid</a> type

+ Morley.Michelson.Typed.Haskell: -- See <a>FieldDescriptions</a> documentation for an example of usage.

+ Morley.Michelson.Typed.Haskell: -- existing constructors and fields are referenced.

+ Morley.Michelson.Typed.Haskell: -- family.

+ Morley.Michelson.Typed.Haskell: -- type.

+ Morley.Michelson.Typed.Haskell: -- whenever <tt>TypeDocFieldDescriptions</tt> is not empty.

+ Morley.Michelson.Typed.Haskell: -- | Description of constructors and fields of <tt>a</tt>.

+ Morley.Michelson.Typed.Haskell: BigMapId :: Natural -> BigMapId k v

+ Morley.Michelson.Typed.Haskell: CaseClauseParam :: Symbol -> CtorField -> CaseClauseParam

+ Morley.Michelson.Typed.Haskell: ComposeCtorNotFound :: ComposeResult a

+ Morley.Michelson.Typed.Haskell: ComposeFieldTypeMismatch :: T -> T -> ComposeResult a

+ Morley.Michelson.Typed.Haskell: ComposeOk :: a -> ComposeResult a

+ Morley.Michelson.Typed.Haskell: ConstructorRep :: Text -> Maybe Text -> [FieldRep a] -> ConstructorRep a

+ Morley.Michelson.Typed.Haskell: ContractRef :: Address -> SomeEntrypointCall arg -> ContractRef (arg :: Type)

+ Morley.Michelson.Typed.Haskell: DStorageType :: DType -> DStorageType

+ Morley.Michelson.Typed.Haskell: FieldConstructor :: Instr (ToTs' st) (ToT field : ToTs' st) -> FieldConstructor (st :: [k]) (field :: Type)

+ Morley.Michelson.Typed.Haskell: FieldRep :: Maybe Text -> Maybe Text -> a -> FieldRep a

+ Morley.Michelson.Typed.Haskell: L :: Branch

+ Morley.Michelson.Typed.Haskell: NoFields :: CtorField

+ Morley.Michelson.Typed.Haskell: OneField :: Type -> CtorField

+ Morley.Michelson.Typed.Haskell: R :: Branch

+ Morley.Michelson.Typed.Haskell: S :: Branch

+ Morley.Michelson.Typed.Haskell: Ticket :: Address -> arg -> Natural -> Ticket (arg :: Type)

+ Morley.Michelson.Typed.Haskell: WithinParens :: Bool -> WithinParens

+ Morley.Michelson.Typed.Haskell: [CaseClause] :: RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

+ Morley.Michelson.Typed.Haskell: [DType] :: TypeHasDoc a => Proxy a -> DType

+ Morley.Michelson.Typed.Haskell: [Dict] :: forall a. a => Dict a

+ Morley.Michelson.Typed.Haskell: [SomeTypeWithDoc] :: TypeHasDoc td => Proxy td -> SomeTypeWithDoc

+ Morley.Michelson.Typed.Haskell: [crAddress] :: ContractRef (arg :: Type) -> Address

+ Morley.Michelson.Typed.Haskell: [crDescription] :: ConstructorRep a -> Maybe Text

+ Morley.Michelson.Typed.Haskell: [crEntrypoint] :: ContractRef (arg :: Type) -> SomeEntrypointCall arg

+ Morley.Michelson.Typed.Haskell: [crFields] :: ConstructorRep a -> [FieldRep a]

+ Morley.Michelson.Typed.Haskell: [crName] :: ConstructorRep a -> Text

+ Morley.Michelson.Typed.Haskell: [frDescription] :: FieldRep a -> Maybe Text

+ Morley.Michelson.Typed.Haskell: [frName] :: FieldRep a -> Maybe Text

+ Morley.Michelson.Typed.Haskell: [frTypeRep] :: FieldRep a -> a

+ Morley.Michelson.Typed.Haskell: [tAmount] :: Ticket (arg :: Type) -> Natural

+ Morley.Michelson.Typed.Haskell: [tData] :: Ticket (arg :: Type) -> arg

+ Morley.Michelson.Typed.Haskell: [tTicketer] :: Ticket (arg :: Type) -> Address

+ Morley.Michelson.Typed.Haskell: [unBigMapId] :: BigMapId k v -> Natural

+ Morley.Michelson.Typed.Haskell: appendCtorFieldAxiom :: (AppendCtorFieldAxiom ('OneField Word) '[Int], AppendCtorFieldAxiom 'NoFields '[Int]) => Dict (AppendCtorFieldAxiom cf st)

+ Morley.Michelson.Typed.Haskell: applyWithinParens :: WithinParens -> Markdown -> Markdown

+ Morley.Michelson.Typed.Haskell: buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown

+ Morley.Michelson.Typed.Haskell: buildTypeWithinParens :: forall a. Typeable a => WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell: castFieldConstructorsImpl :: CastFieldConstructors xs ys => Rec (FieldConstructor st) xs -> Rec (FieldConstructor st) ys

+ Morley.Michelson.Typed.Haskell: class ToTs xs ~ ToTs ys => CastFieldConstructors xs ys

+ Morley.Michelson.Typed.Haskell: class GProductHasDoc (x :: Type -> Type)

+ Morley.Michelson.Typed.Haskell: class GTypeHasDoc (x :: Type -> Type)

+ Morley.Michelson.Typed.Haskell: class HaveCommonTypeCtor a b

+ Morley.Michelson.Typed.Haskell: class IsHomomorphic a

+ Morley.Michelson.Typed.Haskell: class (WellTypedToT a) => IsoValue a where {

+ Morley.Michelson.Typed.Haskell: class IsoValuesStack (ts :: [Type])

+ Morley.Michelson.Typed.Haskell: class ToBigMap m where {

+ Morley.Michelson.Typed.Haskell: class (Typeable a, SingI (TypeDocFieldDescriptions a), FieldDescriptionsValid (TypeDocFieldDescriptions a) a) => TypeHasDoc a where {

+ Morley.Michelson.Typed.Haskell: class (SingI t, WellTypedSuperC t) => WellTyped (t :: T)

+ Morley.Michelson.Typed.Haskell: coerceContractRef :: ToT a ~ ToT b => ContractRef a -> ContractRef b

+ Morley.Michelson.Typed.Haskell: concreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a), HaveCommonTypeCtor b a) => TypeDocHaskellRep b

+ Morley.Michelson.Typed.Haskell: concreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a, HaveCommonTypeCtor b a) => TypeDocMichelsonRep b

+ Morley.Michelson.Typed.Haskell: contractRefToAddr :: ContractRef cp -> EpAddress

+ Morley.Michelson.Typed.Haskell: crDescriptionL :: forall a_a6mKG. Lens' (ConstructorRep a_a6mKG) (Maybe Text)

+ Morley.Michelson.Typed.Haskell: crFieldsL :: forall a_a6mKG a_a6mLS. Lens (ConstructorRep a_a6mKG) (ConstructorRep a_a6mLS) [FieldRep a_a6mKG] [FieldRep a_a6mLS]

+ Morley.Michelson.Typed.Haskell: crNameL :: forall a_a6mKG. Lens' (ConstructorRep a_a6mKG) Text

+ Morley.Michelson.Typed.Haskell: customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell: customTypeDocMdReference' :: (Text, DType) -> [WithinParens -> Markdown] -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell: dStorage :: forall store. TypeHasDoc store => DStorageType

+ Morley.Michelson.Typed.Haskell: dTypeDep :: forall (t :: Type). TypeHasDoc t => SomeDocDefinitionItem

+ Morley.Michelson.Typed.Haskell: dTypeDepP :: forall (t :: Type). TypeHasDoc t => Proxy t -> SomeDocDefinitionItem

+ Morley.Michelson.Typed.Haskell: data BigMap k v

+ Morley.Michelson.Typed.Haskell: data Branch

+ Morley.Michelson.Typed.Haskell: data CaseClause (inp :: [T]) (out :: [T]) (param :: CaseClauseParam)

+ Morley.Michelson.Typed.Haskell: data CaseClauseParam

+ Morley.Michelson.Typed.Haskell: data ComposeResult a

+ Morley.Michelson.Typed.Haskell: data ConstructorRep a

+ Morley.Michelson.Typed.Haskell: data ContractRef (arg :: Type)

+ Morley.Michelson.Typed.Haskell: data CtorField

+ Morley.Michelson.Typed.Haskell: data DType

+ Morley.Michelson.Typed.Haskell: data Dict a

+ Morley.Michelson.Typed.Haskell: data FieldRep a

+ Morley.Michelson.Typed.Haskell: data MyCompoundType

+ Morley.Michelson.Typed.Haskell: data SomeTypeWithDoc

+ Morley.Michelson.Typed.Haskell: data Ticket (arg :: Type)

+ Morley.Michelson.Typed.Haskell: frDescriptionL :: forall a_a6mKF. Lens' (FieldRep a_a6mKF) (Maybe Text)

+ Morley.Michelson.Typed.Haskell: frNameL :: forall a_a6mKF. Lens' (FieldRep a_a6mKF) (Maybe Text)

+ Morley.Michelson.Typed.Haskell: frTypeRepL :: forall a_a6mKF a_a6mNA. Lens (FieldRep a_a6mKF) (FieldRep a_a6mNA) a_a6mKF a_a6mNA

+ Morley.Michelson.Typed.Haskell: fromTaggedVal :: LooseSumC dt => (Text, SomeValue) -> ComposeResult dt

+ Morley.Michelson.Typed.Haskell: fromVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => Value (ToT a) -> a

+ Morley.Michelson.Typed.Haskell: fromValStack :: IsoValuesStack ts => Rec Value (ToTs ts) -> Rec Identity ts

+ Morley.Michelson.Typed.Haskell: genericTypeDocDependencies :: forall a. (Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

+ Morley.Michelson.Typed.Haskell: haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell: haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell: haskellRepStripFieldPrefix :: HasCallStack => TypeDocHaskellRep a -> TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell: homomorphicTypeDocHaskellRep :: forall a. (Generic a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell: homomorphicTypeDocMdReference :: forall (t :: Type). (Typeable t, TypeHasDoc t, IsHomomorphic t) => Proxy t -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell: homomorphicTypeDocMichelsonRep :: forall a. KnownIsoT a => TypeDocMichelsonRep a

+ Morley.Michelson.Typed.Haskell: hsUnwrap :: forall dt name. InstrUnwrapC dt name => Label name -> dt -> Maybe (CtorOnlyField name dt)

+ Morley.Michelson.Typed.Haskell: hsWrap :: forall dt name. InstrWrapC dt name => Label name -> ExtractCtorField (GetCtorField dt name) -> dt

+ Morley.Michelson.Typed.Haskell: infixr 8 //->

+ Morley.Michelson.Typed.Haskell: instrCase :: forall dt out inp. InstrCaseC dt => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt : inp) out

+ Morley.Michelson.Typed.Haskell: instrConstruct :: forall dt st. InstrConstructC dt => Rec (FieldConstructor st) (ConstructorFieldTypes dt) -> Instr st (ToT dt : st)

+ Morley.Michelson.Typed.Haskell: instrConstructStack :: forall dt stack st. (InstrConstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (stack ++ st) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell: instrDeconstruct :: forall dt stack st. (InstrDeconstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (ToT dt : st) (stack ++ st)

+ Morley.Michelson.Typed.Haskell: instrSetField :: forall dt name st. InstrSetFieldC dt name => Label name -> Instr (ToT (GetFieldType dt name) : (ToT dt : st)) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell: instrToField :: forall dt name st. InstrGetFieldC dt name => Label name -> Instr (ToT dt : st) (ToT (GetFieldType dt name) : st)

+ Morley.Michelson.Typed.Haskell: instrWrap :: forall dt name st. InstrWrapC dt name => Label name -> Instr (AppendCtorField (GetCtorField dt name) st) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell: instrWrapOne :: forall dt name st. InstrWrapOneC dt name => Label name -> Instr (ToT (CtorOnlyField name dt) : st) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell: ligoCombLayout :: GenericStrategy

+ Morley.Michelson.Typed.Haskell: ligoLayout :: GenericStrategy

+ Morley.Michelson.Typed.Haskell: mkBigMap :: ToBigMap m => m -> BigMap (ToBigMapKey m) (ToBigMapValue m)

+ Morley.Michelson.Typed.Haskell: newtype BigMapId k v

+ Morley.Michelson.Typed.Haskell: newtype DStorageType

+ Morley.Michelson.Typed.Haskell: newtype FieldConstructor (st :: [k]) (field :: Type)

+ Morley.Michelson.Typed.Haskell: newtype WithinParens

+ Morley.Michelson.Typed.Haskell: poly1TypeDocMdReference :: forall t (r :: Type) (a :: Type). (r ~ t a, Typeable t, Each '[TypeHasDoc] [r, a], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell: poly2TypeDocMdReference :: forall t (r :: Type) (a :: Type) (b :: Type). (r ~ t a b, Typeable t, Each '[TypeHasDoc] [r, a, b], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell: toTaggedVal :: LooseSumC dt => dt -> (Text, SomeValue)

+ Morley.Michelson.Typed.Haskell: toVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => a -> Value (ToT a)

+ Morley.Michelson.Typed.Haskell: toValStack :: IsoValuesStack ts => Rec Identity ts -> Rec Value (ToTs ts)

+ Morley.Michelson.Typed.Haskell: totsAppendLemma :: forall a b. KnownList a => Dict (ToTs (a ++ b) ~ (ToTs a ++ ToTs b))

+ Morley.Michelson.Typed.Haskell: totsKnownLemma :: forall s. KnownList s :- KnownList (ToTs s)

+ Morley.Michelson.Typed.Haskell: type ADTRep a = [ConstructorRep a]

+ Morley.Michelson.Typed.Haskell: type AppendCtorFieldAxiom (cf :: CtorField) (st :: [Type]) = ToTs (AppendCtorField cf st) ~ AppendCtorField cf (ToTs st)

+ Morley.Michelson.Typed.Haskell: type CaseClauses a = GCaseClauses (Rep a)

+ Morley.Michelson.Typed.Haskell: type ConstructorFieldNames dt = GFieldNames (Rep dt)

+ Morley.Michelson.Typed.Haskell: type ConstructorFieldTypes dt = GFieldTypes (Rep dt)

+ Morley.Michelson.Typed.Haskell: type CtorHasOnlyField ctor dt f = GetCtorField dt ctor ~ 'OneField f

+ Morley.Michelson.Typed.Haskell: type CtorOnlyField name dt = RequireOneField name (GetCtorField dt name)

+ Morley.Michelson.Typed.Haskell: type EntrypointCall param arg = EntrypointCallT (ToT param) (ToT arg)

+ Morley.Michelson.Typed.Haskell: type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]

+ Morley.Michelson.Typed.Haskell: type GenericIsoValue t = (IsoValue t, Generic t, ToT t ~ GValueType (Rep t))

+ Morley.Michelson.Typed.Haskell: type GetCtorField dt ctor = LnrFieldType (GetNamed ctor dt)

+ Morley.Michelson.Typed.Haskell: type GetFieldType dt name = LnrFieldType (GetNamed name dt)

+ Morley.Michelson.Typed.Haskell: type HasNoOpToT a = HasNoOp (ToT a)

+ Morley.Michelson.Typed.Haskell: type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (Rep dt))

+ Morley.Michelson.Typed.Haskell: type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (Rep dt))

+ Morley.Michelson.Typed.Haskell: type InstrDeconstructC dt = (GenericIsoValue dt, GInstrDeconstruct (Rep dt))

+ Morley.Michelson.Typed.Haskell: type InstrGetFieldC dt name = (GenericIsoValue dt, GInstrGet name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

+ Morley.Michelson.Typed.Haskell: type InstrSetFieldC dt name = (GenericIsoValue dt, GInstrSetField name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

+ Morley.Michelson.Typed.Haskell: type InstrUnwrapC dt name = (GenericIsoValue dt, GInstrUnwrap (Rep dt) (LnrBranch (GetNamed name dt)) (CtorOnlyField name dt))

+ Morley.Michelson.Typed.Haskell: type InstrWrapC dt name = (GenericIsoValue dt, GInstrWrap (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

+ Morley.Michelson.Typed.Haskell: type InstrWrapOneC dt name = (InstrWrapC dt name, GetCtorField dt name ~ 'OneField (CtorOnlyField name dt))

+ Morley.Michelson.Typed.Haskell: type KnownIsoT a = SingI (ToT a)

+ Morley.Michelson.Typed.Haskell: type LooseSumC dt = (Generic dt, GLooseSum (Rep dt))

+ Morley.Michelson.Typed.Haskell: type Path = [Branch]

+ Morley.Michelson.Typed.Haskell: type PolyTypeHasDocC ts = Each '[TypeHasDoc] ts

+ Morley.Michelson.Typed.Haskell: type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)

+ Morley.Michelson.Typed.Haskell: type ToT a = GValueType (Rep a);

+ Morley.Michelson.Typed.Haskell: type TypeDocFieldDescriptions _ = '[];

+ Morley.Michelson.Typed.Haskell: type TypeDocHaskellRep a = Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)

+ Morley.Michelson.Typed.Haskell: type TypeDocMichelsonRep a = Proxy a -> (Maybe DocTypeRepLHS, T)

+ Morley.Michelson.Typed.Haskell: type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)

+ Morley.Michelson.Typed.Haskell: type WellTypedToT a = WellTyped (ToT a)

+ Morley.Michelson.Typed.Haskell: type family TypeDocFieldDescriptions a :: FieldDescriptions;

+ Morley.Michelson.Typed.Haskell: typeDocDependencies :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

+ Morley.Michelson.Typed.Haskell: typeDocHaskellRep :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a), IsHomomorphic a) => TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell: typeDocMdDescription :: TypeHasDoc a => Markdown

+ Morley.Michelson.Typed.Haskell: typeDocMdReference :: (TypeHasDoc a, Typeable a, IsHomomorphic a) => Proxy a -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell: typeDocMichelsonRep :: (TypeHasDoc a, KnownIsoT a, IsHomomorphic a) => TypeDocMichelsonRep a

+ Morley.Michelson.Typed.Haskell: typeDocName :: (TypeHasDoc a, Generic a, KnownSymbol (GenericTypeName a)) => Proxy a -> Text

+ Morley.Michelson.Typed.Haskell: unsafeConcreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep b

+ Morley.Michelson.Typed.Haskell: unsafeConcreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a) => TypeDocMichelsonRep b

+ Morley.Michelson.Typed.Haskell: unsafeInstrUnwrap :: forall dt name st. InstrUnwrapC dt name => Label name -> Instr (ToT dt : st) (ToT (CtorOnlyField name dt) : st)

+ Morley.Michelson.Typed.Haskell: }

+ Morley.Michelson.Typed.Haskell.Compatibility: ligoCombLayout :: GenericStrategy

+ Morley.Michelson.Typed.Haskell.Compatibility: ligoLayout :: GenericStrategy

+ Morley.Michelson.Typed.Haskell.Doc: --

+ Morley.Michelson.Typed.Haskell.Doc: -- Descriptions will be checked at compile time to make sure that only

+ Morley.Michelson.Typed.Haskell.Doc: -- For implementation of the check see <a>FieldDescriptionsValid</a> type

+ Morley.Michelson.Typed.Haskell.Doc: -- See <a>FieldDescriptions</a> documentation for an example of usage.

+ Morley.Michelson.Typed.Haskell.Doc: -- existing constructors and fields are referenced.

+ Morley.Michelson.Typed.Haskell.Doc: -- family.

+ Morley.Michelson.Typed.Haskell.Doc: -- whenever <tt>TypeDocFieldDescriptions</tt> is not empty.

+ Morley.Michelson.Typed.Haskell.Doc: -- | Description of constructors and fields of <tt>a</tt>.

+ Morley.Michelson.Typed.Haskell.Doc: ConstructorRep :: Text -> Maybe Text -> [FieldRep a] -> ConstructorRep a

+ Morley.Michelson.Typed.Haskell.Doc: DStorageType :: DType -> DStorageType

+ Morley.Michelson.Typed.Haskell.Doc: FieldRep :: Maybe Text -> Maybe Text -> a -> FieldRep a

+ Morley.Michelson.Typed.Haskell.Doc: WithinParens :: Bool -> WithinParens

+ Morley.Michelson.Typed.Haskell.Doc: [DType] :: TypeHasDoc a => Proxy a -> DType

+ Morley.Michelson.Typed.Haskell.Doc: [SomeTypeWithDoc] :: TypeHasDoc td => Proxy td -> SomeTypeWithDoc

+ Morley.Michelson.Typed.Haskell.Doc: [crDescription] :: ConstructorRep a -> Maybe Text

+ Morley.Michelson.Typed.Haskell.Doc: [crFields] :: ConstructorRep a -> [FieldRep a]

+ Morley.Michelson.Typed.Haskell.Doc: [crName] :: ConstructorRep a -> Text

+ Morley.Michelson.Typed.Haskell.Doc: [frDescription] :: FieldRep a -> Maybe Text

+ Morley.Michelson.Typed.Haskell.Doc: [frName] :: FieldRep a -> Maybe Text

+ Morley.Michelson.Typed.Haskell.Doc: [frTypeRep] :: FieldRep a -> a

+ Morley.Michelson.Typed.Haskell.Doc: applyWithinParens :: WithinParens -> Markdown -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: buildTypeWithinParens :: forall a. Typeable a => WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: class GProductHasDoc (x :: Type -> Type)

+ Morley.Michelson.Typed.Haskell.Doc: class GTypeHasDoc (x :: Type -> Type)

+ Morley.Michelson.Typed.Haskell.Doc: class HaveCommonTypeCtor a b

+ Morley.Michelson.Typed.Haskell.Doc: class IsHomomorphic a

+ Morley.Michelson.Typed.Haskell.Doc: class (Typeable a, SingI (TypeDocFieldDescriptions a), FieldDescriptionsValid (TypeDocFieldDescriptions a) a) => TypeHasDoc a where {

+ Morley.Michelson.Typed.Haskell.Doc: concreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a), HaveCommonTypeCtor b a) => TypeDocHaskellRep b

+ Morley.Michelson.Typed.Haskell.Doc: concreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a, HaveCommonTypeCtor b a) => TypeDocMichelsonRep b

+ Morley.Michelson.Typed.Haskell.Doc: crDescriptionL :: forall a_a6mKG. Lens' (ConstructorRep a_a6mKG) (Maybe Text)

+ Morley.Michelson.Typed.Haskell.Doc: crFieldsL :: forall a_a6mKG a_a6mLS. Lens (ConstructorRep a_a6mKG) (ConstructorRep a_a6mLS) [FieldRep a_a6mKG] [FieldRep a_a6mLS]

+ Morley.Michelson.Typed.Haskell.Doc: crNameL :: forall a_a6mKG. Lens' (ConstructorRep a_a6mKG) Text

+ Morley.Michelson.Typed.Haskell.Doc: customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: customTypeDocMdReference' :: (Text, DType) -> [WithinParens -> Markdown] -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: dStorage :: forall store. TypeHasDoc store => DStorageType

+ Morley.Michelson.Typed.Haskell.Doc: dTypeDep :: forall (t :: Type). TypeHasDoc t => SomeDocDefinitionItem

+ Morley.Michelson.Typed.Haskell.Doc: dTypeDepP :: forall (t :: Type). TypeHasDoc t => Proxy t -> SomeDocDefinitionItem

+ Morley.Michelson.Typed.Haskell.Doc: data ConstructorRep a

+ Morley.Michelson.Typed.Haskell.Doc: data DType

+ Morley.Michelson.Typed.Haskell.Doc: data FieldRep a

+ Morley.Michelson.Typed.Haskell.Doc: data SomeTypeWithDoc

+ Morley.Michelson.Typed.Haskell.Doc: frDescriptionL :: forall a_a6mKF. Lens' (FieldRep a_a6mKF) (Maybe Text)

+ Morley.Michelson.Typed.Haskell.Doc: frNameL :: forall a_a6mKF. Lens' (FieldRep a_a6mKF) (Maybe Text)

+ Morley.Michelson.Typed.Haskell.Doc: frTypeRepL :: forall a_a6mKF a_a6mNA. Lens (FieldRep a_a6mKF) (FieldRep a_a6mNA) a_a6mKF a_a6mNA

+ Morley.Michelson.Typed.Haskell.Doc: genericTypeDocDependencies :: forall a. (Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

+ Morley.Michelson.Typed.Haskell.Doc: haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell.Doc: haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell.Doc: haskellRepStripFieldPrefix :: HasCallStack => TypeDocHaskellRep a -> TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell.Doc: homomorphicTypeDocHaskellRep :: forall a. (Generic a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell.Doc: homomorphicTypeDocMdReference :: forall (t :: Type). (Typeable t, TypeHasDoc t, IsHomomorphic t) => Proxy t -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: homomorphicTypeDocMichelsonRep :: forall a. KnownIsoT a => TypeDocMichelsonRep a

+ Morley.Michelson.Typed.Haskell.Doc: instance (Morley.Michelson.Typed.Haskell.Doc.GProductHasDoc x, GHC.TypeLits.KnownSymbol ctor) => Morley.Michelson.Typed.Haskell.Doc.GTypeHasDoc (GHC.Generics.C1 ('GHC.Generics.MetaCons ctor _1 _2) x)

+ Morley.Michelson.Typed.Haskell.Doc: instance (Morley.Michelson.Typed.Haskell.Doc.GProductHasDoc x, Morley.Michelson.Typed.Haskell.Doc.GProductHasDoc y) => Morley.Michelson.Typed.Haskell.Doc.GProductHasDoc (x GHC.Generics.:*: y)

+ Morley.Michelson.Typed.Haskell.Doc: instance (Morley.Michelson.Typed.Haskell.Doc.GTypeHasDoc x, Morley.Michelson.Typed.Haskell.Doc.GTypeHasDoc y) => Morley.Michelson.Typed.Haskell.Doc.GTypeHasDoc (x GHC.Generics.:+: y)

+ Morley.Michelson.Typed.Haskell.Doc: instance (Morley.Michelson.Typed.Haskell.Doc.PolyCTypeHasDocC '[k], Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[v], GHC.Classes.Ord k) => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (Data.Map.Internal.Map k v)

+ Morley.Michelson.Typed.Haskell.Doc: instance (Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (Morley.Util.Named.ApplyNamedFunctor f a), GHC.TypeLits.KnownSymbol n, Morley.Michelson.Typed.Haskell.Value.KnownIsoT (Morley.Util.Named.ApplyNamedFunctor f GHC.Integer.Type.Integer), Data.Typeable.Internal.Typeable f, Data.Typeable.Internal.Typeable a) => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (Named.Internal.NamedF f a n)

+ Morley.Michelson.Typed.Haskell.Doc: instance (Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc a, GHC.TypeLits.KnownSymbol field) => Morley.Michelson.Typed.Haskell.Doc.GProductHasDoc (GHC.Generics.S1 ('GHC.Generics.MetaSel ('GHC.Maybe.Just field) _1 _2 _3) (GHC.Generics.Rec0 a))

+ Morley.Michelson.Typed.Haskell.Doc: instance Data.String.IsString Morley.Michelson.Typed.Haskell.Doc.DocTypeRepLHS

+ Morley.Michelson.Typed.Haskell.Doc: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Haskell.Doc.DocTypeRepLHS

+ Morley.Michelson.Typed.Haskell.Doc: instance GHC.Classes.Eq Morley.Michelson.Typed.Haskell.Doc.DStorageType

+ Morley.Michelson.Typed.Haskell.Doc: instance GHC.Classes.Eq Morley.Michelson.Typed.Haskell.Doc.DType

+ Morley.Michelson.Typed.Haskell.Doc: instance GHC.Classes.Ord Morley.Michelson.Typed.Haskell.Doc.DStorageType

+ Morley.Michelson.Typed.Haskell.Doc: instance GHC.Classes.Ord Morley.Michelson.Typed.Haskell.Doc.DType

+ Morley.Michelson.Typed.Haskell.Doc: instance GHC.Generics.Generic Morley.Michelson.Typed.Haskell.Doc.DStorageType

+ Morley.Michelson.Typed.Haskell.Doc: instance GHC.Show.Show Morley.Michelson.Typed.Haskell.Doc.DType

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Typed.Haskell.Doc.DStorageType

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Doc.DocItem Morley.Michelson.Typed.Haskell.Doc.DType

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.GProductHasDoc GHC.Generics.U1

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.GTypeHasDoc GHC.Generics.V1

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.GTypeHasDoc x => Morley.Michelson.Typed.Haskell.Doc.GTypeHasDoc (GHC.Generics.D1 ('GHC.Generics.MetaData _a _b _c 'GHC.Types.False) x)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyCTypeHasDocC '[a] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (Data.Set.Internal.Set a)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d, e, f, g] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d, e, f, g)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d, e, f] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d, e, f)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d, e] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d, e)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c, d] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c, d)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b, c] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b, c)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a, b] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (a, b)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (GHC.Maybe.Maybe a)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (Morley.Michelson.Typed.Haskell.Value.Ticket a)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[a] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc [a]

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[cp] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (Morley.Michelson.Typed.Haskell.Value.ContractRef cp)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.PolyTypeHasDocC '[l, r] => Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc (Data.Either.Either l r)

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc ()

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Data.ByteString.Internal.ByteString

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc GHC.Integer.Type.Integer

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc GHC.Natural.Natural

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc GHC.Types.Bool

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Michelson.Text.MText

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Michelson.Typed.Aliases.Operation

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Tezos.Address.Address

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Tezos.Core.ChainId

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Tezos.Core.Mutez

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Tezos.Core.Timestamp

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Tezos.Crypto.KeyHash

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Tezos.Crypto.PublicKey

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc Morley.Tezos.Crypto.Signature

+ Morley.Michelson.Typed.Haskell.Doc: instance Morley.Michelson.Typed.Haskell.Doc.TypeHasDoc a => Morley.Michelson.Typed.Haskell.Doc.GProductHasDoc (GHC.Generics.S1 ('GHC.Generics.MetaSel 'GHC.Maybe.Nothing _1 _2 _3) (GHC.Generics.Rec0 a))

+ Morley.Michelson.Typed.Haskell.Doc: instance forall k (a :: k). Morley.Michelson.Typed.Haskell.Doc.HaveCommonTypeCtor a a

+ Morley.Michelson.Typed.Haskell.Doc: instance forall k (a :: k). Morley.Michelson.Typed.Haskell.Doc.IsHomomorphic a

+ Morley.Michelson.Typed.Haskell.Doc: instance forall k1 k2 (a :: k1 -> k2) (b :: k1). (TypeError ...) => Morley.Michelson.Typed.Haskell.Doc.IsHomomorphic (a b)

+ Morley.Michelson.Typed.Haskell.Doc: instance forall k1 k2 k3 k4 (ac :: k1 -> k2) (bc :: k3 -> k4) (a :: k1) (b :: k3). Morley.Michelson.Typed.Haskell.Doc.HaveCommonTypeCtor ac bc => Morley.Michelson.Typed.Haskell.Doc.HaveCommonTypeCtor (ac a) (bc b)

+ Morley.Michelson.Typed.Haskell.Doc: newtype DStorageType

+ Morley.Michelson.Typed.Haskell.Doc: newtype WithinParens

+ Morley.Michelson.Typed.Haskell.Doc: poly1TypeDocMdReference :: forall t (r :: Type) (a :: Type). (r ~ t a, Typeable t, Each '[TypeHasDoc] [r, a], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: poly2TypeDocMdReference :: forall t (r :: Type) (a :: Type) (b :: Type). (r ~ t a b, Typeable t, Each '[TypeHasDoc] [r, a, b], IsHomomorphic t) => Proxy r -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: type ADTRep a = [ConstructorRep a]

+ Morley.Michelson.Typed.Haskell.Doc: type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]

+ Morley.Michelson.Typed.Haskell.Doc: type PolyTypeHasDocC ts = Each '[TypeHasDoc] ts

+ Morley.Michelson.Typed.Haskell.Doc: type TypeDocFieldDescriptions _ = '[];

+ Morley.Michelson.Typed.Haskell.Doc: type TypeDocHaskellRep a = Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)

+ Morley.Michelson.Typed.Haskell.Doc: type TypeDocMichelsonRep a = Proxy a -> (Maybe DocTypeRepLHS, T)

+ Morley.Michelson.Typed.Haskell.Doc: type family TypeDocFieldDescriptions a :: FieldDescriptions;

+ Morley.Michelson.Typed.Haskell.Doc: typeDocDependencies :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a)) => Proxy a -> [SomeDocDefinitionItem]

+ Morley.Michelson.Typed.Haskell.Doc: typeDocHaskellRep :: (TypeHasDoc a, Generic a, GTypeHasDoc (Rep a), IsHomomorphic a) => TypeDocHaskellRep a

+ Morley.Michelson.Typed.Haskell.Doc: typeDocMdDescription :: TypeHasDoc a => Markdown

+ Morley.Michelson.Typed.Haskell.Doc: typeDocMdReference :: (TypeHasDoc a, Typeable a, IsHomomorphic a) => Proxy a -> WithinParens -> Markdown

+ Morley.Michelson.Typed.Haskell.Doc: typeDocMichelsonRep :: (TypeHasDoc a, KnownIsoT a, IsHomomorphic a) => TypeDocMichelsonRep a

+ Morley.Michelson.Typed.Haskell.Doc: typeDocName :: (TypeHasDoc a, Generic a, KnownSymbol (GenericTypeName a)) => Proxy a -> Text

+ Morley.Michelson.Typed.Haskell.Doc: unsafeConcreteTypeDocHaskellRep :: forall a b. (Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep b

+ Morley.Michelson.Typed.Haskell.Doc: unsafeConcreteTypeDocMichelsonRep :: forall a b. (Typeable a, KnownIsoT a) => TypeDocMichelsonRep b

+ Morley.Michelson.Typed.Haskell.Doc: }

+ Morley.Michelson.Typed.Haskell.Instr.Helpers: L :: Branch

+ Morley.Michelson.Typed.Haskell.Instr.Helpers: R :: Branch

+ Morley.Michelson.Typed.Haskell.Instr.Helpers: S :: Branch

+ Morley.Michelson.Typed.Haskell.Instr.Helpers: data Branch

+ Morley.Michelson.Typed.Haskell.Instr.Helpers: type Path = [Branch]

+ Morley.Michelson.Typed.Haskell.Instr.Product: FieldConstructor :: Instr (ToTs' st) (ToT field : ToTs' st) -> FieldConstructor (st :: [k]) (field :: Type)

+ Morley.Michelson.Typed.Haskell.Instr.Product: castFieldConstructorsImpl :: CastFieldConstructors xs ys => Rec (FieldConstructor st) xs -> Rec (FieldConstructor st) ys

+ Morley.Michelson.Typed.Haskell.Instr.Product: class ToTs xs ~ ToTs ys => CastFieldConstructors xs ys

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance ((TypeError ...), Morley.Michelson.Typed.Haskell.Value.GIsoValue x, Morley.Michelson.Typed.Haskell.Value.GIsoValue y) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (x GHC.Generics.:+: y)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Instr.Product.CastFieldConstructors xs ys, Morley.Michelson.Typed.Haskell.Value.ToTs xs GHC.Types.~ Morley.Michelson.Typed.Haskell.Value.ToTs ys, Morley.Michelson.Typed.Haskell.Value.ToT x GHC.Types.~ Morley.Michelson.Typed.Haskell.Value.ToT y) => Morley.Michelson.Typed.Haskell.Instr.Product.CastFieldConstructors (x : xs) (y : ys)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct x, Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct y, Morley.Util.Type.RSplit (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes x) (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes y), Morley.Util.Type.KnownList (Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes x)), Morley.Util.Type.KnownList (Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)), (Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes x) Data.Vinyl.TypeLevel.++ Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) GHC.Types.~ Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes x Data.Vinyl.TypeLevel.++ Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (x GHC.Generics.:*: y)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct x, Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct y, t GHC.Types.~ (x GHC.Generics.:*: y), Morley.Util.Type.KnownList (Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes x)), Morley.Util.Type.KnownList (Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)), (Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes x) Data.Vinyl.TypeLevel.++ Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) GHC.Types.~ Morley.Michelson.Typed.Haskell.Value.ToTs (Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes x Data.Vinyl.TypeLevel.++ Morley.Michelson.Typed.Haskell.Instr.Product.GFieldTypes y)) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct (x GHC.Generics.:*: y)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Instr.Product.GInstrGet name x path f, Morley.Michelson.Typed.Haskell.Value.GIsoValue y) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrGet name (x GHC.Generics.:*: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.L : path) f

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Instr.Product.GInstrGet name y path f, Morley.Michelson.Typed.Haskell.Value.GIsoValue x) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrGet name (x GHC.Generics.:*: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.R : path) f

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Instr.Product.GInstrSetField name x path f, Morley.Michelson.Typed.Haskell.Value.GIsoValue y) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrSetField name (x GHC.Generics.:*: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.L : path) f

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Instr.Product.GInstrSetField name y path f, Morley.Michelson.Typed.Haskell.Value.GIsoValue x) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrSetField name (x GHC.Generics.:*: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.R : path) f

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (Morley.Michelson.Typed.Haskell.Value.IsoValue f, Morley.Michelson.Typed.Haskell.Value.ToT f GHC.Types.~ Morley.Michelson.Typed.Haskell.Value.ToT f') => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrGet name (GHC.Generics.Rec0 f) '[] f'

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (TypeError ...) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct GHC.Generics.V1

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance (TypeError ...) => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct GHC.Generics.V1

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance GHC.Generics.Generic Morley.Michelson.Typed.Haskell.Instr.Product.MyType2

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Instr.Product.CastFieldConstructors '[] '[]

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct GHC.Generics.U1

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct x => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (GHC.Generics.M1 t i x)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct GHC.Generics.U1

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct x => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct (GHC.Generics.M1 t i x)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Instr.Product.GInstrGet name x path f => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrGet name (GHC.Generics.M1 t i x) path f

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Instr.Product.GInstrSetField name x path f => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrSetField name (GHC.Generics.M1 t i x) path f

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Haskell.Instr.Product.MyType2

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrConstruct (GHC.Generics.Rec0 a)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Instr.Product.GInstrDeconstruct (GHC.Generics.Rec0 a)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instrConstruct :: forall dt st. InstrConstructC dt => Rec (FieldConstructor st) (ConstructorFieldTypes dt) -> Instr st (ToT dt : st)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instrConstructStack :: forall dt stack st. (InstrConstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (stack ++ st) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instrDeconstruct :: forall dt stack st. (InstrDeconstructC dt, stack ~ ToTs (ConstructorFieldTypes dt), KnownList stack) => Instr (ToT dt : st) (stack ++ st)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instrSetField :: forall dt name st. InstrSetFieldC dt name => Label name -> Instr (ToT (GetFieldType dt name) : (ToT dt : st)) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell.Instr.Product: instrToField :: forall dt name st. InstrGetFieldC dt name => Label name -> Instr (ToT dt : st) (ToT (GetFieldType dt name) : st)

+ Morley.Michelson.Typed.Haskell.Instr.Product: newtype FieldConstructor (st :: [k]) (field :: Type)

+ Morley.Michelson.Typed.Haskell.Instr.Product: type ConstructorFieldNames dt = GFieldNames (Rep dt)

+ Morley.Michelson.Typed.Haskell.Instr.Product: type ConstructorFieldTypes dt = GFieldTypes (Rep dt)

+ Morley.Michelson.Typed.Haskell.Instr.Product: type GetFieldType dt name = LnrFieldType (GetNamed name dt)

+ Morley.Michelson.Typed.Haskell.Instr.Product: type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (Rep dt))

+ Morley.Michelson.Typed.Haskell.Instr.Product: type InstrDeconstructC dt = (GenericIsoValue dt, GInstrDeconstruct (Rep dt))

+ Morley.Michelson.Typed.Haskell.Instr.Product: type InstrGetFieldC dt name = (GenericIsoValue dt, GInstrGet name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

+ Morley.Michelson.Typed.Haskell.Instr.Product: type InstrSetFieldC dt name = (GenericIsoValue dt, GInstrSetField name (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

+ Morley.Michelson.Typed.Haskell.Instr.Product: type family GLookupNamed (name :: Symbol) (x :: Type -> Type) :: Maybe LookupNamedResult

+ Morley.Michelson.Typed.Haskell.Instr.Sum: (//->) :: Label ("c" `AppendSymbol` ctor) -> RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: CaseClauseParam :: Symbol -> CtorField -> CaseClauseParam

+ Morley.Michelson.Typed.Haskell.Instr.Sum: L :: Branch

+ Morley.Michelson.Typed.Haskell.Instr.Sum: NoFields :: CtorField

+ Morley.Michelson.Typed.Haskell.Instr.Sum: OneField :: Type -> CtorField

+ Morley.Michelson.Typed.Haskell.Instr.Sum: R :: Branch

+ Morley.Michelson.Typed.Haskell.Instr.Sum: S :: Branch

+ Morley.Michelson.Typed.Haskell.Instr.Sum: [CaseClause] :: RemFail Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: appendCtorFieldAxiom :: (AppendCtorFieldAxiom ('OneField Word) '[Int], AppendCtorFieldAxiom 'NoFields '[Int]) => Dict (AppendCtorFieldAxiom cf st)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: data Branch

+ Morley.Michelson.Typed.Haskell.Instr.Sum: data CaseClause (inp :: [T]) (out :: [T]) (param :: CaseClauseParam)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: data CaseClauseParam

+ Morley.Michelson.Typed.Haskell.Instr.Sum: data CtorField

+ Morley.Michelson.Typed.Haskell.Instr.Sum: data MyCompoundType

+ Morley.Michelson.Typed.Haskell.Instr.Sum: hsUnwrap :: forall dt name. InstrUnwrapC dt name => Label name -> dt -> Maybe (CtorOnlyField name dt)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: hsWrap :: forall dt name. InstrWrapC dt name => Label name -> ExtractCtorField (GetCtorField dt name) -> dt

+ Morley.Michelson.Typed.Haskell.Instr.Sum: infixr 8 //->

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCase x, Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCase y, Morley.Util.Type.RSplit (Morley.Michelson.Typed.Haskell.Instr.Sum.GCaseClauses x) (Morley.Michelson.Typed.Haskell.Instr.Sum.GCaseClauses y)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCase (x GHC.Generics.:+: y)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap x path e, Morley.Michelson.Typed.Haskell.Value.GIsoValue y, Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Haskell.Value.GValueType y)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (x GHC.Generics.:+: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.L : path) e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap y path e, Morley.Michelson.Typed.Haskell.Value.GIsoValue x, Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Haskell.Value.GValueType x)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (x GHC.Generics.:+: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.R : path) e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap x path e, Morley.Michelson.Typed.Haskell.Value.GIsoValue y, Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Haskell.Value.GValueType y)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (x GHC.Generics.:+: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.L : path) e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap y path e, Morley.Michelson.Typed.Haskell.Value.GIsoValue x, Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Haskell.Value.GValueType x)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (x GHC.Generics.:+: y) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.R : path) e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (Morley.Michelson.Typed.Haskell.Value.GIsoValue x, Morley.Michelson.Typed.Haskell.Value.GIsoValue y, (TypeError ...)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor (x GHC.Generics.:*: y)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (path GHC.Types.~ (x : xs), Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.Rep sub) path e, Morley.Michelson.Typed.Haskell.Value.GenericIsoValue sub, Morley.Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.Rep sub)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 sub))) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.S : x : xs) e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance (path GHC.Types.~ (x : xs), Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.Rep sub) path e, Morley.Michelson.Typed.Haskell.Value.GenericIsoValue sub, Morley.Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.Rep sub)) => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 sub))) ('Morley.Michelson.Typed.Haskell.Instr.Helpers.S : x : xs) e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Morley.Michelson.Typed.Haskell.Instr.Sum.MyCompoundType

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Morley.Michelson.Typed.Haskell.Instr.Sum.MyEnum

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Morley.Michelson.Typed.Haskell.Instr.Sum.MyType

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Morley.Michelson.Typed.Haskell.Instr.Sum.MyType'

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance GHC.Generics.Generic Morley.Michelson.Typed.Haskell.Instr.Sum.MyTypeWithNamedField

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCase GHC.Generics.V1

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCase x => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCase (GHC.Generics.D1 i x)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor GHC.Generics.U1

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor x => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCase (GHC.Generics.C1 ('GHC.Generics.MetaCons ctor _1 _2) x)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap x path e => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.D1 i x) path e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.C1 c GHC.Generics.U1) '[ 'Morley.Michelson.Typed.Haskell.Instr.Helpers.S] 'Morley.Michelson.Typed.Haskell.Instr.Sum.NoFields

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap x path e => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.D1 i x) path e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Haskell.Instr.Sum.MyCompoundType

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Haskell.Instr.Sum.MyEnum

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Haskell.Instr.Sum.MyType

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Haskell.Instr.Sum.MyType'

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Haskell.Instr.Sum.MyTypeWithNamedField

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrCaseBranch ctor (GHC.Generics.Rec0 a)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue e => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrUnwrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 e))) '[ 'Morley.Michelson.Typed.Haskell.Instr.Helpers.S] e

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue e => Morley.Michelson.Typed.Haskell.Instr.Sum.GInstrWrap (GHC.Generics.C1 c (GHC.Generics.S1 i (GHC.Generics.Rec0 e))) '[ 'Morley.Michelson.Typed.Haskell.Instr.Helpers.S] ('Morley.Michelson.Typed.Haskell.Instr.Sum.OneField e)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instrCase :: forall dt out inp. InstrCaseC dt => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt : inp) out

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instrWrap :: forall dt name st. InstrWrapC dt name => Label name -> Instr (AppendCtorField (GetCtorField dt name) st) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: instrWrapOne :: forall dt name st. InstrWrapOneC dt name => Label name -> Instr (ToT (CtorOnlyField name dt) : st) (ToT dt : st)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type AppendCtorFieldAxiom (cf :: CtorField) (st :: [Type]) = ToTs (AppendCtorField cf st) ~ AppendCtorField cf (ToTs st)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type CaseClauses a = GCaseClauses (Rep a)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type CtorHasOnlyField ctor dt f = GetCtorField dt ctor ~ 'OneField f

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type CtorOnlyField name dt = RequireOneField name (GetCtorField dt name)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type GetCtorField dt ctor = LnrFieldType (GetNamed ctor dt)

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (Rep dt))

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type InstrUnwrapC dt name = (GenericIsoValue dt, GInstrUnwrap (Rep dt) (LnrBranch (GetNamed name dt)) (CtorOnlyField name dt))

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type InstrWrapC dt name = (GenericIsoValue dt, GInstrWrap (Rep dt) (LnrBranch (GetNamed name dt)) (LnrFieldType (GetNamed name dt)))

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type InstrWrapOneC dt name = (InstrWrapC dt name, GetCtorField dt name ~ 'OneField (CtorOnlyField name dt))

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type Path = [Branch]

+ Morley.Michelson.Typed.Haskell.Instr.Sum: type family IsPrimitiveValue (x :: Type) :: Bool

+ Morley.Michelson.Typed.Haskell.Instr.Sum: unsafeInstrUnwrap :: forall dt name st. InstrUnwrapC dt name => Label name -> Instr (ToT dt : st) (ToT (CtorOnlyField name dt) : st)

+ Morley.Michelson.Typed.Haskell.LooseSum: ComposeCtorNotFound :: ComposeResult a

+ Morley.Michelson.Typed.Haskell.LooseSum: ComposeFieldTypeMismatch :: T -> T -> ComposeResult a

+ Morley.Michelson.Typed.Haskell.LooseSum: ComposeOk :: a -> ComposeResult a

+ Morley.Michelson.Typed.Haskell.LooseSum: data ComposeResult a

+ Morley.Michelson.Typed.Haskell.LooseSum: fromTaggedVal :: LooseSumC dt => (Text, SomeValue) -> ComposeResult dt

+ Morley.Michelson.Typed.Haskell.LooseSum: instance (Morley.Michelson.Typed.Haskell.LooseSum.GAccessField x, GHC.TypeLits.KnownSymbol ctor) => Morley.Michelson.Typed.Haskell.LooseSum.GLooseSum (GHC.Generics.C1 ('GHC.Generics.MetaCons ctor f o) x)

+ Morley.Michelson.Typed.Haskell.LooseSum: instance (Morley.Michelson.Typed.Haskell.LooseSum.GLooseSum x, Morley.Michelson.Typed.Haskell.LooseSum.GLooseSum y) => Morley.Michelson.Typed.Haskell.LooseSum.GLooseSum (x GHC.Generics.:+: y)

+ Morley.Michelson.Typed.Haskell.LooseSum: instance (TypeError ...) => Morley.Michelson.Typed.Haskell.LooseSum.GAccessField (x GHC.Generics.:*: y)

+ Morley.Michelson.Typed.Haskell.LooseSum: instance GHC.Base.Functor Morley.Michelson.Typed.Haskell.LooseSum.ComposeResult

+ Morley.Michelson.Typed.Haskell.LooseSum: instance GHC.Base.Monoid (Morley.Michelson.Typed.Haskell.LooseSum.ComposeResult a)

+ Morley.Michelson.Typed.Haskell.LooseSum: instance GHC.Base.Semigroup (Morley.Michelson.Typed.Haskell.LooseSum.ComposeResult a)

+ Morley.Michelson.Typed.Haskell.LooseSum: instance Morley.Michelson.Typed.Haskell.LooseSum.GAccessField GHC.Generics.U1

+ Morley.Michelson.Typed.Haskell.LooseSum: instance Morley.Michelson.Typed.Haskell.LooseSum.GAccessField x => Morley.Michelson.Typed.Haskell.LooseSum.GAccessField (GHC.Generics.S1 i x)

+ Morley.Michelson.Typed.Haskell.LooseSum: instance Morley.Michelson.Typed.Haskell.LooseSum.GLooseSum GHC.Generics.V1

+ Morley.Michelson.Typed.Haskell.LooseSum: instance Morley.Michelson.Typed.Haskell.LooseSum.GLooseSum x => Morley.Michelson.Typed.Haskell.LooseSum.GLooseSum (GHC.Generics.D1 i x)

+ Morley.Michelson.Typed.Haskell.LooseSum: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.LooseSum.GAccessField (GHC.Generics.Rec0 a)

+ Morley.Michelson.Typed.Haskell.LooseSum: toTaggedVal :: LooseSumC dt => dt -> (Text, SomeValue)

+ Morley.Michelson.Typed.Haskell.LooseSum: type LooseSumC dt = (Generic dt, GLooseSum (Rep dt))

+ Morley.Michelson.Typed.Haskell.ValidateDescription: type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]

+ Morley.Michelson.Typed.Haskell.ValidateDescription: type FieldDescriptionsV = Demote FieldDescriptions

+ Morley.Michelson.Typed.Haskell.ValidateDescription: type family FieldDescriptionsValid (descr :: FieldDescriptions) (typ :: Type) :: Constraint

+ Morley.Michelson.Typed.Haskell.Value: -- type.

+ Morley.Michelson.Typed.Haskell.Value: -- | Type function that converts a regular Haskell type into a <tt>T</tt>

+ Morley.Michelson.Typed.Haskell.Value: BigMap :: Maybe (BigMapId k v) -> Map k v -> BigMap k v

+ Morley.Michelson.Typed.Haskell.Value: BigMapId :: Natural -> BigMapId k v

+ Morley.Michelson.Typed.Haskell.Value: ContractRef :: Address -> SomeEntrypointCall arg -> ContractRef (arg :: Type)

+ Morley.Michelson.Typed.Haskell.Value: Ticket :: Address -> arg -> Natural -> Ticket (arg :: Type)

+ Morley.Michelson.Typed.Haskell.Value: [Dict] :: forall a. a => Dict a

+ Morley.Michelson.Typed.Haskell.Value: [bmId] :: BigMap k v -> Maybe (BigMapId k v)

+ Morley.Michelson.Typed.Haskell.Value: [bmMap] :: BigMap k v -> Map k v

+ Morley.Michelson.Typed.Haskell.Value: [crAddress] :: ContractRef (arg :: Type) -> Address

+ Morley.Michelson.Typed.Haskell.Value: [crEntrypoint] :: ContractRef (arg :: Type) -> SomeEntrypointCall arg

+ Morley.Michelson.Typed.Haskell.Value: [tAmount] :: Ticket (arg :: Type) -> Natural

+ Morley.Michelson.Typed.Haskell.Value: [tData] :: Ticket (arg :: Type) -> arg

+ Morley.Michelson.Typed.Haskell.Value: [tTicketer] :: Ticket (arg :: Type) -> Address

+ Morley.Michelson.Typed.Haskell.Value: [unBigMapId] :: BigMapId k v -> Natural

+ Morley.Michelson.Typed.Haskell.Value: class SingI (GValueType x) => GIsoValue (x :: Type -> Type) where {

+ Morley.Michelson.Typed.Haskell.Value: class (WellTypedToT a) => IsoValue a where {

+ Morley.Michelson.Typed.Haskell.Value: class IsoValuesStack (ts :: [Type])

+ Morley.Michelson.Typed.Haskell.Value: class ToBigMap m where {

+ Morley.Michelson.Typed.Haskell.Value: class (SingI t, WellTypedSuperC t) => WellTyped (t :: T)

+ Morley.Michelson.Typed.Haskell.Value: coerceContractRef :: ToT a ~ ToT b => ContractRef a -> ContractRef b

+ Morley.Michelson.Typed.Haskell.Value: contractRefToAddr :: ContractRef cp -> EpAddress

+ Morley.Michelson.Typed.Haskell.Value: data BigMap k v

+ Morley.Michelson.Typed.Haskell.Value: data ContractRef (arg :: Type)

+ Morley.Michelson.Typed.Haskell.Value: data Dict a

+ Morley.Michelson.Typed.Haskell.Value: data Ticket (arg :: Type)

+ Morley.Michelson.Typed.Haskell.Value: fromVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => Value (ToT a) -> a

+ Morley.Michelson.Typed.Haskell.Value: fromValStack :: IsoValuesStack ts => Rec Value (ToTs ts) -> Rec Identity ts

+ Morley.Michelson.Typed.Haskell.Value: instance (Data.Data.Data k, Data.Data.Data v, GHC.Classes.Ord k) => Data.Data.Data (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance (GHC.Classes.Ord k, Formatting.Buildable.Buildable k, Formatting.Buildable.Buildable v) => Formatting.Buildable.Buildable (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance (GHC.Show.Show k, GHC.Show.Show v) => GHC.Show.Show (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.GIsoValue x, Morley.Michelson.Typed.Haskell.Value.GIsoValue y) => Morley.Michelson.Typed.Haskell.Value.GIsoValue (x GHC.Generics.:*: y)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.HasNoOpToT arg, Morley.Michelson.Typed.Haskell.Value.WellTypedToT arg) => Morley.Michelson.Typed.Haskell.Value.IsoValue (Morley.Michelson.Typed.Haskell.Value.ContractRef arg)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.IsoValue a, Morley.Michelson.Typed.Haskell.Value.IsoValue b) => Morley.Michelson.Typed.Haskell.Value.IsoValue (a, b)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.IsoValue a, Morley.Michelson.Typed.Haskell.Value.IsoValue b, Morley.Michelson.Typed.Haskell.Value.IsoValue c, Morley.Michelson.Typed.Haskell.Value.IsoValue d, Morley.Michelson.Typed.Haskell.Value.IsoValue e) => Morley.Michelson.Typed.Haskell.Value.IsoValue (a, b, c, d, e)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.IsoValue a, Morley.Michelson.Typed.Haskell.Value.IsoValue b, Morley.Michelson.Typed.Haskell.Value.IsoValue c, Morley.Michelson.Typed.Haskell.Value.IsoValue d, Morley.Michelson.Typed.Haskell.Value.IsoValue e, Morley.Michelson.Typed.Haskell.Value.IsoValue f) => Morley.Michelson.Typed.Haskell.Value.IsoValue (a, b, c, d, e, f)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.IsoValue a, Morley.Michelson.Typed.Haskell.Value.IsoValue b, Morley.Michelson.Typed.Haskell.Value.IsoValue c, Morley.Michelson.Typed.Haskell.Value.IsoValue d, Morley.Michelson.Typed.Haskell.Value.IsoValue e, Morley.Michelson.Typed.Haskell.Value.IsoValue f, Morley.Michelson.Typed.Haskell.Value.IsoValue g) => Morley.Michelson.Typed.Haskell.Value.IsoValue (a, b, c, d, e, f, g)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.IsoValue l, Morley.Michelson.Typed.Haskell.Value.IsoValue r) => Morley.Michelson.Typed.Haskell.Value.IsoValue (Data.Either.Either l r)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.IsoValue t, Morley.Michelson.Typed.Haskell.Value.IsoValuesStack st) => Morley.Michelson.Typed.Haskell.Value.IsoValuesStack (t : st)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.WellTyped t, Morley.Michelson.Typed.Scope.HasNoOp t) => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TContract t)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.WellTyped t, Morley.Michelson.Typed.Value.Comparable t) => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TTicket t)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Haskell.Value.WellTyped t1, Morley.Michelson.Typed.Haskell.Value.WellTyped t2) => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TLambda t1 t2)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Value.Comparable (Morley.Michelson.Typed.Haskell.Value.ToT a), Morley.Michelson.Typed.Haskell.Value.IsoValue a) => Morley.Michelson.Typed.Haskell.Value.IsoValue (Morley.Michelson.Typed.Haskell.Value.Ticket a)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Value.Comparable (Morley.Michelson.Typed.Haskell.Value.ToT c), GHC.Classes.Ord c, Morley.Michelson.Typed.Haskell.Value.IsoValue c) => Morley.Michelson.Typed.Haskell.Value.IsoValue (Data.Set.Internal.Set c)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Value.Comparable (Morley.Michelson.Typed.Haskell.Value.ToT k), GHC.Classes.Ord k, Morley.Michelson.Typed.Haskell.Value.IsoValue k, Morley.Michelson.Typed.Haskell.Value.IsoValue v) => Morley.Michelson.Typed.Haskell.Value.IsoValue (Data.Map.Internal.Map k v)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Value.Comparable (Morley.Michelson.Typed.Haskell.Value.ToT k), GHC.Classes.Ord k, Morley.Michelson.Typed.Haskell.Value.IsoValue k, Morley.Michelson.Typed.Haskell.Value.IsoValue v, Morley.Michelson.Typed.Haskell.Value.HasNoBigMapToT v, Morley.Michelson.Typed.Haskell.Value.HasNoOpToT v) => Morley.Michelson.Typed.Haskell.Value.IsoValue (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Value.Comparable k, Morley.Michelson.Typed.Haskell.Value.WellTyped k, Morley.Michelson.Typed.Haskell.Value.WellTyped v) => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Value.Comparable k, Morley.Michelson.Typed.Haskell.Value.WellTyped k, Morley.Michelson.Typed.Haskell.Value.WellTyped v, Morley.Michelson.Typed.Scope.HasNoBigMap v, Morley.Michelson.Typed.Scope.HasNoOp v) => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TBigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance (Morley.Michelson.Typed.Value.Comparable t, Morley.Michelson.Typed.Haskell.Value.WellTyped t) => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TSet t)

+ Morley.Michelson.Typed.Haskell.Value: instance Data.Default.Class.Default (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance Data.Foldable.Foldable (Morley.Michelson.Typed.Haskell.Value.BigMap k)

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Classes.Eq (Morley.Michelson.Typed.Haskell.Value.ContractRef arg)

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Classes.Eq arg => GHC.Classes.Eq (Morley.Michelson.Typed.Haskell.Value.Ticket arg)

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Classes.Ord k => GHC.Base.Semigroup (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Classes.Ord k => GHC.Exts.IsList (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Classes.Ord k => Morley.Michelson.Typed.Haskell.Value.ToBigMap (GHC.Base.NonEmpty (k, v))

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Classes.Ord k => Morley.Michelson.Typed.Haskell.Value.ToBigMap [(k, v)]

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Generics.Generic (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Show.Show (Morley.Michelson.Typed.Haskell.Value.ContractRef arg)

+ Morley.Michelson.Typed.Haskell.Value: instance GHC.Show.Show arg => GHC.Show.Show (Morley.Michelson.Typed.Haskell.Value.Ticket arg)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Text.DoNotUseTextError => Morley.Michelson.Typed.Haskell.Value.IsoValue Data.Text.Internal.Text

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.GIsoValue GHC.Generics.U1

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.GIsoValue GHC.Generics.V1

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.GIsoValue x => Morley.Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.M1 t i x)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue ()

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue (Morley.Michelson.Typed.Haskell.Value.ContractRef arg) => Formatting.Buildable.Buildable (Morley.Michelson.Typed.Haskell.Value.ContractRef arg)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Data.ByteString.Internal.ByteString

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Data.Void.Void

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue GHC.Integer.Type.Integer

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue GHC.Natural.Natural

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue GHC.Types.Bool

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Text.MText

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Aliases.Operation

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Michelson.Typed.Entrypoints.EpAddress

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Address.Address

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Core.ChainId

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Core.Mutez

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Core.Timestamp

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Crypto.BLS12381.Bls12381G1

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Crypto.BLS12381.Bls12381G2

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Crypto.KeyHash

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Crypto.PublicKey

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue Morley.Tezos.Crypto.Signature

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Value.GIsoValue (GHC.Generics.Rec0 a)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Value.IsoValue (Data.Functor.Identity.Identity a)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Value.IsoValue (GHC.Maybe.Maybe a)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Value.IsoValue (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Value.IsoValue (Named.Internal.NamedF GHC.Maybe.Maybe a name)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValue a => Morley.Michelson.Typed.Haskell.Value.IsoValue [a]

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.IsoValuesStack '[]

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.ToBigMap (Data.Map.Internal.Map k v)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TAddress

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TBls12381G1

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TBls12381G2

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TBool

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TBytes

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TChainId

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TKey

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TKeyHash

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TNever

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TOperation

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TSignature

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TString

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TTimestamp

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped 'Morley.Michelson.Typed.T.TUnit

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped t => Morley.Michelson.Typed.Haskell.Value.IsoValue (Morley.Michelson.Typed.Aliases.Value t)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped t => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TList t)

+ Morley.Michelson.Typed.Haskell.Value: instance Morley.Michelson.Typed.Haskell.Value.WellTyped t => Morley.Michelson.Typed.Haskell.Value.WellTyped ('Morley.Michelson.Typed.T.TOption t)

+ Morley.Michelson.Typed.Haskell.Value: instance Universum.Container.Class.Container (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance Universum.Container.Class.One (Morley.Michelson.Typed.Haskell.Value.BigMap k v)

+ Morley.Michelson.Typed.Haskell.Value: instance forall k (p :: k). Morley.Michelson.Typed.Haskell.Value.IsoValue (Data.Fixed.Fixed p)

+ Morley.Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). (Data.Typeable.Internal.Typeable k2, Data.Typeable.Internal.Typeable v, Data.Typeable.Internal.Typeable k1, Data.Typeable.Internal.Typeable k3) => Data.Data.Data (Morley.Michelson.Typed.Haskell.Value.BigMapId k2 v)

+ Morley.Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). Formatting.Buildable.Buildable (Morley.Michelson.Typed.Haskell.Value.BigMapId k2 v)

+ Morley.Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). GHC.Num.Num (Morley.Michelson.Typed.Haskell.Value.BigMapId k2 v)

+ Morley.Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). GHC.Show.Show (Morley.Michelson.Typed.Haskell.Value.BigMapId k2 v)

+ Morley.Michelson.Typed.Haskell.Value: instance forall k1 (k2 :: k1) k3 (v :: k3). Morley.Michelson.Typed.Haskell.Value.IsoValue (Morley.Michelson.Typed.Haskell.Value.BigMapId k2 v)

+ Morley.Michelson.Typed.Haskell.Value: mkBigMap :: ToBigMap m => m -> BigMap (ToBigMapKey m) (ToBigMapValue m)

+ Morley.Michelson.Typed.Haskell.Value: newtype BigMapId k v

+ Morley.Michelson.Typed.Haskell.Value: toVal :: (IsoValue a, Generic a, GIsoValue (Rep a), ToT a ~ GValueType (Rep a)) => a -> Value (ToT a)

+ Morley.Michelson.Typed.Haskell.Value: toValStack :: IsoValuesStack ts => Rec Identity ts -> Rec Value (ToTs ts)

+ Morley.Michelson.Typed.Haskell.Value: totsAppendLemma :: forall a b. KnownList a => Dict (ToTs (a ++ b) ~ (ToTs a ++ ToTs b))

+ Morley.Michelson.Typed.Haskell.Value: totsKnownLemma :: forall s. KnownList s :- KnownList (ToTs s)

+ Morley.Michelson.Typed.Haskell.Value: type EntrypointCall param arg = EntrypointCallT (ToT param) (ToT arg)

+ Morley.Michelson.Typed.Haskell.Value: type GenericIsoValue t = (IsoValue t, Generic t, ToT t ~ GValueType (Rep t))

+ Morley.Michelson.Typed.Haskell.Value: type HasNoOpToT a = HasNoOp (ToT a)

+ Morley.Michelson.Typed.Haskell.Value: type KnownIsoT a = SingI (ToT a)

+ Morley.Michelson.Typed.Haskell.Value: type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)

+ Morley.Michelson.Typed.Haskell.Value: type ToT a = GValueType (Rep a);

+ Morley.Michelson.Typed.Haskell.Value: type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)

+ Morley.Michelson.Typed.Haskell.Value: type WellTypedToT a = WellTyped (ToT a)

+ Morley.Michelson.Typed.Haskell.Value: type family ToTs' (t :: [k]) :: [T]

+ Morley.Michelson.Typed.Haskell.Value: }

+ Morley.Michelson.Typed.Instr: COMMENT_ITEM :: CommentType -> ExtInstr s

+ Morley.Michelson.Typed.Instr: Contract :: ContractCode cp st -> ParamNotes cp -> Notes st -> EntriesOrder -> Contract cp st

+ Morley.Michelson.Typed.Instr: DOC_ITEM :: SomeDocItem -> ExtInstr s

+ Morley.Michelson.Typed.Instr: FunctionEnds :: Text -> CommentType

+ Morley.Michelson.Typed.Instr: FunctionStarts :: Text -> CommentType

+ Morley.Michelson.Typed.Instr: JustComment :: Text -> CommentType

+ Morley.Michelson.Typed.Instr: PRINT :: PrintComment s -> ExtInstr s

+ Morley.Michelson.Typed.Instr: PrintComment :: [Either Text (StackRef st)] -> PrintComment (st :: [T])

+ Morley.Michelson.Typed.Instr: STACKTYPE :: StackTypePattern -> ExtInstr s

+ Morley.Michelson.Typed.Instr: StackTypeComment :: Maybe [T] -> CommentType

+ Morley.Michelson.Typed.Instr: StatementEnds :: Text -> CommentType

+ Morley.Michelson.Typed.Instr: StatementStarts :: Text -> CommentType

+ Morley.Michelson.Typed.Instr: TEST_ASSERT :: TestAssert s -> ExtInstr s

+ Morley.Michelson.Typed.Instr: [ABS] :: UnaryArithOp Abs n => Instr (n : s) (UnaryArithRes Abs n : s)

+ Morley.Michelson.Typed.Instr: [ADDRESS] :: Instr ('TContract a : s) ('TAddress : s)

+ Morley.Michelson.Typed.Instr: [ADD] :: ArithOp Add n m => Instr (n : (m : s)) (ArithRes Add n m : s)

+ Morley.Michelson.Typed.Instr: [AMOUNT] :: Instr s ('TMutez : s)

+ Morley.Michelson.Typed.Instr: [AND] :: ArithOp And n m => Instr (n : (m : s)) (ArithRes And n m : s)

+ Morley.Michelson.Typed.Instr: [APPLY] :: forall a b c s. (ConstantScope a, SingI b) => Instr (a : ('TLambda ('TPair a b) c : s)) ('TLambda b c : s)

+ Morley.Michelson.Typed.Instr: [AnnCAR] :: VarAnn -> FieldAnn -> Instr ('TPair a b : s) (a : s)

+ Morley.Michelson.Typed.Instr: [AnnCDR] :: VarAnn -> FieldAnn -> Instr ('TPair a b : s) (b : s)

+ Morley.Michelson.Typed.Instr: [AnnLEFT] :: SingI b => TypeAnn -> FieldAnn -> FieldAnn -> Instr (a : s) ('TOr a b : s)

+ Morley.Michelson.Typed.Instr: [AnnPAIR] :: TypeAnn -> FieldAnn -> FieldAnn -> Instr (a : (b : s)) ('TPair a b : s)

+ Morley.Michelson.Typed.Instr: [AnnRIGHT] :: SingI a => TypeAnn -> FieldAnn -> FieldAnn -> Instr (b : s) ('TOr a b : s)

+ Morley.Michelson.Typed.Instr: [AnnUNPAIR] :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> Instr ('TPair a b : s) (a : (b : s))

+ Morley.Michelson.Typed.Instr: [BALANCE] :: Instr s ('TMutez : s)

+ Morley.Michelson.Typed.Instr: [BLAKE2B] :: Instr ('TBytes : s) ('TBytes : s)

+ Morley.Michelson.Typed.Instr: [CAST] :: forall a s. SingI a => Instr (a : s) (a : s)

+ Morley.Michelson.Typed.Instr: [CHAIN_ID] :: Instr s ('TChainId : s)

+ Morley.Michelson.Typed.Instr: [CHECK_SIGNATURE] :: Instr ('TKey : ('TSignature : ('TBytes : s))) ('TBool : s)

+ Morley.Michelson.Typed.Instr: [COMPARE] :: (Comparable n, SingI n) => Instr (n : (n : s)) ('TInt : s)

+ Morley.Michelson.Typed.Instr: [CONCAT'] :: ConcatOp c => Instr ('TList c : s) (c : s)

+ Morley.Michelson.Typed.Instr: [CONCAT] :: ConcatOp c => Instr (c : (c : s)) (c : s)

+ Morley.Michelson.Typed.Instr: [CONS] :: Instr (a : ('TList a : s)) ('TList a : s)

+ Morley.Michelson.Typed.Instr: [CONTRACT] :: ParameterScope p => Notes p -> EpName -> Instr ('TAddress : s) ('TOption ('TContract p) : s)

+ Morley.Michelson.Typed.Instr: [CREATE_CONTRACT] :: (ParameterScope p, StorageScope g) => Contract p g -> Instr ('TOption 'TKeyHash : ('TMutez : (g : s))) ('TOperation : ('TAddress : s))

+ Morley.Michelson.Typed.Instr: [DIG] :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a => PeanoNatural n -> Instr inp out

+ Morley.Michelson.Typed.Instr: [DIPN] :: forall (n :: Peano) inp out s s'. ConstraintDIPN n inp out s s' => PeanoNatural n -> Instr s s' -> Instr inp out

+ Morley.Michelson.Typed.Instr: [DIP] :: Instr a c -> Instr (b : a) (b : c)

+ Morley.Michelson.Typed.Instr: [DROPN] :: forall (n :: Peano) s. RequireLongerOrSameLength s n => PeanoNatural n -> Instr s (Drop n s)

+ Morley.Michelson.Typed.Instr: [DROP] :: Instr (a : s) s

+ Morley.Michelson.Typed.Instr: [DUG] :: forall (n :: Peano) inp out a. ConstraintDUG n inp out a => PeanoNatural n -> Instr inp out

+ Morley.Michelson.Typed.Instr: [DUPN] :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, DupableScope a) => PeanoNatural n -> Instr inp out

+ Morley.Michelson.Typed.Instr: [DUP] :: DupableScope a => Instr (a : s) (a : (a : s))

+ Morley.Michelson.Typed.Instr: [DocGroup] :: DocGrouping -> Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Instr: [EDIV] :: ArithOp EDiv n m => Instr (n : (m : s)) (ArithRes EDiv n m : s)

+ Morley.Michelson.Typed.Instr: [EMPTY_BIG_MAP] :: (SingI a, SingI b, Comparable a, HasNoBigMap b) => Instr s ('TBigMap a b : s)

+ Morley.Michelson.Typed.Instr: [EMPTY_MAP] :: (SingI a, SingI b, Comparable a) => Instr s ('TMap a b : s)

+ Morley.Michelson.Typed.Instr: [EMPTY_SET] :: (SingI e, Comparable e) => Instr s ('TSet e : s)

+ Morley.Michelson.Typed.Instr: [EQ] :: UnaryArithOp Eq' n => Instr (n : s) (UnaryArithRes Eq' n : s)

+ Morley.Michelson.Typed.Instr: [EXEC] :: Instr (t1 : ('TLambda t1 t2 : s)) (t2 : s)

+ Morley.Michelson.Typed.Instr: [Ext] :: ExtInstr s -> Instr s s

+ Morley.Michelson.Typed.Instr: [FAILWITH] :: (SingI a, ConstantScope a) => Instr (a : s) t

+ Morley.Michelson.Typed.Instr: [Fn] :: Text -> StackFn -> Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Instr: [FrameInstr] :: forall a b s. (KnownList a, KnownList b) => Proxy s -> Instr a b -> Instr (a ++ s) (b ++ s)

+ Morley.Michelson.Typed.Instr: [GETN] :: forall (ix :: Peano) (pair :: T) (s :: [T]). ConstraintGetN ix pair => PeanoNatural ix -> Instr (pair : s) (GetN ix pair : s)

+ Morley.Michelson.Typed.Instr: [GET] :: (GetOp c, SingI (GetOpVal c)) => Instr (GetOpKey c : (c : s)) ('TOption (GetOpVal c) : s)

+ Morley.Michelson.Typed.Instr: [GET_AND_UPDATE] :: (GetOp c, UpdOp c, SingI (GetOpVal c), UpdOpKey c ~ GetOpKey c) => Instr (UpdOpKey c : (UpdOpParams c : (c : s))) ('TOption (GetOpVal c) : (c : s))

+ Morley.Michelson.Typed.Instr: [GE] :: UnaryArithOp Ge n => Instr (n : s) (UnaryArithRes Ge n : s)

+ Morley.Michelson.Typed.Instr: [GT] :: UnaryArithOp Gt n => Instr (n : s) (UnaryArithRes Gt n : s)

+ Morley.Michelson.Typed.Instr: [HASH_KEY] :: Instr ('TKey : s) ('TKeyHash : s)

+ Morley.Michelson.Typed.Instr: [IF] :: Instr s s' -> Instr s s' -> Instr ('TBool : s) s'

+ Morley.Michelson.Typed.Instr: [IF_CONS] :: Instr (a : ('TList a : s)) s' -> Instr s s' -> Instr ('TList a : s) s'

+ Morley.Michelson.Typed.Instr: [IF_LEFT] :: Instr (a : s) s' -> Instr (b : s) s' -> Instr ('TOr a b : s) s'

+ Morley.Michelson.Typed.Instr: [IF_NONE] :: Instr s s' -> Instr (a : s) s' -> Instr ('TOption a : s) s'

+ Morley.Michelson.Typed.Instr: [IMPLICIT_ACCOUNT] :: Instr ('TKeyHash : s) ('TContract 'TUnit : s)

+ Morley.Michelson.Typed.Instr: [INT] :: ToIntArithOp n => Instr (n : s) ('TInt : s)

+ Morley.Michelson.Typed.Instr: [ISNAT] :: Instr ('TInt : s) ('TOption 'TNat : s)

+ Morley.Michelson.Typed.Instr: [ITER] :: IterOp c => Instr (IterOpEl c : s) s -> Instr (c : s) s

+ Morley.Michelson.Typed.Instr: [InstrWithNotes] :: forall a (topElems :: [T]) (s :: [T]). (RMap topElems, RecordToList topElems, ReifyConstraint Show Notes topElems, ReifyConstraint NFData Notes topElems, Each '[SingI] topElems) => Proxy s -> Rec Notes topElems -> Instr a (topElems ++ s) -> Instr a (topElems ++ s)

+ Morley.Michelson.Typed.Instr: [InstrWithVarAnns] :: VarAnns -> Instr a b -> Instr a b

+ Morley.Michelson.Typed.Instr: [InstrWithVarNotes] :: NonEmpty VarAnn -> Instr a b -> Instr a b

+ Morley.Michelson.Typed.Instr: [JOIN_TICKETS] :: Instr ('TPair ('TTicket a) ('TTicket a) : s) ('TOption ('TTicket a) : s)

+ Morley.Michelson.Typed.Instr: [KECCAK] :: Instr ('TBytes : s) ('TBytes : s)

+ Morley.Michelson.Typed.Instr: [LAMBDA] :: forall i o s. (SingI i, SingI o) => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o : s)

+ Morley.Michelson.Typed.Instr: [LEVEL] :: Instr s ('TNat : s)

+ Morley.Michelson.Typed.Instr: [LE] :: UnaryArithOp Le n => Instr (n : s) (UnaryArithRes Le n : s)

+ Morley.Michelson.Typed.Instr: [LOOP] :: Instr s ('TBool : s) -> Instr ('TBool : s) s

+ Morley.Michelson.Typed.Instr: [LOOP_LEFT] :: Instr (a : s) ('TOr a b : s) -> Instr ('TOr a b : s) (b : s)

+ Morley.Michelson.Typed.Instr: [LSL] :: ArithOp Lsl n m => Instr (n : (m : s)) (ArithRes Lsl n m : s)

+ Morley.Michelson.Typed.Instr: [LSR] :: ArithOp Lsr n m => Instr (n : (m : s)) (ArithRes Lsr n m : s)

+ Morley.Michelson.Typed.Instr: [LT] :: UnaryArithOp Lt n => Instr (n : s) (UnaryArithRes Lt n : s)

+ Morley.Michelson.Typed.Instr: [MAP] :: (MapOp c, SingI b) => Instr (MapOpInp c : s) (b : s) -> Instr (c : s) (MapOpRes c b : s)

+ Morley.Michelson.Typed.Instr: [MEM] :: MemOp c => Instr (MemOpKey c : (c : s)) ('TBool : s)

+ Morley.Michelson.Typed.Instr: [MUL] :: ArithOp Mul n m => Instr (n : (m : s)) (ArithRes Mul n m : s)

+ Morley.Michelson.Typed.Instr: [Meta] :: SomeMeta -> Instr a b -> Instr a b

+ Morley.Michelson.Typed.Instr: [NEG] :: UnaryArithOp Neg n => Instr (n : s) (UnaryArithRes Neg n : s)

+ Morley.Michelson.Typed.Instr: [NEQ] :: UnaryArithOp Neq n => Instr (n : s) (UnaryArithRes Neq n : s)

+ Morley.Michelson.Typed.Instr: [NEVER] :: Instr ('TNever : s) t

+ Morley.Michelson.Typed.Instr: [NIL] :: SingI p => Instr s ('TList p : s)

+ Morley.Michelson.Typed.Instr: [NONE] :: forall a s. SingI a => Instr s ('TOption a : s)

+ Morley.Michelson.Typed.Instr: [NOT] :: UnaryArithOp Not n => Instr (n : s) (UnaryArithRes Not n : s)

+ Morley.Michelson.Typed.Instr: [NOW] :: Instr s ('TTimestamp : s)

+ Morley.Michelson.Typed.Instr: [Nested] :: Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Instr: [Nop] :: Instr s s

+ Morley.Michelson.Typed.Instr: [OR] :: ArithOp Or n m => Instr (n : (m : s)) (ArithRes Or n m : s)

+ Morley.Michelson.Typed.Instr: [PACK] :: PackedValScope a => Instr (a : s) ('TBytes : s)

+ Morley.Michelson.Typed.Instr: [PAIRING_CHECK] :: Instr ('TList ('TPair 'TBls12381G1 'TBls12381G2) : s) ('TBool : s)

+ Morley.Michelson.Typed.Instr: [PAIRN] :: forall n inp. ConstraintPairN n inp => PeanoNatural n -> Instr inp (PairN n inp)

+ Morley.Michelson.Typed.Instr: [PUSH] :: forall t s. ConstantScope t => Value' Instr t -> Instr s (t : s)

+ Morley.Michelson.Typed.Instr: [READ_TICKET] :: Instr ('TTicket a : s) (RightComb ['TAddress, a, 'TNat] : ('TTicket a : s))

+ Morley.Michelson.Typed.Instr: [RENAME] :: Instr (a : s) (a : s)

+ Morley.Michelson.Typed.Instr: [SELF] :: forall (arg :: T) s. ParameterScope arg => SomeEntrypointCallT arg -> Instr s ('TContract arg : s)

+ Morley.Michelson.Typed.Instr: [SELF_ADDRESS] :: Instr s ('TAddress : s)

+ Morley.Michelson.Typed.Instr: [SENDER] :: Instr s ('TAddress : s)

+ Morley.Michelson.Typed.Instr: [SET_DELEGATE] :: Instr ('TOption 'TKeyHash : s) ('TOperation : s)

+ Morley.Michelson.Typed.Instr: [SHA256] :: Instr ('TBytes : s) ('TBytes : s)

+ Morley.Michelson.Typed.Instr: [SHA3] :: Instr ('TBytes : s) ('TBytes : s)

+ Morley.Michelson.Typed.Instr: [SHA512] :: Instr ('TBytes : s) ('TBytes : s)

+ Morley.Michelson.Typed.Instr: [SIZE] :: SizeOp c => Instr (c : s) ('TNat : s)

+ Morley.Michelson.Typed.Instr: [SLICE] :: (SliceOp c, SingI c) => Instr ('TNat : ('TNat : (c : s))) ('TOption c : s)

+ Morley.Michelson.Typed.Instr: [SOME] :: Instr (a : s) ('TOption a : s)

+ Morley.Michelson.Typed.Instr: [SOURCE] :: Instr s ('TAddress : s)

+ Morley.Michelson.Typed.Instr: [SPLIT_TICKET] :: Instr ('TTicket a : ('TPair 'TNat 'TNat : s)) ('TOption ('TPair ('TTicket a) ('TTicket a)) : s)

+ Morley.Michelson.Typed.Instr: [SUB] :: ArithOp Sub n m => Instr (n : (m : s)) (ArithRes Sub n m : s)

+ Morley.Michelson.Typed.Instr: [SWAP] :: Instr (a : (b : s)) (b : (a : s))

+ Morley.Michelson.Typed.Instr: [Seq] :: Instr a b -> Instr b c -> Instr a c

+ Morley.Michelson.Typed.Instr: [SomeMeta] :: forall meta. With [NFData, Show, Typeable] meta => meta -> SomeMeta

+ Morley.Michelson.Typed.Instr: [StackRef] :: RequireLongerThan st idx => PeanoNatural idx -> StackRef st

+ Morley.Michelson.Typed.Instr: [TICKET] :: Comparable a => Instr (a : ('TNat : s)) ('TTicket a : s)

+ Morley.Michelson.Typed.Instr: [TOTAL_VOTING_POWER] :: Instr s ('TNat : s)

+ Morley.Michelson.Typed.Instr: [TRANSFER_TOKENS] :: ParameterScope p => Instr (p : ('TMutez : ('TContract p : s))) ('TOperation : s)

+ Morley.Michelson.Typed.Instr: [TestAssert] :: Text -> PrintComment inp -> Instr inp ('TBool : out) -> TestAssert inp

+ Morley.Michelson.Typed.Instr: [UNIT] :: Instr s ('TUnit : s)

+ Morley.Michelson.Typed.Instr: [UNPACK] :: (UnpackedValScope a, SingI a) => Instr ('TBytes : s) ('TOption a : s)

+ Morley.Michelson.Typed.Instr: [UNPAIRN] :: forall (n :: Peano) (pair :: T) (s :: [T]). ConstraintUnpairN n pair => PeanoNatural n -> Instr (pair : s) (UnpairN n pair ++ s)

+ Morley.Michelson.Typed.Instr: [UPDATEN] :: forall (ix :: Peano) (val :: T) (pair :: T) (s :: [T]). ConstraintUpdateN ix pair => PeanoNatural ix -> Instr (val : (pair : s)) (UpdateN ix val pair : s)

+ Morley.Michelson.Typed.Instr: [UPDATE] :: UpdOp c => Instr (UpdOpKey c : (UpdOpParams c : (c : s))) (c : s)

+ Morley.Michelson.Typed.Instr: [VOTING_POWER] :: Instr ('TKeyHash : s) ('TNat : s)

+ Morley.Michelson.Typed.Instr: [WithLoc] :: InstrCallStack -> Instr a b -> Instr a b

+ Morley.Michelson.Typed.Instr: [XOR] :: ArithOp Xor n m => Instr (n : (m : s)) (ArithRes Xor n m : s)

+ Morley.Michelson.Typed.Instr: [cCode] :: Contract cp st -> ContractCode cp st

+ Morley.Michelson.Typed.Instr: [cEntriesOrder] :: Contract cp st -> EntriesOrder

+ Morley.Michelson.Typed.Instr: [cParamNotes] :: Contract cp st -> ParamNotes cp

+ Morley.Michelson.Typed.Instr: [cStoreNotes] :: Contract cp st -> Notes st

+ Morley.Michelson.Typed.Instr: [unPrintComment] :: PrintComment (st :: [T]) -> [Either Text (StackRef st)]

+ Morley.Michelson.Typed.Instr: castInstr :: forall inp1 out1 inp2 out2. (SingI inp1, SingI out1, SingI inp2, SingI out2) => Instr inp1 out1 -> Maybe (Instr inp2 out2)

+ Morley.Michelson.Typed.Instr: data CommentType

+ Morley.Michelson.Typed.Instr: data Contract cp st

+ Morley.Michelson.Typed.Instr: data ExtInstr s

+ Morley.Michelson.Typed.Instr: data Instr (inp :: [T]) (out :: [T])

+ Morley.Michelson.Typed.Instr: data SomeMeta

+ Morley.Michelson.Typed.Instr: data StackRef (st :: [T])

+ Morley.Michelson.Typed.Instr: data TestAssert (s :: [T])

+ Morley.Michelson.Typed.Instr: defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode cp st -> Contract cp st

+ Morley.Michelson.Typed.Instr: infixr 8 :#

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Instr.Contract cp st)

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Instr.ExtInstr s)

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Instr.PrintComment st)

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Instr.StackRef st)

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Instr.TestAssert s)

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Instr.CommentType

+ Morley.Michelson.Typed.Instr: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Instr.SomeMeta

+ Morley.Michelson.Typed.Instr: instance Data.String.IsString (Morley.Michelson.Typed.Instr.PrintComment st)

+ Morley.Michelson.Typed.Instr: instance Data.String.IsString Morley.Michelson.Typed.Instr.CommentType

+ Morley.Michelson.Typed.Instr: instance GHC.Base.Monoid (Morley.Michelson.Typed.Instr.Instr s s)

+ Morley.Michelson.Typed.Instr: instance GHC.Base.Monoid (Morley.Michelson.Typed.Instr.PrintComment st)

+ Morley.Michelson.Typed.Instr: instance GHC.Base.Semigroup (Morley.Michelson.Typed.Instr.Instr s s)

+ Morley.Michelson.Typed.Instr: instance GHC.Base.Semigroup (Morley.Michelson.Typed.Instr.PrintComment st)

+ Morley.Michelson.Typed.Instr: instance GHC.Classes.Eq (Morley.Michelson.Typed.Instr.ContractCode cp st) => GHC.Classes.Eq (Morley.Michelson.Typed.Instr.Contract cp st)

+ Morley.Michelson.Typed.Instr: instance GHC.Classes.Eq (Morley.Michelson.Typed.Instr.PrintComment st)

+ Morley.Michelson.Typed.Instr: instance GHC.Classes.Eq (Morley.Michelson.Typed.Instr.StackRef st)

+ Morley.Michelson.Typed.Instr: instance GHC.Generics.Generic (Morley.Michelson.Typed.Instr.ExtInstr s)

+ Morley.Michelson.Typed.Instr: instance GHC.Generics.Generic (Morley.Michelson.Typed.Instr.PrintComment st)

+ Morley.Michelson.Typed.Instr: instance GHC.Generics.Generic Morley.Michelson.Typed.Instr.CommentType

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.Contract cp st)

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.ExtInstr s)

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.Instr inp out)

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.PrintComment st)

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.StackRef st)

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show (Morley.Michelson.Typed.Instr.TestAssert s)

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show Morley.Michelson.Typed.Instr.CommentType

+ Morley.Michelson.Typed.Instr: instance GHC.Show.Show Morley.Michelson.Typed.Instr.SomeMeta

+ Morley.Michelson.Typed.Instr: mapContractCode :: (ContractCode cp st -> ContractCode cp st) -> Contract cp st -> Contract cp st

+ Morley.Michelson.Typed.Instr: mapEntriesOrdered :: Contract cp st -> (ParamNotes cp -> a) -> (Notes st -> a) -> (ContractCode cp st -> a) -> [a]

+ Morley.Michelson.Typed.Instr: mkStackRef :: forall (gn :: Nat) st n. (n ~ ToPeano gn, SingI (ToPeano gn), RequireLongerThan st n) => StackRef st

+ Morley.Michelson.Typed.Instr: newtype PrintComment (st :: [T])

+ Morley.Michelson.Typed.Instr: pattern (:#) :: Instr a b -> Instr b c -> Instr a c

+ Morley.Michelson.Typed.Instr: pattern UNPAIR :: () => (i ~ ('TPair a b : s), o ~ (a : (b : s))) => Instr i o

+ Morley.Michelson.Typed.Instr: type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a

+ Morley.Michelson.Typed.Instr: type ConstraintDIG' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) = (RequireLongerThan inp n, inp ~ (Take n inp ++ (a : Drop ('S n) inp)), out ~ (a : Take n inp ++ Drop ('S n) inp))

+ Morley.Michelson.Typed.Instr: type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s'

+ Morley.Michelson.Typed.Instr: type ConstraintDIPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (s :: [kind]) (s' :: [kind]) = (RequireLongerOrSameLength inp n, ((Take n inp) ++ s) ~ inp, ((Take n inp) ++ s') ~ out)

+ Morley.Michelson.Typed.Instr: type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a

+ Morley.Michelson.Typed.Instr: type ConstraintDUG' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) = (RequireLongerThan out n, inp ~ (a : Drop ('S 'Z) inp), out ~ (Take n (Drop ('S 'Z) inp) ++ (a : Drop ('S n) inp)))

+ Morley.Michelson.Typed.Instr: type ConstraintDUPN n inp out a = ConstraintDUPN' T n inp out a

+ Morley.Michelson.Typed.Instr: type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) = (RequireLongerOrSameLength inp n, n > 'Z ~ 'True, inp ~ (Take (Decrement n) inp ++ (a : Drop n inp)), out ~ (a : inp))

+ Morley.Michelson.Typed.Instr: type ConstraintGetN (ix :: Peano) (pair :: T) = (TypeErrorUnless (CombedPairNodeIndexIsValid ix pair) (If (IsPair pair) ('Text "'GET " :<>: 'ShowType (FromPeano ix) :<>: 'Text "' expects a right-combed pair with at least " :<>: 'ShowType (FromPeano ix + 1) :<>: 'Text " nodes at the top of the stack," :$$: 'Text "but the pair only contains " :<>: 'ShowType (FromPeano (CombedPairNodeCount pair)) :<>: 'Text " nodes.") ('Text "Expected a pair at the top of the stack, but found: " :<>: 'ShowType pair)))

+ Morley.Michelson.Typed.Instr: type ConstraintPairN (n :: Peano) (inp :: [T]) = (RequireLongerOrSameLength inp n, TypeErrorUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n \8805 2"))

+ Morley.Michelson.Typed.Instr: type ConstraintUnpairN (n :: Peano) (pair :: T) = (TypeErrorUnless (n >= ToPeano 2) ('Text "'UNPAIR n' expects n \8805 2"), TypeErrorUnless (CombedPairLeafCountIsAtLeast n pair) (If (IsPair pair) ('Text "'UNPAIR " :<>: 'ShowType (FromPeano n) :<>: 'Text "' expects a right-combed pair with at least " :<>: 'ShowType (FromPeano n) :<>: 'Text " elements at the top of the stack," :$$: 'Text "but the pair only contains " :<>: 'ShowType (FromPeano (CombedPairLeafCount pair)) :<>: 'Text " elements.") ('Text "Expected a pair at the top of the stack, but found: " :<>: 'ShowType pair)))

+ Morley.Michelson.Typed.Instr: type ConstraintUpdateN (ix :: Peano) (pair :: T) = (TypeErrorUnless (CombedPairNodeIndexIsValid ix pair) (If (IsPair pair) ('Text "'UPDATE " :<>: 'ShowType (FromPeano ix) :<>: 'Text "' expects the 2nd element of the stack to be a right-combed pair with at least " :<>: 'ShowType (FromPeano ix + 1) :<>: 'Text " nodes," :$$: 'Text "but the pair only contains " :<>: 'ShowType (FromPeano (CombedPairNodeCount pair)) :<>: 'Text " nodes.") ('Text "Expected the 2nd element of the stack to be a pair, but found: " :<>: 'ShowType pair)))

+ Morley.Michelson.Typed.Instr: type ContractCode cp st = Instr (ContractInp cp st) (ContractOut st)

+ Morley.Michelson.Typed.Instr: type PairN (n :: Peano) (s :: [T]) = (RightComb (Take n s) : Drop n s)

+ Morley.Michelson.Typed.Instr: type family UpdateN (ix :: Peano) (val :: T) (pair :: T) :: T

+ Morley.Michelson.Typed.OpSize: OpSize :: Word -> OpSize

+ Morley.Michelson.Typed.OpSize: [unOpSize] :: OpSize -> Word

+ Morley.Michelson.Typed.OpSize: contractOpSize :: Contract cp st -> OpSize

+ Morley.Michelson.Typed.OpSize: instrOpSize :: Instr inp out -> OpSize

+ Morley.Michelson.Typed.OpSize: newtype OpSize

+ Morley.Michelson.Typed.OpSize: opSizeHardLimit :: OpSize

+ Morley.Michelson.Typed.OpSize: smallTransferOpSize :: OpSize

+ Morley.Michelson.Typed.OpSize: valueOpSize :: UntypedValScope t => Value t -> OpSize

+ Morley.Michelson.Typed.Operation: OperationHash :: ByteString -> OperationHash

+ Morley.Michelson.Typed.Operation: OriginationOperation :: Address -> Maybe KeyHash -> Mutez -> Value st -> Contract cp st -> GlobalCounter -> OriginationOperation

+ Morley.Michelson.Typed.Operation: SetDelegateOperation :: Address -> Maybe KeyHash -> GlobalCounter -> SetDelegateOperation

+ Morley.Michelson.Typed.Operation: TransferOperation :: Address -> TxData -> GlobalCounter -> TransferOperation

+ Morley.Michelson.Typed.Operation: [ooBalance] :: OriginationOperation -> Mutez

+ Morley.Michelson.Typed.Operation: [ooContract] :: OriginationOperation -> Contract cp st

+ Morley.Michelson.Typed.Operation: [ooCounter] :: OriginationOperation -> GlobalCounter

+ Morley.Michelson.Typed.Operation: [ooDelegate] :: OriginationOperation -> Maybe KeyHash

+ Morley.Michelson.Typed.Operation: [ooOriginator] :: OriginationOperation -> Address

+ Morley.Michelson.Typed.Operation: [ooStorage] :: OriginationOperation -> Value st

+ Morley.Michelson.Typed.Operation: [sdoContract] :: SetDelegateOperation -> Address

+ Morley.Michelson.Typed.Operation: [sdoCounter] :: SetDelegateOperation -> GlobalCounter

+ Morley.Michelson.Typed.Operation: [sdoDelegate] :: SetDelegateOperation -> Maybe KeyHash

+ Morley.Michelson.Typed.Operation: [toCounter] :: TransferOperation -> GlobalCounter

+ Morley.Michelson.Typed.Operation: [toDestination] :: TransferOperation -> Address

+ Morley.Michelson.Typed.Operation: [toTxData] :: TransferOperation -> TxData

+ Morley.Michelson.Typed.Operation: [unOperationHash] :: OperationHash -> ByteString

+ Morley.Michelson.Typed.Operation: data OriginationOperation

+ Morley.Michelson.Typed.Operation: data SetDelegateOperation

+ Morley.Michelson.Typed.Operation: data TransferOperation

+ Morley.Michelson.Typed.Operation: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Operation.OperationHash

+ Morley.Michelson.Typed.Operation: instance GHC.Classes.Eq Morley.Michelson.Typed.Operation.OperationHash

+ Morley.Michelson.Typed.Operation: instance GHC.Classes.Ord Morley.Michelson.Typed.Operation.OperationHash

+ Morley.Michelson.Typed.Operation: instance GHC.Generics.Generic Morley.Michelson.Typed.Operation.OperationHash

+ Morley.Michelson.Typed.Operation: instance GHC.Show.Show Morley.Michelson.Typed.Operation.OperationHash

+ Morley.Michelson.Typed.Operation: instance GHC.Show.Show Morley.Michelson.Typed.Operation.OriginationOperation

+ Morley.Michelson.Typed.Operation: instance GHC.Show.Show Morley.Michelson.Typed.Operation.SetDelegateOperation

+ Morley.Michelson.Typed.Operation: instance GHC.Show.Show Morley.Michelson.Typed.Operation.TransferOperation

+ Morley.Michelson.Typed.Operation: mkContractAddress :: OperationHash -> GlobalCounter -> Address

+ Morley.Michelson.Typed.Operation: mkDelegationOperationHash :: SetDelegateOperation -> OperationHash

+ Morley.Michelson.Typed.Operation: mkOriginationOperationHash :: OriginationOperation -> OperationHash

+ Morley.Michelson.Typed.Operation: mkTransferOperationHash :: ParameterScope t => Address -> Value t -> EpName -> Mutez -> OperationHash

+ Morley.Michelson.Typed.Operation: newtype OperationHash

+ Morley.Michelson.Typed.Polymorphic: class ConcatOp (c :: T)

+ Morley.Michelson.Typed.Polymorphic: class EDivOp (n :: T) (m :: T) where {

+ Morley.Michelson.Typed.Polymorphic: class GetOp (c :: T) where {

+ Morley.Michelson.Typed.Polymorphic: class IterOp (c :: T) where {

+ Morley.Michelson.Typed.Polymorphic: class MapOp (c :: T) where {

+ Morley.Michelson.Typed.Polymorphic: class MemOp (c :: T) where {

+ Morley.Michelson.Typed.Polymorphic: class SizeOp (c :: T)

+ Morley.Michelson.Typed.Polymorphic: class SliceOp (c :: T)

+ Morley.Michelson.Typed.Polymorphic: class UpdOp (c :: T) where {

+ Morley.Michelson.Typed.Polymorphic: convergeEDiv :: EDivOp n m => Notes n -> Notes m -> Either AnnConvergeError (Notes ('TOption ('TPair (EDivOpRes n m) (EModOpRes n m))))

+ Morley.Michelson.Typed.Polymorphic: divMich :: Integral a => a -> a -> a

+ Morley.Michelson.Typed.Polymorphic: evalConcat :: ConcatOp c => Value' instr c -> Value' instr c -> Value' instr c

+ Morley.Michelson.Typed.Polymorphic: evalConcat' :: ConcatOp c => [Value' instr c] -> Value' instr c

+ Morley.Michelson.Typed.Polymorphic: evalEDivOp :: EDivOp n m => Value' instr n -> Value' instr m -> Value' instr ('TOption ('TPair (EDivOpRes n m) (EModOpRes n m)))

+ Morley.Michelson.Typed.Polymorphic: evalGet :: GetOp c => Value' instr (GetOpKey c) -> Value' instr c -> Maybe (Value' instr (GetOpVal c))

+ Morley.Michelson.Typed.Polymorphic: evalMem :: MemOp c => Value' instr (MemOpKey c) -> Value' instr c -> Bool

+ Morley.Michelson.Typed.Polymorphic: evalSize :: SizeOp c => Value' instr c -> Int

+ Morley.Michelson.Typed.Polymorphic: evalSlice :: SliceOp c => Natural -> Natural -> Value' instr c -> Maybe (Value' instr c)

+ Morley.Michelson.Typed.Polymorphic: evalUpd :: UpdOp c => Value' instr (UpdOpKey c) -> Value' instr (UpdOpParams c) -> Value' instr c -> Value' instr c

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.ConcatOp 'Morley.Michelson.Typed.T.TBytes

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.ConcatOp 'Morley.Michelson.Typed.T.TString

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.EDivOp 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.EDivOp 'Morley.Michelson.Typed.T.TInt 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.EDivOp 'Morley.Michelson.Typed.T.TMutez 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.EDivOp 'Morley.Michelson.Typed.T.TMutez 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.EDivOp 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.EDivOp 'Morley.Michelson.Typed.T.TNat 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.GetOp ('Morley.Michelson.Typed.T.TBigMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.GetOp ('Morley.Michelson.Typed.T.TMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.IterOp ('Morley.Michelson.Typed.T.TList e)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.IterOp ('Morley.Michelson.Typed.T.TMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.IterOp ('Morley.Michelson.Typed.T.TSet e)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.MapOp ('Morley.Michelson.Typed.T.TList e)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.MapOp ('Morley.Michelson.Typed.T.TMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.MemOp ('Morley.Michelson.Typed.T.TBigMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.MemOp ('Morley.Michelson.Typed.T.TMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.MemOp ('Morley.Michelson.Typed.T.TSet e)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.SizeOp 'Morley.Michelson.Typed.T.TBytes

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.SizeOp 'Morley.Michelson.Typed.T.TString

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.SizeOp ('Morley.Michelson.Typed.T.TList a)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.SizeOp ('Morley.Michelson.Typed.T.TMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.SizeOp ('Morley.Michelson.Typed.T.TSet a)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.SliceOp 'Morley.Michelson.Typed.T.TBytes

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.SliceOp 'Morley.Michelson.Typed.T.TString

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.UpdOp ('Morley.Michelson.Typed.T.TBigMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.UpdOp ('Morley.Michelson.Typed.T.TMap k v)

+ Morley.Michelson.Typed.Polymorphic: instance Morley.Michelson.Typed.Polymorphic.UpdOp ('Morley.Michelson.Typed.T.TSet a)

+ Morley.Michelson.Typed.Polymorphic: iterOpDetachOne :: IterOp c => Value' instr c -> (Maybe (Value' instr (IterOpEl c)), Value' instr c)

+ Morley.Michelson.Typed.Polymorphic: iterOpNotes :: IterOp c => Notes c -> Notes (IterOpEl c)

+ Morley.Michelson.Typed.Polymorphic: mapOpFromList :: (MapOp c, SingI b) => Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b)

+ Morley.Michelson.Typed.Polymorphic: mapOpNotes :: MapOp c => Notes c -> Notes (MapOpInp c)

+ Morley.Michelson.Typed.Polymorphic: mapOpToList :: MapOp c => Value' instr c -> [Value' instr (MapOpInp c)]

+ Morley.Michelson.Typed.Polymorphic: modMich :: Integral a => a -> a -> a

+ Morley.Michelson.Typed.Polymorphic: type family UpdOpParams c :: T;

+ Morley.Michelson.Typed.Polymorphic: }

+ Morley.Michelson.Typed.Scope: BigMapAbsent :: BigMapPresence (t :: T)

+ Morley.Michelson.Typed.Scope: BigMapPresent :: BigMapPresence (t :: T)

+ Morley.Michelson.Typed.Scope: BtHasBigMap :: BadTypeForScope

+ Morley.Michelson.Typed.Scope: BtHasContract :: BadTypeForScope

+ Morley.Michelson.Typed.Scope: BtHasNestedBigMap :: BadTypeForScope

+ Morley.Michelson.Typed.Scope: BtHasTicket :: BadTypeForScope

+ Morley.Michelson.Typed.Scope: BtIsOperation :: BadTypeForScope

+ Morley.Michelson.Typed.Scope: BtNotComparable :: BadTypeForScope

+ Morley.Michelson.Typed.Scope: ContractAbsent :: ContractPresence (t :: T)

+ Morley.Michelson.Typed.Scope: ContractPresent :: ContractPresence (t :: T)

+ Morley.Michelson.Typed.Scope: NestedBigMapsAbsent :: NestedBigMapsPresence (t :: T)

+ Morley.Michelson.Typed.Scope: NestedBigMapsPresent :: NestedBigMapsPresence (t :: T)

+ Morley.Michelson.Typed.Scope: OpAbsent :: OpPresence (t :: T)

+ Morley.Michelson.Typed.Scope: OpPresent :: OpPresence (t :: T)

+ Morley.Michelson.Typed.Scope: Sub :: (a => Dict b) -> (:-) a b

+ Morley.Michelson.Typed.Scope: TicketAbsent :: TicketPresence (t :: T)

+ Morley.Michelson.Typed.Scope: TicketPresent :: TicketPresence (t :: T)

+ Morley.Michelson.Typed.Scope: bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t)

+ Morley.Michelson.Typed.Scope: checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty

+ Morley.Michelson.Typed.Scope: checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty

+ Morley.Michelson.Typed.Scope: checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty

+ Morley.Michelson.Typed.Scope: checkOpPresence :: Sing (ty :: T) -> OpPresence ty

+ Morley.Michelson.Typed.Scope: checkScope :: CheckScope c => Either BadTypeForScope (Dict c)

+ Morley.Michelson.Typed.Scope: checkTicketPresence :: Sing (ty :: T) -> TicketPresence ty

+ Morley.Michelson.Typed.Scope: class CheckScope (c :: Constraint)

+ Morley.Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t

+ Morley.Michelson.Typed.Scope: class (SingI t, HasNoTicket t) => DupableScope t

+ Morley.Michelson.Typed.Scope: class (ContainsBigMap t ~ 'False) => HasNoBigMap t

+ Morley.Michelson.Typed.Scope: class (ContainsContract t ~ 'False) => HasNoContract t

+ Morley.Michelson.Typed.Scope: class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t

+ Morley.Michelson.Typed.Scope: class (ContainsOp t ~ 'False) => HasNoOp t

+ Morley.Michelson.Typed.Scope: class (ContainsTicket t ~ 'False) => HasNoTicket t

+ Morley.Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t

+ Morley.Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t

+ Morley.Michelson.Typed.Scope: class SingI (a :: k)

+ Morley.Michelson.Typed.Scope: class (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t

+ Morley.Michelson.Typed.Scope: class (PackedValScope t, ConstantScope t) => UnpackedValScope t

+ Morley.Michelson.Typed.Scope: class WithDeMorganScope (c :: T -> Constraint) t a b

+ Morley.Michelson.Typed.Scope: contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoContract t)

+ Morley.Michelson.Typed.Scope: data BadTypeForScope

+ Morley.Michelson.Typed.Scope: data BigMapPresence (t :: T)

+ Morley.Michelson.Typed.Scope: data ContractPresence (t :: T)

+ Morley.Michelson.Typed.Scope: data NestedBigMapsPresence (t :: T)

+ Morley.Michelson.Typed.Scope: data OpPresence (t :: T)

+ Morley.Michelson.Typed.Scope: data TicketPresence (t :: T)

+ Morley.Michelson.Typed.Scope: forbiddenBigMap :: forall t a. (SingI t, ForbidBigMap t) => (HasNoBigMap t => a) -> a

+ Morley.Michelson.Typed.Scope: forbiddenContractType :: forall t a. (SingI t, ForbidContract t) => (HasNoContract t => a) -> a

+ Morley.Michelson.Typed.Scope: forbiddenNestedBigMaps :: forall t a. (SingI t, ForbidNestedBigMaps t) => (HasNoNestedBigMaps t => a) -> a

+ Morley.Michelson.Typed.Scope: forbiddenOp :: forall t a. (SingI t, ForbidOp t) => (HasNoOp t => a) -> a

+ Morley.Michelson.Typed.Scope: infixr 9 :-

+ Morley.Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Morley.Michelson.Typed.Scope.HasNoOp t, Morley.Michelson.Typed.Scope.HasNoBigMap t, Morley.Michelson.Typed.Scope.HasNoContract t, Morley.Michelson.Typed.Scope.HasNoTicket t) => Morley.Michelson.Typed.Scope.ConstantScope t

+ Morley.Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Morley.Michelson.Typed.Scope.HasNoOp t, Morley.Michelson.Typed.Scope.HasNoBigMap t, Morley.Michelson.Typed.Scope.HasNoTicket t) => Morley.Michelson.Typed.Scope.PackedValScope t

+ Morley.Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Morley.Michelson.Typed.Scope.HasNoOp t, Morley.Michelson.Typed.Scope.HasNoNestedBigMaps t) => Morley.Michelson.Typed.Scope.ParameterScope t

+ Morley.Michelson.Typed.Scope: instance (Data.Singletons.Internal.SingI t, Morley.Michelson.Typed.Scope.HasNoTicket t) => Morley.Michelson.Typed.Scope.DupableScope t

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.ContainsBigMap t GHC.Types.~ 'GHC.Types.False) => Morley.Michelson.Typed.Scope.HasNoBigMap t

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.ContainsContract t GHC.Types.~ 'GHC.Types.False) => Morley.Michelson.Typed.Scope.HasNoContract t

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.ContainsNestedBigMaps t GHC.Types.~ 'GHC.Types.False) => Morley.Michelson.Typed.Scope.HasNoNestedBigMaps t

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.ContainsOp t GHC.Types.~ 'GHC.Types.False) => Morley.Michelson.Typed.Scope.HasNoOp t

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.ContainsTicket t GHC.Types.~ 'GHC.Types.False) => Morley.Michelson.Typed.Scope.HasNoTicket t

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.PackedValScope t, Morley.Michelson.Typed.Scope.ConstantScope t) => Morley.Michelson.Typed.Scope.UnpackedValScope t

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoBigMap t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoContract t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoTicket t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.ConstantScope t a b

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoBigMap t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoTicket t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.PackedValScope t a b

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoNestedBigMaps t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.ParameterScope t a b

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoNestedBigMaps t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoContract t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.StorageScope t a b

+ Morley.Michelson.Typed.Scope: instance (Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.PackedValScope t a b, Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.ConstantScope t a b, Data.Singletons.Internal.SingI a, Data.Singletons.Internal.SingI b) => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.UnpackedValScope t a b

+ Morley.Michelson.Typed.Scope: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Scope.BadTypeForScope

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoBigMap 'Morley.Michelson.Typed.T.TOr a b

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoBigMap 'Morley.Michelson.Typed.T.TPair a b

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp 'Morley.Michelson.Typed.T.TOr a b

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp 'Morley.Michelson.Typed.T.TPair a b

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI a => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoTicket 'Morley.Michelson.Typed.T.TOr a b

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI k => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp 'Morley.Michelson.Typed.T.TBigMap k v

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI k => Morley.Michelson.Typed.Scope.WithDeMorganScope Morley.Michelson.Typed.Scope.HasNoOp 'Morley.Michelson.Typed.T.TMap k v

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.ConstantScope t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.DupableScope t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.HasNoBigMap t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.HasNoContract t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.HasNoNestedBigMaps t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.HasNoOp t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.HasNoTicket t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.PackedValScope t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.ParameterScope t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.StorageScope t)

+ Morley.Michelson.Typed.Scope: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Scope.UnpackedValScope t)

+ Morley.Michelson.Typed.Scope: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Scope.BadTypeForScope

+ Morley.Michelson.Typed.Scope: instance GHC.Classes.Eq Morley.Michelson.Typed.Scope.BadTypeForScope

+ Morley.Michelson.Typed.Scope: instance GHC.Generics.Generic Morley.Michelson.Typed.Scope.BadTypeForScope

+ Morley.Michelson.Typed.Scope: instance GHC.Show.Show Morley.Michelson.Typed.Scope.BadTypeForScope

+ Morley.Michelson.Typed.Scope: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Typed.Scope.BadTypeForScope

+ Morley.Michelson.Typed.Scope: nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoNestedBigMaps t)

+ Morley.Michelson.Typed.Scope: newtype a :- b

+ Morley.Michelson.Typed.Scope: opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)

+ Morley.Michelson.Typed.Scope: properConstantEvi :: forall t. ProperConstantBetterErrors t :- ConstantScope t

+ Morley.Michelson.Typed.Scope: properDupableEvi :: forall t. ProperDupableBetterErrors t :- DupableScope t

+ Morley.Michelson.Typed.Scope: properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t

+ Morley.Michelson.Typed.Scope: properParameterEvi :: forall t. ProperParameterBetterErrors t :- ParameterScope t

+ Morley.Michelson.Typed.Scope: properStorageEvi :: forall t. ProperStorageBetterErrors t :- StorageScope t

+ Morley.Michelson.Typed.Scope: properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t

+ Morley.Michelson.Typed.Scope: properUntypedValEvi :: forall t. ProperUntypedValBetterErrors t :- UntypedValScope t

+ Morley.Michelson.Typed.Scope: sing :: SingI a => Sing a

+ Morley.Michelson.Typed.Scope: type ForbidBigMap t = FailOnBigMapFound (ContainsBigMap t)

+ Morley.Michelson.Typed.Scope: type ForbidContract t = FailOnContractFound (ContainsContract t)

+ Morley.Michelson.Typed.Scope: type ForbidNestedBigMaps t = FailOnNestedBigMapsFound (ContainsNestedBigMaps t)

+ Morley.Michelson.Typed.Scope: type ForbidNonComparable t = FailOnNonComparableFound (IsComparable t)

+ Morley.Michelson.Typed.Scope: type ForbidOp t = FailOnOperationFound (ContainsOp t)

+ Morley.Michelson.Typed.Scope: type ForbidTicket t = FailOnTicketFound (ContainsTicket t)

+ Morley.Michelson.Typed.Scope: type ProperConstantBetterErrors t = (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t, ForbidTicket t)

+ Morley.Michelson.Typed.Scope: type ProperDupableBetterErrors t = (SingI t, ForbidTicket t)

+ Morley.Michelson.Typed.Scope: type ProperNonComparableValBetterErrors t = (SingI t, ForbidNonComparable t)

+ Morley.Michelson.Typed.Scope: type ProperPackedValBetterErrors t = (SingI t, ForbidOp t, ForbidBigMap t, ForbidTicket t)

+ Morley.Michelson.Typed.Scope: type ProperParameterBetterErrors t = (SingI t, ForbidOp t, ForbidNestedBigMaps t)

+ Morley.Michelson.Typed.Scope: type ProperStorageBetterErrors t = (SingI t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)

+ Morley.Michelson.Typed.Scope: type ProperUnpackedValBetterErrors t = (ProperPackedValBetterErrors t, ProperConstantBetterErrors t)

+ Morley.Michelson.Typed.Scope: type ProperUntypedValBetterErrors t = (SingI t, ForbidOp t)

+ Morley.Michelson.Typed.Scope: type UntypedValScope t = (SingI t, HasNoOp t)

+ Morley.Michelson.Typed.Scope: type family FailOnNonComparableFound (comparable :: Bool) :: Constraint

+ Morley.Michelson.Typed.Scope: withDeMorganScope :: (WithDeMorganScope c t a b, c (t a b)) => ((c a, c b) => ret) -> ret

+ Morley.Michelson.Typed.Scope: withDict :: HasDict c e => e -> (c => r) -> r

+ Morley.Michelson.Typed.Sing: [STAddress] :: SingT ('TAddress :: T)

+ Morley.Michelson.Typed.Sing: [STBigMap] :: forall (n_a1Jid :: T) (n_a1Jie :: T). () => Sing n_a1Jid -> Sing n_a1Jie -> SingT ('TBigMap n_a1Jid n_a1Jie :: T)

+ Morley.Michelson.Typed.Sing: [STBls12381Fr] :: SingT ('TBls12381Fr :: T)

+ Morley.Michelson.Typed.Sing: [STBls12381G1] :: SingT ('TBls12381G1 :: T)

+ Morley.Michelson.Typed.Sing: [STBls12381G2] :: SingT ('TBls12381G2 :: T)

+ Morley.Michelson.Typed.Sing: [STBool] :: SingT ('TBool :: T)

+ Morley.Michelson.Typed.Sing: [STBytes] :: SingT ('TBytes :: T)

+ Morley.Michelson.Typed.Sing: [STChainId] :: SingT ('TChainId :: T)

+ Morley.Michelson.Typed.Sing: [STContract] :: forall (n_a1JhT :: T). () => Sing n_a1JhT -> SingT ('TContract n_a1JhT :: T)

+ Morley.Michelson.Typed.Sing: [STInt] :: SingT ('TInt :: T)

+ Morley.Michelson.Typed.Sing: [STKeyHash] :: SingT ('TKeyHash :: T)

+ Morley.Michelson.Typed.Sing: [STKey] :: SingT ('TKey :: T)

+ Morley.Michelson.Typed.Sing: [STLambda] :: forall (n_a1Ji5 :: T) (n_a1Ji6 :: T). () => Sing n_a1Ji5 -> Sing n_a1Ji6 -> SingT ('TLambda n_a1Ji5 n_a1Ji6 :: T)

+ Morley.Michelson.Typed.Sing: [STList] :: forall (n_a1JhP :: T). () => Sing n_a1JhP -> SingT ('TList n_a1JhP :: T)

+ Morley.Michelson.Typed.Sing: [STMap] :: forall (n_a1Ji9 :: T) (n_a1Jia :: T). () => Sing n_a1Ji9 -> Sing n_a1Jia -> SingT ('TMap n_a1Ji9 n_a1Jia :: T)

+ Morley.Michelson.Typed.Sing: [STMutez] :: SingT ('TMutez :: T)

+ Morley.Michelson.Typed.Sing: [STNat] :: SingT ('TNat :: T)

+ Morley.Michelson.Typed.Sing: [STNever] :: SingT ('TNever :: T)

+ Morley.Michelson.Typed.Sing: [STOperation] :: SingT ('TOperation :: T)

+ Morley.Michelson.Typed.Sing: [STOption] :: forall (n_a1JhN :: T). () => Sing n_a1JhN -> SingT ('TOption n_a1JhN :: T)

+ Morley.Michelson.Typed.Sing: [STOr] :: forall (n_a1Ji1 :: T) (n_a1Ji2 :: T). () => Sing n_a1Ji1 -> Sing n_a1Ji2 -> SingT ('TOr n_a1Ji1 n_a1Ji2 :: T)

+ Morley.Michelson.Typed.Sing: [STPair] :: forall (n_a1JhX :: T) (n_a1JhY :: T). () => Sing n_a1JhX -> Sing n_a1JhY -> SingT ('TPair n_a1JhX n_a1JhY :: T)

+ Morley.Michelson.Typed.Sing: [STSet] :: forall (n_a1JhR :: T). () => Sing n_a1JhR -> SingT ('TSet n_a1JhR :: T)

+ Morley.Michelson.Typed.Sing: [STSignature] :: SingT ('TSignature :: T)

+ Morley.Michelson.Typed.Sing: [STString] :: SingT ('TString :: T)

+ Morley.Michelson.Typed.Sing: [STTicket] :: forall (n_a1JhV :: T). () => Sing n_a1JhV -> SingT ('TTicket n_a1JhV :: T)

+ Morley.Michelson.Typed.Sing: [STTimestamp] :: SingT ('TTimestamp :: T)

+ Morley.Michelson.Typed.Sing: [STUnit] :: SingT ('TUnit :: T)

+ Morley.Michelson.Typed.Sing: castM :: forall (a :: T) (b :: T) t m. (SingI a, SingI b, Monad m) => t a -> (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x) -> m (t b)

+ Morley.Michelson.Typed.Sing: castSingE :: forall (a :: T) (b :: T) t. (SingI a, SingI b) => t a -> Either Text (t b)

+ Morley.Michelson.Typed.Sing: data SingT z_a1Jj2

+ Morley.Michelson.Typed.Sing: eqP :: forall (a :: T) (b :: T). (SingI a, SingI b) => Proxy a -> Proxy b -> Maybe (a :~: b)

+ Morley.Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TBigMap n1 n2)

+ Morley.Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TLambda n1 n2)

+ Morley.Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TMap n1 n2)

+ Morley.Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TOr n1 n2)

+ Morley.Michelson.Typed.Sing: instance (Data.Singletons.Internal.SingI n1, Data.Singletons.Internal.SingI n2) => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TPair n1 n2)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Decide.SDecide Morley.Michelson.Typed.T.T => Data.Singletons.Decide.SDecide Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Decide.SDecide Morley.Michelson.Typed.T.T => Data.Type.Coercion.TestCoercion Morley.Michelson.Typed.Sing.SingT

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Decide.SDecide Morley.Michelson.Typed.T.T => Data.Type.Equality.TestEquality Morley.Michelson.Typed.Sing.SingT

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TAddress

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TBls12381Fr

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TBls12381G1

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TBls12381G2

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TBool

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TBytes

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TChainId

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TKey

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TKeyHash

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TNever

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TOperation

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TSignature

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TString

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TTimestamp

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI 'Morley.Michelson.Typed.T.TUnit

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TBigMapSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TContractSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TLambdaSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TListSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TMapSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TOptionSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TOrSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TPairSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TSetSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI Morley.Michelson.Typed.Sing.TTicketSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Sing.TBigMapSym1 d)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Sing.TLambdaSym1 d)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Sing.TMapSym1 d)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Sing.TOrSym1 d)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI d => Data.Singletons.Internal.SingI (Morley.Michelson.Typed.Sing.TPairSym1 d)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI k => Morley.Util.Sing.SingI1 ('Morley.Michelson.Typed.T.TMap k)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TContract n)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TList n)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TOption n)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TSet n)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Morley.Michelson.Typed.T.TTicket n)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.Internal.SingKind Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Morley.Michelson.Typed.Sing.TBigMapSym1 a6989586621679422188)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Morley.Michelson.Typed.Sing.TLambdaSym1 a6989586621679422182)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Morley.Michelson.Typed.Sing.TMapSym1 a6989586621679422185)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Morley.Michelson.Typed.Sing.TOrSym1 a6989586621679422179)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Morley.Michelson.Typed.Sing.TPairSym1 a6989586621679422176)

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TBigMapSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TContractSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TLambdaSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TListSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TMapSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TOptionSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TOrSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TPairSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TSetSym0

+ Morley.Michelson.Typed.Sing: instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Morley.Michelson.Typed.Sing.TTicketSym0

+ Morley.Michelson.Typed.Sing: instance Morley.Util.Sing.SingI1 'Morley.Michelson.Typed.T.TList

+ Morley.Michelson.Typed.Sing: requireEq :: forall (a :: T) (b :: T) m. (SingI a, SingI b, Monad m) => (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x) -> m (a :~: b)

+ Morley.Michelson.Typed.T: TAddress :: T

+ Morley.Michelson.Typed.T: TBigMap :: T -> T -> T

+ Morley.Michelson.Typed.T: TBls12381Fr :: T

+ Morley.Michelson.Typed.T: TBls12381G1 :: T

+ Morley.Michelson.Typed.T: TBls12381G2 :: T

+ Morley.Michelson.Typed.T: TBool :: T

+ Morley.Michelson.Typed.T: TBytes :: T

+ Morley.Michelson.Typed.T: TChainId :: T

+ Morley.Michelson.Typed.T: TContract :: T -> T

+ Morley.Michelson.Typed.T: TInt :: T

+ Morley.Michelson.Typed.T: TKey :: T

+ Morley.Michelson.Typed.T: TKeyHash :: T

+ Morley.Michelson.Typed.T: TLambda :: T -> T -> T

+ Morley.Michelson.Typed.T: TList :: T -> T

+ Morley.Michelson.Typed.T: TMap :: T -> T -> T

+ Morley.Michelson.Typed.T: TMutez :: T

+ Morley.Michelson.Typed.T: TNat :: T

+ Morley.Michelson.Typed.T: TNever :: T

+ Morley.Michelson.Typed.T: TOperation :: T

+ Morley.Michelson.Typed.T: TOption :: T -> T

+ Morley.Michelson.Typed.T: TOr :: T -> T -> T

+ Morley.Michelson.Typed.T: TPair :: T -> T -> T

+ Morley.Michelson.Typed.T: TSet :: T -> T

+ Morley.Michelson.Typed.T: TSignature :: T

+ Morley.Michelson.Typed.T: TString :: T

+ Morley.Michelson.Typed.T: TTicket :: T -> T

+ Morley.Michelson.Typed.T: TTimestamp :: T

+ Morley.Michelson.Typed.T: TUnit :: T

+ Morley.Michelson.Typed.T: buildStack :: [T] -> Builder

+ Morley.Michelson.Typed.T: data T

+ Morley.Michelson.Typed.T: instance Control.DeepSeq.NFData Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.T: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.T: instance GHC.Classes.Eq Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.T: instance GHC.Generics.Generic Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.T: instance GHC.Show.Show Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.T: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Typed.T.T

+ Morley.Michelson.Typed.T: toUType :: T -> Ty

+ Morley.Michelson.Typed.TypeLevel: type family CombedPairNodeIndexIsValid (nodeIndex :: Peano) (pair :: T) :: Bool

+ Morley.Michelson.Typed.Util: CtorEffectsApp :: Text -> (forall i o. Semigroup x => x -> x -> Instr i o -> (Instr i o, x)) -> CtorEffectsApp x

+ Morley.Michelson.Typed.Util: DfsSettings :: Bool -> CtorEffectsApp x -> DfsSettings x

+ Morley.Michelson.Typed.Util: [ConstantStorage] :: ConstantScope st => Value st -> PushableStorageSplit s st

+ Morley.Michelson.Typed.Util: [PartlyPushableStorage] :: (StorageScope heavy, StorageScope st) => Value heavy -> Instr (heavy : s) (st : s) -> PushableStorageSplit s st

+ Morley.Michelson.Typed.Util: [PushableValueStorage] :: StorageScope st => Instr s (st : s) -> PushableStorageSplit s st

+ Morley.Michelson.Typed.Util: [ceaApplyEffects] :: CtorEffectsApp x -> forall i o. Semigroup x => x -> x -> Instr i o -> (Instr i o, x)

+ Morley.Michelson.Typed.Util: [ceaName] :: CtorEffectsApp x -> Text

+ Morley.Michelson.Typed.Util: [dsCtorEffectsApp] :: DfsSettings x -> CtorEffectsApp x

+ Morley.Michelson.Typed.Util: [dsGoToValues] :: DfsSettings x -> Bool

+ Morley.Michelson.Typed.Util: allAtomicValues :: forall t a. (forall t'. Value t' -> Maybe a) -> Value t -> [a]

+ Morley.Michelson.Typed.Util: ceaBottomToTop :: CtorEffectsApp x

+ Morley.Michelson.Typed.Util: data CtorEffectsApp x

+ Morley.Michelson.Typed.Util: data DfsSettings x

+ Morley.Michelson.Typed.Util: data PushableStorageSplit s st

+ Morley.Michelson.Typed.Util: dfsFoldInstr :: forall x inp out. Semigroup x => DfsSettings x -> (forall i o. Instr i o -> x) -> Instr inp out -> x

+ Morley.Michelson.Typed.Util: dfsFoldMapValue :: Monoid x => (forall t'. Value t' -> x) -> Value t -> x

+ Morley.Michelson.Typed.Util: dfsFoldMapValueM :: (Monoid x, Monad m) => (forall t'. Value t' -> m x) -> Value t -> m x

+ Morley.Michelson.Typed.Util: dfsInstr :: forall x inp out. Semigroup x => DfsSettings x -> (forall i o. Instr i o -> (Instr i o, x)) -> Instr inp out -> (Instr inp out, x)

+ Morley.Michelson.Typed.Util: dfsMapValue :: forall t. (forall t'. Value t' -> Value t') -> Value t -> Value t

+ Morley.Michelson.Typed.Util: dfsModifyInstr :: DfsSettings () -> (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Util: dfsTraverseValue :: forall t m. Monad m => (forall t'. Value t' -> m (Value t')) -> Value t -> m (Value t)

+ Morley.Michelson.Typed.Util: instance Data.Default.Class.Default (Morley.Michelson.Typed.Util.DfsSettings x)

+ Morley.Michelson.Typed.Util: instance GHC.Show.Show (Morley.Michelson.Typed.Util.CtorEffectsApp x)

+ Morley.Michelson.Typed.Util: instance GHC.Show.Show (Morley.Michelson.Typed.Util.DfsSettings x)

+ Morley.Michelson.Typed.Util: isBytesValue :: Value t -> Maybe ByteString

+ Morley.Michelson.Typed.Util: isStringValue :: Value t -> Maybe MText

+ Morley.Michelson.Typed.Util: linearizeLeft :: Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Util: linearizeLeftDeep :: Instr inp out -> Instr inp out

+ Morley.Michelson.Typed.Util: splitPushableStorage :: StorageScope t => Value t -> PushableStorageSplit s t

+ Morley.Michelson.Typed.Value: CreateContract :: Address -> Maybe KeyHash -> Mutez -> Value' instr st -> instr (ContractInp cp st) (ContractOut st) -> GlobalCounter -> CreateContract instr cp st

+ Morley.Michelson.Typed.Value: SetDelegate :: Maybe KeyHash -> GlobalCounter -> SetDelegate

+ Morley.Michelson.Typed.Value: TransferTokens :: Value' instr p -> Mutez -> Value' instr ('TContract p) -> GlobalCounter -> TransferTokens instr p

+ Morley.Michelson.Typed.Value: [CanBeCompared] :: Comparable t => Comparability t

+ Morley.Michelson.Typed.Value: [CannotBeCompared] :: IsComparable t ~ 'False => Comparability t

+ Morley.Michelson.Typed.Value: [OpCreateContract] :: (Show (instr (ContractInp cp st) (ContractOut st)), NFData (instr (ContractInp cp st) (ContractOut st)), Typeable instr, ParameterScope cp, StorageScope st) => CreateContract instr cp st -> Operation' instr

+ Morley.Michelson.Typed.Value: [OpSetDelegate] :: SetDelegate -> Operation' instr

+ Morley.Michelson.Typed.Value: [OpTransferTokens] :: ParameterScope p => TransferTokens instr p -> Operation' instr

+ Morley.Michelson.Typed.Value: [RfAlwaysFails] :: (forall o'. instr i o') -> RemFail instr i o

+ Morley.Michelson.Typed.Value: [RfNormal] :: instr i o -> RemFail instr i o

+ Morley.Michelson.Typed.Value: [VAddress] :: EpAddress -> Value' instr 'TAddress

+ Morley.Michelson.Typed.Value: [VBigMap] :: forall k v instr. (SingI k, SingI v, Comparable k, HasNoBigMap v) => Maybe Natural -> Map (Value' instr k) (Value' instr v) -> Value' instr ('TBigMap k v)

+ Morley.Michelson.Typed.Value: [VBls12381Fr] :: Bls12381Fr -> Value' instr 'TBls12381Fr

+ Morley.Michelson.Typed.Value: [VBls12381G1] :: Bls12381G1 -> Value' instr 'TBls12381G1

+ Morley.Michelson.Typed.Value: [VBls12381G2] :: Bls12381G2 -> Value' instr 'TBls12381G2

+ Morley.Michelson.Typed.Value: [VBool] :: Bool -> Value' instr 'TBool

+ Morley.Michelson.Typed.Value: [VBytes] :: ByteString -> Value' instr 'TBytes

+ Morley.Michelson.Typed.Value: [VChainId] :: ChainId -> Value' instr 'TChainId

+ Morley.Michelson.Typed.Value: [VContract] :: forall arg instr. (SingI arg, HasNoOp arg) => Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)

+ Morley.Michelson.Typed.Value: [VInt] :: Integer -> Value' instr 'TInt

+ Morley.Michelson.Typed.Value: [VKeyHash] :: KeyHash -> Value' instr 'TKeyHash

+ Morley.Michelson.Typed.Value: [VKey] :: PublicKey -> Value' instr 'TKey

+ Morley.Michelson.Typed.Value: [VLam] :: forall inp out instr. (SingI inp, SingI out, forall i o. Show (instr i o), forall i o. Eq (instr i o), forall i o. NFData (instr i o)) => RemFail instr (inp : '[]) (out : '[]) -> Value' instr ('TLambda inp out)

+ Morley.Michelson.Typed.Value: [VList] :: forall t instr. SingI t => [Value' instr t] -> Value' instr ('TList t)

+ Morley.Michelson.Typed.Value: [VMap] :: forall k v instr. (SingI k, SingI v, Comparable k) => Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v)

+ Morley.Michelson.Typed.Value: [VMutez] :: Mutez -> Value' instr 'TMutez

+ Morley.Michelson.Typed.Value: [VNat] :: Natural -> Value' instr 'TNat

+ Morley.Michelson.Typed.Value: [VOp] :: Operation' instr -> Value' instr 'TOperation

+ Morley.Michelson.Typed.Value: [VOption] :: forall t instr. SingI t => Maybe (Value' instr t) -> Value' instr ('TOption t)

+ Morley.Michelson.Typed.Value: [VOr] :: forall l r instr. (SingI l, SingI r) => Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)

+ Morley.Michelson.Typed.Value: [VPair] :: forall l r instr. (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)

+ Morley.Michelson.Typed.Value: [VSet] :: forall t instr. (SingI t, Comparable t) => Set (Value' instr t) -> Value' instr ('TSet t)

+ Morley.Michelson.Typed.Value: [VSignature] :: Signature -> Value' instr 'TSignature

+ Morley.Michelson.Typed.Value: [VString] :: MText -> Value' instr 'TString

+ Morley.Michelson.Typed.Value: [VTicket] :: forall arg instr. Comparable arg => Address -> Value' instr arg -> Natural -> Value' instr ('TTicket arg)

+ Morley.Michelson.Typed.Value: [VTimestamp] :: Timestamp -> Value' instr 'TTimestamp

+ Morley.Michelson.Typed.Value: [VUnit] :: Value' instr 'TUnit

+ Morley.Michelson.Typed.Value: [ccBalance] :: CreateContract instr cp st -> Mutez

+ Morley.Michelson.Typed.Value: [ccContractCode] :: CreateContract instr cp st -> instr (ContractInp cp st) (ContractOut st)

+ Morley.Michelson.Typed.Value: [ccCounter] :: CreateContract instr cp st -> GlobalCounter

+ Morley.Michelson.Typed.Value: [ccDelegate] :: CreateContract instr cp st -> Maybe KeyHash

+ Morley.Michelson.Typed.Value: [ccOriginator] :: CreateContract instr cp st -> Address

+ Morley.Michelson.Typed.Value: [ccStorageVal] :: CreateContract instr cp st -> Value' instr st

+ Morley.Michelson.Typed.Value: [sdCounter] :: SetDelegate -> GlobalCounter

+ Morley.Michelson.Typed.Value: [sdMbKeyHash] :: SetDelegate -> Maybe KeyHash

+ Morley.Michelson.Typed.Value: [ttAmount] :: TransferTokens instr p -> Mutez

+ Morley.Michelson.Typed.Value: [ttContract] :: TransferTokens instr p -> Value' instr ('TContract p)

+ Morley.Michelson.Typed.Value: [ttCounter] :: TransferTokens instr p -> GlobalCounter

+ Morley.Michelson.Typed.Value: [ttTransferArgument] :: TransferTokens instr p -> Value' instr p

+ Morley.Michelson.Typed.Value: addressToVContract :: forall t instr. (ParameterScope t, ForbidOr t) => Address -> Value' instr ('TContract t)

+ Morley.Michelson.Typed.Value: buildVContract :: Value' instr ('TContract arg) -> Builder

+ Morley.Michelson.Typed.Value: checkComparability :: Sing t -> Comparability t

+ Morley.Michelson.Typed.Value: class (IsComparable t ~ 'True) => Comparable t

+ Morley.Michelson.Typed.Value: comparabilityPresence :: Sing t -> Maybe (Dict $ Comparable t)

+ Morley.Michelson.Typed.Value: compileEpLiftSequence :: EpLiftSequence arg param -> Value' instr arg -> Value' instr param

+ Morley.Michelson.Typed.Value: data Comparability t

+ Morley.Michelson.Typed.Value: data CreateContract instr cp st

+ Morley.Michelson.Typed.Value: data Operation' instr

+ Morley.Michelson.Typed.Value: data RemFail (instr :: k -> k -> Type) (i :: k) (o :: k)

+ Morley.Michelson.Typed.Value: data SetDelegate

+ Morley.Michelson.Typed.Value: data TransferTokens instr p

+ Morley.Michelson.Typed.Value: data Value' instr t

+ Morley.Michelson.Typed.Value: eqValueExt :: Value' instr t1 -> Value' instr t2 -> Bool

+ Morley.Michelson.Typed.Value: getComparableProofS :: Sing (a :: T) -> Maybe (Dict (Comparable a))

+ Morley.Michelson.Typed.Value: instance (Morley.Michelson.Typed.Value.Comparable e, Morley.Michelson.Typed.Scope.ForbidNonComparable e) => Morley.Michelson.Typed.Value.Comparable ('Morley.Michelson.Typed.T.TOption e)

+ Morley.Michelson.Typed.Value: instance (Morley.Michelson.Typed.Value.Comparable e1, Morley.Michelson.Typed.Value.Comparable e2, Morley.Michelson.Typed.Scope.FailOnNonComparableFound (Morley.Michelson.Typed.Scope.IsComparable e1 Data.Type.Bool.&& Morley.Michelson.Typed.Scope.IsComparable e2)) => Morley.Michelson.Typed.Value.Comparable ('Morley.Michelson.Typed.T.TOr e1 e2)

+ Morley.Michelson.Typed.Value: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Value.Operation' instr)

+ Morley.Michelson.Typed.Value: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Value.TransferTokens instr p)

+ Morley.Michelson.Typed.Value: instance Control.DeepSeq.NFData (Morley.Michelson.Typed.Value.Value' instr t)

+ Morley.Michelson.Typed.Value: instance Control.DeepSeq.NFData (instr (Morley.Michelson.Typed.Value.ContractInp cp st) (Morley.Michelson.Typed.Value.ContractOut st)) => Control.DeepSeq.NFData (Morley.Michelson.Typed.Value.CreateContract instr cp st)

+ Morley.Michelson.Typed.Value: instance Control.DeepSeq.NFData Morley.Michelson.Typed.Value.SetDelegate

+ Morley.Michelson.Typed.Value: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Value.ComparabilityScope t)

+ Morley.Michelson.Typed.Value: instance Data.Singletons.Internal.SingI t => Morley.Michelson.Typed.Scope.CheckScope (Morley.Michelson.Typed.Value.Comparable t)

+ Morley.Michelson.Typed.Value: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Value.CreateContract instr cp st)

+ Morley.Michelson.Typed.Value: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Value.Operation' instr)

+ Morley.Michelson.Typed.Value: instance Formatting.Buildable.Buildable (Morley.Michelson.Typed.Value.TransferTokens instr p)

+ Morley.Michelson.Typed.Value: instance Formatting.Buildable.Buildable Morley.Michelson.Typed.Value.SetDelegate

+ Morley.Michelson.Typed.Value: instance GHC.Classes.Eq (Morley.Michelson.Typed.Value.CreateContract instr cp st)

+ Morley.Michelson.Typed.Value: instance GHC.Classes.Eq (Morley.Michelson.Typed.Value.Operation' instr)

+ Morley.Michelson.Typed.Value: instance GHC.Classes.Eq (Morley.Michelson.Typed.Value.TransferTokens instr p)

+ Morley.Michelson.Typed.Value: instance GHC.Classes.Eq (Morley.Michelson.Typed.Value.Value' instr t)

+ Morley.Michelson.Typed.Value: instance GHC.Classes.Eq Morley.Michelson.Typed.Value.SetDelegate

+ Morley.Michelson.Typed.Value: instance GHC.Generics.Generic (Morley.Michelson.Typed.Value.TransferTokens instr p)

+ Morley.Michelson.Typed.Value: instance GHC.Generics.Generic Morley.Michelson.Typed.Value.SetDelegate

+ Morley.Michelson.Typed.Value: instance GHC.Show.Show (Morley.Michelson.Typed.Value.CreateContract instr cp st)

+ Morley.Michelson.Typed.Value: instance GHC.Show.Show (Morley.Michelson.Typed.Value.Operation' instr)

+ Morley.Michelson.Typed.Value: instance GHC.Show.Show (Morley.Michelson.Typed.Value.TransferTokens instr p)

+ Morley.Michelson.Typed.Value: instance GHC.Show.Show (Morley.Michelson.Typed.Value.Value' instr t)

+ Morley.Michelson.Typed.Value: instance GHC.Show.Show Morley.Michelson.Typed.Value.SetDelegate

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TAddress

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TBool

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TBytes

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TChainId

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TInt

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TKey

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TKeyHash

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TMutez

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TNat

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TNever

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TSignature

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TString

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TTimestamp

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable 'Morley.Michelson.Typed.T.TUnit

+ Morley.Michelson.Typed.Value: instance Morley.Michelson.Typed.Value.Comparable e => GHC.Classes.Ord (Morley.Michelson.Typed.Value.Value' instr e)

+ Morley.Michelson.Typed.Value: instance forall k (instr :: k -> k -> *) (i :: k) (o :: k). (forall (o' :: k). Control.DeepSeq.NFData (instr i o')) => Control.DeepSeq.NFData (Morley.Michelson.Typed.Value.RemFail instr i o)

+ Morley.Michelson.Typed.Value: instance forall k (instr :: k -> k -> *) (i :: k) (o :: k). (forall (o' :: k). GHC.Show.Show (instr i o')) => GHC.Show.Show (Morley.Michelson.Typed.Value.RemFail instr i o)

+ Morley.Michelson.Typed.Value: instance forall k (instr :: k -> k -> *) (i :: k) (o :: k). GHC.Classes.Eq (instr i o) => GHC.Classes.Eq (Morley.Michelson.Typed.Value.RemFail instr i o)

+ Morley.Michelson.Typed.Value: liftCallArg :: EntrypointCallT param arg -> Value' instr arg -> Value' instr param

+ Morley.Michelson.Typed.Value: rfAnyInstr :: RemFail instr i o -> instr i o

+ Morley.Michelson.Typed.Value: rfMapAnyInstr :: (forall o'. instr i1 o' -> instr i2 o') -> RemFail instr i1 o -> RemFail instr i2 o

+ Morley.Michelson.Typed.Value: rfMerge :: (forall o'. instr i1 o' -> instr i2 o' -> instr i3 o') -> RemFail instr i1 o -> RemFail instr i2 o -> RemFail instr i3 o

+ Morley.Michelson.Typed.Value: type ComparabilityScope t = (SingI t, Comparable t)

+ Morley.Michelson.Typed.Value: type ContractInp param st = '[ContractInp1 param st]

+ Morley.Michelson.Typed.Value: type ContractInp1 param st = 'TPair param st

+ Morley.Michelson.Typed.Value: type ContractOut st = '[ContractOut1 st]

+ Morley.Michelson.Typed.Value: type ContractOut1 st = 'TPair ('TList 'TOperation) st

+ Morley.Michelson.Typed.Value: valueTypeSanity :: Value' instr t -> Dict (SingI t)

+ Morley.Michelson.Typed.Value: withValueTypeSanity :: Value' instr t -> (SingI t => a) -> a

+ Morley.Michelson.Untyped.Aliases: type Contract = Contract' ExpandedOp

+ Morley.Michelson.Untyped.Aliases: type ExpandedExtInstr = ExtInstrAbstract ExpandedOp

+ Morley.Michelson.Untyped.Aliases: type Value = Value' ExpandedOp

+ Morley.Michelson.Untyped.Annotation: AnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet

+ Morley.Michelson.Untyped.Annotation: OneVarAnn :: VarAnn -> VarAnns

+ Morley.Michelson.Untyped.Annotation: TwoVarAnns :: VarAnn -> VarAnn -> VarAnns

+ Morley.Michelson.Untyped.Annotation: UnsafeAnnotation :: Text -> Annotation tag

+ Morley.Michelson.Untyped.Annotation: [asFields] :: AnnotationSet -> [FieldAnn]

+ Morley.Michelson.Untyped.Annotation: [asTypes] :: AnnotationSet -> [TypeAnn]

+ Morley.Michelson.Untyped.Annotation: [asVars] :: AnnotationSet -> [VarAnn]

+ Morley.Michelson.Untyped.Annotation: [unAnnotation] :: Annotation tag -> Text

+ Morley.Michelson.Untyped.Annotation: annPrefix :: KnownAnnTag tag => Text

+ Morley.Michelson.Untyped.Annotation: annQ :: QuasiQuoter

+ Morley.Michelson.Untyped.Annotation: annsCount :: AnnotationSet -> (Int, Int, Int)

+ Morley.Michelson.Untyped.Annotation: class Typeable (tag :: Type) => KnownAnnTag tag

+ Morley.Michelson.Untyped.Annotation: convAnn :: Annotation tag1 -> Annotation tag2

+ Morley.Michelson.Untyped.Annotation: convergeVarAnns :: VarAnn -> VarAnn -> VarAnn

+ Morley.Michelson.Untyped.Annotation: data AnnotationSet

+ Morley.Michelson.Untyped.Annotation: data FieldTag

+ Morley.Michelson.Untyped.Annotation: data TypeTag

+ Morley.Michelson.Untyped.Annotation: data VarAnns

+ Morley.Michelson.Untyped.Annotation: data VarTag

+ Morley.Michelson.Untyped.Annotation: emptyAnnSet :: AnnotationSet

+ Morley.Michelson.Untyped.Annotation: fieldAnnQ :: QuasiQuoter

+ Morley.Michelson.Untyped.Annotation: firstAnn :: KnownAnnTag tag => AnnotationSet -> Annotation tag

+ Morley.Michelson.Untyped.Annotation: fullAnnSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet

+ Morley.Michelson.Untyped.Annotation: ifAnnUnified :: Annotation tag -> Annotation tag -> Bool

+ Morley.Michelson.Untyped.Annotation: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Annotation.VarAnns

+ Morley.Michelson.Untyped.Annotation: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Annotation.AnnotationSet

+ Morley.Michelson.Untyped.Annotation: instance GHC.Base.Functor Morley.Michelson.Untyped.Annotation.Annotation

+ Morley.Michelson.Untyped.Annotation: instance GHC.Base.Monoid Morley.Michelson.Untyped.Annotation.AnnotationSet

+ Morley.Michelson.Untyped.Annotation: instance GHC.Base.Monoid Morley.Michelson.Untyped.Annotation.VarAnn

+ Morley.Michelson.Untyped.Annotation: instance GHC.Base.Semigroup Morley.Michelson.Untyped.Annotation.AnnotationSet

+ Morley.Michelson.Untyped.Annotation: instance GHC.Base.Semigroup Morley.Michelson.Untyped.Annotation.VarAnn

+ Morley.Michelson.Untyped.Annotation: instance GHC.Classes.Eq Morley.Michelson.Untyped.Annotation.AnnotationSet

+ Morley.Michelson.Untyped.Annotation: instance GHC.Generics.Generic Morley.Michelson.Untyped.Annotation.VarAnns

+ Morley.Michelson.Untyped.Annotation: instance GHC.Show.Show Morley.Michelson.Untyped.Annotation.AnnotationSet

+ Morley.Michelson.Untyped.Annotation: instance GHC.Show.Show Morley.Michelson.Untyped.Annotation.VarAnns

+ Morley.Michelson.Untyped.Annotation: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Untyped.Annotation.AnnotationSet

+ Morley.Michelson.Untyped.Annotation: instance Morley.Michelson.Untyped.Annotation.KnownAnnTag Morley.Michelson.Untyped.Annotation.FieldTag

+ Morley.Michelson.Untyped.Annotation: instance Morley.Michelson.Untyped.Annotation.KnownAnnTag Morley.Michelson.Untyped.Annotation.TypeTag

+ Morley.Michelson.Untyped.Annotation: instance Morley.Michelson.Untyped.Annotation.KnownAnnTag Morley.Michelson.Untyped.Annotation.VarTag

+ Morley.Michelson.Untyped.Annotation: instance Morley.Michelson.Untyped.Annotation.KnownAnnTag tag => Formatting.Buildable.Buildable (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance Morley.Michelson.Untyped.Annotation.KnownAnnTag tag => GHC.Show.Show (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance Morley.Michelson.Untyped.Annotation.KnownAnnTag tag => Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). (Data.Typeable.Internal.Typeable tag, Data.Typeable.Internal.Typeable k) => Data.Data.Data (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). Control.DeepSeq.NFData (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). Data.Aeson.Types.FromJSON.FromJSON (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). Data.Aeson.Types.ToJSON.ToJSON (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). Data.Default.Class.Default (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). GHC.Classes.Eq (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). GHC.Generics.Generic (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: instance forall k (tag :: k). Language.Haskell.TH.Syntax.Lift (Morley.Michelson.Untyped.Annotation.Annotation tag)

+ Morley.Michelson.Untyped.Annotation: isNoAnnSet :: AnnotationSet -> Bool

+ Morley.Michelson.Untyped.Annotation: isValidAnnBodyChar :: Char -> Bool

+ Morley.Michelson.Untyped.Annotation: isValidAnnStart :: Char -> Bool

+ Morley.Michelson.Untyped.Annotation: minAnnSetSize :: AnnotationSet -> Int

+ Morley.Michelson.Untyped.Annotation: minimizeAnnSet :: AnnotationSet -> AnnotationSet

+ Morley.Michelson.Untyped.Annotation: mkAnnotation :: Text -> Either Text (Annotation a)

+ Morley.Michelson.Untyped.Annotation: newtype Annotation tag

+ Morley.Michelson.Untyped.Annotation: noAnn :: Annotation a

+ Morley.Michelson.Untyped.Annotation: orAnn :: Annotation t -> Annotation t -> Annotation t

+ Morley.Michelson.Untyped.Annotation: pattern Annotation :: Text -> Annotation tag

+ Morley.Michelson.Untyped.Annotation: pattern WithAnn :: Annotation tag -> Annotation tag

+ Morley.Michelson.Untyped.Annotation: secondAnn :: KnownAnnTag tag => AnnotationSet -> Annotation tag

+ Morley.Michelson.Untyped.Annotation: singleAnnSet :: forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet

+ Morley.Michelson.Untyped.Annotation: singleGroupAnnSet :: forall tag. KnownAnnTag tag => [Annotation tag] -> AnnotationSet

+ Morley.Michelson.Untyped.Annotation: specialFieldAnn :: Text

+ Morley.Michelson.Untyped.Annotation: specialVarAnns :: [Text]

+ Morley.Michelson.Untyped.Annotation: type FieldAnn = Annotation FieldTag

+ Morley.Michelson.Untyped.Annotation: type RootAnn = Annotation FieldTag

+ Morley.Michelson.Untyped.Annotation: type SomeAnn = Annotation SomeTag

+ Morley.Michelson.Untyped.Annotation: type TypeAnn = Annotation TypeTag

+ Morley.Michelson.Untyped.Annotation: type VarAnn = Annotation VarTag

+ Morley.Michelson.Untyped.Annotation: typeAnnQ :: QuasiQuoter

+ Morley.Michelson.Untyped.Annotation: unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)

+ Morley.Michelson.Untyped.Annotation: unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn

+ Morley.Michelson.Untyped.Annotation: unsafeMkAnnotation :: HasCallStack => Text -> Annotation a

+ Morley.Michelson.Untyped.Annotation: varAnnQ :: QuasiQuoter

+ Morley.Michelson.Untyped.Contract: CBCode :: [op] -> ContractBlock op

+ Morley.Michelson.Untyped.Contract: CBParam :: ParameterType -> ContractBlock op

+ Morley.Michelson.Untyped.Contract: CBStorage :: Ty -> ContractBlock op

+ Morley.Michelson.Untyped.Contract: CPS :: EntriesOrder

+ Morley.Michelson.Untyped.Contract: CSP :: EntriesOrder

+ Morley.Michelson.Untyped.Contract: Contract :: ParameterType -> Storage -> [op] -> EntriesOrder -> Contract' op

+ Morley.Michelson.Untyped.Contract: PCS :: EntriesOrder

+ Morley.Michelson.Untyped.Contract: PSC :: EntriesOrder

+ Morley.Michelson.Untyped.Contract: SCP :: EntriesOrder

+ Morley.Michelson.Untyped.Contract: SPC :: EntriesOrder

+ Morley.Michelson.Untyped.Contract: [contractCode] :: Contract' op -> [op]

+ Morley.Michelson.Untyped.Contract: [contractParameter] :: Contract' op -> ParameterType

+ Morley.Michelson.Untyped.Contract: [contractStorage] :: Contract' op -> Storage

+ Morley.Michelson.Untyped.Contract: [entriesOrder] :: Contract' op -> EntriesOrder

+ Morley.Michelson.Untyped.Contract: canonicalEntriesOrder :: EntriesOrder

+ Morley.Michelson.Untyped.Contract: data Contract' op

+ Morley.Michelson.Untyped.Contract: data ContractBlock op

+ Morley.Michelson.Untyped.Contract: data EntriesOrder

+ Morley.Michelson.Untyped.Contract: entriesOrderToInt :: EntriesOrder -> (Int, Int, Int)

+ Morley.Michelson.Untyped.Contract: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance Data.Data.Data Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance Data.Data.Data op => Data.Data.Data (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance Data.Default.Class.Default Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance GHC.Base.Functor Morley.Michelson.Untyped.Contract.Contract'

+ Morley.Michelson.Untyped.Contract: instance GHC.Classes.Eq Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance GHC.Classes.Eq op => GHC.Classes.Eq (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance GHC.Classes.Eq op => GHC.Classes.Eq (Morley.Michelson.Untyped.Contract.ContractBlock op)

+ Morley.Michelson.Untyped.Contract: instance GHC.Enum.Bounded Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance GHC.Enum.Enum Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance GHC.Generics.Generic (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance GHC.Generics.Generic Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance GHC.Show.Show Morley.Michelson.Untyped.Contract.EntriesOrder

+ Morley.Michelson.Untyped.Contract: instance GHC.Show.Show op => GHC.Show.Show (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance GHC.Show.Show op => GHC.Show.Show (Morley.Michelson.Untyped.Contract.ContractBlock op)

+ Morley.Michelson.Untyped.Contract: instance Morley.Michelson.Printer.Util.RenderDoc op => Formatting.Buildable.Buildable (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: instance Morley.Michelson.Printer.Util.RenderDoc op => Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Untyped.Contract.Contract' op)

+ Morley.Michelson.Untyped.Contract: mapEntriesOrdered :: Contract' op -> (ParameterType -> a) -> (Storage -> a) -> ([op] -> a) -> [a]

+ Morley.Michelson.Untyped.Contract: orderContractBlock :: (ContractBlock op, ContractBlock op, ContractBlock op) -> Maybe (Contract' op)

+ Morley.Michelson.Untyped.Contract: type Storage = Ty

+ Morley.Michelson.Untyped.Entrypoints: InEpNameBadAnnotation :: FieldAnn -> EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: UnsafeEpName :: Text -> EpName

+ Morley.Michelson.Untyped.Entrypoints: [unEpName] :: EpName -> Text

+ Morley.Michelson.Untyped.Entrypoints: buildEpName :: Text -> Either String EpName

+ Morley.Michelson.Untyped.Entrypoints: data EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: epNameFromParamAnn :: FieldAnn -> Maybe EpName

+ Morley.Michelson.Untyped.Entrypoints: epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName

+ Morley.Michelson.Untyped.Entrypoints: epNameFromSelfAnn :: FieldAnn -> EpName

+ Morley.Michelson.Untyped.Entrypoints: epNameToParamAnn :: EpName -> FieldAnn

+ Morley.Michelson.Untyped.Entrypoints: epNameToRefAnn :: EpName -> FieldAnn

+ Morley.Michelson.Untyped.Entrypoints: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: instance GHC.Classes.Eq Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance GHC.Classes.Eq Morley.Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: instance GHC.Classes.Ord Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance GHC.Generics.Generic Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance GHC.Generics.Generic Morley.Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: instance GHC.Show.Show Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: instance GHC.Show.Show Morley.Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Untyped.Entrypoints.EpNameFromRefAnnError

+ Morley.Michelson.Untyped.Entrypoints: instance Morley.Util.CLI.HasCLReader Morley.Michelson.Untyped.Entrypoints.EpName

+ Morley.Michelson.Untyped.Entrypoints: isDefEpName :: EpName -> Bool

+ Morley.Michelson.Untyped.Entrypoints: mkEntrypointsMap :: ParameterType -> Map EpName Ty

+ Morley.Michelson.Untyped.Entrypoints: newtype EpName

+ Morley.Michelson.Untyped.Entrypoints: pattern DefEpName :: EpName

+ Morley.Michelson.Untyped.Entrypoints: unsafeBuildEpName :: HasCallStack => Text -> EpName

+ Morley.Michelson.Untyped.Ext: FN :: Text -> StackFn -> [op] -> ExtInstrAbstract op

+ Morley.Michelson.Untyped.Ext: PrintComment :: [Either Text StackRef] -> PrintComment

+ Morley.Michelson.Untyped.Ext: STACKTYPE :: StackTypePattern -> ExtInstrAbstract op

+ Morley.Michelson.Untyped.Ext: StackFn :: Maybe (Set Var) -> StackTypePattern -> StackTypePattern -> StackFn

+ Morley.Michelson.Untyped.Ext: StackRef :: Natural -> StackRef

+ Morley.Michelson.Untyped.Ext: StkCons :: TyVar -> StackTypePattern -> StackTypePattern

+ Morley.Michelson.Untyped.Ext: StkEmpty :: StackTypePattern

+ Morley.Michelson.Untyped.Ext: StkRest :: StackTypePattern

+ Morley.Michelson.Untyped.Ext: TestAssert :: Text -> PrintComment -> [op] -> TestAssert op

+ Morley.Michelson.Untyped.Ext: TyCon :: Ty -> TyVar

+ Morley.Michelson.Untyped.Ext: UCOMMENT :: Text -> ExtInstrAbstract op

+ Morley.Michelson.Untyped.Ext: UPRINT :: PrintComment -> ExtInstrAbstract op

+ Morley.Michelson.Untyped.Ext: UTEST_ASSERT :: TestAssert op -> ExtInstrAbstract op

+ Morley.Michelson.Untyped.Ext: Var :: Text -> Var

+ Morley.Michelson.Untyped.Ext: VarID :: Var -> TyVar

+ Morley.Michelson.Untyped.Ext: [sfnInPattern] :: StackFn -> StackTypePattern

+ Morley.Michelson.Untyped.Ext: [sfnOutPattern] :: StackFn -> StackTypePattern

+ Morley.Michelson.Untyped.Ext: [sfnQuantifiedVars] :: StackFn -> Maybe (Set Var)

+ Morley.Michelson.Untyped.Ext: [tassComment] :: TestAssert op -> PrintComment

+ Morley.Michelson.Untyped.Ext: [tassInstrs] :: TestAssert op -> [op]

+ Morley.Michelson.Untyped.Ext: [tassName] :: TestAssert op -> Text

+ Morley.Michelson.Untyped.Ext: [unUPrintComment] :: PrintComment -> [Either Text StackRef]

+ Morley.Michelson.Untyped.Ext: data ExtInstrAbstract op

+ Morley.Michelson.Untyped.Ext: data StackFn

+ Morley.Michelson.Untyped.Ext: data StackTypePattern

+ Morley.Michelson.Untyped.Ext: data TestAssert op

+ Morley.Michelson.Untyped.Ext: data TyVar

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data op => Data.Data.Data (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance Data.Data.Data op => Data.Data.Data (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable op => Formatting.Buildable.Buildable (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance Formatting.Buildable.Buildable op => Formatting.Buildable.Buildable (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance GHC.Base.Functor Morley.Michelson.Untyped.Ext.ExtInstrAbstract

+ Morley.Michelson.Untyped.Ext: instance GHC.Base.Functor Morley.Michelson.Untyped.Ext.TestAssert

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq op => GHC.Classes.Eq (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Eq op => GHC.Classes.Eq (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance GHC.Classes.Ord Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance GHC.Generics.Generic Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show Morley.Michelson.Untyped.Ext.PrintComment

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show Morley.Michelson.Untyped.Ext.StackFn

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show Morley.Michelson.Untyped.Ext.StackRef

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show Morley.Michelson.Untyped.Ext.StackTypePattern

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show Morley.Michelson.Untyped.Ext.TyVar

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show Morley.Michelson.Untyped.Ext.Var

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show op => GHC.Show.Show (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: instance GHC.Show.Show op => GHC.Show.Show (Morley.Michelson.Untyped.Ext.TestAssert op)

+ Morley.Michelson.Untyped.Ext: instance Morley.Michelson.Printer.Util.RenderDoc op => Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Untyped.Ext.ExtInstrAbstract op)

+ Morley.Michelson.Untyped.Ext: newtype PrintComment

+ Morley.Michelson.Untyped.Ext: newtype StackRef

+ Morley.Michelson.Untyped.Ext: newtype Var

+ Morley.Michelson.Untyped.Ext: stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)

+ Morley.Michelson.Untyped.Ext: varSet :: StackTypePattern -> Set Var

+ Morley.Michelson.Untyped.Instr: ABS :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: ADD :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: ADDRESS :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: AMOUNT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: AND :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: APPLY :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: BALANCE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: BLAKE2B :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CAR :: VarAnn -> FieldAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CAST :: VarAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CDR :: VarAnn -> FieldAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CHAIN_ID :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CHECK_SIGNATURE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: COMPARE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CONCAT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CONS :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CONTRACT :: VarAnn -> FieldAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: CREATE_CONTRACT :: VarAnn -> VarAnn -> Contract' op -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DIG :: Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DIP :: [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DIPN :: Word -> [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DROP :: InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DROPN :: Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DUG :: Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DUP :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: DUPN :: VarAnn -> Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: EDIV :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: EMPTY_BIG_MAP :: TypeAnn -> VarAnn -> Ty -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: EMPTY_MAP :: TypeAnn -> VarAnn -> Ty -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: EMPTY_SET :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: EQ :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: EXEC :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: EXT :: ExtInstrAbstract op -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: FAILWITH :: InstrAbstract op

+ Morley.Michelson.Untyped.Instr: GE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: GET :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: GETN :: VarAnn -> Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: GET_AND_UPDATE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: GT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: HASH_KEY :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: IF :: [op] -> [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: IF_CONS :: [op] -> [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: IF_LEFT :: [op] -> [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: IF_NONE :: [op] -> [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: IMPLICIT_ACCOUNT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: INT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: ISNAT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: ITER :: [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: JOIN_TICKETS :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: KECCAK :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LAMBDA :: VarAnn -> Ty -> Ty -> [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LEFT :: TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LEVEL :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LOOP :: [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LOOP_LEFT :: [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LSL :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LSR :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: LT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: MAP :: VarAnn -> [op] -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: MEM :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: MUL :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: NEG :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: NEQ :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: NEVER :: InstrAbstract op

+ Morley.Michelson.Untyped.Instr: NIL :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: NONE :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: NOT :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: NOW :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: OR :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: PACK :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: PAIR :: TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: PAIRING_CHECK :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: PAIRN :: VarAnn -> Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: PUSH :: VarAnn -> Ty -> Value' op -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: PrimEx :: ExpandedInstr -> ExpandedOp

+ Morley.Michelson.Untyped.Instr: READ_TICKET :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: RENAME :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: RIGHT :: TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SELF :: VarAnn -> FieldAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SELF_ADDRESS :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SENDER :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SET_DELEGATE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SHA256 :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SHA3 :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SHA512 :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SIZE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SLICE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SOME :: TypeAnn -> VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SOURCE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SPLIT_TICKET :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SUB :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SWAP :: InstrAbstract op

+ Morley.Michelson.Untyped.Instr: SeqEx :: [ExpandedOp] -> ExpandedOp

+ Morley.Michelson.Untyped.Instr: TICKET :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: TOTAL_VOTING_POWER :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: TRANSFER_TOKENS :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: UNIT :: TypeAnn -> VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: UNPACK :: TypeAnn -> VarAnn -> Ty -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: UNPAIR :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: UNPAIRN :: Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: UPDATE :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: UPDATEN :: VarAnn -> Word -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: VOTING_POWER :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: WithSrcEx :: InstrCallStack -> ExpandedOp -> ExpandedOp

+ Morley.Michelson.Untyped.Instr: XOR :: VarAnn -> InstrAbstract op

+ Morley.Michelson.Untyped.Instr: data ExpandedOp

+ Morley.Michelson.Untyped.Instr: data InstrAbstract op

+ Morley.Michelson.Untyped.Instr: flattenExpandedOp :: ExpandedOp -> [ExpandedInstr]

+ Morley.Michelson.Untyped.Instr: instance (Morley.Michelson.Printer.Util.RenderDoc op, Formatting.Buildable.Buildable op) => Formatting.Buildable.Buildable (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance Data.Data.Data Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance Data.Data.Data op => Data.Data.Data (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance GHC.Base.Functor Morley.Michelson.Untyped.Instr.InstrAbstract

+ Morley.Michelson.Untyped.Instr: instance GHC.Classes.Eq Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance GHC.Classes.Eq op => GHC.Classes.Eq (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance GHC.Generics.Generic (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance GHC.Generics.Generic Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance GHC.Show.Show Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Untyped.Instr.InstrAbstract op) => GHC.Show.Show (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Untyped.Instr.ExpandedOp

+ Morley.Michelson.Untyped.Instr: instance Morley.Michelson.Printer.Util.RenderDoc op => Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Untyped.Instr.InstrAbstract op)

+ Morley.Michelson.Untyped.Instr: type ExpandedInstr = InstrAbstract ExpandedOp

+ Morley.Michelson.Untyped.OpSize: OpSize :: Word -> OpSize

+ Morley.Michelson.Untyped.OpSize: [unOpSize] :: OpSize -> Word

+ Morley.Michelson.Untyped.OpSize: expandedInstrsOpSize :: [ExpandedOp] -> OpSize

+ Morley.Michelson.Untyped.OpSize: instance (Morley.Michelson.Untyped.Annotation.KnownAnnTag t, Morley.Michelson.Untyped.OpSize.AnnsOpSizeVararg x) => Morley.Michelson.Untyped.OpSize.AnnsOpSizeVararg (Morley.Michelson.Untyped.Annotation.Annotation t -> x)

+ Morley.Michelson.Untyped.OpSize: instance (Morley.Michelson.Untyped.Annotation.KnownAnnTag t, Morley.Michelson.Untyped.OpSize.AnnsOpSizeVararg x) => Morley.Michelson.Untyped.OpSize.AnnsOpSizeVararg ([Morley.Michelson.Untyped.Annotation.Annotation t] -> x)

+ Morley.Michelson.Untyped.OpSize: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.OpSize.OpSize

+ Morley.Michelson.Untyped.OpSize: instance GHC.Base.Monoid Morley.Michelson.Untyped.OpSize.OpSize

+ Morley.Michelson.Untyped.OpSize: instance GHC.Base.Semigroup Morley.Michelson.Untyped.OpSize.OpSize

+ Morley.Michelson.Untyped.OpSize: instance GHC.Classes.Eq Morley.Michelson.Untyped.OpSize.OpSize

+ Morley.Michelson.Untyped.OpSize: instance GHC.Classes.Ord Morley.Michelson.Untyped.OpSize.OpSize

+ Morley.Michelson.Untyped.OpSize: instance GHC.Show.Show Morley.Michelson.Untyped.OpSize.OpSize

+ Morley.Michelson.Untyped.OpSize: instance Morley.Michelson.Untyped.OpSize.AnnsOpSizeVararg Morley.Michelson.Untyped.OpSize.OpSize

+ Morley.Michelson.Untyped.OpSize: instrOpSize :: InstrAbstract ExpandedOp -> OpSize

+ Morley.Michelson.Untyped.OpSize: newtype OpSize

+ Morley.Michelson.Untyped.OpSize: opSizeHardLimit :: OpSize

+ Morley.Michelson.Untyped.OpSize: smallTransferOpSize :: OpSize

+ Morley.Michelson.Untyped.OpSize: valueOpSize :: Value -> OpSize

+ Morley.Michelson.Untyped.Type: ParameterType :: Ty -> RootAnn -> ParameterType

+ Morley.Michelson.Untyped.Type: TAddress :: T

+ Morley.Michelson.Untyped.Type: TBigMap :: Ty -> Ty -> T

+ Morley.Michelson.Untyped.Type: TBls12381Fr :: T

+ Morley.Michelson.Untyped.Type: TBls12381G1 :: T

+ Morley.Michelson.Untyped.Type: TBls12381G2 :: T

+ Morley.Michelson.Untyped.Type: TBool :: T

+ Morley.Michelson.Untyped.Type: TBytes :: T

+ Morley.Michelson.Untyped.Type: TChainId :: T

+ Morley.Michelson.Untyped.Type: TContract :: Ty -> T

+ Morley.Michelson.Untyped.Type: TInt :: T

+ Morley.Michelson.Untyped.Type: TKey :: T

+ Morley.Michelson.Untyped.Type: TKeyHash :: T

+ Morley.Michelson.Untyped.Type: TLambda :: Ty -> Ty -> T

+ Morley.Michelson.Untyped.Type: TList :: Ty -> T

+ Morley.Michelson.Untyped.Type: TMap :: Ty -> Ty -> T

+ Morley.Michelson.Untyped.Type: TMutez :: T

+ Morley.Michelson.Untyped.Type: TNat :: T

+ Morley.Michelson.Untyped.Type: TNever :: T

+ Morley.Michelson.Untyped.Type: TOperation :: T

+ Morley.Michelson.Untyped.Type: TOption :: Ty -> T

+ Morley.Michelson.Untyped.Type: TOr :: FieldAnn -> FieldAnn -> Ty -> Ty -> T

+ Morley.Michelson.Untyped.Type: TPair :: FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> Ty -> Ty -> T

+ Morley.Michelson.Untyped.Type: TSet :: Ty -> T

+ Morley.Michelson.Untyped.Type: TSignature :: T

+ Morley.Michelson.Untyped.Type: TString :: T

+ Morley.Michelson.Untyped.Type: TTicket :: Ty -> T

+ Morley.Michelson.Untyped.Type: TTimestamp :: T

+ Morley.Michelson.Untyped.Type: TUnit :: T

+ Morley.Michelson.Untyped.Type: Ty :: ~T -> TypeAnn -> Ty

+ Morley.Michelson.Untyped.Type: data ParameterType

+ Morley.Michelson.Untyped.Type: data T

+ Morley.Michelson.Untyped.Type: data Ty

+ Morley.Michelson.Untyped.Type: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance Data.Data.Data Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance Data.Data.Data Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance Data.Data.Data Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance Formatting.Buildable.Buildable Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance GHC.Classes.Eq Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance GHC.Classes.Eq Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance GHC.Classes.Eq Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance GHC.Generics.Generic Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance GHC.Generics.Generic Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance GHC.Generics.Generic Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance GHC.Show.Show Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance GHC.Show.Show Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance GHC.Show.Show Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance Language.Haskell.TH.Syntax.Lift Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance Language.Haskell.TH.Syntax.Lift Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance Language.Haskell.TH.Syntax.Lift Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: instance Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Printer.Util.Prettier Morley.Michelson.Untyped.Type.ParameterType)

+ Morley.Michelson.Untyped.Type: instance Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Printer.Util.Prettier Morley.Michelson.Untyped.Type.Ty)

+ Morley.Michelson.Untyped.Type: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Untyped.Type.ParameterType

+ Morley.Michelson.Untyped.Type: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Untyped.Type.T

+ Morley.Michelson.Untyped.Type: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Michelson.Untyped.Type.Ty

+ Morley.Michelson.Untyped.Type: isAtomicType :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isBool :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isBytes :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isComparable :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isInt :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isInteger :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isKey :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isKeyHash :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isMutez :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isNat :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isSignature :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isString :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: isTimestamp :: Ty -> Bool

+ Morley.Michelson.Untyped.Type: renderType :: T -> Bool -> RenderContext -> AnnotationSet -> Doc

+ Morley.Michelson.Untyped.Type: toption :: Ty -> T

+ Morley.Michelson.Untyped.Type: tor :: Ty -> Ty -> T

+ Morley.Michelson.Untyped.Type: tpair :: Ty -> Ty -> T

+ Morley.Michelson.Untyped.Type: tyImplicitAccountParam :: Ty

+ Morley.Michelson.Untyped.Type: tybool :: Ty

+ Morley.Michelson.Untyped.Type: tyint :: Ty

+ Morley.Michelson.Untyped.Type: tynat :: Ty

+ Morley.Michelson.Untyped.Type: tyor :: Ty -> Ty -> Ty

+ Morley.Michelson.Untyped.Type: typair :: Ty -> Ty -> Ty

+ Morley.Michelson.Untyped.Type: tyunit :: Ty

+ Morley.Michelson.Untyped.Type: unwrapT :: Ty -> T

+ Morley.Michelson.Untyped.Value: Elt :: Value' op -> Value' op -> Elt op

+ Morley.Michelson.Untyped.Value: InternalByteString :: ByteString -> InternalByteString

+ Morley.Michelson.Untyped.Value: ValueBytes :: InternalByteString -> Value' op

+ Morley.Michelson.Untyped.Value: ValueFalse :: Value' op

+ Morley.Michelson.Untyped.Value: ValueInt :: Integer -> Value' op

+ Morley.Michelson.Untyped.Value: ValueLambda :: NonEmpty op -> Value' op

+ Morley.Michelson.Untyped.Value: ValueLeft :: Value' op -> Value' op

+ Morley.Michelson.Untyped.Value: ValueMap :: (NonEmpty $ Elt op) -> Value' op

+ Morley.Michelson.Untyped.Value: ValueNil :: Value' op

+ Morley.Michelson.Untyped.Value: ValueNone :: Value' op

+ Morley.Michelson.Untyped.Value: ValuePair :: Value' op -> Value' op -> Value' op

+ Morley.Michelson.Untyped.Value: ValueRight :: Value' op -> Value' op

+ Morley.Michelson.Untyped.Value: ValueSeq :: (NonEmpty $ Value' op) -> Value' op

+ Morley.Michelson.Untyped.Value: ValueSome :: Value' op -> Value' op

+ Morley.Michelson.Untyped.Value: ValueString :: MText -> Value' op

+ Morley.Michelson.Untyped.Value: ValueTrue :: Value' op

+ Morley.Michelson.Untyped.Value: ValueUnit :: Value' op

+ Morley.Michelson.Untyped.Value: data Elt op

+ Morley.Michelson.Untyped.Value: data Value' op

+ Morley.Michelson.Untyped.Value: instance Control.DeepSeq.NFData Morley.Michelson.Untyped.Value.InternalByteString

+ Morley.Michelson.Untyped.Value: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance Control.DeepSeq.NFData op => Control.DeepSeq.NFData (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Michelson.Untyped.Value.InternalByteString

+ Morley.Michelson.Untyped.Value: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance Data.Aeson.Types.FromJSON.FromJSON op => Data.Aeson.Types.FromJSON.FromJSON (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Michelson.Untyped.Value.InternalByteString

+ Morley.Michelson.Untyped.Value: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance Data.Aeson.Types.ToJSON.ToJSON op => Data.Aeson.Types.ToJSON.ToJSON (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance Data.Data.Data Morley.Michelson.Untyped.Value.InternalByteString

+ Morley.Michelson.Untyped.Value: instance Data.Data.Data op => Data.Data.Data (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance Data.Data.Data op => Data.Data.Data (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance GHC.Base.Functor Morley.Michelson.Untyped.Value.Elt

+ Morley.Michelson.Untyped.Value: instance GHC.Base.Functor Morley.Michelson.Untyped.Value.Value'

+ Morley.Michelson.Untyped.Value: instance GHC.Classes.Eq Morley.Michelson.Untyped.Value.InternalByteString

+ Morley.Michelson.Untyped.Value: instance GHC.Classes.Eq op => GHC.Classes.Eq (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance GHC.Classes.Eq op => GHC.Classes.Eq (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance GHC.Generics.Generic (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance GHC.Generics.Generic (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance GHC.Generics.Generic Morley.Michelson.Untyped.Value.InternalByteString

+ Morley.Michelson.Untyped.Value: instance GHC.Show.Show Morley.Michelson.Untyped.Value.InternalByteString

+ Morley.Michelson.Untyped.Value: instance GHC.Show.Show op => GHC.Show.Show (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance GHC.Show.Show op => GHC.Show.Show (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance Morley.Michelson.Printer.Util.RenderDoc op => Formatting.Buildable.Buildable (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance Morley.Michelson.Printer.Util.RenderDoc op => Formatting.Buildable.Buildable (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: instance Morley.Michelson.Printer.Util.RenderDoc op => Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Untyped.Value.Elt op)

+ Morley.Michelson.Untyped.Value: instance Morley.Michelson.Printer.Util.RenderDoc op => Morley.Michelson.Printer.Util.RenderDoc (Morley.Michelson.Untyped.Value.Value' op)

+ Morley.Michelson.Untyped.Value: linearizeRightCombValuePair :: Value' op -> NonEmpty (Value' op)

+ Morley.Michelson.Untyped.Value: newtype InternalByteString

+ Morley.Michelson.Untyped.Value: renderElt' :: (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc

+ Morley.Michelson.Untyped.Value: renderLeft :: RenderContext -> (RenderContext -> Doc) -> Doc

+ Morley.Michelson.Untyped.Value: renderNone :: Doc

+ Morley.Michelson.Untyped.Value: renderPair :: RenderContext -> (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc

+ Morley.Michelson.Untyped.Value: renderRight :: RenderContext -> (RenderContext -> Doc) -> Doc

+ Morley.Michelson.Untyped.Value: renderSome :: RenderContext -> (RenderContext -> Doc) -> Doc

+ Morley.Michelson.Untyped.Value: renderValuesList :: (e -> Doc) -> NonEmpty e -> Doc

+ Morley.Michelson.Untyped.Value: unInternalByteString :: InternalByteString -> ByteString

+ Morley.Tezos.Address: ContractAddress :: ContractHash -> Address

+ Morley.Tezos.Address: ContractHash :: ByteString -> ContractHash

+ Morley.Tezos.Address: GlobalCounter :: Word64 -> GlobalCounter

+ Morley.Tezos.Address: KeyAddress :: KeyHash -> Address

+ Morley.Tezos.Address: ParseAddressBothFailed :: CryptoParseError -> ParseContractAddressError -> ParseAddressError

+ Morley.Tezos.Address: ParseAddressRawInvalidPrefix :: ByteString -> ParseAddressRawError

+ Morley.Tezos.Address: ParseAddressRawMalformedSeparator :: ByteString -> ParseAddressRawError

+ Morley.Tezos.Address: ParseAddressRawWrongSize :: ByteString -> ParseAddressRawError

+ Morley.Tezos.Address: ParseAddressWrongBase58Check :: ParseAddressError

+ Morley.Tezos.Address: ParseContractAddressWrongBase58Check :: ParseContractAddressError

+ Morley.Tezos.Address: ParseContractAddressWrongPrefix :: ByteString -> ParseContractAddressError

+ Morley.Tezos.Address: ParseContractAddressWrongSize :: ByteString -> ParseContractAddressError

+ Morley.Tezos.Address: [unGlobalCounter] :: GlobalCounter -> Word64

+ Morley.Tezos.Address: data Address

+ Morley.Tezos.Address: data ParseAddressError

+ Morley.Tezos.Address: data ParseAddressRawError

+ Morley.Tezos.Address: data ParseContractAddressError

+ Morley.Tezos.Address: detGenKeyAddress :: ByteString -> Address

+ Morley.Tezos.Address: formatAddress :: Address -> Text

+ Morley.Tezos.Address: instance (TypeError ...) => Data.String.IsString Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Control.DeepSeq.NFData Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Control.DeepSeq.NFData Morley.Tezos.Address.ContractHash

+ Morley.Tezos.Address: instance Control.DeepSeq.NFData Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance Control.DeepSeq.NFData Morley.Tezos.Address.ParseAddressError

+ Morley.Tezos.Address: instance Control.DeepSeq.NFData Morley.Tezos.Address.ParseAddressRawError

+ Morley.Tezos.Address: instance Control.DeepSeq.NFData Morley.Tezos.Address.ParseContractAddressError

+ Morley.Tezos.Address: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance Data.Aeson.Types.FromJSON.FromJSONKey Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance Data.Aeson.Types.ToJSON.ToJSONKey Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Data.Hashable.Class.Hashable Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance Formatting.Buildable.Buildable Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Formatting.Buildable.Buildable Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance Formatting.Buildable.Buildable Morley.Tezos.Address.ParseAddressError

+ Morley.Tezos.Address: instance Formatting.Buildable.Buildable Morley.Tezos.Address.ParseAddressRawError

+ Morley.Tezos.Address: instance Formatting.Buildable.Buildable Morley.Tezos.Address.ParseContractAddressError

+ Morley.Tezos.Address: instance GHC.Classes.Eq Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance GHC.Classes.Eq Morley.Tezos.Address.ContractHash

+ Morley.Tezos.Address: instance GHC.Classes.Eq Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance GHC.Classes.Eq Morley.Tezos.Address.ParseAddressError

+ Morley.Tezos.Address: instance GHC.Classes.Eq Morley.Tezos.Address.ParseAddressRawError

+ Morley.Tezos.Address: instance GHC.Classes.Eq Morley.Tezos.Address.ParseContractAddressError

+ Morley.Tezos.Address: instance GHC.Classes.Ord Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance GHC.Classes.Ord Morley.Tezos.Address.ContractHash

+ Morley.Tezos.Address: instance GHC.Generics.Generic Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance GHC.Generics.Generic Morley.Tezos.Address.ContractHash

+ Morley.Tezos.Address: instance GHC.Generics.Generic Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance GHC.Generics.Generic Morley.Tezos.Address.ParseAddressError

+ Morley.Tezos.Address: instance GHC.Generics.Generic Morley.Tezos.Address.ParseAddressRawError

+ Morley.Tezos.Address: instance GHC.Generics.Generic Morley.Tezos.Address.ParseContractAddressError

+ Morley.Tezos.Address: instance GHC.Num.Num Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance GHC.Show.Show Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance GHC.Show.Show Morley.Tezos.Address.ContractHash

+ Morley.Tezos.Address: instance GHC.Show.Show Morley.Tezos.Address.GlobalCounter

+ Morley.Tezos.Address: instance GHC.Show.Show Morley.Tezos.Address.ParseAddressError

+ Morley.Tezos.Address: instance GHC.Show.Show Morley.Tezos.Address.ParseAddressRawError

+ Morley.Tezos.Address: instance GHC.Show.Show Morley.Tezos.Address.ParseContractAddressError

+ Morley.Tezos.Address: instance Language.Haskell.TH.Syntax.Lift Morley.Tezos.Address.Address

+ Morley.Tezos.Address: instance Language.Haskell.TH.Syntax.Lift Morley.Tezos.Address.ContractHash

+ Morley.Tezos.Address: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Tezos.Address.ParseAddressError

+ Morley.Tezos.Address: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Tezos.Address.ParseAddressRawError

+ Morley.Tezos.Address: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Tezos.Address.ParseContractAddressError

+ Morley.Tezos.Address: instance Morley.Util.CLI.HasCLReader Morley.Tezos.Address.Address

+ Morley.Tezos.Address: isKeyAddress :: Address -> Bool

+ Morley.Tezos.Address: mformatAddress :: Address -> MText

+ Morley.Tezos.Address: mkContractHashHack :: ByteString -> ContractHash

+ Morley.Tezos.Address: mkKeyAddress :: PublicKey -> Address

+ Morley.Tezos.Address: newtype ContractHash

+ Morley.Tezos.Address: newtype GlobalCounter

+ Morley.Tezos.Address: parseAddress :: Text -> Either ParseAddressError Address

+ Morley.Tezos.Address: parseAddressRaw :: ByteString -> Either ParseAddressRawError Address

+ Morley.Tezos.Address: parseContractHash :: Text -> Either ParseContractAddressError ContractHash

+ Morley.Tezos.Address: ta :: QuasiQuoter

+ Morley.Tezos.Address: unsafeParseAddress :: HasCallStack => Text -> Address

+ Morley.Tezos.Address: unsafeParseAddressRaw :: ByteString -> Address

+ Morley.Tezos.Address: unsafeParseContractHash :: HasCallStack => Text -> ContractHash

+ Morley.Tezos.Core: Timestamp :: POSIXTime -> Timestamp

+ Morley.Tezos.Core: UnsafeChainId :: ByteString -> ChainId

+ Morley.Tezos.Core: UnsafeMutez :: Word64 -> Mutez

+ Morley.Tezos.Core: [unChainId] :: ChainId -> ByteString

+ Morley.Tezos.Core: [unMutez] :: Mutez -> Word64

+ Morley.Tezos.Core: [unTimestamp] :: Timestamp -> POSIXTime

+ Morley.Tezos.Core: addMutez :: Mutez -> Mutez -> Maybe Mutez

+ Morley.Tezos.Core: chainIdLength :: Int

+ Morley.Tezos.Core: divModMutez :: Mutez -> Mutez -> Maybe (Word64, Mutez)

+ Morley.Tezos.Core: divModMutezInt :: Integral a => Mutez -> a -> Maybe (Mutez, Mutez)

+ Morley.Tezos.Core: dummyChainId :: ChainId

+ Morley.Tezos.Core: farFuture :: Timestamp

+ Morley.Tezos.Core: farPast :: Timestamp

+ Morley.Tezos.Core: formatChainId :: ChainId -> Text

+ Morley.Tezos.Core: formatTimestamp :: Timestamp -> Text

+ Morley.Tezos.Core: getCurrentTime :: IO Timestamp

+ Morley.Tezos.Core: instance Control.DeepSeq.NFData Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance Control.DeepSeq.NFData Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance Control.DeepSeq.NFData Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance Data.Data.Data Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance Data.Data.Data Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance Formatting.Buildable.Buildable Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance Formatting.Buildable.Buildable Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance Formatting.Buildable.Buildable Morley.Tezos.Core.ParseChainIdError

+ Morley.Tezos.Core: instance Formatting.Buildable.Buildable Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance GHC.Classes.Eq Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance GHC.Classes.Eq Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance GHC.Classes.Eq Morley.Tezos.Core.ParseChainIdError

+ Morley.Tezos.Core: instance GHC.Classes.Eq Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance GHC.Classes.Ord Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance GHC.Classes.Ord Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance GHC.Classes.Ord Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance GHC.Enum.Bounded Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance GHC.Enum.Enum Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance GHC.Exception.Type.Exception Morley.Tezos.Core.ParseChainIdError

+ Morley.Tezos.Core: instance GHC.Generics.Generic Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance GHC.Generics.Generic Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance GHC.Generics.Generic Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance GHC.Show.Show Morley.Tezos.Core.ChainId

+ Morley.Tezos.Core: instance GHC.Show.Show Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: instance GHC.Show.Show Morley.Tezos.Core.ParseChainIdError

+ Morley.Tezos.Core: instance GHC.Show.Show Morley.Tezos.Core.Timestamp

+ Morley.Tezos.Core: instance Morley.Util.CLI.HasCLReader Morley.Tezos.Core.Mutez

+ Morley.Tezos.Core: mformatChainId :: ChainId -> MText

+ Morley.Tezos.Core: mkChainId :: ByteString -> Maybe ChainId

+ Morley.Tezos.Core: mkMutez :: (Integral i, Bits i) => i -> Either Text Mutez

+ Morley.Tezos.Core: mulMutez :: Integral a => Mutez -> a -> Maybe Mutez

+ Morley.Tezos.Core: newtype ChainId

+ Morley.Tezos.Core: newtype Mutez

+ Morley.Tezos.Core: newtype Timestamp

+ Morley.Tezos.Core: oneMutez :: Mutez

+ Morley.Tezos.Core: parseChainId :: Text -> Either ParseChainIdError ChainId

+ Morley.Tezos.Core: parseTimestamp :: Text -> Maybe Timestamp

+ Morley.Tezos.Core: prettyTez :: Mutez -> Text

+ Morley.Tezos.Core: subMutez :: Mutez -> Mutez -> Maybe Mutez

+ Morley.Tezos.Core: timestampFromSeconds :: Integer -> Timestamp

+ Morley.Tezos.Core: timestampFromUTCTime :: UTCTime -> Timestamp

+ Morley.Tezos.Core: timestampPlusSeconds :: Timestamp -> Integer -> Timestamp

+ Morley.Tezos.Core: timestampQuote :: QuasiQuoter

+ Morley.Tezos.Core: timestampToSeconds :: Integral a => Timestamp -> a

+ Morley.Tezos.Core: timestampToUTCTime :: Timestamp -> UTCTime

+ Morley.Tezos.Core: toMutez :: Word32 -> Mutez

+ Morley.Tezos.Core: unsafeAddMutez :: HasCallStack => Mutez -> Mutez -> Mutez

+ Morley.Tezos.Core: unsafeMkChainId :: HasCallStack => ByteString -> ChainId

+ Morley.Tezos.Core: unsafeMkMutez :: HasCallStack => Word64 -> Mutez

+ Morley.Tezos.Core: unsafeMulMutez :: Mutez -> Natural -> Mutez

+ Morley.Tezos.Core: unsafeSubMutez :: HasCallStack => Mutez -> Mutez -> Mutez

+ Morley.Tezos.Core: zeroMutez :: Mutez

+ Morley.Tezos.Crypto: B58CheckWithPrefixWrongEncoding :: B58CheckWithPrefixError

+ Morley.Tezos.Crypto: B58CheckWithPrefixWrongPrefix :: ByteString -> B58CheckWithPrefixError

+ Morley.Tezos.Crypto: CryptoParseBinaryError :: Text -> CryptoParseError

+ Morley.Tezos.Crypto: CryptoParseCryptoError :: CryptoError -> CryptoParseError

+ Morley.Tezos.Crypto: CryptoParseUnexpectedLength :: Builder -> Int -> CryptoParseError

+ Morley.Tezos.Crypto: CryptoParseWrongBase58Check :: CryptoParseError

+ Morley.Tezos.Crypto: CryptoParseWrongTag :: ByteString -> CryptoParseError

+ Morley.Tezos.Crypto: KeyHash :: KeyHashTag -> ByteString -> KeyHash

+ Morley.Tezos.Crypto: KeyHashEd25519 :: KeyHashTag

+ Morley.Tezos.Crypto: KeyHashP256 :: KeyHashTag

+ Morley.Tezos.Crypto: KeyHashSecp256k1 :: KeyHashTag

+ Morley.Tezos.Crypto: PublicKeyEd25519 :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto: PublicKeyP256 :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto: PublicKeySecp256k1 :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto: SecretKeyEd25519 :: SecretKey -> SecretKey

+ Morley.Tezos.Crypto: SecretKeyP256 :: SecretKey -> SecretKey

+ Morley.Tezos.Crypto: SecretKeySecp256k1 :: SecretKey -> SecretKey

+ Morley.Tezos.Crypto: SignatureEd25519 :: Signature -> Signature

+ Morley.Tezos.Crypto: SignatureGeneric :: ByteString -> Signature

+ Morley.Tezos.Crypto: SignatureP256 :: Signature -> Signature

+ Morley.Tezos.Crypto: SignatureSecp256k1 :: Signature -> Signature

+ Morley.Tezos.Crypto: [khBytes] :: KeyHash -> ByteString

+ Morley.Tezos.Crypto: [khTag] :: KeyHash -> KeyHashTag

+ Morley.Tezos.Crypto: blake2b :: ByteString -> ByteString

+ Morley.Tezos.Crypto: blake2b160 :: ByteString -> ByteString

+ Morley.Tezos.Crypto: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

+ Morley.Tezos.Crypto: data B58CheckWithPrefixError

+ Morley.Tezos.Crypto: data Bls12381Fr

+ Morley.Tezos.Crypto: data Bls12381G1

+ Morley.Tezos.Crypto: data Bls12381G2

+ Morley.Tezos.Crypto: data CryptoParseError

+ Morley.Tezos.Crypto: data KeyHash

+ Morley.Tezos.Crypto: data KeyHashTag

+ Morley.Tezos.Crypto: data PublicKey

+ Morley.Tezos.Crypto: data SecretKey

+ Morley.Tezos.Crypto: data Signature

+ Morley.Tezos.Crypto: decodeBase58Check :: Text -> Maybe ByteString

+ Morley.Tezos.Crypto: decodeBase58CheckWithPrefix :: ByteString -> Text -> Either B58CheckWithPrefixError ByteString

+ Morley.Tezos.Crypto: detSecretKey :: HasCallStack => ByteString -> SecretKey

+ Morley.Tezos.Crypto: encodeBase58Check :: ByteString -> Text

+ Morley.Tezos.Crypto: formatKeyHash :: KeyHash -> Text

+ Morley.Tezos.Crypto: formatPublicKey :: PublicKey -> Text

+ Morley.Tezos.Crypto: formatSecretKey :: SecretKey -> Text

+ Morley.Tezos.Crypto: formatSignature :: Signature -> Text

+ Morley.Tezos.Crypto: hashKey :: PublicKey -> KeyHash

+ Morley.Tezos.Crypto: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.SecretKey

+ Morley.Tezos.Crypto: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.FromJSON.FromJSONKey Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance Data.Aeson.Types.ToJSON.ToJSONKey Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.ParseSignatureRawError

+ Morley.Tezos.Crypto: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.SecretKey

+ Morley.Tezos.Crypto: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance GHC.Classes.Eq Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance GHC.Classes.Eq Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance GHC.Classes.Eq Morley.Tezos.Crypto.ParseSignatureRawError

+ Morley.Tezos.Crypto: instance GHC.Classes.Eq Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance GHC.Classes.Eq Morley.Tezos.Crypto.SecretKey

+ Morley.Tezos.Crypto: instance GHC.Classes.Eq Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance GHC.Classes.Ord Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance GHC.Classes.Ord Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance GHC.Classes.Ord Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance GHC.Classes.Ord Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance GHC.Enum.Bounded Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance GHC.Enum.Enum Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance GHC.Generics.Generic Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance GHC.Generics.Generic Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance GHC.Generics.Generic Morley.Tezos.Crypto.ParseSignatureRawError

+ Morley.Tezos.Crypto: instance GHC.Generics.Generic Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance GHC.Generics.Generic Morley.Tezos.Crypto.SecretKey

+ Morley.Tezos.Crypto: instance GHC.Generics.Generic Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance GHC.Show.Show Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance GHC.Show.Show Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance GHC.Show.Show Morley.Tezos.Crypto.ParseSignatureRawError

+ Morley.Tezos.Crypto: instance GHC.Show.Show Morley.Tezos.Crypto.PublicKey

+ Morley.Tezos.Crypto: instance GHC.Show.Show Morley.Tezos.Crypto.SecretKey

+ Morley.Tezos.Crypto: instance GHC.Show.Show Morley.Tezos.Crypto.Signature

+ Morley.Tezos.Crypto: instance Language.Haskell.TH.Syntax.Lift Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Language.Haskell.TH.Syntax.Lift Morley.Tezos.Crypto.KeyHashTag

+ Morley.Tezos.Crypto: instance Morley.Util.CLI.HasCLReader Morley.Tezos.Crypto.KeyHash

+ Morley.Tezos.Crypto: instance Morley.Util.CLI.HasCLReader Morley.Tezos.Crypto.SecretKey

+ Morley.Tezos.Crypto: keccak :: ByteString -> ByteString

+ Morley.Tezos.Crypto: keyDecoders :: [TaggedDecoder PublicKey]

+ Morley.Tezos.Crypto: keyHashDecoders :: [TaggedDecoder KeyHash]

+ Morley.Tezos.Crypto: keyHashLengthBytes :: Integral n => n

+ Morley.Tezos.Crypto: mformatKeyHash :: KeyHash -> MText

+ Morley.Tezos.Crypto: mformatPublicKey :: PublicKey -> MText

+ Morley.Tezos.Crypto: mformatSignature :: Signature -> MText

+ Morley.Tezos.Crypto: mkSignature :: ByteArray ba => ba -> Maybe Signature

+ Morley.Tezos.Crypto: parseKeyHash :: Text -> Either CryptoParseError KeyHash

+ Morley.Tezos.Crypto: parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash

+ Morley.Tezos.Crypto: parsePublicKey :: Text -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto: parsePublicKeyRaw :: ByteString -> Either Text PublicKey

+ Morley.Tezos.Crypto: parseSecretKey :: Text -> Either CryptoParseError SecretKey

+ Morley.Tezos.Crypto: parseSignature :: Text -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto: parseSignatureRaw :: ByteString -> Either ParseSignatureRawError Signature

+ Morley.Tezos.Crypto: sha256 :: ByteString -> ByteString

+ Morley.Tezos.Crypto: sha3 :: ByteString -> ByteString

+ Morley.Tezos.Crypto: sha512 :: ByteString -> ByteString

+ Morley.Tezos.Crypto: sign :: MonadRandom m => SecretKey -> ByteString -> m Signature

+ Morley.Tezos.Crypto: signatureLengthBytes :: HasCallStack => Integral n => n

+ Morley.Tezos.Crypto: signatureToBytes :: ByteArray ba => Signature -> ba

+ Morley.Tezos.Crypto: toPublic :: SecretKey -> PublicKey

+ Morley.Tezos.Crypto: unsafeParseKeyHash :: HasCallStack => Text -> KeyHash

+ Morley.Tezos.Crypto.BLS12381: CompressedFormIsNotSupported :: DeserializationError

+ Morley.Tezos.Crypto.BLS12381: PointNotOnCurve :: ByteString -> DeserializationError

+ Morley.Tezos.Crypto.BLS12381: TooLargeLength :: ("limit" :! Int) -> ("given" :! Int) -> DeserializationError

+ Morley.Tezos.Crypto.BLS12381: UnexpectedLength :: ("expected" :! Int) -> ("given" :! Int) -> DeserializationError

+ Morley.Tezos.Crypto.BLS12381: ValueOutsideOfField :: Integer -> DeserializationError

+ Morley.Tezos.Crypto.BLS12381: add :: CurveObject a => a -> a -> a

+ Morley.Tezos.Crypto.BLS12381: checkPairing :: [(Bls12381G1, Bls12381G2)] -> Bool

+ Morley.Tezos.Crypto.BLS12381: class CurveObject a

+ Morley.Tezos.Crypto.BLS12381: class MultiplyPoint scalar point

+ Morley.Tezos.Crypto.BLS12381: data Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: data Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: data Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: data DeserializationError

+ Morley.Tezos.Crypto.BLS12381: fromMichelsonBytes :: CurveObject a => ByteString -> Either DeserializationError a

+ Morley.Tezos.Crypto.BLS12381: g1One :: Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: g2One :: Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: generate :: (CurveObject a, MonadRandom m) => m a

+ Morley.Tezos.Crypto.BLS12381: generateFrom :: CurveObject a => Int -> a

+ Morley.Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.BLS12381.Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.BLS12381.Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.BLS12381.DeserializationError

+ Morley.Tezos.Crypto.BLS12381: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.BLS12381.DeserializationError

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Morley.Tezos.Crypto.BLS12381.Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Morley.Tezos.Crypto.BLS12381.Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Classes.Eq Morley.Tezos.Crypto.BLS12381.DeserializationError

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Classes.Ord Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Enum.Bounded Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Enum.Enum Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Generics.Generic Morley.Tezos.Crypto.BLS12381.DeserializationError

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Num.Num Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Real.Fractional Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Real.Integral Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Real.Real Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Show.Show Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Show.Show Morley.Tezos.Crypto.BLS12381.Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Show.Show Morley.Tezos.Crypto.BLS12381.Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: instance GHC.Show.Show Morley.Tezos.Crypto.BLS12381.DeserializationError

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Tezos.Crypto.BLS12381.DeserializationError

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Tezos.Crypto.BLS12381.CurveObject Morley.Tezos.Crypto.BLS12381.Bls12381Fr

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Tezos.Crypto.BLS12381.CurveObject Morley.Tezos.Crypto.BLS12381.Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Tezos.Crypto.BLS12381.CurveObject Morley.Tezos.Crypto.BLS12381.Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Tezos.Crypto.BLS12381.MultiplyPoint GHC.Integer.Type.Integer Morley.Tezos.Crypto.BLS12381.Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Tezos.Crypto.BLS12381.MultiplyPoint GHC.Integer.Type.Integer Morley.Tezos.Crypto.BLS12381.Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Tezos.Crypto.BLS12381.MultiplyPoint Morley.Tezos.Crypto.BLS12381.Bls12381Fr Morley.Tezos.Crypto.BLS12381.Bls12381G1

+ Morley.Tezos.Crypto.BLS12381: instance Morley.Tezos.Crypto.BLS12381.MultiplyPoint Morley.Tezos.Crypto.BLS12381.Bls12381Fr Morley.Tezos.Crypto.BLS12381.Bls12381G2

+ Morley.Tezos.Crypto.BLS12381: multiply :: MultiplyPoint scalar point => scalar -> point -> point

+ Morley.Tezos.Crypto.BLS12381: negate :: CurveObject a => a -> a

+ Morley.Tezos.Crypto.BLS12381: toMichelsonBytes :: CurveObject a => a -> ByteString

+ Morley.Tezos.Crypto.BLS12381: unsafeFromMichelsonBytes :: (CurveObject a, HasCallStack) => ByteString -> a

+ Morley.Tezos.Crypto.BLS12381: unsafeReadFromHex :: (CurveObject a, HasCallStack) => String -> a

+ Morley.Tezos.Crypto.BLS12381: zero :: CurveObject a => a

+ Morley.Tezos.Crypto.Ed25519: PublicKey :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto.Ed25519: Signature :: Signature -> Signature

+ Morley.Tezos.Crypto.Ed25519: [unPublicKey] :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto.Ed25519: [unSignature] :: Signature -> Signature

+ Morley.Tezos.Crypto.Ed25519: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

+ Morley.Tezos.Crypto.Ed25519: data SecretKey

+ Morley.Tezos.Crypto.Ed25519: detSecretKey :: ByteString -> SecretKey

+ Morley.Tezos.Crypto.Ed25519: formatPublicKey :: PublicKey -> Text

+ Morley.Tezos.Crypto.Ed25519: formatSecretKey :: SecretKey -> Text

+ Morley.Tezos.Crypto.Ed25519: formatSignature :: Signature -> Text

+ Morley.Tezos.Crypto.Ed25519: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Ed25519.PublicKey

+ Morley.Tezos.Crypto.Ed25519: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Ed25519.SecretKey

+ Morley.Tezos.Crypto.Ed25519: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Ed25519.Signature

+ Morley.Tezos.Crypto.Ed25519: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Ed25519.PublicKey

+ Morley.Tezos.Crypto.Ed25519: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Ed25519.SecretKey

+ Morley.Tezos.Crypto.Ed25519: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Ed25519.Signature

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Classes.Eq Morley.Tezos.Crypto.Ed25519.PublicKey

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Classes.Eq Morley.Tezos.Crypto.Ed25519.SecretKey

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Classes.Eq Morley.Tezos.Crypto.Ed25519.Signature

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Classes.Ord Morley.Tezos.Crypto.Ed25519.PublicKey

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Generics.Generic Morley.Tezos.Crypto.Ed25519.PublicKey

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Generics.Generic Morley.Tezos.Crypto.Ed25519.SecretKey

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Generics.Generic Morley.Tezos.Crypto.Ed25519.Signature

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Show.Show Morley.Tezos.Crypto.Ed25519.PublicKey

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Show.Show Morley.Tezos.Crypto.Ed25519.SecretKey

+ Morley.Tezos.Crypto.Ed25519: instance GHC.Show.Show Morley.Tezos.Crypto.Ed25519.Signature

+ Morley.Tezos.Crypto.Ed25519: mformatPublicKey :: PublicKey -> MText

+ Morley.Tezos.Crypto.Ed25519: mformatSignature :: Signature -> MText

+ Morley.Tezos.Crypto.Ed25519: mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto.Ed25519: mkSignature :: ByteArrayAccess ba => ba -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto.Ed25519: newtype PublicKey

+ Morley.Tezos.Crypto.Ed25519: newtype Signature

+ Morley.Tezos.Crypto.Ed25519: parsePublicKey :: Text -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto.Ed25519: parseSecretKey :: Text -> Either CryptoParseError SecretKey

+ Morley.Tezos.Crypto.Ed25519: parseSignature :: Text -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto.Ed25519: publicKeyLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n

+ Morley.Tezos.Crypto.Ed25519: publicKeyToBytes :: ByteArray ba => PublicKey -> ba

+ Morley.Tezos.Crypto.Ed25519: sign :: SecretKey -> ByteString -> Signature

+ Morley.Tezos.Crypto.Ed25519: signatureLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n

+ Morley.Tezos.Crypto.Ed25519: signatureToBytes :: ByteArray ba => Signature -> ba

+ Morley.Tezos.Crypto.Ed25519: toPublic :: SecretKey -> PublicKey

+ Morley.Tezos.Crypto.Hash: blake2b :: ByteString -> ByteString

+ Morley.Tezos.Crypto.Hash: blake2b160 :: ByteString -> ByteString

+ Morley.Tezos.Crypto.Hash: keccak :: ByteString -> ByteString

+ Morley.Tezos.Crypto.Hash: sha256 :: ByteString -> ByteString

+ Morley.Tezos.Crypto.Hash: sha3 :: ByteString -> ByteString

+ Morley.Tezos.Crypto.Hash: sha512 :: ByteString -> ByteString

+ Morley.Tezos.Crypto.P256: PublicKey :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto.P256: Signature :: Signature -> Signature

+ Morley.Tezos.Crypto.P256: [unPublicKey] :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto.P256: [unSignature] :: Signature -> Signature

+ Morley.Tezos.Crypto.P256: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

+ Morley.Tezos.Crypto.P256: data SecretKey

+ Morley.Tezos.Crypto.P256: detSecretKey :: ByteString -> SecretKey

+ Morley.Tezos.Crypto.P256: detSecretKeyDo :: MonadRandom m => m SecretKey

+ Morley.Tezos.Crypto.P256: formatPublicKey :: PublicKey -> Text

+ Morley.Tezos.Crypto.P256: formatSecretKey :: SecretKey -> Text

+ Morley.Tezos.Crypto.P256: formatSignature :: Signature -> Text

+ Morley.Tezos.Crypto.P256: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.P256.PublicKey

+ Morley.Tezos.Crypto.P256: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.P256.SecretKey

+ Morley.Tezos.Crypto.P256: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.P256.Signature

+ Morley.Tezos.Crypto.P256: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.P256.PublicKey

+ Morley.Tezos.Crypto.P256: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.P256.SecretKey

+ Morley.Tezos.Crypto.P256: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.P256.Signature

+ Morley.Tezos.Crypto.P256: instance GHC.Classes.Eq Morley.Tezos.Crypto.P256.PublicKey

+ Morley.Tezos.Crypto.P256: instance GHC.Classes.Eq Morley.Tezos.Crypto.P256.SecretKey

+ Morley.Tezos.Crypto.P256: instance GHC.Classes.Eq Morley.Tezos.Crypto.P256.Signature

+ Morley.Tezos.Crypto.P256: instance GHC.Classes.Ord Morley.Tezos.Crypto.P256.PublicKey

+ Morley.Tezos.Crypto.P256: instance GHC.Generics.Generic Morley.Tezos.Crypto.P256.PublicKey

+ Morley.Tezos.Crypto.P256: instance GHC.Generics.Generic Morley.Tezos.Crypto.P256.SecretKey

+ Morley.Tezos.Crypto.P256: instance GHC.Generics.Generic Morley.Tezos.Crypto.P256.Signature

+ Morley.Tezos.Crypto.P256: instance GHC.Show.Show Morley.Tezos.Crypto.P256.PublicKey

+ Morley.Tezos.Crypto.P256: instance GHC.Show.Show Morley.Tezos.Crypto.P256.SecretKey

+ Morley.Tezos.Crypto.P256: instance GHC.Show.Show Morley.Tezos.Crypto.P256.Signature

+ Morley.Tezos.Crypto.P256: mformatPublicKey :: PublicKey -> MText

+ Morley.Tezos.Crypto.P256: mformatSignature :: Signature -> MText

+ Morley.Tezos.Crypto.P256: mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto.P256: mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto.P256: newtype PublicKey

+ Morley.Tezos.Crypto.P256: newtype Signature

+ Morley.Tezos.Crypto.P256: parsePublicKey :: Text -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto.P256: parseSecretKey :: Text -> Either CryptoParseError SecretKey

+ Morley.Tezos.Crypto.P256: parseSignature :: Text -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto.P256: publicKeyLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n

+ Morley.Tezos.Crypto.P256: publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba

+ Morley.Tezos.Crypto.P256: sign :: MonadRandom m => SecretKey -> ByteString -> m Signature

+ Morley.Tezos.Crypto.P256: signatureLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n

+ Morley.Tezos.Crypto.P256: signatureToBytes :: ByteArray ba => Signature -> ba

+ Morley.Tezos.Crypto.P256: toPublic :: SecretKey -> PublicKey

+ Morley.Tezos.Crypto.Secp256k1: PublicKey :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto.Secp256k1: Signature :: Signature -> Signature

+ Morley.Tezos.Crypto.Secp256k1: [unPublicKey] :: PublicKey -> PublicKey

+ Morley.Tezos.Crypto.Secp256k1: [unSignature] :: Signature -> Signature

+ Morley.Tezos.Crypto.Secp256k1: checkSignature :: PublicKey -> Signature -> ByteString -> Bool

+ Morley.Tezos.Crypto.Secp256k1: data SecretKey

+ Morley.Tezos.Crypto.Secp256k1: detSecretKey :: ByteString -> SecretKey

+ Morley.Tezos.Crypto.Secp256k1: detSecretKeyDo :: MonadRandom m => m SecretKey

+ Morley.Tezos.Crypto.Secp256k1: formatPublicKey :: PublicKey -> Text

+ Morley.Tezos.Crypto.Secp256k1: formatSecretKey :: SecretKey -> Text

+ Morley.Tezos.Crypto.Secp256k1: formatSignature :: Signature -> Text

+ Morley.Tezos.Crypto.Secp256k1: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Secp256k1.PublicKey

+ Morley.Tezos.Crypto.Secp256k1: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Secp256k1.SecretKey

+ Morley.Tezos.Crypto.Secp256k1: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Secp256k1.Signature

+ Morley.Tezos.Crypto.Secp256k1: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Secp256k1.PublicKey

+ Morley.Tezos.Crypto.Secp256k1: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Secp256k1.SecretKey

+ Morley.Tezos.Crypto.Secp256k1: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Secp256k1.Signature

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Classes.Eq Morley.Tezos.Crypto.Secp256k1.PublicKey

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Classes.Eq Morley.Tezos.Crypto.Secp256k1.SecretKey

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Classes.Eq Morley.Tezos.Crypto.Secp256k1.Signature

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Classes.Ord Morley.Tezos.Crypto.Secp256k1.PublicKey

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Generics.Generic Morley.Tezos.Crypto.Secp256k1.PublicKey

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Generics.Generic Morley.Tezos.Crypto.Secp256k1.SecretKey

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Generics.Generic Morley.Tezos.Crypto.Secp256k1.Signature

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Show.Show Morley.Tezos.Crypto.Secp256k1.PublicKey

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Show.Show Morley.Tezos.Crypto.Secp256k1.SecretKey

+ Morley.Tezos.Crypto.Secp256k1: instance GHC.Show.Show Morley.Tezos.Crypto.Secp256k1.Signature

+ Morley.Tezos.Crypto.Secp256k1: mformatPublicKey :: PublicKey -> MText

+ Morley.Tezos.Crypto.Secp256k1: mformatSignature :: Signature -> MText

+ Morley.Tezos.Crypto.Secp256k1: mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto.Secp256k1: mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto.Secp256k1: newtype PublicKey

+ Morley.Tezos.Crypto.Secp256k1: newtype Signature

+ Morley.Tezos.Crypto.Secp256k1: parsePublicKey :: Text -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto.Secp256k1: parseSecretKey :: Text -> Either CryptoParseError SecretKey

+ Morley.Tezos.Crypto.Secp256k1: parseSignature :: Text -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto.Secp256k1: publicKeyLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n

+ Morley.Tezos.Crypto.Secp256k1: publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba

+ Morley.Tezos.Crypto.Secp256k1: sign :: MonadRandom m => SecretKey -> ByteString -> m Signature

+ Morley.Tezos.Crypto.Secp256k1: signatureLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n

+ Morley.Tezos.Crypto.Secp256k1: signatureToBytes :: ByteArray ba => Signature -> ba

+ Morley.Tezos.Crypto.Secp256k1: toPublic :: SecretKey -> PublicKey

+ Morley.Tezos.Crypto.Util: B58CheckWithPrefixWrongEncoding :: B58CheckWithPrefixError

+ Morley.Tezos.Crypto.Util: B58CheckWithPrefixWrongPrefix :: ByteString -> B58CheckWithPrefixError

+ Morley.Tezos.Crypto.Util: CryptoParseBinaryError :: Text -> CryptoParseError

+ Morley.Tezos.Crypto.Util: CryptoParseCryptoError :: CryptoError -> CryptoParseError

+ Morley.Tezos.Crypto.Util: CryptoParseUnexpectedLength :: Builder -> Int -> CryptoParseError

+ Morley.Tezos.Crypto.Util: CryptoParseWrongBase58Check :: CryptoParseError

+ Morley.Tezos.Crypto.Util: CryptoParseWrongTag :: ByteString -> CryptoParseError

+ Morley.Tezos.Crypto.Util: data B58CheckWithPrefixError

+ Morley.Tezos.Crypto.Util: data CryptoParseError

+ Morley.Tezos.Crypto.Util: decodeBase58Check :: Text -> Maybe ByteString

+ Morley.Tezos.Crypto.Util: decodeBase58CheckWithPrefix :: ByteString -> Text -> Either B58CheckWithPrefixError ByteString

+ Morley.Tezos.Crypto.Util: deterministic :: ByteString -> MonadPseudoRandom ChaChaDRG a -> a

+ Morley.Tezos.Crypto.Util: encodeBase58Check :: ByteString -> Text

+ Morley.Tezos.Crypto.Util: firstRight :: NonEmpty (Either e a) -> Either e a

+ Morley.Tezos.Crypto.Util: formatImpl :: ByteArrayAccess x => ByteString -> x -> Text

+ Morley.Tezos.Crypto.Util: instance Control.DeepSeq.NFData Morley.Tezos.Crypto.Util.CryptoParseError

+ Morley.Tezos.Crypto.Util: instance Formatting.Buildable.Buildable Morley.Tezos.Crypto.Util.CryptoParseError

+ Morley.Tezos.Crypto.Util: instance GHC.Classes.Eq Morley.Tezos.Crypto.Util.CryptoParseError

+ Morley.Tezos.Crypto.Util: instance GHC.Show.Show Morley.Tezos.Crypto.Util.B58CheckWithPrefixError

+ Morley.Tezos.Crypto.Util: instance GHC.Show.Show Morley.Tezos.Crypto.Util.CryptoParseError

+ Morley.Tezos.Crypto.Util: instance Morley.Michelson.Printer.Util.RenderDoc Morley.Tezos.Crypto.Util.CryptoParseError

+ Morley.Tezos.Crypto.Util: mkPublicKey_ :: ByteArrayAccess ba => Curve -> ba -> Either CryptoParseError PublicKey

+ Morley.Tezos.Crypto.Util: mkSecretKey_ :: ByteArray ba => Curve -> ba -> KeyPair

+ Morley.Tezos.Crypto.Util: mkSignature_ :: ByteArray ba => Curve -> ba -> Either CryptoParseError Signature

+ Morley.Tezos.Crypto.Util: parseImpl :: ByteString -> (ByteString -> Either CryptoParseError res) -> Text -> Either CryptoParseError res

+ Morley.Tezos.Crypto.Util: publicKeyLengthBytes_ :: (Integral n, IsIntSubType Int n ~ 'True) => Curve -> n

+ Morley.Tezos.Crypto.Util: publicKeyToBytes_ :: forall ba. (ByteArray ba, HasCallStack) => Curve -> PublicKey -> ba

+ Morley.Tezos.Crypto.Util: rnfCurve :: Curve -> ()

+ Morley.Tezos.Crypto.Util: secretKeyToBytes_ :: ByteArray ba => KeyPair -> ba

+ Morley.Tezos.Crypto.Util: signatureLengthBytes_ :: (Integral n, IsIntSubType Int n ~ 'True) => Curve -> n

+ Morley.Tezos.Crypto.Util: signatureToBytes_ :: ByteArray ba => Curve -> Signature -> ba

+ Morley.Util.Aeson: morleyAesonOptions :: Options

+ Morley.Util.Binary: (#:) :: Word8 -> Get a -> TaggedDecoder a

+ Morley.Util.Binary: TaggedDecoder :: Word8 -> Get a -> TaggedDecoder a

+ Morley.Util.Binary: UnpackError :: Text -> UnpackError

+ Morley.Util.Binary: [tdDecoder] :: TaggedDecoder a -> Get a

+ Morley.Util.Binary: [tdTag] :: TaggedDecoder a -> Word8

+ Morley.Util.Binary: [unUnpackError] :: UnpackError -> Text

+ Morley.Util.Binary: data TaggedDecoder a

+ Morley.Util.Binary: decodeBytesLike :: Buildable err => String -> (ByteString -> Either err a) -> Get a

+ Morley.Util.Binary: decodeWithTag :: String -> [TaggedDecoder a] -> Get a

+ Morley.Util.Binary: ensureEnd :: Get ()

+ Morley.Util.Binary: getByteStringCopy :: Int -> Get ByteString

+ Morley.Util.Binary: getRemainingByteStringCopy :: Get ByteString

+ Morley.Util.Binary: infixr 0 #:

+ Morley.Util.Binary: instance Formatting.Buildable.Buildable Morley.Util.Binary.UnpackError

+ Morley.Util.Binary: instance GHC.Classes.Eq Morley.Util.Binary.UnpackError

+ Morley.Util.Binary: instance GHC.Exception.Type.Exception Morley.Util.Binary.UnpackError

+ Morley.Util.Binary: instance GHC.Show.Show Morley.Util.Binary.UnpackError

+ Morley.Util.Binary: launchGet :: Get a -> LByteString -> Either UnpackError a

+ Morley.Util.Binary: newtype UnpackError

+ Morley.Util.Binary: unknownTag :: String -> Word8 -> Get a

+ Morley.Util.ByteString: HexJSONByteString :: ByteString -> HexJSONByteString

+ Morley.Util.ByteString: [unHexJSONByteString] :: HexJSONByteString -> ByteString

+ Morley.Util.ByteString: instance Control.DeepSeq.NFData Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: instance Data.Hashable.Class.Hashable Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: instance GHC.Classes.Eq Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: instance GHC.Classes.Ord Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: instance GHC.Generics.Generic Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: instance GHC.Show.Show Morley.Util.ByteString.HexJSONByteString

+ Morley.Util.ByteString: newtype HexJSONByteString

+ Morley.Util.CLI: class HasCLReader a

+ Morley.Util.CLI: eitherReader :: (String -> Either String a) -> ReadM a

+ Morley.Util.CLI: getMetavar :: HasCLReader a => String

+ Morley.Util.CLI: getReader :: HasCLReader a => ReadM a

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader Data.Text.Internal.Text

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Base.String

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Int.Int16

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Int.Int32

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Int.Int64

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Int.Int8

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Integer.Type.Integer

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Natural.Natural

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Types.Int

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Types.Word

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Word.Word16

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Word.Word32

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Word.Word64

+ Morley.Util.CLI: instance Morley.Util.CLI.HasCLReader GHC.Word.Word8

+ Morley.Util.CLI: integralReader :: (Integral a, Bits a) => ReadM a

+ Morley.Util.CLI: maybeAddDefault :: HasValue f => (a -> String) -> Maybe a -> Mod f a

+ Morley.Util.CLI: mkCLArgumentParser :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("help" :! String) -> Parser a

+ Morley.Util.CLI: mkCLArgumentParserExt :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("help" :! String) -> [Mod ArgumentFields a] -> Parser a

+ Morley.Util.CLI: mkCLOptionParser :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a

+ Morley.Util.CLI: mkCLOptionParserExt :: forall a. (Buildable a, HasCLReader a) => Maybe a -> ("name" :! String) -> ("help" :! String) -> [Mod OptionFields a] -> Parser a

+ Morley.Util.CLI: mkCommandParser :: String -> Parser a -> String -> Mod CommandFields a

+ Morley.Util.CLI: namedParser :: forall (a :: Type) (name :: Symbol). (Buildable a, HasCLReader a, KnownSymbol name) => Maybe a -> String -> Parser (name :! a)

+ Morley.Util.CLI: outputOption :: Parser (Maybe FilePath)

+ Morley.Util.CLI: readerError :: String -> ReadM a

+ Morley.Util.CustomGeneric: alphabetically :: EntriesReorder

+ Morley.Util.CustomGeneric: cstr :: forall n. KnownNat n => [Natural] -> CstrDepth

+ Morley.Util.CustomGeneric: customGeneric :: String -> GenericStrategy -> Q [Dec]

+ Morley.Util.CustomGeneric: customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]

+ Morley.Util.CustomGeneric: data GenericStrategy

+ Morley.Util.CustomGeneric: deriveFullType :: Name -> Maybe Kind -> [TyVarBndr] -> TypeQ

+ Morley.Util.CustomGeneric: fld :: forall n. KnownNat n => Natural

+ Morley.Util.CustomGeneric: forbidUnnamedFields :: UnnamedEntriesReorder

+ Morley.Util.CustomGeneric: fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy

+ Morley.Util.CustomGeneric: haskellBalanced :: GenericStrategy

+ Morley.Util.CustomGeneric: leaveUnnamedFields :: UnnamedEntriesReorder

+ Morley.Util.CustomGeneric: leftBalanced :: GenericStrategy

+ Morley.Util.CustomGeneric: leftComb :: GenericStrategy

+ Morley.Util.CustomGeneric: reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])

+ Morley.Util.CustomGeneric: reorderingConstrs :: EntriesReorder -> GenericStrategy -> GenericStrategy

+ Morley.Util.CustomGeneric: reorderingData :: UnnamedEntriesReorder -> EntriesReorder -> GenericStrategy -> GenericStrategy

+ Morley.Util.CustomGeneric: reorderingFields :: UnnamedEntriesReorder -> EntriesReorder -> GenericStrategy -> GenericStrategy

+ Morley.Util.CustomGeneric: rightBalanced :: GenericStrategy

+ Morley.Util.CustomGeneric: rightComb :: GenericStrategy

+ Morley.Util.CustomGeneric: withDepths :: [CstrDepth] -> GenericStrategy

+ Morley.Util.Default: class Default a

+ Morley.Util.Default: def :: Default a => a

+ Morley.Util.Default: permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a, b)

+ Morley.Util.Default: permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) => f a -> f b -> f c -> f (a, b, c)

+ Morley.Util.Exception: throwLeft :: (MonadThrow m, Exception e) => m (Either e a) -> m a

+ Morley.Util.Fcf: data (<|>) :: f a -> f a -> Exp (f a)

+ Morley.Util.Fcf: data ApplyConstraints :: [a -> Constraint] -> a -> Exp Constraint

+ Morley.Util.Fcf: data Over2 :: (a -> b -> Exp r) -> (x -> Exp a) -> (x -> Exp b) -> x -> Exp r

+ Morley.Util.Fcf: data TyEqSing :: a -> b -> Exp Bool

+ Morley.Util.Fcf: type family Eval (e :: Exp a) :: a

+ Morley.Util.Generic: mkGenericTree :: (Natural -> a -> a -> a) -> NonEmpty a -> a

+ Morley.Util.Generic: mkGenericTreeVec :: HasCallStack => (a -> b) -> (Natural -> b -> b -> b) -> Vector a -> b

+ Morley.Util.Generic: type GenericTypeName a = GTypeName (Rep a)

+ Morley.Util.Instances: instance Data.Default.Class.Default GHC.Natural.Natural

+ Morley.Util.Instances: instance Formatting.Buildable.Buildable GHC.Natural.Natural

+ Morley.Util.Instances: instance Formatting.Buildable.Buildable a => Formatting.Buildable.Buildable (Data.Functor.Identity.Identity a)

+ Morley.Util.Interpolate: i :: QuasiQuoter

+ Morley.Util.Interpolate: ib :: QuasiQuoter

+ Morley.Util.Interpolate: instance GHC.Classes.Eq Morley.Util.Interpolate.Transformation

+ Morley.Util.Interpolate: instance GHC.Classes.Ord Morley.Util.Interpolate.Transformation

+ Morley.Util.Interpolate: instance GHC.Enum.Bounded Morley.Util.Interpolate.Transformation

+ Morley.Util.Interpolate: instance GHC.Enum.Enum Morley.Util.Interpolate.Transformation

+ Morley.Util.Interpolate: it :: QuasiQuoter

+ Morley.Util.Interpolate: itb :: QuasiQuoter

+ Morley.Util.Interpolate: itu :: QuasiQuoter

+ Morley.Util.Interpolate: itub :: QuasiQuoter

+ Morley.Util.Interpolate: iu :: QuasiQuoter

+ Morley.Util.Interpolate: iub :: QuasiQuoter

+ Morley.Util.Interpolate: li :: QuasiQuoter

+ Morley.Util.Interpolate: lib :: QuasiQuoter

+ Morley.Util.Interpolate: lit :: QuasiQuoter

+ Morley.Util.Interpolate: litb :: QuasiQuoter

+ Morley.Util.Interpolate: litu :: QuasiQuoter

+ Morley.Util.Interpolate: litub :: QuasiQuoter

+ Morley.Util.Interpolate: liu :: QuasiQuoter

+ Morley.Util.Interpolate: liub :: QuasiQuoter

+ Morley.Util.Label: [Label] :: KnownSymbol name => Label name

+ Morley.Util.Label: class IsLabel (x :: Symbol) a

+ Morley.Util.Label: data Label (name :: Symbol)

+ Morley.Util.Label: fromLabel :: IsLabel x a => a

+ Morley.Util.Label: instance (GHC.TypeLits.KnownSymbol name, s GHC.Types.~ name) => GHC.OverloadedLabels.IsLabel s (Morley.Util.Label.Label name)

+ Morley.Util.Label: instance Formatting.Buildable.Buildable (Morley.Util.Label.Label name)

+ Morley.Util.Label: instance GHC.Classes.Eq (Morley.Util.Label.Label name)

+ Morley.Util.Label: instance GHC.Show.Show (Morley.Util.Label.Label name)

+ Morley.Util.Label: labelToText :: Label name -> Text

+ Morley.Util.Lens: makeLensesWith :: LensRules -> Name -> DecsQ

+ Morley.Util.Lens: postfixLFields :: LensRules

+ Morley.Util.Main: wrapMain :: IO () -> IO ()

+ Morley.Util.Markdown: Anchor :: Text -> Anchor

+ Morley.Util.Markdown: HeaderLevel :: Int -> HeaderLevel

+ Morley.Util.Markdown: [unAnchor] :: Anchor -> Text

+ Morley.Util.Markdown: class ToAnchor anchor

+ Morley.Util.Markdown: instance Data.String.IsString Morley.Util.Markdown.Anchor

+ Morley.Util.Markdown: instance Morley.Util.Markdown.ToAnchor Data.Text.Internal.Text

+ Morley.Util.Markdown: instance Morley.Util.Markdown.ToAnchor Morley.Util.Markdown.Anchor

+ Morley.Util.Markdown: md :: QuasiQuoter

+ Morley.Util.Markdown: mdAnchor :: ToAnchor anchor => anchor -> Markdown

+ Morley.Util.Markdown: mdBold :: Markdown -> Markdown

+ Morley.Util.Markdown: mdComment :: Builder -> Builder

+ Morley.Util.Markdown: mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown

+ Morley.Util.Markdown: mdHeader :: HeaderLevel -> Markdown -> Markdown

+ Morley.Util.Markdown: mdItalic :: Markdown -> Markdown

+ Morley.Util.Markdown: mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown

+ Morley.Util.Markdown: mdRef :: Markdown -> Markdown -> Markdown

+ Morley.Util.Markdown: mdSeparator :: Markdown

+ Morley.Util.Markdown: mdSpoiler :: Markdown -> Markdown -> Markdown

+ Morley.Util.Markdown: mdSubsection :: Markdown -> Markdown -> Markdown

+ Morley.Util.Markdown: mdSubsectionTitle :: Markdown -> Markdown

+ Morley.Util.Markdown: mdTicked :: Markdown -> Markdown

+ Morley.Util.Markdown: mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown

+ Morley.Util.Markdown: newtype Anchor

+ Morley.Util.Markdown: newtype HeaderLevel

+ Morley.Util.Markdown: nextHeaderLevel :: HeaderLevel -> HeaderLevel

+ Morley.Util.Markdown: toAnchor :: ToAnchor anchor => anchor -> Anchor

+ Morley.Util.Markdown: type Markdown = Builder

+ Morley.Util.Named: (!) :: WithParam p fn fn' => fn -> Param p -> fn'

+ Morley.Util.Named: (<:!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)

+ Morley.Util.Named: (<:?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)

+ Morley.Util.Named: ArgF :: f a -> NamedF (f :: Type -> Type) a (name :: Symbol)

+ Morley.Util.Named: Name :: Name (name :: Symbol)

+ Morley.Util.Named: argDef :: forall (name :: Symbol) a. Name name -> a -> (name :? a) -> a

+ Morley.Util.Named: class KnownNamedFunctor f

+ Morley.Util.Named: data Name (name :: Symbol)

+ Morley.Util.Named: infixl 4 <:?>

+ Morley.Util.Named: infixl 9 !

+ Morley.Util.Named: instance (Data.Typeable.Internal.Typeable f, Data.Typeable.Internal.Typeable a, GHC.TypeLits.KnownSymbol name, Data.Data.Data (f a)) => Data.Data.Data (Named.Internal.NamedF f a name)

+ Morley.Util.Named: instance (GHC.Show.Show a, GHC.TypeLits.KnownSymbol name) => GHC.Show.Show (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

+ Morley.Util.Named: instance (GHC.TypeLits.KnownSymbol name, Formatting.Buildable.Buildable (f a)) => Formatting.Buildable.Buildable (Named.Internal.NamedF f a name)

+ Morley.Util.Named: instance Control.DeepSeq.NFData (f a) => Control.DeepSeq.NFData (Named.Internal.NamedF f a name)

+ Morley.Util.Named: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

+ Morley.Util.Named: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Named.Internal.NamedF GHC.Maybe.Maybe a name)

+ Morley.Util.Named: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Named.Internal.NamedF Data.Functor.Identity.Identity a name)

+ Morley.Util.Named: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Named.Internal.NamedF GHC.Maybe.Maybe a name)

+ Morley.Util.Named: instance GHC.Classes.Eq (f a) => GHC.Classes.Eq (Named.Internal.NamedF f a name)

+ Morley.Util.Named: instance GHC.Classes.Ord (f a) => GHC.Classes.Ord (Named.Internal.NamedF f a name)

+ Morley.Util.Named: instance Morley.Util.Named.KnownNamedFunctor Data.Functor.Identity.Identity

+ Morley.Util.Named: instance Morley.Util.Named.KnownNamedFunctor GHC.Maybe.Maybe

+ Morley.Util.Named: namedL :: KnownNamedFunctor f => Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a)

+ Morley.Util.Named: newtype NamedF (f :: Type -> Type) a (name :: Symbol)

+ Morley.Util.Named: pattern (:?) :: Name name -> Maybe a -> NamedF Maybe a name

+ Morley.Util.Named: pattern Arg :: a -> name :! a

+ Morley.Util.Named: pattern M :: Maybe a -> NamedF Maybe a name

+ Morley.Util.Named: pattern N :: a -> NamedF Identity a name

+ Morley.Util.Named: pattern NoArg :: NamedF Maybe a name

+ Morley.Util.Named: pattern SomeArg :: a -> NamedF Maybe a name

+ Morley.Util.Named: type (name :: Symbol) :? a = NamedF Maybe a name

+ Morley.Util.Named: type family NamedInner (n :: Type)

+ Morley.Util.Peano: S :: !Nat -> Nat

+ Morley.Util.Peano: Z :: Nat

+ Morley.Util.Peano: [SS] :: !SingNat n -> SingNat ('S n)

+ Morley.Util.Peano: [SZ] :: SingNat 'Z

+ Morley.Util.Peano: class (RequireLongerOrSameLength' l a, LongerOrSameLength l a) => RequireLongerOrSameLength (l :: [k]) (a :: Peano)

+ Morley.Util.Peano: class (RequireLongerThan' l a, LongerThan l a) => RequireLongerThan (l :: [k]) (a :: Peano)

+ Morley.Util.Peano: data Nat

+ Morley.Util.Peano: data SingNat (n :: Nat)

+ Morley.Util.Peano: instance Control.DeepSeq.NFData (Morley.Util.Peano.SingNat n)

+ Morley.Util.Peano: instance Data.Singletons.Internal.SingI 'Data.Vinyl.TypeLevel.Z

+ Morley.Util.Peano: instance Data.Singletons.Internal.SingI n => Data.Singletons.Internal.SingI ('Data.Vinyl.TypeLevel.S n)

+ Morley.Util.Peano: instance GHC.Classes.Eq (Morley.Util.Peano.SingNat n)

+ Morley.Util.Peano: instance GHC.Show.Show (Morley.Util.Peano.SingNat n)

+ Morley.Util.Peano: instance forall k (l :: [k]) (a :: Data.Vinyl.TypeLevel.Nat). (Morley.Util.Peano.RequireLongerThan' l a, Morley.Util.Peano.LongerThan l a) => Morley.Util.Peano.RequireLongerThan l a

+ Morley.Util.Peano: instance forall k (l :: [k]) (a :: Morley.Util.Peano.Peano). (Morley.Util.Peano.RequireLongerOrSameLength' l a, Morley.Util.Peano.LongerOrSameLength l a) => Morley.Util.Peano.RequireLongerOrSameLength l a

+ Morley.Util.Peano: instance forall k (l :: [k]) (a :: Morley.Util.Peano.Peano). Morley.Util.Type.MockableConstraint (Morley.Util.Peano.RequireLongerOrSameLength l a)

+ Morley.Util.Peano: instance forall k (l :: [k]) (a :: Morley.Util.Peano.Peano). Morley.Util.Type.MockableConstraint (Morley.Util.Peano.RequireLongerThan l a)

+ Morley.Util.Peano: isGreaterEqualThan :: Sing a -> Sing b -> Maybe (Dict ((a >= b) ~ 'True))

+ Morley.Util.Peano: isGreaterThan :: Sing a -> Sing b -> Maybe (Dict ((a > b) ~ 'True))

+ Morley.Util.Peano: peanoSing :: forall (n :: Nat). SingI (ToPeano n) => SingNat (ToPeano n)

+ Morley.Util.Peano: peanoSingDecrement :: Sing n -> Maybe (Sing (Decrement n))

+ Morley.Util.Peano: requireLongerOrSameLength :: Rec any stk -> Sing n -> Maybe (Dict (RequireLongerOrSameLength stk n))

+ Morley.Util.Peano: requireLongerThan :: Rec any stk -> Sing n -> Maybe (Dict (RequireLongerThan stk n))

+ Morley.Util.Peano: type LongerOrSameLength l a = IsLongerOrSameLength l a ~ 'True

+ Morley.Util.Peano: type LongerThan l a = IsLongerThan l a ~ 'True

+ Morley.Util.Peano: type Peano = Nat

+ Morley.Util.Peano: type family IsLongerOrSameLength (l :: [k]) (a :: Peano) :: Bool

+ Morley.Util.PeanoNatural: data PeanoNatural (n :: Nat)

+ Morley.Util.PeanoNatural: fromPeanoNatural :: forall n. PeanoNatural n -> Natural

+ Morley.Util.PeanoNatural: instance Control.DeepSeq.NFData (Morley.Util.PeanoNatural.PeanoNatural n)

+ Morley.Util.PeanoNatural: instance GHC.Classes.Eq (Morley.Util.PeanoNatural.PeanoNatural n)

+ Morley.Util.PeanoNatural: instance GHC.Show.Show (Morley.Util.PeanoNatural.PeanoNatural n)

+ Morley.Util.PeanoNatural: instance Morley.Michelson.Printer.Util.RenderDoc (Morley.Util.PeanoNatural.PeanoNatural n)

+ Morley.Util.PeanoNatural: pattern Two :: () => n ~ 'S ('S 'Z) => PeanoNatural n

+ Morley.Util.PeanoNatural: singPeanoVal :: forall (n :: Nat). SingNat n -> Natural

+ Morley.Util.PeanoNatural: toPeanoNatural :: forall n. SingI n => PeanoNatural n

+ Morley.Util.PeanoNatural: toPeanoNatural' :: forall (n :: Nat). SingI (ToPeano n) => PeanoNatural (ToPeano n)

+ Morley.Util.Positive: UnsafePositive :: Natural -> Positive

+ Morley.Util.Positive: [unPositive] :: Positive -> Natural

+ Morley.Util.Positive: instance Control.DeepSeq.NFData Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance Data.Aeson.Types.FromJSON.FromJSON Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance Data.Aeson.Types.ToJSON.ToJSON Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance Data.Data.Data Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance Formatting.Buildable.Buildable Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance GHC.Classes.Eq Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance GHC.Classes.Ord Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance GHC.Generics.Generic Morley.Util.Positive.Positive

+ Morley.Util.Positive: instance GHC.Show.Show Morley.Util.Positive.Positive

+ Morley.Util.Positive: lengthNE :: NonEmpty a -> Positive

+ Morley.Util.Positive: mkPositive :: forall i. (Integral i, Buildable i) => i -> Either Text Positive

+ Morley.Util.Positive: newtype Positive

+ Morley.Util.Positive: replicateNE :: Positive -> a -> NonEmpty a

+ Morley.Util.Sing: castSing :: forall a b t. (SingI a, SingI b, SDecide (KindOf a)) => t a -> Maybe (t b)

+ Morley.Util.Sing: class SingI1 f

+ Morley.Util.Sing: eqI :: forall a b. (SingI a, SingI b, TestEquality (Sing @(KindOf a))) => Maybe (a :~: b)

+ Morley.Util.Sing: eqParamSing :: forall a1 a2 t. (SingI a1, SingI a2, SDecide (KindOf a1), Eq (t a1)) => t a1 -> t a2 -> Bool

+ Morley.Util.Sing: eqParamSing2 :: forall a1 a2 b1 b2 t. (SingI a1, SingI a2, SingI b1, SingI b2, SDecide (KindOf a1), SDecide (KindOf b1), Eq (t a1 b2)) => t a1 b1 -> t a2 b2 -> Bool

+ Morley.Util.Sing: eqParamSing3 :: forall instr1 instr2 a1 a2 b1 b2 t. (Typeable instr1, Typeable instr2, SingI a1, SingI a2, SingI b1, SingI b2, SDecide (KindOf a1), SDecide (KindOf b1), Eq (t instr1 a1 b1)) => t instr1 a1 b1 -> t instr2 a2 b2 -> Bool

+ Morley.Util.Sing: withSingI1 :: forall x r. (SingI1 f, SingI x) => (SingI (f x) => r) -> r

+ Morley.Util.TH: deriveGADTNFData :: Name -> Q [Dec]

+ Morley.Util.TH: isTypeAlias :: Name -> Q Bool

+ Morley.Util.TH: lookupTypeNameOrFail :: String -> Q Name

+ Morley.Util.Text: dquotes :: (Semigroup a, IsString a) => a -> a

+ Morley.Util.Text: headToLower :: HasCallStack => Text -> Text

+ Morley.Util.Text: surround :: Semigroup a => a -> a -> a -> a

+ Morley.Util.Type: Some1 :: f a -> Some1 (f :: k -> Type)

+ Morley.Util.Type: [KCons] :: KnownList xs => Proxy x -> Proxy xs -> KList (x : xs)

+ Morley.Util.Type: [KNil] :: KList '[]

+ Morley.Util.Type: class KnownList l

+ Morley.Util.Type: class MockableConstraint (c :: Constraint)

+ Morley.Util.Type: class ReifyList (c :: k -> Constraint) (l :: [k])

+ Morley.Util.Type: data KList (l :: [k])

+ Morley.Util.Type: data Some1 (f :: k -> Type)

+ Morley.Util.Type: failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True)

+ Morley.Util.Type: failWhenEvi :: forall cond msg. FailWhen cond msg :- (cond ~ 'False)

+ Morley.Util.Type: infix 4 ==

+ Morley.Util.Type: instance (Morley.Util.Type.MockableConstraint c1, Morley.Util.Type.MockableConstraint c2) => Morley.Util.Type.MockableConstraint (c1, c2)

+ Morley.Util.Type: instance (Morley.Util.Type.MockableConstraint c1, Morley.Util.Type.MockableConstraint c2, Morley.Util.Type.MockableConstraint c3) => Morley.Util.Type.MockableConstraint (c1, c2, c3)

+ Morley.Util.Type: instance (Morley.Util.Type.MockableConstraint c1, Morley.Util.Type.MockableConstraint c2, Morley.Util.Type.MockableConstraint c3, Morley.Util.Type.MockableConstraint c4) => Morley.Util.Type.MockableConstraint (c1, c2, c3, c4)

+ Morley.Util.Type: instance (Morley.Util.Type.MockableConstraint c1, Morley.Util.Type.MockableConstraint c2, Morley.Util.Type.MockableConstraint c3, Morley.Util.Type.MockableConstraint c4, Morley.Util.Type.MockableConstraint c5) => Morley.Util.Type.MockableConstraint (c1, c2, c3, c4, c5)

+ Morley.Util.Type: instance Morley.Util.Type.KnownList '[]

+ Morley.Util.Type: instance forall a (c :: a -> GHC.Types.Constraint) (x :: a) (xs :: [a]). (c x, Morley.Util.Type.ReifyList c xs) => Morley.Util.Type.ReifyList c (x : xs)

+ Morley.Util.Type: instance forall k (a :: k) (b :: k). Morley.Util.Type.MockableConstraint (a GHC.Types.~ b)

+ Morley.Util.Type: instance forall k (c :: k -> GHC.Types.Constraint) (a :: k). c a => Morley.Util.Type.MockableConstraint (c a)

+ Morley.Util.Type: instance forall k (c :: k -> GHC.Types.Constraint). Morley.Util.Type.ReifyList c '[]

+ Morley.Util.Type: instance forall k (f :: k -> *). (forall (a :: k). GHC.Show.Show (f a)) => GHC.Show.Show (Morley.Util.Type.Some1 f)

+ Morley.Util.Type: instance forall k (xs :: [k]) (x :: k). Morley.Util.Type.KnownList xs => Morley.Util.Type.KnownList (x : xs)

+ Morley.Util.Type: klist :: KnownList l => KList l

+ Morley.Util.Type: listOfTypesConcatAssociativityAxiom :: forall a b c. Dict (ConcatListOfTypesAssociativity a b c)

+ Morley.Util.Type: onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c

+ Morley.Util.Type: recordToSomeList :: Rec f l -> [Some1 f]

+ Morley.Util.Type: reifyList :: ReifyList c l => (forall a. c a => Proxy a -> r) -> [r]

+ Morley.Util.Type: reifyTypeEquality :: forall a b x. (a == b) ~ 'True => (a ~ b => x) -> x

+ Morley.Util.Type: rsplit :: forall k (l :: [k]) (r :: [k]) f. RSplit l r => Rec f (l ++ r) -> (Rec f l, Rec f r)

+ Morley.Util.Type: type ConcatListOfTypesAssociativity a b c = ((a ++ b) ++ c) ~ (a ++ (b ++ c))

+ Morley.Util.Type: type FailWhen cond msg = FailUnless (Not cond) msg

+ Morley.Util.Type: type RSplit l r = KnownList l

+ Morley.Util.Type: type RequireAllUnique desc l = RequireAllUnique' desc l l

+ Morley.Util.Type: type family PatternMatchL (l :: [k]) :: Constraint

+ Morley.Util.Type: unsafeProvideConstraint :: MockableConstraint c => Dict c

+ Morley.Util.TypeLits: (:$$:) :: ErrorMessage -> ErrorMessage -> ErrorMessage

+ Morley.Util.TypeLits: (:<>:) :: ErrorMessage -> ErrorMessage -> ErrorMessage

+ Morley.Util.TypeLits: ShowType :: t -> ErrorMessage

+ Morley.Util.TypeLits: Text :: Symbol -> ErrorMessage

+ Morley.Util.TypeLits: class KnownSymbol (n :: Symbol)

+ Morley.Util.TypeLits: data ErrorMessage

+ Morley.Util.TypeLits: data Symbol

+ Morley.Util.TypeLits: infixl 5 :$$:

+ Morley.Util.TypeLits: infixl 6 :<>:

+ Morley.Util.TypeLits: symbolVal :: forall (n :: Symbol) proxy. KnownSymbol n => proxy n -> String

+ Morley.Util.TypeLits: symbolValT :: forall s. KnownSymbol s => Proxy s -> Text

+ Morley.Util.TypeLits: symbolValT' :: forall s. KnownSymbol s => Text

+ Morley.Util.TypeLits: type AssertTypesEqual a b (err :: ErrorMessage) = (TypeErrorUnlessHelper (a == b) err, a ~ b)

+ Morley.Util.TypeLits: type TypeErrorUnless (cond :: Bool) (err :: ErrorMessage) = (TypeErrorUnlessHelper cond err, cond ~ 'True)

+ Morley.Util.TypeLits: type family TypeError (a :: ErrorMessage) :: b

+ Morley.Util.TypeTuple: class RecFromTuple r where {

+ Morley.Util.TypeTuple: recFromTuple :: RecFromTuple r => IsoRecTuple r -> r

+ Morley.Util.TypeTuple: type family IsoRecTuple r :: Type;

+ Morley.Util.TypeTuple: }

+ Morley.Util.TypeTuple.Class: class RecFromTuple r where {

+ Morley.Util.TypeTuple.Class: recFromTuple :: RecFromTuple r => IsoRecTuple r -> r

+ Morley.Util.TypeTuple.Class: type family IsoRecTuple r :: Type;

+ Morley.Util.TypeTuple.Class: }

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (a :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[a])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u) (x23 :: u) (x24 :: u) (x25 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u) (x23 :: u) (x24 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u) (x23 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u) (x22 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u) (x21 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u) (x20 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u) (x19 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u) (x18 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u) (x17 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u) (x16 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u) (x15 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u) (x13 :: u) (x14 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u) (x12 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u) (x11 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u) (x10 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u) (x9 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8, x9])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u) (x8 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7, x8])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u) (x7 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6, x7])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u) (x6 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5, x6])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u) (x5 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4, x5])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u) (x4 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3, x4])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u) (x3 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2, x3])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *) (x1 :: u) (x2 :: u). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[x1, x2])

+ Morley.Util.TypeTuple.Instances: instance forall u (f :: u -> *). Morley.Util.TypeTuple.Class.RecFromTuple (Data.Vinyl.Core.Rec f '[])

+ Morley.Util.TypeTuple.TH: deriveRecFromTuple :: Word16 -> Q [Dec]

+ Morley.Util.Typeable: [Refl] :: forall k (a :: k). a :~: a

+ Morley.Util.Typeable: castIgnoringPhantom :: forall c x. (Typeable x, Typeable c, forall phantom1 phantom2. Coercible (c phantom1) (c phantom2)) => x -> Maybe (c DummyPhantomType)

+ Morley.Util.Typeable: compareExt :: forall a1 a2. (Typeable a1, Typeable a2, Ord a1) => a1 -> a2 -> Ordering

+ Morley.Util.Typeable: data (a :: k) :~: (b :: k)

+ Morley.Util.Typeable: eqExt :: forall a1 a2. (Typeable a1, Typeable a2, Eq a1) => a1 -> a2 -> Bool

+ Morley.Util.Typeable: eqParam1 :: forall a1 a2 t. (Typeable a1, Typeable a2, Eq (t a1)) => t a1 -> t a2 -> Bool

+ Morley.Util.Typeable: eqParam2 :: forall a1 a2 b1 b2 t. (Typeable a1, Typeable a2, Typeable b1, Typeable b2, Eq (t a1 b2)) => t a1 b1 -> t a2 b2 -> Bool

+ Morley.Util.Typeable: eqParam3 :: forall a1 a2 b1 b2 c1 c2 t. (Typeable a1, Typeable a2, Typeable b1, Typeable b2, Typeable c1, Typeable c2, Eq (t a1 b1 c1)) => t a1 b1 c1 -> t a2 b2 c2 -> Bool

+ Morley.Util.Typeable: eqT :: forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b)

+ Morley.Util.Typeable: eqTypeIgnoringPhantom :: forall c x r. (Typeable x, Typeable c) => (forall a. Typeable a => (c a :~: x) -> Proxy a -> r) -> Maybe r

+ Morley.Util.Typeable: infix 4 :~:

Files

CHANGES.md +59/−3
README.md +12/−7
app/Main.hs +32/−32
app/REPL.hs +118/−24
docs/michelsonTypes.md +3/−3
docs/morleyInterpreter.md +2/−2
docs/morleyRuntime.md +1/−1
docs/morleyTypechecker.md +4/−4
doctests/Main.hs +0/−171
morley.cabal +221/−150
src/Michelson/Analyzer.hs +0/−118
src/Michelson/Doc.hs +0/−818
src/Michelson/ErrorPos.hs +0/−90
src/Michelson/FailPattern.hs +0/−126
src/Michelson/Interpret.hs +0/−899
src/Michelson/Interpret/Pack.hs +0/−44
src/Michelson/Interpret/Unpack.hs +0/−84
src/Michelson/Interpret/Utils.hs +0/−43
src/Michelson/Let.hs +0/−31
src/Michelson/Macro.hs +0/−469
src/Michelson/Optimizer.hs +0/−553
src/Michelson/Parser.hs +0/−330
src/Michelson/Parser/Annotations.hs +0/−96
src/Michelson/Parser/Error.hs +0/−74
src/Michelson/Parser/Ext.hs +0/−72
src/Michelson/Parser/Helpers.hs +0/−51
src/Michelson/Parser/Instr.hs +0/−443
src/Michelson/Parser/Let.hs +0/−125
src/Michelson/Parser/Lexer.hs +0/−81
src/Michelson/Parser/Macro.hs +0/−169
src/Michelson/Parser/Type.hs +0/−305
src/Michelson/Parser/Types.hs +0/−34
src/Michelson/Parser/Value.hs +0/−152
src/Michelson/Preprocess.hs +0/−53
src/Michelson/Printer.hs +0/−62
src/Michelson/Printer/Util.hs +0/−156
src/Michelson/Runtime.hs +0/−741
src/Michelson/Runtime/Dummy.hs +0/−77
src/Michelson/Runtime/GState.hs +0/−415
src/Michelson/Runtime/Import.hs +0/−205
src/Michelson/Runtime/TxData.hs +0/−41
src/Michelson/Text.hs +0/−216
src/Michelson/TypeCheck.hs +0/−33
src/Michelson/TypeCheck/Error.hs +0/−366
src/Michelson/TypeCheck/Ext.hs +0/−187
src/Michelson/TypeCheck/Helpers.hs +0/−964
src/Michelson/TypeCheck/Instr.hs +0/−1717
src/Michelson/TypeCheck/TypeCheck.hs +0/−280
src/Michelson/TypeCheck/TypeCheckedOp.hs +0/−62
src/Michelson/TypeCheck/TypeCheckedSeq.hs +0/−51
src/Michelson/TypeCheck/Types.hs +0/−310
src/Michelson/TypeCheck/Value.hs +0/−387
src/Michelson/Typed.hs +0/−25
src/Michelson/Typed/Aliases.hs +0/−14
src/Michelson/Typed/Annotation.hs +0/−309
src/Michelson/Typed/Arith.hs +0/−469
src/Michelson/Typed/Convert.hs +0/−856
src/Michelson/Typed/Doc.hs +0/−157
src/Michelson/Typed/Entrypoints.hs +0/−500
src/Michelson/Typed/Existential.hs +0/−79
src/Michelson/Typed/Extract.hs +0/−219
src/Michelson/Typed/Haskell.hs +0/−14
src/Michelson/Typed/Haskell/Compatibility.hs +0/−53
src/Michelson/Typed/Haskell/Doc.hs +0/−942
src/Michelson/Typed/Haskell/Instr.hs +0/−10
src/Michelson/Typed/Haskell/Instr/Helpers.hs +0/−22
src/Michelson/Typed/Haskell/Instr/Product.hs +0/−424
src/Michelson/Typed/Haskell/Instr/Sum.hs +0/−719
src/Michelson/Typed/Haskell/LooseSum.hs +0/−129
src/Michelson/Typed/Haskell/ValidateDescription.hs +0/−134
src/Michelson/Typed/Haskell/Value.hs +0/−498
src/Michelson/Typed/Instr.hs +0/−955
src/Michelson/Typed/OpSize.hs +0/−34
src/Michelson/Typed/Origination.hs +0/−110
src/Michelson/Typed/Polymorphic.hs +0/−282
src/Michelson/Typed/Scope.hs +0/−981
src/Michelson/Typed/Sing.hs +0/−96
src/Michelson/Typed/T.hs +0/−99
src/Michelson/Typed/TypeLevel.hs +0/−59
src/Michelson/Typed/Util.hs +0/−787
src/Michelson/Typed/Value.hs +0/−484
src/Michelson/Untyped.hs +0/−17
src/Michelson/Untyped/Aliases.hs +0/−20
src/Michelson/Untyped/Annotation.hs +0/−428
src/Michelson/Untyped/Contract.hs +0/−127
src/Michelson/Untyped/Entrypoints.hs +0/−184
src/Michelson/Untyped/Ext.hs +0/−169
src/Michelson/Untyped/Instr.hs +0/−362
src/Michelson/Untyped/OpSize.hs +0/−283
src/Michelson/Untyped/Type.hs +0/−360
src/Michelson/Untyped/Value.hs +0/−135
src/Morley/CLI.hs +24/−24
src/Morley/Micheline.hs +1/−1
src/Morley/Micheline/Binary.hs +13/−11
src/Morley/Micheline/Class.hs +15/−14
src/Morley/Micheline/Expression.hs +6/−6
src/Morley/Micheline/Json.hs +5/−3
src/Morley/Michelson/Analyzer.hs +118/−0
src/Morley/Michelson/Doc.hs +819/−0
src/Morley/Michelson/ErrorPos.hs +94/−0
src/Morley/Michelson/FailPattern.hs +126/−0
src/Morley/Michelson/Interpret.hs +942/−0
src/Morley/Michelson/Interpret/Pack.hs +44/−0
src/Morley/Michelson/Interpret/Unpack.hs +84/−0
src/Morley/Michelson/Interpret/Utils.hs +44/−0
src/Morley/Michelson/Let.hs +31/−0
src/Morley/Michelson/Macro.hs +462/−0
src/Morley/Michelson/Optimizer.hs +641/−0
src/Morley/Michelson/Parser.hs +322/−0
src/Morley/Michelson/Parser/Annotations.hs +96/−0
src/Morley/Michelson/Parser/Error.hs +73/−0
src/Morley/Michelson/Parser/Ext.hs +72/−0
src/Morley/Michelson/Parser/Helpers.hs +57/−0
src/Morley/Michelson/Parser/Instr.hs +443/−0
src/Morley/Michelson/Parser/Let.hs +125/−0
src/Morley/Michelson/Parser/Lexer.hs +81/−0
src/Morley/Michelson/Parser/Macro.hs +170/−0
src/Morley/Michelson/Parser/Type.hs +307/−0
src/Morley/Michelson/Parser/Types.hs +83/−0
src/Morley/Michelson/Parser/Value.hs +173/−0
src/Morley/Michelson/Preprocess.hs +53/−0
src/Morley/Michelson/Printer.hs +62/−0
src/Morley/Michelson/Printer/Util.hs +161/−0
src/Morley/Michelson/Runtime.hs +801/−0
src/Morley/Michelson/Runtime/Dummy.hs +86/−0
src/Morley/Michelson/Runtime/GState.hs +433/−0
src/Morley/Michelson/Runtime/Import.hs +211/−0
src/Morley/Michelson/Runtime/TxData.hs +41/−0
src/Morley/Michelson/Text.hs +216/−0
src/Morley/Michelson/TypeCheck.hs +33/−0
src/Morley/Michelson/TypeCheck/Error.hs +367/−0
src/Morley/Michelson/TypeCheck/Ext.hs +187/−0
src/Morley/Michelson/TypeCheck/Helpers.hs +967/−0
src/Morley/Michelson/TypeCheck/Instr.hs +1717/−0
src/Morley/Michelson/TypeCheck/TypeCheck.hs +280/−0
src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs +62/−0
src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs +51/−0
src/Morley/Michelson/TypeCheck/Types.hs +301/−0
src/Morley/Michelson/TypeCheck/Value.hs +384/−0
src/Morley/Michelson/Typed.hs +25/−0
src/Morley/Michelson/Typed/Aliases.hs +14/−0
src/Morley/Michelson/Typed/Annotation.hs +308/−0
src/Morley/Michelson/Typed/Arith.hs +499/−0
src/Morley/Michelson/Typed/Convert.hs +939/−0
src/Morley/Michelson/Typed/Doc.hs +157/−0
src/Morley/Michelson/Typed/Entrypoints.hs +500/−0
src/Morley/Michelson/Typed/Existential.hs +83/−0
src/Morley/Michelson/Typed/Extract.hs +223/−0
src/Morley/Michelson/Typed/Haskell.hs +15/−0
src/Morley/Michelson/Typed/Haskell/Compatibility.hs +53/−0
src/Morley/Michelson/Typed/Haskell/Doc.hs +964/−0
src/Morley/Michelson/Typed/Haskell/Instr.hs +10/−0
src/Morley/Michelson/Typed/Haskell/Instr/Helpers.hs +23/−0
src/Morley/Michelson/Typed/Haskell/Instr/Product.hs +423/−0
src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs +719/−0
src/Morley/Michelson/Typed/Haskell/LooseSum.hs +129/−0
src/Morley/Michelson/Typed/Haskell/ValidateDescription.hs +135/−0
src/Morley/Michelson/Typed/Haskell/Value.hs +521/−0
src/Morley/Michelson/Typed/Instr.hs +972/−0
src/Morley/Michelson/Typed/OpSize.hs +33/−0
src/Morley/Michelson/Typed/Operation.hs +173/−0
src/Morley/Michelson/Typed/Polymorphic.hs +283/−0
src/Morley/Michelson/Typed/Scope.hs +1021/−0
src/Morley/Michelson/Typed/Sing.hs +93/−0
src/Morley/Michelson/Typed/T.hs +99/−0
src/Morley/Michelson/Typed/TypeLevel.hs +59/−0
src/Morley/Michelson/Typed/Util.hs +792/−0
src/Morley/Michelson/Typed/Value.hs +464/−0
src/Morley/Michelson/Untyped.hs +17/−0
src/Morley/Michelson/Untyped/Aliases.hs +20/−0
src/Morley/Michelson/Untyped/Annotation.hs +445/−0
src/Morley/Michelson/Untyped/Contract.hs +138/−0
src/Morley/Michelson/Untyped/Entrypoints.hs +184/−0
src/Morley/Michelson/Untyped/Ext.hs +167/−0
src/Morley/Michelson/Untyped/Instr.hs +362/−0
src/Morley/Michelson/Untyped/OpSize.hs +284/−0
src/Morley/Michelson/Untyped/Type.hs +392/−0
src/Morley/Michelson/Untyped/Value.hs +158/−0
src/Morley/Tezos/Address.hs +338/−0
src/Morley/Tezos/Core.hs +384/−0
src/Morley/Tezos/Crypto.hs +532/−0
src/Morley/Tezos/Crypto/BLS12381.hs +454/−0
src/Morley/Tezos/Crypto/Ed25519.hs +180/−0
src/Morley/Tezos/Crypto/Hash.hs +51/−0
src/Morley/Tezos/Crypto/P256.hs +201/−0
src/Morley/Tezos/Crypto/Secp256k1.hs +201/−0
src/Morley/Tezos/Crypto/Util.hs +256/−0
src/Morley/Util/Aeson.hs +17/−0
src/Morley/Util/Binary.hs +113/−0
src/Morley/Util/ByteString.hs +26/−0
src/Morley/Util/CLI.hs +228/−0
src/Morley/Util/CustomGeneric.hs +597/−0
src/Morley/Util/Default.hs +25/−0
src/Morley/Util/Exception.hs +16/−0
src/Morley/Util/Fcf.hs +31/−0
src/Morley/Util/Generic.hs +49/−0
src/Morley/Util/Instances.hs +20/−0
src/Morley/Util/Interpolate.hs +315/−0
src/Morley/Util/Label.hs +47/−0
src/Morley/Util/Lens.hs +16/−0
src/Morley/Util/Main.hs +25/−0
src/Morley/Util/Markdown.hs +158/−0
src/Morley/Util/Named.hs +125/−0
src/Morley/Util/Peano.hs +316/−0
src/Morley/Util/PeanoNatural.hs +90/−0
src/Morley/Util/Positive.hs +41/−0
src/Morley/Util/Sing.hs +93/−0
src/Morley/Util/TH.hs +64/−0
src/Morley/Util/Text.hs +26/−0
src/Morley/Util/Type.hs +239/−0
src/Morley/Util/TypeLits.hs +102/−0
src/Morley/Util/TypeTuple.hs +11/−0
src/Morley/Util/TypeTuple/Class.hs +17/−0
src/Morley/Util/TypeTuple/Instances.hs +19/−0
src/Morley/Util/TypeTuple/TH.hs +39/−0
src/Morley/Util/Typeable.hs +148/−0
src/Tezos/Address.hs +0/−347
src/Tezos/Core.hs +0/−398
src/Tezos/Crypto.hs +0/−532
src/Tezos/Crypto/BLS12381.hs +0/−455
src/Tezos/Crypto/Ed25519.hs +0/−180
src/Tezos/Crypto/Hash.hs +0/−51
src/Tezos/Crypto/P256.hs +0/−201
src/Tezos/Crypto/Secp256k1.hs +0/−201
src/Tezos/Crypto/Util.hs +0/−256
src/Util/Aeson.hs +0/−17
src/Util/Alternative.hs +0/−17
src/Util/Binary.hs +0/−113
src/Util/ByteString.hs +0/−26
src/Util/CLI.hs +0/−229
src/Util/CustomGeneric.hs +0/−594
src/Util/Default.hs +0/−25
src/Util/Exception.hs +0/−16
src/Util/Fcf.hs +0/−31
src/Util/Generic.hs +0/−48
src/Util/Instances.hs +0/−32
src/Util/Label.hs +0/−47
src/Util/Lens.hs +0/−16
src/Util/Main.hs +0/−25
src/Util/Markdown.hs +0/−156
src/Util/Named.hs +0/−89
src/Util/Num.hs +0/−19
src/Util/Peano.hs +0/−316
src/Util/PeanoNatural.hs +0/−90
src/Util/Positive.hs +0/−40
src/Util/Sing.hs +0/−93
src/Util/TH.hs +0/−57
src/Util/Text.hs +0/−22
src/Util/Type.hs +0/−239
src/Util/TypeLits.hs +0/−102
src/Util/TypeTuple.hs +0/−11
src/Util/TypeTuple/Class.hs +0/−17
src/Util/TypeTuple/Instances.hs +0/−19
src/Util/TypeTuple/TH.hs +0/−39
src/Util/Typeable.hs +0/−148

CHANGES.md view

@@ -1,9 +1,63 @@-Unreleased-==========-<!-- Append new entries here -->+<!-- Unreleased: append new entries here --> ++1.16.0+======+* [!1011](https://gitlab.com/morley-framework/morley/-/merge_requests/1011)+  Support working with delegates in the morley interpreter+  + `SET_DELEGATE` previously was a no-op. Now it emits an operation,+  which is then interpreted to set a field in the contract state.+* [!989](https://gitlab.com/morley-framework/morley/-/merge_requests/989)+  Switch from interpolate to home-grown string interpolation module+  + Adds `Morley.Util.StringInterpolation` module to `morley`.+  + Note this changes the syntax of slices in `md` quasiquoter. Before+  we could use expressions `#{expression}`, now we can only use variable+  names `#{name}`.+* [!909](https://gitlab.com/morley-framework/morley/-/merge_requests/909)+  + Add new patterns to `Morley.Util.Named` allowing to pattern-match more easily on named variables+  + Replaced import of `Named` package with `Morley.Util.Named`+* [!995](https://gitlab.com/morley-framework/morley/-/merge_requests/995)+  Allow users to save meta instructions in the typed representation.+  + New typed instruction: `Meta`, which takes some existential value that can be matched and tested with `cast`.+* [!851](https://gitlab.com/morley-framework/morley/-/merge_requests/851)+  + Make `source` argument optional in `readValue`, `readContract` and similar functions.+  + Rename `ImportContractError` and `ImportValueError` types to `ContractReadError` and `ValueReadError` respectively. Their constructors (starting from `ICE` and `VCE` are updated accordingly).+* [!971](https://gitlab.com/morley-framework/morley/-/merge_requests/971)+  Fix exponential backtracking when parsing Michelson tuple values+  + New helpers in "Morley.Michelson.Parser.Helpers": `sepBy1` and `some'`, which are versions of Megaparsec's `sepBy1` and `some` returning a `NonEmpty` instead of `[]`.+  + Removed `mparens` from "Morley.Michelson.Parser.Helpers": it happens to be unused now, and can be pretty dangerous.+  + Removed `typeWithParen` from "Morley.Michelson.Parser.Type", since it was completely equivalent to just `type_`, but its performance was slightly worse.+* [!941](https://gitlab.com/morley-framework/morley/-/merge_requests/941)+  Use pretty-printer in PRINT instruction+  + New `RenderDoc` instance for typed `Value`s without operations+  + Some places that were using `Buildable Value` instance changed to use `buildRenderDoc` to preserve `HasNoOp` constraint (where it makes sense, i.e. outside of other `Buildable` instances)+  + New `Buildable` instance for typed `Value`s, closely mirroring the behaviour of the old one, but able to print opreations via `Buildable Operation` instance.+  + Use `Fmt.pretty` instead of `show` in `PRINT` implementation+  + Use `Buildable Operation` pretty-printer for Michelson failure reports (i.e. in `Buildable MichelsonFailed` instance, used for `FAILWITH`)+* [!943](https://gitlab.com/morley-framework/morley/-/merge_requests/943)+  + Place modules below a top-level `Morley` name.+* [!918](https://gitlab.com/morley-framework/morley/-/merge_requests/918)+  + Add `pairMisc` rule which handles `PAIR :# CDR` and `PAIR :# CAR` to Optimizer+  + Add `justDoubleDrops` rule optimizing `i :# DROP` where `i :: a : b : s -> c : s` to Optimizer+  + Make `optimize` function several-staged: flatten the sequence to right-combed firstly, then apply default rules and finally perform `adjacentDrops`+  + Update documentation of Optimizer+* [!937](https://gitlab.com/morley-framework/morley/-/merge_requests/937)+  Attach source code location to interpreter error messages+  + New `Buildable InstrCallStack` instance+  + New `ceInstrCallStack :: InstrCallStack` field in `ContractEnv`+  + New `MichelsonFailureWithStack` type which is a product of `MichelsonFailed` and `InstrCallStack`, with a `Buidlable` instance+  + Changed interpreter error type from `MichelsonFailed` to `MichelsonFailureWithStack`+* [!945](https://gitlab.com/morley-framework/morley/-/merge_requests/945)+  + Bump Stackage LTS version from 17.9 to 18.10.+* [!908](https://gitlab.com/morley-framework/morley/-/merge_requests/916)+  + Remove `NFData` instance for `Rec` and require `vinyl` ≥ 0.13.1.+* [!881](https://gitlab.com/morley-framework/morley/-/merge_requests/881)+  + Rename `PrintedValScope` to `UntypedValScope` with related types and functions.+ 1.15.1 ======+* [!908](https://gitlab.com/morley-framework/morley/-/merge_requests/908)+  + Remove `NFData` constrains from `Instr` constructors * [!879](https://gitlab.com/morley-framework/morley/-/merge_requests/879)   + Add Buildable and RenderDoc instances for `Instr inp out` type.   + Instances are based on transforming `Instr inp out` to list of `ExpandedOp` and using its instance@@ -12,6 +66,8 @@  1.15.0 ======+* [!896](https://gitlab.com/morley-framework/morley/-/merge_requests/896)+  + Move `MorleyLogs` in interpreter monad to a dedicated `WriterT` layer. * [!878](https://gitlab.com/morley-framework/morley/-/merge_requests/878)   + Fixed behavior of `packValue` to match the `tezos-client hash data`     behavior.

README.md view

@@ -64,13 +64,18 @@ Morley-the library is available on [Hackage](https://hackage.haskell.org/package/morley). It consists of the following parts: -- The `Tezos.*` hierarchy ([`Tezos.Address`](http://hackage.haskell.org/package/morley/docs/Tezos-Address.html), [`Tezos.Core`](http://hackage.haskell.org/package/morley/docs/Tezos-Core.html), [`Tezos.Crypto`](http://hackage.haskell.org/package/morley/docs/Tezos-Crypto.html)) is designed to implement cryptographic primitives, string and byte formats, and any other functionality specific to the Tezos protocol which is required for testing/execution of Michelson contracts but is used not only by Michelson.-- [`Michelson.Untyped`](http://hackage.haskell.org/package/morley/docs/Michelson-Untyped.html) and [`Michelson.Typed`](http://hackage.haskell.org/package/morley/docs/Michelson-Typed.html) hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/michelsonTypes.md).-- [`Michelson.TypeCheck`](http://hackage.haskell.org/package/morley/docs/Michelson-TypeCheck.html): A typechecker that validates Michelson contracts according to the Michelson's typing rules. Essentially, it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyTypechecker.md).-- [`Michelson.Interpret`](http://hackage.haskell.org/package/morley/docs/Michelson-Interpret.html): An interpreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyInterpreter.md).-- [`Michelson.Macro`](http://hackage.haskell.org/package/morley/docs/Michelson-Macro.html) Types for macros, syntactic sugar, and other extensions that are described in the next chapter.-- [`Michelson.Parser`](http://hackage.haskell.org/package/morley/docs/Michelson-Parser.html) A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT.-- [`Michelson.Runtime`](http://hackage.haskell.org/package/morley/docs/Michelson-Runtime.html): A high-level interface to Morley functionality, see [morleyRuntime.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyRuntime.md).+- The `Morley.Tezos.*` hierarchy ([`Morley.Tezos.Address`](http://hackage.haskell.org/package/morley/docs/Tezos-Address.html), [`Morley.Tezos.Core`](http://hackage.haskell.org/package/morley/docs/Tezos-Core.html), [`Morley.Tezos.Crypto`](http://hackage.haskell.org/package/morley/docs/Tezos-Crypto.html)) is designed to implement cryptographic primitives, string and byte formats, and any other functionality specific to the Tezos protocol which is required for testing/execution of Michelson contracts but is used not only by Michelson.+- [`Morley.Michelson.Untyped`](http://hackage.haskell.org/package/morley/docs/Michelson-Untyped.html) and [`Morley.Michelson.Typed`](http://hackage.haskell.org/package/morley/docs/Michelson-Typed.html) hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/michelsonTypes.md).+- [`Morley.Michelson.TypeCheck`](http://hackage.haskell.org/package/morley/docs/Michelson-TypeCheck.html): A typechecker that validates Michelson contracts according to the Michelson's typing rules. Essentially, it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyTypechecker.md).+- [`Morley.Michelson.Interpret`](http://hackage.haskell.org/package/morley/docs/Michelson-Interpret.html): An interpreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyInterpreter.md).+- [`Morley.Michelson.Macro`](http://hackage.haskell.org/package/morley/docs/Michelson-Macro.html) Types for macros, syntactic sugar, and other extensions that are described in the next chapter.+- [`Morley.Michelson.Parser`](http://hackage.haskell.org/package/morley/docs/Michelson-Parser.html) A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT.+- [`Morley.Michelson.Runtime`](http://hackage.haskell.org/package/morley/docs/Michelson-Runtime.html): A high-level interface to Morley functionality, see [morleyRuntime.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyRuntime.md).+- The `Morley.Micheline.*` hierarchy ([`Morley.Micheline.Binary`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Binary.html), [`Morley.Micheline.Class`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Class.html),+[`Morley.Micheline.Expression`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Expression.html), [`Morley.Micheline.Json`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Json.html))+contains the representation of Micheline `Expression`s, conversion to/from Michelson values,+as well as encoding/decoding to/from JSON and binary format.+- The `Morley.Util.*` hierarchy defines various `Morley`-related utilities that are used all over the project.  ## Morley language

app/Main.hs view

@@ -9,7 +9,6 @@ import qualified Data.Text.Lazy.IO.Utf8 as Utf8 (writeFile) import Data.Version (showVersion) import Fmt (pretty)-import Named (arg, argF, (!)) import Options.Applicative   (execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc, short,   subparser, switch)@@ -17,24 +16,25 @@ import Options.Applicative.Help.Pretty (Doc, linebreak) import Paths_morley (version) -import Michelson.Analyzer (analyze)-import Michelson.Optimizer (optimize)-import Michelson.Printer (printSomeContract, printUntypedContract)-import Michelson.Runtime (TxData(..), originateContract, prepareContract, runContract, transfer)-import Michelson.Runtime.GState (genesisAddress)-import Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckingWith)-import qualified Michelson.TypeCheck as TypeCheck-import Michelson.TypeCheck.Types (mapSomeContract)-import Michelson.Typed (Contract(..), SomeContract(..))-import qualified Michelson.Untyped as U import Morley.CLI+import Morley.Michelson.Analyzer (analyze)+import Morley.Michelson.Optimizer (optimize)+import Morley.Michelson.Printer (printSomeContract, printUntypedContract)+import Morley.Michelson.Runtime+  (TxData(..), originateContract, prepareContract, runContract, transfer)+import Morley.Michelson.Runtime.GState (genesisAddress)+import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckingWith)+import qualified Morley.Michelson.TypeCheck as TypeCheck+import Morley.Michelson.TypeCheck.Types (mapSomeContract)+import Morley.Michelson.Typed (Contract(..), SomeContract(..))+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (Mutez, Timestamp(..), toMutez)+import Morley.Tezos.Crypto+import Morley.Util.CLI (mkCommandParser, outputOption)+import Morley.Util.Main (wrapMain)+import Morley.Util.Named import REPL-import Tezos.Address (Address)-import Tezos.Core (Mutez, Timestamp(..), unsafeMkMutez)-import Tezos.Crypto-import Util.CLI (mkCommandParser, outputOption)-import Util.Main (wrapMain)-import Util.Named  ---------------------------------------------------------------------------- -- Command line options@@ -120,9 +120,9 @@      printSubCmd =       mkCommandParser "print"-      (Print <$> (#input <.?> optional contractFileOption)-             <*> (#output <.?> outputOption)-             <*> (#singleLine <.!> onelineOption))+      (Print <$> (#input <:?> optional contractFileOption)+             <*> (#output <:?> outputOption)+             <*> (#singleLine <:!> onelineOption))       ("Parse a Morley contract and print corresponding Michelson " <>        "contract that can be parsed by the OCaml reference client: tezos-client") @@ -188,7 +188,7 @@       <*> typeCheckOptionsOption      defaultBalance :: Mutez-    defaultBalance = unsafeMkMutez 4000000+    defaultBalance = toMutez 4000000      optimizeOptions :: Opt.Parser OptimizeOptions     optimizeOptions = OptimizeOptions@@ -205,15 +205,15 @@         <$> optional contractFileOption         <*> dbPathOption         <*> typeCheckOptionsOption-        <*> valueOption Nothing (#name .! "storage")-            (#help .! "Initial storage of a running contract")+        <*> valueOption Nothing (#name :! "storage")+            (#help :! "Initial storage of a running contract")         <*> txDataOption         <*> verboseFlag         <*> nowOption         <*> levelOption         <*> maxStepsOption         <*> mutezOption (Just defaultBalance)-            (#name .! "balance") (#help .! "Initial balance of this contract")+            (#name :! "balance") (#help :! "Initial balance of this contract")         <*> writeFlag      originateOptions :: Opt.Parser OriginateOptions@@ -223,15 +223,15 @@         <*> dbPathOption         <*> typeCheckOptionsOption         <*> addressOption (Just genesisAddress)-            (#name .! "originator") (#help .! "Contract's originator")+            (#name :! "originator") (#help :! "Contract's originator")         <*> optional             (keyHashOption Nothing-              (#name .! "delegate") (#help .! "Contract's optional delegate")+              (#name :! "delegate") (#help :! "Contract's optional delegate")             )         <*> valueOption Nothing-            (#name .! "storage") (#help .! "Initial storage of an originating contract")+            (#name :! "storage") (#help :! "Initial storage of an originating contract")         <*> mutezOption (Just defaultBalance)-            (#name .! "balance") (#help .! "Initial balance of an originating contract")+            (#name :! "balance") (#help :! "Initial balance of an originating contract")         <*> verboseFlag      transferOptions :: Opt.Parser TransferOptions@@ -240,7 +240,7 @@       toTcOptions <- typeCheckOptionsOption       toDestination <-         addressOption Nothing-        (#name .! "to") (#help .! "Destination address")+        (#name :! "to") (#help :! "Destination address")       toTxData <- txDataOption       toNow <- nowOption       toLevel <- levelOption@@ -278,9 +278,9 @@      run :: CmdLnArgs -> IO ()     run args = case args of-      Print (argF #input -> mInputFile)-            (argF #output -> mOutputFile)-            (arg #singleLine -> forceSingleLine) -> do+      Print (M mInputFile)+            (M mOutputFile)+            (N forceSingleLine) -> do         contract <- prepareContract mInputFile         let write = maybe putStrLn Utf8.writeFile mOutputFile         write $ printUntypedContract forceSingleLine contract

app/REPL.hs view

@@ -17,30 +17,36 @@   ) where  import Control.Exception (IOException)+import Control.Monad.Random (randomIO) import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Base58 as Base58 import qualified Data.ByteString.Lazy as BSL import Data.List (stripPrefix)-import Data.Text (strip)+import Data.Text as T (length, replicate, strip)+import qualified Data.Text as T (stripPrefix) import Data.Vinyl (Rec(..))-import Fmt (pretty)+import Fmt (fmt, pretty) import System.Console.Haskeline import Text.Megaparsec (parse) -import Michelson.Interpret (interpretInstr)-import Michelson.Macro (ParsedOp, expandList)-import Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_)-import Michelson.Parser.Types (noLetEnv)-import Michelson.Printer (printDoc, printTypedValue)-import Michelson.Printer.Util (doesntNeedParens)-import Michelson.Runtime.Dummy-import Michelson.TypeCheck+import Morley.Michelson.Interpret (interpretInstr)+import Morley.Michelson.Macro (ParsedOp, expandList)+import Morley.Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_)+import Morley.Michelson.Parser.Types (MichelsonSource(..), noLetEnv)+import Morley.Michelson.Printer (printDoc, printTypedValue)+import Morley.Michelson.Printer.Util (buildRenderDoc, doesntNeedParens)+import Morley.Michelson.Runtime.Dummy+import Morley.Michelson.Runtime.Import (readValue)+import Morley.Michelson.TypeCheck   (SomeInstr(..), SomeInstrOut(..), TypeCheckOptions(..), getWTP, runTypeCheckIsolated,   typeCheckingWith)-import Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)-import Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))-import qualified Michelson.Typed as T-import qualified Michelson.Untyped as U-import Util.Sing (castSing)+import Morley.Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)+import Morley.Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Crypto+import Morley.Util.Sing (castSing)+import Text.Hex (decodeHex, encodeHex)  data SomeStack = forall t. T.SingI t => SomeStack   { stValues :: (Rec T.Value t)@@ -76,18 +82,103 @@         "" -> pass         ":clear" -> lift $ put emptyStack         ":stack" -> printStack-        (stripPrefix ":dumpstack" -> Just filename) ->+        ":help" -> printHelp+        (stripPrefixNonEmpty ":dumpstack" -> Just filename) ->           dumpStackToFile $ toString $ strip $ toText filename-        (stripPrefix ":loadstack" -> Just filename) ->+        (stripPrefixNonEmpty ":loadstack" -> Just filename) ->           loadStackFromFile $ toString $ strip $ toText filename-        ":help" -> printHelp-        (stripPrefix ":" -> Just cmd) ->-          printErr $ "Unknown command`"<> (toText cmd) <> "`. Use :help to see a list of commands"+        (stripPrefixNonEmpty ":parse" -> Just parseInput) ->+          tryParse $ strip $ toText parseInput+        (stripPrefixNonEmpty ":base58encode" -> Just parseInput) ->+          base58Encode $ strip $ toText parseInput+        (stripPrefix ":genkeys" -> Just mseed) -> do+           seed <- case mseed of+             "" -> show <$> (liftIO (randomIO @Word64))+             seed -> pure seed+           let sk = detSecretKey (encodeUtf8 seed)+           let pk = toPublic sk+           let pkh = hashKey pk+           printResult "Secret Key" (formatSecretKey sk)+           printResult "Public Key" (formatPublicKey pk)+           printResult "Public Key hash" (formatKeyHash pkh)+        (stripPrefixNonEmpty ":" -> Just cmd) ->+          printErr $ "Unknown command or argument missing in `:"<> (toText cmd) <> "`. Use :help to see a list of commands"         _ -> flip catch (\Interrupt -> putTextLn "Cancelled") $ withInterrupt $ runCode (toText input)       repl_   where     strStrip = toString . strip . toText+    stripPrefixNonEmpty p i = case stripPrefix p i of+      Just "" -> Nothing+      x -> x +base58Encode :: Text -> ReplM ()+base58Encode inp = case decodeHex $ fromMaybe inp $ (T.stripPrefix "0x" inp) of+  Just b -> do+    printResult "Base58encode" $ decodeUtf8 $ Base58.encodeBase58 Base58.bitcoinAlphabet b+    printResult "Base58encode with checksum" $ encodeBase58Check b+  Nothing -> putTextLn "Can't parse input as hex-encoded bytes"++tryParseMichelsonValue :: forall (t :: T.T). (T.SingI t, T.HasNoOp t) => Text -> Text -> ReplM ()+tryParseMichelsonValue msg parseInput =+  case readValue @t MSStdin parseInput of+    Right s -> printResult msg $ (fmt . buildRenderDoc) s+    Left _ -> pass++underlined :: MonadIO m => Text -> m ()+underlined x = liftIO do+  putTextLn x+  putTextLn $ T.replicate (T.length x) "-"++printResult :: MonadIO m => Text -> Text -> m ()+printResult heading result = do+  underlined heading+  putTextLn result+  putTextLn ""++tryParse :: Text -> ReplM ()+tryParse parseInput = do+  tryParseMichelsonValue @'T.TKey "Michelson Key" parseInput+  tryParseMichelsonValue @'T.TUnit "Michelson Unit" parseInput+  tryParseMichelsonValue @'T.TSignature "Michelson Signature" parseInput+  tryParseMichelsonValue @'T.TChainId "Michelson ChainId" parseInput+  tryParseMichelsonValue @'T.TTimestamp "Michelson Timestamp" parseInput+  tryParseMichelsonValue @'T.TAddress "Michelson Address" parseInput+  tryParseMichelsonValue @'T.TString "Michelson String" parseInput+  tryParseMichelsonValue @'T.TInt "Michelson Int" parseInput+  tryParseMichelsonValue @'T.TNat "Michelson Nat" parseInput+  tryParseMichelsonValue @'T.TBytes "Michelson Bytes" parseInput+  tryParseMichelsonValue @'T.TMutez "Michelson Mutez" parseInput+  tryParseMichelsonValue @'T.TKeyHash "Michelson KeyHash" parseInput+  tryParseMichelsonValue @'T.TBls12381Fr "Michelson Bls12381Fr" parseInput+  tryParseMichelsonValue @'T.TBls12381G1 "Michelson Bls12381G1" parseInput+  tryParseMichelsonValue @'T.TBls12381G2 "Michelson Bls12381G2" parseInput+  tryParseMichelsonValue @'T.TBool "Michelson Bool" parseInput++  case parsePublicKey parseInput of+    Right p -> do+      printResult "Public Key" $ formatPublicKey p+    Left _ -> pass+  case parseSignature parseInput of+    Right p -> do+      printResult "Signature" $ formatSignature p+    Left _ -> pass+  case parseSecretKey parseInput of+    Right p -> do+      printResult "Secret Key" $ formatSecretKey p+    Left _ -> pass+  case parseKeyHash parseInput of+    Right p -> do+      printResult "KeyHash" $ formatKeyHash p+    Left _ -> pass+  case Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 parseInput) of+    Just p -> do+      printResult "Base58 Encoded Bytes" $ "0x" <> (encodeHex p)+    Nothing -> pass+  case decodeBase58Check parseInput of+    Just p -> do+      printResult "Base58Check Encoded Bytes" $ "0x" <> (encodeHex p)+    Nothing -> pass+ -- | Try to execute the given input string as a Morley instruction. runCode :: Text -> ReplM () runCode code = do@@ -116,8 +207,11 @@   \ the modified stack, or an error is printed. Multiple instructions separated by semicolons should work\   \ as expected. Available meta commads are:\n\   \ ':help', displays this help\n ':stack', prints the current stack\n\-  \ ':loadstack filename', loads the stack from a file\n\-  \ ':dumpstack filename', dumps the stack to a file \n\+  \ ':parse <input>', tries to parse the given string using known formats\n\+  \ ':base58encode <input>', prints the base58 encoding of a bytestring\n\+  \ ':genkeys <seed>', generates a key pair with hash using the seed string \n\+  \ ':loadstack <filename>', loads the stack from a file\n\+  \ ':dumpstack <filename>', dumps the stack to a file \n\   \ ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."  printStack :: ReplM ()@@ -131,7 +225,7 @@  parseInstructions :: Text -> Either Text [ParsedOp] parseInstructions src =-  case parseNoEnv ops "" src of+  case parseNoEnv ops MSUnspecified src of     Right p -> Right p     Left err -> Left (toText $ errorBundlePretty err) @@ -207,7 +301,7 @@     buildStack :: Either Text SomeStack -> (Text, Text) -> Either Text SomeStack     buildStack (Left err) _ = Left err     buildStack (Right (SomeStack stk hst)) (txVal, txTyp) = case-      (parseExpandValue txVal, parse (runReaderT type_ noLetEnv) "" txTyp) of+      (parseExpandValue "stack" txVal, parse (runReaderT type_ noLetEnv) "" txTyp) of         (Right val, Right typ) ->           case typeCheckingWith tcOptions $ typeCheckParameter mempty typ val of             Right (T.SomeValue tVal) ->

docs/michelsonTypes.md view

@@ -7,7 +7,7 @@ # Michelson Types  We have two representations of types that assemble a Michelson contract: typed and untyped representations.-The former is located in the `Michelson.Typed` module hierarchy, the latter is in `Michelson.Untyped`.+The former is located in the `Morley.Michelson.Typed` module hierarchy, the latter is in `Morley.Michelson.Untyped`.  ## Untyped types @@ -15,7 +15,7 @@ It is capable of representing instructions and values with and without macros because it is parameterized by a type parameter for instructions. This parameter can be an instruction with macros or without. -`U.Value` (a.k.a. [`Michelson.Untyped.Value`](/code/morley/src/Michelson/Untyped/Aliases.hs)) type is used to represent values as they are written in Michelson contracts.+`U.Value` (a.k.a. [`Morley.Michelson.Untyped.Value`](/code/morley/src/Morley/Michelson/Untyped/Aliases.hs)) type is used to represent values as they are written in Michelson contracts. It means that we don't have separate constructors for `address`, `key`, etc. All these types are represented as strings. The same applies to sets and lists, for example.@@ -31,7 +31,7 @@ These types are more advanced than untyped types and are a bit harder to use. However, they are much more powerful. -A typed Michelson value has type `T.Value t` (a.k.a. [`Michelson.Typed.Value`](/code/morley/src/Michelson/Typed/Aliases.hs)) where `t` has kind `T` and `T` represents one of the Michelson types.+A typed Michelson value has type `T.Value t` (a.k.a. [`Morley.Michelson.Typed.Value`](/code/morley/src/Morley/Michelson/Typed/Aliases.hs)) where `t` has kind `T` and `T` represents one of the Michelson types. It allows statically knowing the Michelson type of each value. As a consequence, we can ensure that a typed list always contains values of the same type.

docs/morleyInterpreter.md view

@@ -15,9 +15,9 @@ Morley interpreter is implemented in two layers: * An interpreter for the core Michelson language which doesn't perform any side effects. It means that it always interprets only one contract.-It's located in `Michelson.Interpret`.+It's located in `Morley.Michelson.Interpret`. * High-level Morley interpreter (we call it **executor**) that runs smart contracts using Michelson interpreter and _executes_ side effects.-It's located in `Morley.Runtime`.+It's located in `Morley.Michelson.Runtime`.  ## Michelson interpreter

docs/morleyRuntime.md view

@@ -6,7 +6,7 @@  # Morley Runtime -Morley runtime (`Michelson.Runtime*` modules) provides a high-level interface to Morley functionality.+Morley runtime (`Morley.Michelson.Runtime*` modules) provides a high-level interface to Morley functionality. It implements [high-level Morley executor](./morleyInterpreter.md#high-level-executor) and provides functions to read and parse a contract, originate it, transfer tokens, etc.  At present, Morley runtime doesn't communicate with any real Tezos network.

docs/morleyTypechecker.md view

@@ -7,7 +7,7 @@ # Morley Typechecker  In Morley, we have a typechecker for the core Michelson language,-i. e. without macros.  It is located in `Michelson.TypeCheck` and+i. e. without macros.  It is located in `Morley.Michelson.TypeCheck` and designed in the following way: * It takes a core Michelson contract extended with `EXT` instruction   to support additional instructions described in the@@ -37,12 +37,12 @@  An internal structure of the typechecker is pretty well described in Haddock comments.  Two main modules are:-* [`Michelson.TypeCheck.Value`](/code/morley/src/Michelson/TypeCheck/Value.hs)+* [`Morley.Michelson.TypeCheck.Value`](/code/morley/src/Morley/Michelson/TypeCheck/Value.hs)   contains logic for checking Michelson values.-* [`Michelson.TypeCheck.Instr`](/code/morley/src/Michelson/TypeCheck/Instr.hs)+* [`Morley.Michelson.TypeCheck.Instr`](/code/morley/src/Morley/Michelson/TypeCheck/Instr.hs)   contains logic for checking Michelson instructions and the whole   contract.  Their functionality is re-exported from the-[`Michelson.TypeCheck`](/code/morley/src/Michelson/TypeCheck.hs)+[`Morley.Michelson.TypeCheck`](/code/morley/src/Morley/Michelson/TypeCheck.hs) module along with some auxiliary types and functions.

− doctests/Main.hs

@@ -1,171 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Main-  ( main-  ) where--import qualified Data.ByteString as BS-import Data.Char (isSpace)-import qualified Data.List as List-import Distribution.Fields (runParseResult, showPError)-import Distribution.PackageDescription-  (BuildInfo(defaultExtensions, targetBuildDepends), CondTree(condTreeData),-  GenericPackageDescription(condLibrary), Library(libBuildInfo))-import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)-import Distribution.Simple (Extension(EnableExtension), depPkgName, unPackageName)-import Options.Applicative-  (ParserInfo, execParser, flag', fullDesc, help, helper, info, long, metavar, progDesc, short,-  showDefault, strArgument, strOption, value)-import System.Environment (lookupEnv)-import System.Process (readProcess)-import Test.DocTest (doctest)---- | Runs 'doctest' on the 'morley' package.------ To run via stack, simply run:------ > stack test morley:test:doctests------ Otherwise, you'll need to specify 3 things:------ * The location of the GHC's package database--- * The location of morley's source code--- * The location of morley's cabal file------ > ./doctests --cabal-file code/morley/morley.cabal -- -package-db=<pkg-db-dir> -i code/morley/src------ Any other arguments passed to this program will be forwarded to @doctest@.-main :: IO ()-main = do-  opts <- execParser parserInfo-  doctestArgs <- getDoctestArgs opts--  log opts "Running doctest with args:"-  traverse_ (log opts . mappend "  ") doctestArgs--  putTextLn "Running doctest."-  doctest doctestArgs--data Options = Options-  { cabalFile :: FilePath-  , verbosity :: Maybe Int-  , otherArgs :: [String]-  }-  deriving stock Show--parserInfo :: ParserInfo Options-parserInfo =-  info-    (optionsParser <**> helper)-    (mconcat-      [ fullDesc-      , progDesc "Run doctests. All arguments passed after '--' will be passed down to doctest and GHC."-      ]-    )-  where-    optionsParser =-      Options-      <$> strOption-          (mconcat-            [ long "cabal-file"-            , value "morley.cabal"-            , showDefault-            , metavar "FILEPATH"-            , help "Filepath for the .cabal file"-            ]-          )-      <*> (fmap (fmap length) . optional . some . flag' () . mconcat $-            [ short 'V'-            , help "Increase verbosity (pass up to 5 times to increase further, e.g. '-VVV').\-                   \ This flag will be passed down to doctest and GHC."-            ]-          )-      <*> many (strArgument (metavar "ARGS..." ))---- | Get all the arguments needed to run `doctest`.-getDoctestArgs :: Options -> IO [String]-getDoctestArgs opts = do-  lib <- getCabalLibComponent opts-  argsFromStack <- getArgsFromStack opts--  pure $-    [ "-package-env=-"-    , "-hide-all-packages"-    ]-    <> maybeToList (getGHCVerbosityFlag opts)-    <> argsFromStack-    <> (getDependencies lib <&> \pkg -> "-package=" <> pkg)-    <> (getEnabledExtensions lib <&> \ext -> "-X" <> ext)-    <> otherArgs opts---- | If this program is running via @stack@, then we can:------ * guess where the source code is located--- * use @stack@ to find out where the package database is located------ Otherwise, these arguments will have to be specified by the user, via the--- @-package-db@ and @-i@ flags.-getArgsFromStack :: Options -> IO [String]-getArgsFromStack opts = do-  -- If 'STACK_EXE' is set, we assume we're running via 'stack' and not,-  -- for example, via cabal or haskell.nix.-  lookupEnv "STACK_EXE" >>= \case-    Nothing ->  do-      log opts "The environment variable 'STACK_EXE' is not set."-      pure []-    Just stackBin -> do-      log opts $ "The environment variable 'STACK_EXE' is set: " <> stackBin-      log opts "Assuming we're running via stack."-      snapshotPkgDb <- readProcess stackBin ["path", "--snapshot-pkg-db"] []-      localPkgDb <- readProcess stackBin ["path", "--local-pkg-db"] []-      pure-        [ "-package-db=" <> List.dropWhileEnd isSpace snapshotPkgDb-        , "-package-db=" <> List.dropWhileEnd isSpace localPkgDb-        , "-i", "src"-        ]---- | Parse a cabal file and extract info about its "library" component.-getCabalLibComponent :: Options -> IO Library-getCabalLibComponent opts = do-  let cabalFilePath = cabalFile opts-  log opts $ "Reading cabal file:" <> cabalFilePath-  contents <- BS.readFile cabalFilePath-  case snd <$> runParseResult $ parseGenericPackageDescription contents of-    Left (version, err :| errs) -> do-      die $ toString $ List.unlines $-        [ "Failed to parse .cabal file: " <> cabalFilePath-        , "Version: " <> show version-        , "Errors:"-        ]-        <> (showPError cabalFilePath <$> (err : errs))-    Right cabal -> do-      case condLibrary cabal of-        Nothing -> die "Cabal file did not contain a library component."-        Just condTreeLib -> pure $ condTreeData condTreeLib--getEnabledExtensions :: Library -> [String]-getEnabledExtensions lib =-  libBuildInfo lib & defaultExtensions & mapMaybe \case-    EnableExtension extension -> Just $ show extension-    _ -> Nothing--getDependencies :: Library -> [String]-getDependencies lib =-  libBuildInfo lib & targetBuildDepends & fmap (unPackageName . depPkgName)---- | Due to a limitation in optparse-applicative, our @-V@ flag has a--- different syntax than GHC's @-v@ flag.------ Our @-VVV@ corresponds to @-v3@ in GHC.------ This function transforms our syntax into GHC's.-getGHCVerbosityFlag :: Options -> Maybe String-getGHCVerbosityFlag opts =-  verbosity opts <&> \i -> "-v" <> show i--log :: Options -> String -> IO ()-log opts msg =-  whenJust (verbosity opts) \_ ->-    putStrLn msg

morley.cabal view

@@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.34.3.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack  name:           morley-version:        1.15.1+version:        1.16.0 synopsis:       Developer tools for the Michelson Language description:    A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category:       Language@@ -37,137 +37,182 @@  library   exposed-modules:-      Michelson.Analyzer-      Michelson.Doc-      Michelson.ErrorPos-      Michelson.FailPattern-      Michelson.Interpret-      Michelson.Interpret.Pack-      Michelson.Interpret.Unpack-      Michelson.Interpret.Utils-      Michelson.Let-      Michelson.Macro-      Michelson.Optimizer-      Michelson.Parser-      Michelson.Parser.Annotations-      Michelson.Parser.Error-      Michelson.Parser.Ext-      Michelson.Parser.Helpers-      Michelson.Parser.Instr-      Michelson.Parser.Let-      Michelson.Parser.Lexer-      Michelson.Parser.Macro-      Michelson.Parser.Type-      Michelson.Parser.Types-      Michelson.Parser.Value-      Michelson.Preprocess-      Michelson.Printer-      Michelson.Printer.Util-      Michelson.Runtime-      Michelson.Runtime.Dummy-      Michelson.Runtime.GState-      Michelson.Runtime.Import-      Michelson.Runtime.TxData-      Michelson.Text-      Michelson.TypeCheck-      Michelson.TypeCheck.Error-      Michelson.TypeCheck.Ext-      Michelson.TypeCheck.Helpers-      Michelson.TypeCheck.Instr-      Michelson.TypeCheck.TypeCheck-      Michelson.TypeCheck.TypeCheckedOp-      Michelson.TypeCheck.TypeCheckedSeq-      Michelson.TypeCheck.Types-      Michelson.TypeCheck.Value-      Michelson.Typed-      Michelson.Typed.Aliases-      Michelson.Typed.Annotation-      Michelson.Typed.Arith-      Michelson.Typed.Convert-      Michelson.Typed.Doc-      Michelson.Typed.Entrypoints-      Michelson.Typed.Existential-      Michelson.Typed.Extract-      Michelson.Typed.Haskell-      Michelson.Typed.Haskell.Compatibility-      Michelson.Typed.Haskell.Doc-      Michelson.Typed.Haskell.Instr-      Michelson.Typed.Haskell.Instr.Helpers-      Michelson.Typed.Haskell.Instr.Product-      Michelson.Typed.Haskell.Instr.Sum-      Michelson.Typed.Haskell.LooseSum-      Michelson.Typed.Haskell.ValidateDescription-      Michelson.Typed.Haskell.Value-      Michelson.Typed.Instr-      Michelson.Typed.OpSize-      Michelson.Typed.Origination-      Michelson.Typed.Polymorphic-      Michelson.Typed.Scope-      Michelson.Typed.Sing-      Michelson.Typed.T-      Michelson.Typed.TypeLevel-      Michelson.Typed.Util-      Michelson.Typed.Value-      Michelson.Untyped-      Michelson.Untyped.Aliases-      Michelson.Untyped.Annotation-      Michelson.Untyped.Contract-      Michelson.Untyped.Entrypoints-      Michelson.Untyped.Ext-      Michelson.Untyped.Instr-      Michelson.Untyped.OpSize-      Michelson.Untyped.Type-      Michelson.Untyped.Value       Morley.CLI       Morley.Micheline       Morley.Micheline.Binary       Morley.Micheline.Class       Morley.Micheline.Expression       Morley.Micheline.Json-      Tezos.Address-      Tezos.Core-      Tezos.Crypto-      Tezos.Crypto.BLS12381-      Tezos.Crypto.Ed25519-      Tezos.Crypto.Hash-      Tezos.Crypto.P256-      Tezos.Crypto.Secp256k1-      Tezos.Crypto.Util-      Util.Aeson-      Util.Alternative-      Util.Binary-      Util.ByteString-      Util.CLI-      Util.CustomGeneric-      Util.Default-      Util.Exception-      Util.Fcf-      Util.Generic-      Util.Instances-      Util.Label-      Util.Lens-      Util.Main-      Util.Markdown-      Util.Named-      Util.Num-      Util.Peano-      Util.PeanoNatural-      Util.Positive-      Util.Sing-      Util.Text-      Util.TH-      Util.Type-      Util.Typeable-      Util.TypeLits-      Util.TypeTuple-      Util.TypeTuple.Class-      Util.TypeTuple.Instances-      Util.TypeTuple.TH+      Morley.Michelson.Analyzer+      Morley.Michelson.Doc+      Morley.Michelson.ErrorPos+      Morley.Michelson.FailPattern+      Morley.Michelson.Interpret+      Morley.Michelson.Interpret.Pack+      Morley.Michelson.Interpret.Unpack+      Morley.Michelson.Interpret.Utils+      Morley.Michelson.Let+      Morley.Michelson.Macro+      Morley.Michelson.Optimizer+      Morley.Michelson.Parser+      Morley.Michelson.Parser.Annotations+      Morley.Michelson.Parser.Error+      Morley.Michelson.Parser.Ext+      Morley.Michelson.Parser.Helpers+      Morley.Michelson.Parser.Instr+      Morley.Michelson.Parser.Let+      Morley.Michelson.Parser.Lexer+      Morley.Michelson.Parser.Macro+      Morley.Michelson.Parser.Type+      Morley.Michelson.Parser.Types+      Morley.Michelson.Parser.Value+      Morley.Michelson.Preprocess+      Morley.Michelson.Printer+      Morley.Michelson.Printer.Util+      Morley.Michelson.Runtime+      Morley.Michelson.Runtime.Dummy+      Morley.Michelson.Runtime.GState+      Morley.Michelson.Runtime.Import+      Morley.Michelson.Runtime.TxData+      Morley.Michelson.Text+      Morley.Michelson.TypeCheck+      Morley.Michelson.TypeCheck.Error+      Morley.Michelson.TypeCheck.Ext+      Morley.Michelson.TypeCheck.Helpers+      Morley.Michelson.TypeCheck.Instr+      Morley.Michelson.TypeCheck.TypeCheck+      Morley.Michelson.TypeCheck.TypeCheckedOp+      Morley.Michelson.TypeCheck.TypeCheckedSeq+      Morley.Michelson.TypeCheck.Types+      Morley.Michelson.TypeCheck.Value+      Morley.Michelson.Typed+      Morley.Michelson.Typed.Aliases+      Morley.Michelson.Typed.Annotation+      Morley.Michelson.Typed.Arith+      Morley.Michelson.Typed.Convert+      Morley.Michelson.Typed.Doc+      Morley.Michelson.Typed.Entrypoints+      Morley.Michelson.Typed.Existential+      Morley.Michelson.Typed.Extract+      Morley.Michelson.Typed.Haskell+      Morley.Michelson.Typed.Haskell.Compatibility+      Morley.Michelson.Typed.Haskell.Doc+      Morley.Michelson.Typed.Haskell.Instr+      Morley.Michelson.Typed.Haskell.Instr.Helpers+      Morley.Michelson.Typed.Haskell.Instr.Product+      Morley.Michelson.Typed.Haskell.Instr.Sum+      Morley.Michelson.Typed.Haskell.LooseSum+      Morley.Michelson.Typed.Haskell.ValidateDescription+      Morley.Michelson.Typed.Haskell.Value+      Morley.Michelson.Typed.Instr+      Morley.Michelson.Typed.Operation+      Morley.Michelson.Typed.OpSize+      Morley.Michelson.Typed.Polymorphic+      Morley.Michelson.Typed.Scope+      Morley.Michelson.Typed.Sing+      Morley.Michelson.Typed.T+      Morley.Michelson.Typed.TypeLevel+      Morley.Michelson.Typed.Util+      Morley.Michelson.Typed.Value+      Morley.Michelson.Untyped+      Morley.Michelson.Untyped.Aliases+      Morley.Michelson.Untyped.Annotation+      Morley.Michelson.Untyped.Contract+      Morley.Michelson.Untyped.Entrypoints+      Morley.Michelson.Untyped.Ext+      Morley.Michelson.Untyped.Instr+      Morley.Michelson.Untyped.OpSize+      Morley.Michelson.Untyped.Type+      Morley.Michelson.Untyped.Value+      Morley.Tezos.Address+      Morley.Tezos.Core+      Morley.Tezos.Crypto+      Morley.Tezos.Crypto.BLS12381+      Morley.Tezos.Crypto.Ed25519+      Morley.Tezos.Crypto.Hash+      Morley.Tezos.Crypto.P256+      Morley.Tezos.Crypto.Secp256k1+      Morley.Tezos.Crypto.Util+      Morley.Util.Aeson+      Morley.Util.Binary+      Morley.Util.ByteString+      Morley.Util.CLI+      Morley.Util.CustomGeneric+      Morley.Util.Default+      Morley.Util.Exception+      Morley.Util.Fcf+      Morley.Util.Generic+      Morley.Util.Instances+      Morley.Util.Interpolate+      Morley.Util.Label+      Morley.Util.Lens+      Morley.Util.Main+      Morley.Util.Markdown+      Morley.Util.Named+      Morley.Util.Peano+      Morley.Util.PeanoNatural+      Morley.Util.Positive+      Morley.Util.Sing+      Morley.Util.Text+      Morley.Util.TH+      Morley.Util.Type+      Morley.Util.Typeable+      Morley.Util.TypeLits+      Morley.Util.TypeTuple+      Morley.Util.TypeTuple.Class+      Morley.Util.TypeTuple.Instances+      Morley.Util.TypeTuple.TH   other-modules:       Paths_morley   hs-source-dirs:       src-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages   build-depends:       MonadRandom@@ -184,12 +229,11 @@     , data-default     , elliptic-curve     , first-class-families >=0.5.0.0-    , fmt+    , fmt >=0.6.3.0     , galois-field     , generic-deriving     , gitrev     , hex-text-    , interpolate     , lens     , megaparsec >=7.0.0     , memory@@ -214,7 +258,7 @@     , uncaught-exception     , unordered-containers     , vector-    , vinyl+    , vinyl >=0.13.1     , with-utf8     , wl-pprint-text   default-language: Haskell2010@@ -228,14 +272,63 @@       Paths_morley   hs-source-dirs:       app-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages   build-depends:-      aeson+      MonadRandom+    , aeson     , base-noprelude >=4.7 && <5+    , base58-bytestring     , bytestring     , fmt     , haskeline+    , hex-text     , megaparsec >=7.0.0     , morley     , morley-prelude@@ -244,26 +337,4 @@     , text     , vinyl     , with-utf8-  default-language: Haskell2010--test-suite doctests-  type: exitcode-stdio-1.0-  main-is: Main.hs-  other-modules:-      Paths_morley-  hs-source-dirs:-      doctests-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"-  build-tool-depends:-      tasty-discover:tasty-discover-  build-depends:-      Cabal-    , base-noprelude >=4.7 && <5-    , bytestring-    , doctest-    , morley-    , morley-prelude-    , optparse-applicative-    , process   default-language: Haskell2010

− src/Michelson/Analyzer.hs

@@ -1,118 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Static analysis of Michelson code.--module Michelson.Analyzer-  ( AnalyzerRes (..)-  , analyze-  ) where--import Data.Default (def)-import qualified Data.HashMap.Strict as HM-import qualified Data.List.NonEmpty as NE-import Fmt (Buildable(..), Builder, blockMapF', hexF, nameF, (+|))--import Michelson.FailPattern-import Michelson.Text (MText)-import Michelson.Typed--data AnalyzerRes = AnalyzerRes-  { arConstStrings :: HashMap MText Word-  -- ^ All string constants and number of their occurrences.-  , arConstBytes :: HashMap ByteString Word-  -- ^ All bytes constants and number of their occurrences.-  , arErrorTags :: HashMap MText Word-  -- ^ Which strings are used as error tags and how many times.-  -- There is no notion of "error tag" in Michelson, so we use a heuristic-  -- to find out whether a string is an error tag. Specifically, we consider-  -- three patterns:-  -- 1. A constant string is pushed and then there is `FAILWITH` immediately.-  -- 2. A constant string is pushed, followed by `PAIR` instruction and then-  -- `FAILWITH`.-  -- 3. A constant pair is pushed where the first item is a string and then-  -- there is `FAILWITH.-  } deriving stock (Show, Eq)--instance Buildable AnalyzerRes where-  build (AnalyzerRes-    (toPairs -> constStrings)-    (toPairs -> constBytes)-    (toPairs -> errorTags)-    ) =-    nameF "String constants"-      (buildStrings $ sortByCount constStrings)-    +|-    nameF "Bytes constants"-      (buildBytes $ sortByCount constBytes)-    +|-    nameF "Error tags"-      (buildStrings $ sortByCount errorTags)-    +|-    longest "strings" constStrings buildStrings-    +|-    longest "bytes" constBytes buildBytes-    where-      inQuotes toBuilder x = "\"" <> toBuilder x <> "\""--      buildStrings = blockMapF' (inQuotes build) build-      buildBytes = blockMapF' (mappend "0x" . hexF) build--      sortByCount :: [(k, Word)] -> [(k, Word)]-      sortByCount = sortWith snd--      sortByLength :: Container k => [(k, Word)] -> [(k, Word)]-      sortByLength = sortWith (Down . length . fst)--      longest ::-        Container x =>-        Builder -> [(x, Word)] -> ([(x, Word)] -> Builder) -> Builder-      longest name items builder-        | length items > 6 =-          nameF ("Longest " <> name) $ builder $ take 4 $ sortByLength items-        | otherwise = mempty--instance Semigroup AnalyzerRes where-  ar1 <> ar2 = AnalyzerRes-    { arConstStrings = arConstStrings ar1 <+> arConstStrings ar2-    , arConstBytes = arConstBytes ar1 <+> arConstBytes ar2-    , arErrorTags = arErrorTags ar1 <+> arErrorTags ar2-    }-    where-      m1 <+> m2 = HM.unionWith (+) m1 m2--instance Monoid AnalyzerRes where-  mempty = AnalyzerRes-    { arConstStrings = mempty-    , arConstBytes = mempty-    , arErrorTags = mempty-    }---- | Statically analyze an instruction. Typed representation is used--- because it's easier to analyze. It means that we can't analyze--- ill-typed contracts, but hopefully it's not a serious limitation.-analyze :: Instr inp out -> AnalyzerRes-analyze = dfsFoldInstr def{ dsGoToValues = True } step . linearizeLeftDeep-  where-    step :: forall i o. Instr i o -> AnalyzerRes-    step i = analyzeConstants i <> analyzeErrorTags i--    countItems :: (Ord i, Hashable i) => [i] -> HashMap i Word-    countItems = HM.fromList . map f . NE.group . sort-      where-        f ne = (head ne, fromIntegral $ length ne)--    analyzeConstants :: forall i o. Instr i o -> AnalyzerRes-    analyzeConstants = \case-      PUSH v -> mempty-        { arConstStrings = countItems $ allAtomicValues isStringValue v-        , arConstBytes = countItems $ allAtomicValues isBytesValue v-        }-      _ -> mempty--    analyzeErrorTags :: forall i o. Instr i o -> AnalyzerRes-    analyzeErrorTags i-      | Just tfw <- isTypicalFailWith i =-          mempty { arErrorTags = one (typicalFailWithTag tfw, 1) }-      | otherwise = mempty

− src/Michelson/Doc.hs

@@ -1,818 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE TypeFamilyDependencies, UndecidableSuperClasses #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Renderable documentation injected to contract code.-module Michelson.Doc-  ( DocItem (..)-  , docItemPosition-  , DocItemId (..)-  , DocItemPlacementKind (..)-  , DocItemPos (..)-  , DocItemRef (..)-  , DocItemReferencedKind-  , DocSectionNameStyle (..)-  , SomeDocItem (..)-  , SomeDocDefinitionItem (..)-  , DocElem (..)-  , DocSection (..)-  , DocBlock-  , SubDoc (..)-  , ContractDoc (..)-  , DocGrouping-  , cdContentsL-  , cdDefinitionsL-  , cdDefinitionsSetL-  , cdDefinitionIdsL-  , deIsAtomic-  , subDocToMarkdown-  , docItemToBlock-  , docItemSectionRef-  , lookupDocBlockSection-  , contractDocToMarkdown-  , contractDocToToc-  , docGroupContent-  , docDefinitionRef-  , mdTocFromRef-  , WithFinalizedDoc (..)-  , finalizedAsIs-  , ContainsDoc (..)-  , ContainsUpdateableDoc (..)-  , buildDoc-  , buildMarkdownDoc-  , modifyDoc--  , DGeneralInfoSection (..)-  , DName (..)-  , DDescription (..)-  , DGitRevision (..)-  , GitRepoSettings (..)-  , mkDGitRevision-  , morleyRepoSettings-  , DComment (..)-  , DAnchor (..)-  , DToc (..)-  , DConversionInfo (..)-  , attachGitInfo-  , attachToc-  , attachDocCommons-  ) where--import qualified Data.Map as M-import qualified Data.Map.Merge.Strict as M-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import Data.Typeable (cast, typeRep)-import Development.GitRev (gitCommitDate, gitHash)-import Fmt (Buildable, build, fmt, (+|), (+||), (|+), (||+))-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Lift as TH-import System.Environment (lookupEnv)-import qualified Text.Show--import Util.Instances ()-import Util.Lens-import Util.Markdown-import Util.Type-import Util.Typeable---- | A piece of documentation describing one property of a thing,--- be it a name or description of a contract, or an error throwable--- by given endpoint.------ Items of the same type appear close to each other in a rendered documentation--- and form a /section/.------ Doc items are later injected into a contract code via a dedicated nop-like--- instruction. Normally doc items which belong to one section appear in--- resulting doc in the same order in which they appeared in the contract.------ While documentation framework grows, this typeclass acquires more and more--- methods for fine tuning of existing rendering logic because we don't want--- to break backward compatibility, hope one day we will make everything--- concise :(--- E.g. all rendering and reording stuff could be merged in one method, and--- we could have several template implementations for it which would allow--- user to specify only stuff relevant to his case.-class (Typeable d, DOrd d) => DocItem d where-  -- | Position of this item in the resulting documentation;-  -- the smaller the value, the higher the section with this element-  -- will be placed. If the position is the same as other doc items,-  -- they will be placed base on their name, alphabetically.-  ---  -- Documentation structure is not necessarily flat.-  -- If some doc item consolidates a whole documentation block within it,-  -- this block will have its own placement of items independent from outer parts-  -- of the doc.-  docItemPos :: Natural--  -- | When multiple items of the same type belong to one section, how-  -- this section will be called.-  ---  -- If not provided, section will contain just untitled content.-  docItemSectionName :: Maybe Text--  -- | Description of a section.-  ---  -- Can be used to mention some common things about all elements of this section.-  -- Markdown syntax is permitted here.-  docItemSectionDescription :: Maybe Markdown-  docItemSectionDescription = Nothing--  -- | How to render section name.-  ---  -- Takes effect only if section name is set.-  docItemSectionNameStyle :: DocSectionNameStyle-  docItemSectionNameStyle = DocSectionNameBig--  -- | Defines where given doc item should be put. There are two options:-  -- 1. Inline right here (default behaviour);-  -- 2. Put into definitions section.-  ---  -- Note that we require all doc items with "in definitions" placement to-  -- have 'Eq' and 'Ord' instances which comply the following law:-  -- if two documentation items describe the same entity or property, they-  -- should be considered equal.-  type DocItemPlacement d :: DocItemPlacementKind-  type DocItemPlacement _ = 'DocItemInlined--  type DocItemReferenced d :: DocItemReferencedKind-  type DocItemReferenced _ = 'False--  -- | Defines a function which constructs an unique identifier of given doc item,-  -- if it has been decided to put the doc item into definitions section.-  ---  -- Identifier should be unique both among doc items of the same type and items-  -- of other types. Thus, consider using "typeId-contentId" pattern.-  docItemRef :: d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)-  default docItemRef-    :: ( DocItemPlacement d ~ 'DocItemInlined-       , DocItemReferenced d ~ 'False-       )-    => d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)-  docItemRef _ = DocItemNoRef--  -- | Render given doc item to Markdown, preferably one line,-  -- optionally with header.-  ---  -- Accepts the smallest allowed level of header.-  -- (Using smaller value than provided one will interfere with existing-  -- headers thus delivering mess).-  docItemToMarkdown :: HeaderLevel -> d -> Markdown--  -- | Render table of contents entry for given doc item to Markdown.-  docItemToToc :: HeaderLevel -> d -> Markdown-  docItemToToc _ _ = ""--  -- | All doc items which this doc item refers to.-  ---  -- They will automatically be put to definitions as soon as given doc item-  -- is detected.-  docItemDependencies :: d -> [SomeDocDefinitionItem]-  docItemDependencies _ = []--  -- | This function accepts doc items put under the same section in the order-  -- in which they appeared in the contract and returns their new desired order.-  -- It's also fine to use this function for filtering or merging doc items.-  ---  -- Default implementation-  -- * leaves inlined items as is;-  -- * for items put to definitions, lexicographically sorts them by their id.-  docItemsOrder :: [d] -> [d]-  docItemsOrder = \case-    [] -> []-    docItems@(someDocItem : _) -> case docItemRef someDocItem of-      DocItemNoRef -> docItems-      DocItemRef _ ->-        docItemsOrderById docItems-      DocItemRefInlined _ ->-        docItems---- | Generate 'DToc' entry anchor from 'docItemRef'.-mdTocFromRef :: (DocItem d, DocItemReferenced d ~ 'True) => HeaderLevel -> Markdown -> d -> Markdown-mdTocFromRef lvl text d =-  mdToc lvl text (toAnchor $ docItemRef d)---- | Get doc item position at term-level.-docItemPosition :: forall d. DocItem d => DocItemPos-docItemPosition = DocItemPos (docItemPos @d, show (typeRep $ Proxy @d))---- | Render an item into Markdown block with all required adjustments.-docItemToMarkdownFull :: DocItem d => HeaderLevel -> d -> Markdown-docItemToMarkdownFull l d =-  manchor <> docItemToMarkdown l d <> "\n\n"-  where-    manchor = case docItemRef d of-      DocItemRef docItemId -> mdAnchor docItemId-      DocItemRefInlined docItemId -> mdAnchor docItemId-      DocItemNoRef -> ""---- | Order items by their 'docItemId'.-docItemsOrderById-  :: forall d. (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)-  => [d] -> [d]-docItemsOrderById docItems =-  let getDocItemId :: d -> DocItemId-      getDocItemId d = case docItemRef d of { DocItemRef di -> di }-  in sortOn getDocItemId docItems---- | Make a reference to doc item in definitions.-docDefinitionRef-  :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)-  => Markdown -> d -> Markdown-docDefinitionRef refText d = case docItemRef d of-  DocItemRef docItemId -> mdLocalRef refText docItemId---- | Some unique identifier of a doc item.------ All doc items which should be refer-able need to have this identifier.-newtype DocItemId = DocItemId Text-  deriving stock (Eq, Ord, Show)-  deriving newtype (ToAnchor)---- | Position of all doc items of some type.-newtype DocItemPos = DocItemPos (Natural, Text)-  deriving stock (Eq, Ord, Show)--instance Buildable DocItemPos where-  build (DocItemPos (a, _)) = build a---- | Where do we place given doc item.-data DocItemPlacementKind-  = DocItemInlined-    -- ^ Placed in the document content itself.-  | DocItemInDefinitions-    -- ^ Placed in dedicated definitions section; can later be referenced.---- | Type-level check whether or not a doc item can be referenced.-type DocItemReferencedKind = Bool--data DocItemRef (p :: DocItemPlacementKind) (r :: DocItemReferencedKind) where-  DocItemRef        :: DocItemId -> DocItemRef 'DocItemInDefinitions 'True-  DocItemRefInlined :: DocItemId -> DocItemRef 'DocItemInlined 'True-  DocItemNoRef      :: DocItemRef 'DocItemInlined 'False--instance ToAnchor (DocItemRef d 'True) where-  toAnchor (DocItemRef ref) = toAnchor ref-  toAnchor (DocItemRefInlined ref) = toAnchor ref---- | How to render section name.-data DocSectionNameStyle-  = DocSectionNameBig-    -- ^ Suitable for block name.-  | DocSectionNameSmall-    -- ^ Suitable for subsection title within block.---- | Hides some documentation item.-data SomeDocItem where-  SomeDocItem :: DocItem d => d -> SomeDocItem---- NFData instance is needed for benchmarks and we want to avoid requiring users--- to implement NFData instance for every single DocItem and they should not--- affect the performance anyway.-instance NFData SomeDocItem where-  rnf (SomeDocItem _) = ()---- | Hides some documentation item which is put to "definitions" section.-data SomeDocDefinitionItem where-  SomeDocDefinitionItem-    :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)-    => d -> SomeDocDefinitionItem--instance Eq SomeDocDefinitionItem where-  SomeDocDefinitionItem d1 == SomeDocDefinitionItem d2 =-    d1 `eqExt` d2-instance Ord SomeDocDefinitionItem where-  SomeDocDefinitionItem d1 `compare` SomeDocDefinitionItem d2 =-    d1 `compareExt` d2---- | To automatically derive @instance Show Michelson.Typed.Instr@ later.-instance Show SomeDocItem where-  show _ = "<doc item>"--type family DOrd d :: Constraint where-  DOrd d = If (DocItemPlacement d == 'DocItemInDefinitions)-             (Ord d) (() :: Constraint)---- | A doc item which we store, along with related information.-data DocElem d = DocElem-  { deItem :: d-    -- ^ Doc item itself.-  , deSub :: Maybe SubDoc-    -- ^ Subdocumentation, if given item is a group.-  }---- | Whether given 'DocElem' is atomic.------ Normally, atomic 'DocElem's are ones appearing in @DOC_ITEM@ instruction,--- and non-atomic ones are put to @DocGroup@.-deIsAtomic :: DocElem d -> Bool-deIsAtomic = isNothing . deSub---- | Several doc items of the same type.-data DocSection = forall d. DocItem d => DocSection (NonEmpty $ DocElem d)--instance Show DocSection where-  show (DocSection (ds :: NonEmpty (DocElem d))) =-    "Doc items section: " <> show (typeRep $ Proxy @d) <>-    " / " <> show (length ds) <> " item(s)"--unsafeAppendDocSection-  :: HasCallStack-  => DocSection -> DocSection -> DocSection-unsafeAppendDocSection (DocSection ls) (DocSection rs) =-  DocSection $ unsafeAppendDocSectionImpl ls (toList rs)--unsafeAppendDocSectionImpl-  :: forall d1 d2.-     (Typeable d1, Typeable d2, HasCallStack)-  => NonEmpty d1 -> [d2] -> NonEmpty d1-unsafeAppendDocSectionImpl (l :| ls) rs =-  let rs' = rs <&> \r -> cast r ?: onTypeMismatch-  in l :| ls <> rs'-  where-    onTypeMismatch =-      error $ "appending doc sections for doc items of different types:"-              +|| typeRep (Proxy @d1) ||+ " and " +|| typeRep (Proxy @d2) ||+ ""---- | A map from positions to document elements.------ This form effeciently keeps documentation for its incremental building.--- Doc items here appear close to how they were located in the contract;--- for instance, 'docItemsOrder' is not yet applied at this stage.--- You only can be sure that items within each group are splitted across--- sections correctly.-type DocBlock = Map DocItemPos DocSection---- | Render a documentation block.-docBlockToMarkdown :: HeaderLevel -> DocBlock -> Markdown-docBlockToMarkdown hl block =-  mconcat $ M.elems block <&> \(DocSection items@((_ :: DocElem di) :| _)) ->-    let sectionName = docItemSectionName @di-        sectionNameStyle = docItemSectionNameStyle @di-        (sectionNameFull, headerLevelDelta) =-          case sectionName of-            Nothing -> ("", id)-            Just sn ->-              let sn' = build sn-              in case sectionNameStyle of-                  DocSectionNameBig ->-                    (mdHeader hl sn', nextHeaderLevel)-                  DocSectionNameSmall ->-                    ( mdSubsectionTitle sn' <> "\n"-                    , error $ "Using headers is not allowed when section name is set small\n\-                              \Make sure docItemToMarkdown @" <> show (typeRep $ Proxy @di) <>-                              "does not use its 'header level' argument"-                    )-        sectionDesc = docItemSectionDescription @di-        sectionDescFull =-          case sectionDesc of-            Nothing -> ""-            Just sd -> sd <> "\n\n"-        resItems = docItemsOrder $ map deItem (toList items)-        content =-          mconcat $ resItems <&> \di ->-            docItemToMarkdownFull (headerLevelDelta hl) di-        anchor = maybe "" mdAnchor (docItemSectionAnchor @di)-    in if null resItems-       then ""-       else anchor <> sectionNameFull <> sectionDescFull <> content---- | Anchor for all the sections (referring them as to headers may cause--- colissions).-newtype SectionAnchor = SectionAnchor-  { _unSectionAnchor :: Text-    -- ^ Section name-  }--instance ToAnchor SectionAnchor where-  toAnchor (SectionAnchor t) = Anchor ("section-" <> t)---- | Make an anchor that is to be attached to the given section.-docItemSectionAnchor :: forall di. DocItem di => Maybe SectionAnchor-docItemSectionAnchor = do-  case docItemSectionNameStyle @di of-    DocSectionNameBig -> pass-    DocSectionNameSmall -> mzero-  SectionAnchor <$> docItemSectionName @di---- | Reference to the given section.------ Will return @Nothing@ if sections of given doc item type are not--- assumed to be referred outside.-docItemSectionRef :: forall di. DocItem di => Maybe Markdown-docItemSectionRef = do-  name <- docItemSectionName @di-  anchor <- docItemSectionAnchor @di-  return $ mdLocalRef (build name) anchor---- | Render a part of table of contents from 'DocBlock'.-docBlockToToc :: HeaderLevel -> DocBlock -> Markdown-docBlockToToc hl block =-  mconcat $ M.elems block <&> \(DocSection items@((_ :: DocElem di) :| _)) ->-    let sectionName = docItemSectionName @di-        (sectionNameFull, headerLevelDelta) =-          case (sectionName, docItemSectionAnchor @di) of-            (_, Nothing) -> ("", id)-            (Nothing, _) -> ("", id)-            (Just "Table of contents", _) -> ("", id)-            (Just sn, Just anchor) ->-              (mdToc hl (build sn) anchor, nextHeaderLevel)-        resItems = docItemsOrder $ map deItem (toList items)-        content =-          mconcat $ resItems <&> docItemToToc (headerLevelDelta hl)-    in if null resItems-       then ""-       else sectionNameFull <> content---- | Lift a doc item to a block, be it atomic doc item or grouping one.-docItemToBlockGeneral :: forall di. DocItem di => di -> Maybe SubDoc -> DocBlock-docItemToBlockGeneral di msub =-  one ( docItemPosition @di-      , DocSection $ one (DocElem di msub)-      )---- | Lift an atomic doc item to a block.-docItemToBlock :: forall di. DocItem di => di -> DocBlock-docItemToBlock di = docItemToBlockGeneral di Nothing---- | Find all doc items of the given type.-lookupDocBlockSection :: forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)-lookupDocBlockSection block = do-  DocSection (ds :: NonEmpty (DocElem d')) <- M.lookup (docItemPosition @d) block-  case eqT @d @d' of-    Nothing -> error $ "Invalid DocBlock: item of type " +|| typeRep (Proxy @d) ||+ " \-                       \under position " +| docItemPosition @d |+ ""-    Just Refl -> pure $ map deItem ds---- | A part of documentation to be grouped. Essentially incapsulates 'DocBlock'.---- One day we may need to define 'Eq' instance for this thing, and probably--- we can consider any two entities equal for efficiency.-newtype SubDoc = SubDoc DocBlock---- | Render documentation for 'SubDoc'.-subDocToMarkdown :: HeaderLevel -> SubDoc -> Markdown-subDocToMarkdown hl (SubDoc d) = docBlockToMarkdown hl d---- | Render documentation for 'SubDoc'.-subDocToToc :: HeaderLevel -> SubDoc -> Markdown-subDocToToc hl (SubDoc d) = docBlockToToc hl d---- | Keeps documentation gathered for some piece of contract code.------ Used for building documentation of a contract.-data ContractDoc = ContractDoc-  { cdContents :: DocBlock-    -- ^ All inlined doc items.-  , cdDefinitions :: DocBlock-    -- ^ Definitions used in document.-    ---    -- Usually you put some large and repetitive descriptions here.-    -- This differs from the document content in that-    -- it contains sections which are always at top-level,-    -- disregard the nesting.-    ---    -- All doc items which define 'docItemId' method go here, and only they.-  , cdDefinitionsSet :: Set SomeDocDefinitionItem-    -- ^ We remember all already declared entries to avoid cyclic dependencies-    -- in documentation items discovery.-  , cdDefinitionIds :: Set DocItemId-    -- ^ We remember all already used identifiers.-    -- (Documentation naturally should not declare multiple items with-    -- the same identifier because that would make references to the respective-    -- anchors ambiguous).-  }--makeLensesWith postfixLFields ''ContractDoc---- | Contract documentation assembly primarily relies on this instance.-instance Semigroup ContractDoc where-  cd1 <> cd2 = ContractDoc-    { cdContents =-        M.merge-          M.preserveMissing M.preserveMissing-          (M.zipWithMatched $ \_k l r -> unsafeAppendDocSection l r)-          (cdContents cd1) (cdContents cd2)-    , cdDefinitions =-        M.merge-          M.preserveMissing M.preserveMissing-          (M.zipWithMatched $ \_k (DocSection ls) (DocSection rs) ->-             let removeDups = filter $ not . (`isDefinedIn` cdDefinitionIds cd1) . deItem-             in DocSection $ unsafeAppendDocSectionImpl ls (removeDups $ toList rs)-          )-          (cdDefinitions cd1) (cdDefinitions cd2)-    , cdDefinitionsSet =-        S.union (cdDefinitionsSet cd1) (cdDefinitionsSet cd2)-    , cdDefinitionIds =-        S.union (cdDefinitionIds cd1) (cdDefinitionIds cd2)-    }-    where-      isDefinedIn :: DocItem d => d -> Set DocItemId -> Bool-      isDefinedIn di defs =-        case docItemRef di of-          DocItemNoRef -> False-          DocItemRef docItemId -> docItemId `S.member` defs-          DocItemRefInlined docItemId -> docItemId `S.member` defs--instance Monoid ContractDoc where-  mempty = ContractDoc-    { cdContents = M.empty-    , cdDefinitions = M.empty-    , cdDefinitionsSet = S.empty-    , cdDefinitionIds = S.empty-    }---- | Render given contract documentation to markdown document.-contractDocToMarkdown :: ContractDoc -> LText-contractDocToMarkdown ContractDoc{..} =-  let-    contents =-      docBlockToMarkdown (HeaderLevel 1) cdContents |+ "\n\n"-    definitions-      | null cdDefinitions = ""-      | otherwise =-        "# Definitions\n\n" +| docBlockToMarkdown (HeaderLevel 2) cdDefinitions-    total = fmt (contents <> definitions)-  in LT.strip total <> "\n"--contractDocToToc :: ContractDoc -> Markdown-contractDocToToc ContractDoc{..} =-  let-    contents =-      docBlockToToc (HeaderLevel 1) cdContents--    definitions-      | null cdDefinitions = ""-      | otherwise = "\n**[Definitions](#definitions)**\n\n"-          +| docBlockToToc (HeaderLevel 2) cdDefinitions-  in contents <> definitions <> "\n"---- | A function which groups a piece of doc under one doc item.-type DocGrouping = SubDoc -> SomeDocItem--instance Show DocGrouping where-  show _ = "<doc grouping>"---- | Apply given grouping to documentation being built.-docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc-docGroupContent grouping doc =-  doc-  { cdContents =-      let sub = SubDoc (cdContents doc)-      in case grouping sub of-           SomeDocItem d -> docItemToBlockGeneral d (Just sub)-  }---- | Everything that contains doc items that can be used to render the--- documentation.-class ContainsDoc a where-  -- | Gather documentation.-  ---  -- Calling this method directly is discouraged in prod, see 'buildDoc' instead.-  -- Using this method in tests is fine though.-  buildDocUnfinalized :: a -> ContractDoc---- | Some contract languages may support documentation update.-class ContainsDoc a => ContainsUpdateableDoc a where-  -- | Modify all documentation items recursively.-  modifyDocEntirely :: (SomeDocItem -> SomeDocItem) -> a -> a---- | Often there is some tuning recommended prior to rendering the contract,--- like attaching git revision info; this type designates that those last changes--- were applied.------ For example, at Michelson level you may want to use 'attachDocCommons'.------ If you want no special tuning (e.g. for tests), say that explicitly with--- 'finalizedAsIs'.-newtype WithFinalizedDoc a = WithFinalizedDoc (Identity a)-  deriving newtype (Functor, Applicative, Monad)---- | Mark the code with doc as finalized without any changes.-finalizedAsIs :: a -> WithFinalizedDoc a-finalizedAsIs = WithFinalizedDoc . Identity---- | Gather documenation.-buildDoc :: ContainsDoc a => WithFinalizedDoc a -> ContractDoc-buildDoc (WithFinalizedDoc (Identity a)) = buildDocUnfinalized a---- | Construct and format documentation in textual form.-buildMarkdownDoc :: ContainsDoc a => WithFinalizedDoc a -> LText-buildMarkdownDoc = contractDocToMarkdown . buildDoc---- | Recursevly traverse doc items and modify those that match given type.------ If mapper returns 'Nothing', doc item will remain unmodified.-modifyDoc-  :: (ContainsUpdateableDoc a, DocItem i1, DocItem i2)-  => (i1 -> Maybe i2) -> a -> a-modifyDoc mapper = modifyDocEntirely untypedMapper-  where-  untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do-    di' <- cast di-    newDi <- mapper di'-    return (SomeDocItem newDi)--------------------------------------------------------------------------------- Basic doc items--------------------------------------------------------------------------------- | General (meta-)information about the contract such as git--- revision, contract's authors, etc. Should be relatively short (not--- several pages) because it is put somewhere close to the beginning of--- documentation.-newtype DGeneralInfoSection = DGeneralInfoSection SubDoc--instance DocItem DGeneralInfoSection where-  docItemPos = 1-  docItemSectionName = Nothing-  docItemToMarkdown lvl (DGeneralInfoSection subDoc) =-    subDocToMarkdown lvl subDoc-  docItemToToc lvl (DGeneralInfoSection subDoc) =-    subDocToToc lvl subDoc---- | Give a name to document block.-data DName = DName Text SubDoc--instance DocItem DName where-  docItemPos = 3-  docItemSectionName = Nothing-  docItemToMarkdown lvl (DName name doc) =-    mdHeader lvl (build name) <>-    subDocToMarkdown (nextHeaderLevel lvl) doc-  docItemToToc lvl (DName _ doc) =-    subDocToToc (nextHeaderLevel lvl) doc---- | This instance allows writing something like @docGroup "Title"@,--- this makes sense as the most primitive and basic use case for doc groups--- is putting a section under name.-instance (di ~ DName) => IsString (SubDoc -> di) where-  fromString = DName . fromString---- | Description of something.-data DDescription = DDescription Markdown--instance DocItem DDescription where-  docItemPos = 10-  docItemSectionName = Nothing-  docItemToMarkdown _ (DDescription txt) = build txt---- | Specify version if given contract.-data DGitRevisionInfo = DGitRevisionInfo-  { dgrRepoSettings :: GitRepoSettings-  , dgrCommitSha :: Text-  , dgrCommitDate :: Text-  }--data DGitRevision-  = DGitRevisionKnown DGitRevisionInfo-  | DGitRevisionUnknown---- | Repository settings for 'DGitRevision'.-newtype GitRepoSettings = GitRepoSettings-  { grsMkGitRevision :: Text -> Text-    -- ^ By commit sha make up a url to that commit in remote repository.--    -- @martoon: I tried to get remote URL automatically, but failed to-    -- find a way. Even "git-link" in emacs performs complex parsing.-  }--morleyRepoSettings :: GitRepoSettings-morleyRepoSettings = GitRepoSettings $ \commit ->-  "https://gitlab.com/morley-framework/morley/-/tree/" <> commit---- | Make 'DGitRevision'.------ >>> :t $mkDGitRevision--- ... :: GitRepoSettings -> DGitRevision-mkDGitRevision :: TH.ExpQ-mkDGitRevision = [e| \dgrRepoSettings ->-  maybe DGitRevisionUnknown DGitRevisionKnown $-    -- TH does not like do-blocks-    $(pickInfo gitHash "MORLEY_DOC_GIT_COMMIT_SHA") >>= \dgrCommitSha ->-    $(pickInfo gitCommitDate "MORLEY_DOC_GIT_COMMIT_DATE") >>= \dgrCommitDate ->-    return DGitRevisionInfo{..}-  |]-  where-    pickInfo a b = TH.lift =<< pickInfo' a b--    pickInfo' :: TH.ExpQ -> String -> TH.Q (Maybe String)-    pickInfo' askGit envKey =-      liftIO (lookupEnv envKey) >>= \case-        Just "UNSPECIFIED" -> return Nothing-        Just envValue -> return $ Just envValue-        Nothing -> askGit >>= \case-          -- Looks like with GitRev package we can't do anything better-          TH.LitE (TH.StringL "UNKNOWN") -> do-            TH.reportWarning $-              "Contract autodoc: \-              \Not including git repository info because it cannot be deduced. \-              \Either provide repository environment, or pass '" <> envKey <> "' \-              \environmental variable."-            return Nothing-          TH.LitE (TH.StringL str) -> return (Just str)-          value -> error $ "Unknown value returned by git: " <> show value--instance DocItem DGitRevision where-  docItemPos = 2-  docItemSectionName = Nothing-  docItemToMarkdown _ (DGitRevisionKnown DGitRevisionInfo{..}) =-    mconcat-    [ mdSubsection "Code revision" $-        let link = grsMkGitRevision dgrRepoSettings dgrCommitSha-        in mconcat-           [ mdRef (build $ T.take 7 dgrCommitSha) (build link)-           , " "-           , mdItalic $ "(" <> build dgrCommitDate <> ")"-           ]-    ]-  docItemToMarkdown _ DGitRevisionUnknown = ""---- | Comment in the doc (mostly used for licenses)-data DComment = DComment Text--instance DocItem DComment where-  docItemPos = 0-  docItemSectionName = Nothing-  docItemToMarkdown _ (DComment commentText) =-    "<!---\n" +| commentText |+ "\n-->"---- | @Table of contents@ to be inserted into the doc in an ad-hoc way.------ It is not intended to be inserted manually. See 'attachToc' to understand--- how this works.----data DToc = DToc Markdown--instance DocItem DToc where-  docItemPos = 11-  docItemSectionName = Just "Table of contents"-  docItemToMarkdown _ (DToc toc) = toc---- | A hand-made anchor.-data DAnchor = DAnchor Anchor--instance DocItem DAnchor where-  docItemPos = 4-  docItemSectionName = Nothing-  docItemToMarkdown _ (DAnchor a) = mdAnchor a--data DConversionInfo = DConversionInfo---- TODO: we should also recommend using morley-client when--- it'll become good enough-instance DocItem DConversionInfo where-  docItemPos = 15-  docItemSectionName = Just "Haskell ⇄ Michelson conversion"-  docItemToMarkdown _ _ =-    "This smart contract is developed in Haskell using the \-    \[Morley framework](https://gitlab.com/morley-framework/morley). \-    \Documentation mentions Haskell types that can be used for interaction with \-    \this contract from Haskell, but for each Haskell type we also mention its \-    \Michelson representation to make interactions outside of Haskell possible.\n\n\-    \There are multiple ways to interact with this contract:\n\n\-    \* Use this contract in your Haskell application, thus all operation submissions \-    \should be handled separately, e.g. via calling `tezos-client`, which will communicate \-    \with the `tezos-node`. In order to be able to call `tezos-client` you'll need to be able \-    \to construct Michelson values from Haskell.\n\n\-    \  The easiest way to do that is to serialize Haskell value using `lPackValue` function \-    \from [`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs) \-    \module, encode resulting bytestring to hexadecimal representation using `encodeHex` function. \-    \Resulting hexadecimal encoded bytes sequence can be decoded back to Michelson value via \-    \`tezos-client unpack michelson data`.\n\n\-    \  Reverse conversion from Michelson value to the \-    \Haskell value can be done by serializing Michelson value using `tezos-client hash data` command, \-    \resulting `Raw packed data` should be decoded from the hexadecimal representation using `decodeHex` \-    \and deserialized to the Haskell value via `lUnpackValue` function from \-    \[`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs).\n\n\-    \* Construct values for this contract directly on Michelson level using types provided in the \-    \documentation."---- | Attach information about git revision.--- The code must contain git revision placeholder.------ We do this in two stages because we use TH to deduce git revision information--- at compile time, and this is best to be done in the very end to recompile--- less modules.-attachGitInfo :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a-attachGitInfo gitRev = finalizedAsIs ... modifyDoc $ \case-  DGitRevisionUnknown -> Just gitRev-  _ -> Nothing--attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a-attachToc toc = finalizedAsIs ... modifyDoc $ \case-  DToc "" -> Just toc-  _ -> Nothing---- | Attach common information that is available only in the end.-attachDocCommons :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a-attachDocCommons gitRev code = do-  let toc = DToc $ contractDocToToc (buildDocUnfinalized code)-  pure code-    >>= attachGitInfo gitRev-    >>= attachToc toc

− src/Michelson/ErrorPos.hs

@@ -1,90 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.ErrorPos-  ( mkPos-  , unsafeMkPos-  , Pos (..)-  , SrcPos (..)-  , srcPos-  , InstrCallStack (..)-  , LetCallStack-  , LetName (..)-  ) where--import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import Data.Default (Default(..))-import qualified Data.Text as T-import Fmt (Buildable (..))-import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable)-import Text.PrettyPrint.Leijen.Text---import Util.Aeson---newtype Pos = Pos {unPos :: Word}-  deriving stock (Eq, Ord, Show, Generic, Data)--instance NFData Pos--unsafeMkPos :: Int -> Pos-unsafeMkPos x-  | x < 0     = error $ "negative pos: " <> show x-  | otherwise = Pos $ fromIntegral x--mkPos :: Int -> Maybe Pos-mkPos x-  | x < 0     = Nothing-  | otherwise = Just $ Pos $ fromIntegral x--data SrcPos =-  SrcPos-  { srcLine :: Pos-  , srcCol :: Pos-  } deriving stock (Eq, Ord, Show, Generic, Data)--instance Buildable SrcPos where-  build (SrcPos (Pos l) (Pos c)) = build l <> ":" <> build c--instance NFData SrcPos--srcPos :: Word -> Word -> SrcPos-srcPos x y = SrcPos (Pos x) (Pos y)--newtype LetName = LetName T.Text-  deriving stock (Eq, Ord, Show, Data, Generic)-  deriving newtype Buildable--instance NFData LetName--type LetCallStack = [LetName]-data InstrCallStack = InstrCallStack-  { icsCallStack :: LetCallStack-  , icsSrcPos    :: SrcPos-  } deriving stock (Eq, Ord, Show, Generic, Data)--instance RenderDoc InstrCallStack where-  renderDoc _ InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos row) (Pos col)} =-    "Error occurred on line" <+> (renderAnyBuildable (row + 1)) <+> "char" <+> (renderAnyBuildable (col + 1))-    <> case icsCallStack of-         [] -> "."-         _ -> " inside these let defenitions:" <+> (list $ fmap (text . show) icsCallStack) <> "."--instance NFData InstrCallStack--instance Default Pos where-  def = Pos 0--instance Default SrcPos where-  def = SrcPos def def--instance Default InstrCallStack where-  def = InstrCallStack def def--deriveJSON morleyAesonOptions ''Pos-deriveJSON morleyAesonOptions ''SrcPos-deriveJSON morleyAesonOptions ''LetName-deriveJSON morleyAesonOptions ''InstrCallStack

− src/Michelson/FailPattern.hs

@@ -1,126 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- NOTE this pragmas.--- We disable some wargnings for the sake of speed up.--- Write code with care.-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}---- | Typical usages of FAILWITH instruction.--module Michelson.FailPattern-  ( TypicalFailWith-  , typicalFailWithTag-  , isTypicalFailWith-  , modifyTypicalFailWith-  ) where--import Data.Singletons (withSingI)--import Michelson.Text (MText)-import Michelson.Typed---- | This data type captures typical ways to use `FAILWITH` instruction.--- Each constructor corresponds to a usage pattern.-data TypicalFailWith-  = FailWithString MText-  -- ^ Push a constant string and fail with it.-  | FailWithConstantPair MText (SomeConstrainedValue ConstantScope)-  -- ^ Push a constant pair where the first item is a string and the-  -- second one is an arbitrary constant. Fail afterwards.-  | FailWithStackValue MText-  -- ^ Push a constant string and apply the 'PAIR' instruction, then fail.---- | Extract error tag out of 'TypicalFailWith'.-typicalFailWithTag :: TypicalFailWith -> MText-typicalFailWithTag = \case-  FailWithString str -> str-  FailWithConstantPair str _ -> str-  FailWithStackValue str -> str---- | Check whether given instruction ends with a typical 'FAILWITH'--- usage. It does not recursively check instructions that can be--- passed to other instructions.------ The instruction MUST be linearized to the left (see 'linearizeLeft').-isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith-isTypicalFailWith = \case-  Seq i1 FAILWITH -> isTypicalPreFailWith i1-  _ -> Nothing-  where-    isTypicalPreFailWith ::-      Instr inp (a ': out) -> Maybe TypicalFailWith-    isTypicalPreFailWith =-      \case-        PUSH v -> isTypicalErrorConstant v-        Seq _ (PUSH v) -> isTypicalErrorConstant v--        Seq (PUSH v) PAIR -> FailWithStackValue <$> isStringValue v-        Seq (Seq _ (PUSH v)) PAIR -> FailWithStackValue <$> isStringValue v--        _ -> Nothing--isTypicalErrorConstant ::-  forall t. ConstantScope t => Value t -> Maybe TypicalFailWith-isTypicalErrorConstant v-  | Just str <- isStringValue v = Just (FailWithString str)-  | VPair (VString str, secondItem) <- v =-      -- We need to pattern match to deduce `singI` for second item of the pair.-      case sing @t of-        STPair l r -> withSingI l $ withSingI r $ Just (FailWithConstantPair str (SomeConstrainedValue secondItem))-  | otherwise = Nothing---- | If given instruction ends with a typical 'FAILWITH' usage, modify--- the tag used there using given transformation function. It can--- return any value, not necessarily a string.-modifyTypicalFailWith-  :: HasCallStack-  => (MText -> SomeConstrainedValue ConstantScope)-  -> Instr inp out-  -> Instr inp out-modifyTypicalFailWith f = modifyTypicalFailWith' . linearizeLeft-  where-    modifyTypicalFailWith' :: HasCallStack => Instr inp out -> Instr inp out-    modifyTypicalFailWith' =-      \case-        Seq i1 FAILWITH ->-          case i1 of-            PUSH v -> onPush v-            Seq i0 (PUSH v) -> Seq i0 (onPush v)--            -- It is quite hard to move the body of these very similar-            -- cases into a separate function because involved types-            -- are quite sophisticated.-            Seq (PUSH v) PAIR-              | _ :: Value a <- v-              , _ :: Instr (b ': s) ('TPair a b ': s) <- i1 ->-                case sing @('TPair a b) of-                  STPair l r -> withSingI l $ withSingI r $ case isStringValue v of-                    Just (f -> SomeConstrainedValue v') ->-                      PUSH v' `Seq` PAIR `Seq` FAILWITH-                    Nothing ->-                      PUSH v `Seq` PAIR `Seq` FAILWITH-            Seq (Seq i0 (PUSH v)) PAIR-              | _ :: Value a <- v-              , _ :: Instr s0 ('TPair a b ': s) <- i1 ->-                case sing @('TPair a b) of-                  STPair l r -> withSingI l $ withSingI r $ Seq i0 $ case isStringValue v of-                    Just (f -> SomeConstrainedValue v') ->-                      PUSH v' `Seq` PAIR `Seq` FAILWITH-                    Nothing ->-                      PUSH v `Seq` PAIR `Seq` FAILWITH--            _ -> Seq i1 FAILWITH--        i -> i--    onPush ::-      (HasCallStack, ConstantScope v) => Value v -> Instr inp out-    onPush v = case isTypicalErrorConstant v of-      Just (FailWithString (f -> SomeConstrainedValue v')) -> PUSH v' `Seq` FAILWITH-      Just (FailWithConstantPair (f -> SomeConstrainedValue v') (SomeConstrainedValue arg)) ->-        PUSH (VPair (v', arg)) `Seq` FAILWITH-      Just _ -> error "Unexpected TypicalFailWith"-      Nothing -> PUSH v `Seq` FAILWITH

− src/Michelson/Interpret.hs

@@ -1,899 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, containing function to interpret Michelson--- instructions against given context and input stack.-module Michelson.Interpret-  ( ContractEnv (..)-  , InterpreterState (..)-  , isMorleyLogsL-  , MichelsonFailed (..)-  , RemainingSteps (..)-  , SomeItStack (..)-  , MorleyLogs (..)-  , noMorleyLogs-  , pickMorleyLogs--  , interpret-  , interpretInstr-  , interpretInstrAnnotated-  , ContractReturn--  , mkInitStack-  , fromFinalStack-  , InterpretError (..)-  , InterpretResult (..)-  , EvalM-  , InterpreterStateMonad (..)-  , StkEl (..)-  , starNotesStkEl-  , InstrRunner-  , runInstr-  , runInstrNoGas-  , runUnpack--    -- * Internals-  , initInterpreterState-  , handleContractReturn-  , runInstrImpl-  , assignBigMapIds-  ) where--import Prelude hiding (EQ, GT, LT)--import Control.Lens (makeLensesFor, traverseOf, (<<+=))-import Control.Monad.Except (MonadError, throwError)-import Data.Default (Default(..))-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Vinyl (Rec(..), (<+>))-import Data.Vinyl.Recursive (rmap)-import Fmt (Buildable(build), Builder, blockListF, prettyLn)--import Michelson.Interpret.Pack (packValue')-import Michelson.Interpret.Unpack (UnpackError, unpackValue')-import Michelson.Runtime.GState-import Michelson.TypeCheck (SomeParamType(..), TcOriginatedContracts, matchTypes)-import Michelson.Typed hiding (Branch(..))-import qualified Michelson.Typed as T-import Michelson.Typed.Origination-  (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash)-import qualified Michelson.Untyped as U-import Michelson.Untyped.Annotation (annQ)-import Tezos.Address (Address(..), GlobalCounter(..), OriginationIndex(..))-import Tezos.Core (ChainId, Mutez, Timestamp)-import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, keccak, sha256, sha3, sha512)-import Tezos.Crypto.BLS12381 (checkPairing)-import Util.Peano (LongerThan, Peano)-import Util.PeanoNatural (PeanoNatural(..))-import Util.Sing (eqParamSing)-import Util.TH-import Util.Type-import Util.Typeable---- | Morley logs for interpreter state that are stored in reverse order.-newtype MorleyLogs = MorleyLogs [Text]-  deriving stock (Eq, Show, Generic)-  deriving newtype Default--pickMorleyLogs :: MorleyLogs -> [Text]-pickMorleyLogs (MorleyLogs logs) = reverse logs--instance Buildable MorleyLogs where-  build = blockListF . pickMorleyLogs--instance NFData MorleyLogs--noMorleyLogs :: MorleyLogs-noMorleyLogs = MorleyLogs []--newtype RemainingSteps = RemainingSteps Word64-  deriving stock (Show, Generic)-  deriving newtype (Eq, Ord, Buildable, Num)--instance NFData RemainingSteps--data InterpreterState = InterpreterState-  { isMorleyLogs :: MorleyLogs-  , isRemainingSteps :: RemainingSteps-  , isOriginationNonce :: OriginationIndex-  , isBigMapCounter :: BigMapCounter-  } deriving stock (Show, Generic)--instance NFData InterpreterState-makeLensesFor-  [ ("isMorleyLogs", "isMorleyLogsL")-  , ("isBigMapCounter", "isBigMapCounterL")-  ]-  ''InterpreterState--data StkEl t = StkEl-  { seValue :: Value t-  , seVarAnn :: U.VarAnn-  , seNotes :: Notes t-  } deriving stock (Eq, Show)--makeLensesFor-  [ ("seValue", "seValueL")-  , ("seVarAnn", "seVarAnnL")-  ]-  ''StkEl--starNotesStkEl :: forall t. Value t -> StkEl t-starNotesStkEl v = StkEl v U.noAnn $ withValueTypeSanity v $ starNotes @t---- | Environment for contract execution.-data ContractEnv = ContractEnv-  { ceNow :: Timestamp-  -- ^ Timestamp returned by the 'NOW' instruction.-  , ceMaxSteps :: RemainingSteps-  -- ^ Number of steps after which execution unconditionally terminates.-  , ceBalance :: Mutez-  -- ^ Current amount of mutez of the current contract.-  , ceContracts :: TcOriginatedContracts-  -- ^ Mapping from existing contracts' addresses to their executable-  -- representation.-  , ceSelf :: Address-  -- ^ Address of the interpreted contract.-  , ceSource :: Address-  -- ^ The contract that initiated the current transaction.-  , ceSender :: Address-  -- ^ The contract that initiated the current internal transaction.-  , ceAmount :: Mutez-  -- ^ Amount of the current transaction.-  , ceVotingPowers :: VotingPowers-  -- ^ Distribution of voting power.-  , ceChainId :: ChainId-  -- ^ Identifier of the current chain.-  , ceOperationHash :: Maybe OperationHash-  -- ^ Hash of the currently executed operation, required for-  -- correct contract address computation in 'CREATE_CONTRACT' instruction.-  , ceGlobalCounter :: GlobalCounter-  -- ^ A global counter that is used to ensure newly created-  -- contracts have unique addresses.-  , ceLevel :: Natural-  -- ^ Number of blocks before the given one in the chain-  }---- | Represents @[FAILED]@ state of a Michelson program. Contains--- value that was on top of the stack when @FAILWITH@ was called.-data MichelsonFailed where-  MichelsonFailedWith :: (SingI t, ConstantScope t) => T.Value t -> MichelsonFailed-  MichelsonArithError-    :: (Typeable n, Typeable m, Typeable instr)-    => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed-  MichelsonGasExhaustion :: MichelsonFailed-  MichelsonFailedTestAssert :: Text -> MichelsonFailed--deriving stock instance Show MichelsonFailed--instance Eq MichelsonFailed where-  MichelsonFailedWith v1 == MichelsonFailedWith v2 = v1 `eqParamSing` v2-  MichelsonFailedWith _ == _ = False-  MichelsonArithError ae1 == MichelsonArithError ae2 = ae1 `eqParam2` ae2-  MichelsonArithError _ == _ = False-  MichelsonGasExhaustion == MichelsonGasExhaustion = True-  MichelsonGasExhaustion == _ = False-  MichelsonFailedTestAssert t1 == MichelsonFailedTestAssert t2 = t1 == t2-  MichelsonFailedTestAssert _ == _ = False--instance Buildable MichelsonFailed where-  build =-    \case-      MichelsonFailedWith (v :: T.Value t) ->-        "Reached FAILWITH instruction with " <> formatValue v-      MichelsonArithError v -> build v-      MichelsonGasExhaustion ->-        "Gas limit exceeded on contract execution"-      MichelsonFailedTestAssert t -> build t-    where-      formatValue :: forall t . SingI t => Value t -> Builder-      formatValue v =-        case T.checkOpPresence (sing @t) of-          OpPresent -> "<value with operations>"-          OpAbsent -> build (untypeValue v)--newtype InterpretError = InterpretError (MichelsonFailed, MorleyLogs)-  deriving stock (Generic)--deriving stock instance Show InterpretError--instance Buildable InterpretError where-  build (InterpretError (mf, _)) = prettyLn mf--data InterpretResult where-  InterpretResult-    :: ( StorageScope st )-    => { iurOps :: [Operation]-       , iurNewStorage :: T.Value st-       , iurNewState   :: InterpreterState-       }-    -> InterpretResult--deriving stock instance Show InterpretResult--constructIR ::-  (StorageScope st) =>-  (([Operation], Value' Instr st), InterpreterState) ->-  InterpretResult-constructIR ((ops, val), st) =-  InterpretResult-  { iurOps = ops-  , iurNewStorage = val-  , iurNewState = st-  }--type ContractReturn st =-  (Either MichelsonFailed ([Operation], T.Value st), InterpreterState)--handleContractReturn-  :: (StorageScope st)-  => ContractReturn st -> Either InterpretError InterpretResult-handleContractReturn (ei, s) =-  bimap (InterpretError . (, isMorleyLogs s)) (constructIR . (, s)) ei---- | Helper function to convert a record of @Value@ to @StkEl@. These will be--- created with @starNotes@.-mapToStkEl :: Rec T.Value inp -> Rec StkEl inp-mapToStkEl = rmap starNotesStkEl---- | Helper function to convert a record of @StkEl@ to @Value@. Any present--- notes will be discarded.-mapToValue :: Rec StkEl inp -> Rec T.Value inp-mapToValue = rmap seValue--interpret'-  :: forall cp st arg.-     Contract cp st-  -> EntrypointCallT cp arg-  -> T.Value arg-  -> T.Value st-  -> ContractEnv-  -> InterpreterState-  -> ContractReturn st-interpret' Contract{..} epc param initSt env ist = first (fmap fromFinalStack) $-  runEvalOp-    (runInstr cCode $ mkInitStack (liftCallArg epc param) cParamNotes initSt cStoreNotes)-    env-    ist--mkInitStack-  :: T.Value param-  -> T.ParamNotes param-  -> T.Value st-  -> T.Notes st-  -> Rec StkEl (ContractInp param st)-mkInitStack param T.UnsafeParamNotes{..} st stNotes = StkEl-  (T.VPair (param, st))-  U.noAnn-  (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn [annQ|parameter|] [annQ|storage|] pnNotes stNotes)-    :& RNil--fromFinalStack :: Rec StkEl (ContractOut st) -> ([T.Operation], T.Value st)-fromFinalStack (StkEl (T.VPair (T.VList ops, st)) _ _ :& RNil) =-  (map (\(T.VOp op) -> op) ops, st)--interpret-  :: Contract cp st-  -> EntrypointCallT cp arg-  -> T.Value arg-  -> T.Value st-  -> BigMapCounter-  -> ContractEnv-  -> ContractReturn st-interpret contract epc param initSt bmCounter env =-  interpret' contract epc param initSt env (initInterpreterState bmCounter env)--initInterpreterState :: BigMapCounter -> ContractEnv -> InterpreterState-initInterpreterState bmCounter env = InterpreterState def (ceMaxSteps env) (OriginationIndex 0) bmCounter---- | Interpret an instruction in vacuum, putting no extra contraints on--- its execution.------ Mostly for testing purposes.-interpretInstr-  :: ContractEnv-  -> Instr inp out-  -> Rec T.Value inp-  -> Either MichelsonFailed (Rec T.Value out)-interpretInstr = fmap mapToValue ... interpretInstrAnnotated---- | Interpret an instruction in vacuum, putting no extra contraints on--- its execution while preserving its annotations.------ Mostly for testing purposes.-interpretInstrAnnotated-  :: ContractEnv-  -> Instr inp out-  -> Rec T.Value inp-  -> Either MichelsonFailed (Rec StkEl out)-interpretInstrAnnotated env instr inpSt =-  fst $-  runEvalOp-    (runInstr instr $ mapToStkEl inpSt)-    env-    InterpreterState-      { isMorleyLogs = MorleyLogs []-      , isRemainingSteps = 9999999999-      , isOriginationNonce = OriginationIndex 0-      , isBigMapCounter = 0-      }--data SomeItStack where-  SomeItStack :: T.ExtInstr inp -> Rec StkEl inp -> SomeItStack--type EvalOp a =-  ExceptT MichelsonFailed-    (ReaderT ContractEnv-       (State InterpreterState)) a--runEvalOp-  :: EvalOp a-  -> ContractEnv-  -> InterpreterState-  -> (Either MichelsonFailed a, InterpreterState)-runEvalOp act env initSt =-  flip runState initSt $ usingReaderT env $ runExceptT act--class Monad m => InterpreterStateMonad m where-  getInterpreterState :: m InterpreterState-  getInterpreterState = stateInterpreterState (\s -> (s, s))--  putInterpreterState :: InterpreterState -> m ()-  putInterpreterState s = stateInterpreterState (\_ -> ((), s))--  stateInterpreterState :: (InterpreterState -> (a, InterpreterState)) -> m a-  stateInterpreterState f = do-    s <- getInterpreterState-    let (a, s') = f s-    a <$ putInterpreterState s'--  modifyInterpreterState :: (InterpreterState -> InterpreterState) -> m ()-  modifyInterpreterState f = stateInterpreterState (((), ) . f)--instance InterpreterStateMonad (ExceptT MichelsonFailed $-                                ReaderT ContractEnv $-                                State InterpreterState) where-  stateInterpreterState f = lift $ lift $ state f--type EvalM m =-  ( MonadReader ContractEnv m-  , InterpreterStateMonad m-  , MonadError MichelsonFailed m-  )--type InstrRunner m =-  forall inp out.-     Instr inp out-  -> Rec StkEl inp-  -> m (Rec StkEl out)---- | Function to change amount of remaining steps stored in State monad.-runInstr :: EvalM m => InstrRunner m-runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r-runInstr i@(WithLoc _ _) r = runInstrImpl runInstr i r-runInstr i@(InstrWithNotes _ _ _i1) r = runInstrImpl runInstr i r-runInstr i@(InstrWithVarNotes _ _i1) r = runInstrImpl runInstr i r-runInstr i@(InstrWithVarAnns _ _i1) r = runInstrImpl runInstr i r-runInstr i@Nop r = runInstrImpl runInstr i r-runInstr i@(Nested _) r = runInstrImpl runInstr i r-runInstr i@(DocGroup _ _i1) r = runInstrImpl runInstr i r-runInstr i@(Fn _ _ _i1) r = runInstrImpl runInstr i r-runInstr i r = do-  rs <- isRemainingSteps <$> getInterpreterState-  if rs == 0-  then throwError MichelsonGasExhaustion-  else do-    modifyInterpreterState (\s -> s {isRemainingSteps = rs - 1})-    runInstrImpl runInstr i r--runInstrNoGas :: EvalM m => InstrRunner m-runInstrNoGas = runInstrImpl runInstrNoGas---- | Function to interpret Michelson instruction(s) against given stack.-runInstrImpl :: forall m. EvalM m => InstrRunner m -> InstrRunner m-runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'-runInstrImpl runner (WithLoc _ i) r = runner i r-runInstrImpl runner (InstrWithNotes (_ :: Proxy rest) notes instr) inp = do-  out <- runner instr inp-  let zipRec :: Rec Notes topElems -> Rec StkEl (topElems ++ rest) -> Rec StkEl (topElems ++ rest)-      zipRec RNil stkElems = stkElems-      zipRec (stkElemNotes :& xs) (stkElem :& ys) =-        stkElem { seNotes = stkElemNotes } :& zipRec xs ys-  pure $ zipRec notes out-runInstrImpl runner (InstrWithVarNotes _vns i) inp = runner i inp-runInstrImpl runner (InstrWithVarAnns vns i) inp = do-  runner i inp <&> \case-    StkEl v1 _ n1 :& StkEl v2 vn2 n2 :& r -> case vns of-      U.OneVarAnn vn      -> StkEl v1 vn n1 :& StkEl v2 vn2 n2 :& r-      U.TwoVarAnns vn vn' -> StkEl v1 vn n1 :& StkEl v2 vn' n2 :& r-    StkEl v _ n :& r -> case vns of-      U.OneVarAnn vn   -> StkEl v vn n :& r-      U.TwoVarAnns _ _ -> error "Input stack is exhausted but there is still a variable annotation."-    RNil -> error "Input stack is exhausted but there is still variables annotations."-runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do-  let (inp, end) = rsplit @_ @_ @s r-  out <- runInstrImpl runner i inp-  return (out <+> end)-runInstrImpl _ Nop r = pure $ r-runInstrImpl runner (Ext nop) r = r <$ interpretExt runner (SomeItStack nop r)-runInstrImpl runner (Nested sq) r = runner sq r-runInstrImpl runner (DocGroup _ sq) r = runInstrImpl runner sq r-runInstrImpl runner (Fn _ _ i) r = runner i r-runInstrImpl _ DROP (_ :& r) = pure $ r-runInstrImpl runner (DROPN n) stack =-  case n of-    Zero    -> pure stack-    Succ s' -> case stack of-      (_ :& r) -> runInstrImpl runner (DROPN s') r-      -- Note: we intentionally do not use `runner` to recursively-      -- interpret `DROPN` here.-      -- All these recursive calls together correspond to a single-      -- Michelson instruction call.-      -- This recursion is implementation detail of `DROPN`.-      -- The same reasoning applies to other instructions parameterized-      -- by a natural number like 'DIPN'.-runInstrImpl _ DUP (stkEl :& r) = do-  -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s).-  duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl-  pure $ duplicateStkEl :& stkEl :& r-runInstrImpl _ (DUPN s) stack = go s stack-  where-    go :: forall (n :: Peano) inp out a. ConstraintDUPN n inp out a-       => PeanoNatural n -> Rec StkEl inp -> m (Rec StkEl out)-    go (Succ Zero) stk@(stkEl :& _) = do-        -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s).-        duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl-        -- Discard variable annotations. This is consistent with tezos-client.-        pure $ (duplicateStkEl & seVarAnnL .~ U.noAnn) :& stk-    go (Succ n@(Succ _)) (b :& r) =-      go n r <&> \case-        (a :& resTail) -> a :& b :& resTail-runInstrImpl _ SWAP (a :& b :& r) = pure $ b :& a :& r-runInstrImpl _ (DIG s) input0 =-  pure $ go s input0-  where-    go :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a-       => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out-    go Zero stack = stack-    go (Succ n') (b :& r) = case go n' r of-      (a :& resTail) -> a :& b :& resTail-runInstrImpl _ (DUG s) input0 =-  pure $ go s input0-  where-    go :: forall (n :: Peano) inp out a. ConstraintDUG n inp out a-       => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out-    go Zero stack = stack-    go (Succ n') (a :& b :& r) = b :& go n' (a :& r)-runInstrImpl _ SOME ((seValue -> a) :& r) =-  withValueTypeSanity a $-    pure $ starNotesStkEl (VOption (Just a)) :& r-runInstrImpl _ (PUSH v) r = pure $ starNotesStkEl v :& r-runInstrImpl _ NONE r = pure $ starNotesStkEl (VOption Nothing) :& r-runInstrImpl _ UNIT r = pure $ starNotesStkEl VUnit :& r-runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) vn (NTOption _ n) :& r) =-  runner bJust (StkEl a vn n :& r)-runInstrImpl runner (IF_NONE bNone _bJust) (StkEl (VOption Nothing) _ _ :& r) =-  runner bNone r-runInstrImpl _ NEVER inp = case inp of {}-runInstrImpl _ (AnnPAIR{}) ((StkEl a _ _) :& (StkEl b _ _) :& r) =-  pure $ starNotesStkEl (VPair (a, b)) :& r-runInstrImpl _ (AnnUNPAIR{}) ((StkEl (VPair (a, b)) _ _) :& r) =-  pure $ starNotesStkEl a :& starNotesStkEl b :& r-runInstrImpl _ (PAIRN s) stack = pure $ go s stack-  where-    go :: forall n inp. ConstraintPairN n inp => PeanoNatural n -> Rec StkEl inp -> Rec StkEl (PairN n inp)-    go (Succ (Succ Zero)) (StkEl a _ _ :& StkEl b _ _ :& r) =-      -- if n=2-      starNotesStkEl (VPair (a, b)) :& r-    go (Succ n@(Succ (Succ _))) (StkEl a _ _ :& r@(_ :& _ :& _)) =-      -- if n>2-      case go n r of-        StkEl combed _ _ :& r' ->-            starNotesStkEl (VPair (a, combed)) :& r'-runInstrImpl _ (UNPAIRN s) (StkEl pair0 _ pairNotes0 :& r) = do-  pure $ go s pair0 pairNotes0 <+> r-  where-    go-      :: forall n pair. ConstraintUnpairN n pair-      => PeanoNatural n -> Value pair -> Notes pair-      -> Rec StkEl (UnpairN n pair)-    go n pair pairNotes =-      case (n, pair, pairNotes) of-        -- if n=2-        (Succ (Succ Zero), VPair (a, b), NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes) ->-          -- @UNPAIR n@ converts field annotations into var annotations.-          ---          -- > /* [ @pair pair (int %aa) (int %bb) (int %cc) (int %dd) ] */ ;-          -- > UNPAIR 3-          -- > /* [ @aa int : @bb int : pair (int %cc) (int %dd) ] */ ;-          ---          -- Nested var annotations will be discarded.-          ---          -- > /* [ pair (int @c) (int @a) (int @b) ] */ ;-          -- UNPAIR 3-          -- /* [ int : int : int ] */ ;-          StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes-            :& StkEl b (U.convAnn @U.FieldTag @U.VarTag bFieldAnn) bNotes-            :& RNil-        -- if n>2-        (Succ n'@(Succ (Succ _)), VPair (a, b@(VPair _)), NTPair _ aFieldAnn _ _ _ aNotes bNotes) ->-          StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes-            :& go n' b bNotes-runInstrImpl _ (AnnCAR _ _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r-runInstrImpl _ (AnnCDR _ _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r-runInstrImpl _ (AnnLEFT nt nf1 nf2) ((StkEl a _ na) :& r) =-  withValueTypeSanity a $-    pure $ StkEl (VOr $ Left a) U.noAnn (NTOr nt nf1 nf2 na starNotes) :& r-runInstrImpl _ (AnnRIGHT nt nf1 nf2) ((StkEl b _ nb) :& r) =-  withValueTypeSanity b $-    pure $ StkEl (VOr $ Right b) U.noAnn (NTOr nt nf1 nf2 starNotes nb) :& r-runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) =-  runner bLeft (StkEl a vn nl :& r)-runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) vn (NTOr _ _ _ _ nr) :& r) =-  runner bRight (StkEl a vn nr :& r)-runInstrImpl _ NIL r = pure $ starNotesStkEl (VList []) :& r-runInstrImpl _ CONS (a :& StkEl (VList l) _ _ :& r) = pure $ starNotesStkEl (VList (seValue a : l)) :& r-runInstrImpl runner (IF_CONS _ bNil) (StkEl (VList []) _ _ :& r) = runner bNil r-runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) vn ntl@(NTList _ nhd) :& r) =-  runner bCons (StkEl lh vn nhd :& StkEl (VList lr) vn ntl :& r)-runInstrImpl _ SIZE (a :& r) = pure $ starNotesStkEl (VNat $ (fromInteger . toInteger) $ evalSize $ seValue a) :& r-runInstrImpl _ EMPTY_SET r = pure $ starNotesStkEl (VSet Set.empty) :& r-runInstrImpl _ EMPTY_MAP r = pure $ starNotesStkEl (VMap Map.empty) :& r-runInstrImpl _ EMPTY_BIG_MAP r = do-  bigMap <- assignBigMapIds' $ VBigMap Nothing Map.empty-  pure $ starNotesStkEl bigMap :& r-runInstrImpl runner (MAP (code :: Instr (MapOpInp c ': s) (b ': s))) (StkEl a vn n :& r) = do-  -- Evaluation must preserve all stack modifications that @MAP@'s does.-  (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do-    res <- runner code (val :& curStack)-    case res of-      ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))-    (r, []) ((\el -> StkEl el vn (mapOpNotes n)) <$> mapOpToList @c a)-  pure $ starNotesStkEl (mapOpFromList a (reverse newList)) :& newStack-runInstrImpl runner (ITER (code :: Instr (IterOpEl c ': s) s)) (StkEl a vn n :& r) =-  case iterOpDetachOne @c a of-    (Just x, xs) -> do-      res <- runner code (StkEl x vn (iterOpNotes n) :& r)-      runner (ITER code) (StkEl xs vn n :& res)-    (Nothing, _) -> pure r-runInstrImpl _ MEM (a :& b :& r) = pure $ starNotesStkEl (VBool (evalMem (seValue a) (seValue b))) :& r-runInstrImpl _ GET (a :& b :& r) = pure $ starNotesStkEl (VOption (evalGet (seValue a) (seValue b))) :& r-runInstrImpl _ (GETN s) (StkEl pair _ _ :& r) = do-  pure $ starNotesStkEl (go s pair) :& r-  where-    go-      :: forall ix a. ConstraintGetN ix a-      => PeanoNatural ix -> Value a-      -> Value (GetN ix a)-    go Zero            a                   = a-    go (Succ Zero)      (VPair (left, _))  = left-    go (Succ (Succ n')) (VPair (_, right)) = go n' right-runInstrImpl _ UPDATE (a :& b :& StkEl c _ _ :& r) =-  pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) c) :& r-runInstrImpl _ (UPDATEN s) (StkEl (val :: Value val) _ _  :& StkEl pair _ _ :& r) = do-  pure $ starNotesStkEl (go s pair) :& r-  where-    go-      :: forall ix pair. ConstraintUpdateN ix pair-      => PeanoNatural ix -> Value pair -> Value (UpdateN ix val pair)-    go Zero             _                      = val-    go (Succ Zero)      (VPair (_, right))     = VPair (val, right)-    go (Succ (Succ n')) (VPair (left, right))  = VPair (left, go n' right)-runInstrImpl _ GET_AND_UPDATE (StkEl key _ _ :& StkEl valMb _ _ :& StkEl collection _ _ :& r) =-  pure $-    starNotesStkEl (VOption (evalGet key collection))-    :& starNotesStkEl (evalUpd key valMb collection)-    :& r-runInstrImpl runner (IF bTrue _) (StkEl (VBool True) _ _ :& r) = runner bTrue r-runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) _ _ :& r) = runner bFalse r-runInstrImpl _ (LOOP _) (StkEl (VBool False) _ _ :& r) = pure $ r-runInstrImpl runner (LOOP ops) (StkEl (VBool True) _ _ :& r) = do-  res <- runner ops r-  runner (LOOP ops) res-runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) _ _ :& r) = pure $ starNotesStkEl a :& r-runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) = do-  res <- runner ops (StkEl a vn nl :& r)-  runner (LOOP_LEFT ops) res-runInstrImpl _ (LAMBDA lam) r = pure $ starNotesStkEl lam :& r-runInstrImpl runner EXEC (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) _ _ :& r) = do-  res <- runner lBody (a :& RNil)-  pure $ res <+> r-runInstrImpl _ APPLY (StkEl (a :: T.Value a) _ _ :& StkEl (VLam lBody) _ _ :& r) = do-  pure $ starNotesStkEl (VLam (T.rfMapAnyInstr doApply lBody)) :& r-  where-    doApply :: Instr ('TPair a i ': s) o -> Instr (i ': s) o-    doApply b = PUSH a `Seq` PAIR `Seq` Nested b-runInstrImpl runner (DIP i) (a :& r) = do-  res <- runner i r-  pure $ a :& res-runInstrImpl runner (DIPN s i) stack =-  case s of-    Zero -> runner i stack-    Succ s' -> case stack of-      (a :& r) -> (a :&) <$> runInstrImpl runner (DIPN s' i) r-runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith (seValue a)-runInstrImpl _ CAST (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r-runInstrImpl _ RENAME (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r-runInstrImpl _ PACK ((seValue -> a) :& r) = pure $ starNotesStkEl (VBytes $ packValue' a) :& r-runInstrImpl _ UNPACK (StkEl (VBytes a) _ _ :& r) =-  pure $ starNotesStkEl (VOption . rightToMaybe $ runUnpack a) :& r-runInstrImpl _ CONCAT (a :& b :& r) = pure $ starNotesStkEl (evalConcat (seValue a) (seValue b)) :& r-runInstrImpl _ CONCAT' (StkEl (VList a) _ _ :& r) = pure $ starNotesStkEl (evalConcat' a) :& r-runInstrImpl _ SLICE (StkEl (VNat o) _ _ :& StkEl (VNat l) _ _ :& StkEl s _ _ :& r) =-  pure $ starNotesStkEl (VOption (evalSlice o l s)) :& r-runInstrImpl _ ISNAT (StkEl (VInt i) _ _ :& r) =-  if i < 0-  then pure $ starNotesStkEl (VOption Nothing) :& r-  else pure $ starNotesStkEl (VOption (Just (VNat $ fromInteger i))) :& r-runInstrImpl _ ADD (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Add) l r-runInstrImpl _ SUB (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r-runInstrImpl _ MUL (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r-runInstrImpl _ EDIV (l :& r :& rest) = pure $ starNotesStkEl (evalEDivOp (seValue l) (seValue r)) :& rest-runInstrImpl _ ABS ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Abs) a) :& rest-runInstrImpl _ NEG ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neg) a) :& rest-runInstrImpl _ LSL (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s-runInstrImpl _ LSR (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s-runInstrImpl _ OR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r-runInstrImpl _ AND (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r-runInstrImpl _ XOR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r-runInstrImpl _ NOT ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Not) a) :& rest-runInstrImpl _ COMPARE ((seValue -> l) :& (seValue -> r) :& rest) =-  pure $ starNotesStkEl (T.VInt (compareOp l r)) :& rest-runInstrImpl _ EQ ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest-runInstrImpl _ NEQ ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neq) a) :& rest-runInstrImpl _ LT ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Lt) a) :& rest-runInstrImpl _ GT ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Gt) a) :& rest-runInstrImpl _ LE ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Le) a) :& rest-runInstrImpl _ GE ((seValue -> a) :& rest) =-  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest-runInstrImpl _ INT (StkEl a _ _ :& r) =-  pure $ starNotesStkEl (evalToIntOp a) :& r-runInstrImpl _ (SELF sepc :: Instr inp out) r = do-  ContractEnv{..} <- ask-  case Proxy @out of-    (_ :: Proxy ('TContract cp ': s)) -> do-      pure $ starNotesStkEl (VContract ceSelf sepc) :& r-runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (StkEl (VAddress epAddr) _ _ :& r) = do-  ContractEnv{..} <- ask-  let T.EpAddress addr addrEpName = epAddr-  let mepName =-        case (instrEpName, addrEpName) of-          (DefEpName, DefEpName) -> Just DefEpName-          (DefEpName, en) -> Just en-          (en, DefEpName) -> Just en-          _ -> Nothing--  let withNotes v = StkEl v U.noAnn (NTOption U.noAnn $ NTContract U.noAnn nt) :& r-  pure $ withNotes $ case mepName of-    Nothing -> VOption Nothing-    Just epName ->-      case addr of-        KeyAddress _ -> castContract addr epName T.tyImplicitAccountParam-        ContractAddress ca ->-          case Map.lookup ca ceContracts of-            Just (SomeParamType _ paramNotes) -> castContract addr epName paramNotes-            Nothing -> VOption Nothing-  where-  castContract-    :: forall p. T.ParameterScope p-    => Address -> EpName -> T.ParamNotes p -> T.Value ('TOption ('TContract a))-  castContract addr epName param = VOption $ do-    -- As we are within Maybe monad, pattern-match failure results in Nothing-    MkEntrypointCallRes na epc <- T.mkEntrypointCall epName param-    Right (Refl, _) <- pure $ matchTypes nt na-    return $ VContract addr (T.SomeEpc epc)--runInstrImpl _ TRANSFER_TOKENS-  (StkEl p _ _ :& StkEl (VMutez mutez) _ _ :& StkEl contract _ _ :& r) =-  pure $ starNotesStkEl (VOp (OpTransferTokens $ TransferTokens p mutez contract)) :& r-runInstrImpl _ SET_DELEGATE (StkEl (VOption mbKeyHash) _ _ :& r) =-  case mbKeyHash of-    Just (VKeyHash k) -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate $ Just k)) :& r-    Nothing -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate $ Nothing)) :& r-runInstrImpl _ (CREATE_CONTRACT contract)-  (StkEl (VOption mbKeyHash) _ _ :& StkEl (VMutez m) _ _ :& StkEl g _ _ :& r) = do-  originator <- ceSelf <$> ask--  originationNonce <- isOriginationNonce <$> getInterpreterState-  globalCounter <- asks ceGlobalCounter-  opHash <- ceOperationHash <$> ask-  modifyInterpreterState $ \iState ->-    iState { isOriginationNonce = OriginationIndex $ (unOriginationIndex $ isOriginationNonce iState) + 1 }-  let ops = cCode contract-  let resAddr =-        case opHash of-          Just hash -> mkContractAddress hash originationNonce globalCounter-          Nothing ->-            mkContractAddress-              (mkOriginationOperationHash (createOrigOp originator mbKeyHash m contract g))-              -- If opHash is Nothing it means that interpreter is running in some kind of test-              -- context, therefore we generate dummy contract address with its own origination-              -- operation.-              originationNonce-              globalCounter-  let resEpAddr = EpAddress resAddr DefEpName-  let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g ops-  pure $ starNotesStkEl (VOp (OpCreateContract resOp))-      :& starNotesStkEl (VAddress resEpAddr)-      :& r-runInstrImpl _ IMPLICIT_ACCOUNT (StkEl (VKeyHash k) _ _ :& r) =-  pure $ (starNotesStkEl (VContract (KeyAddress k) sepcPrimitive)) :& r-runInstrImpl _ NOW r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VTimestamp ceNow) :& r-runInstrImpl _ AMOUNT r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VMutez ceAmount) :& r-runInstrImpl _ BALANCE r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VMutez ceBalance) :& r-runInstrImpl _ VOTING_POWER (StkEl (VKeyHash k) _ _ :& r) = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VNat $ vpPick k ceVotingPowers) :& r-runInstrImpl _ TOTAL_VOTING_POWER r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VNat $ vpTotal ceVotingPowers) :& r-runInstrImpl _ CHECK_SIGNATURE-  (StkEl (VKey k) _ _ :& StkEl (VSignature v) _ _ :& StkEl (VBytes b) _ _ :& r) =-  pure $ starNotesStkEl (VBool $ checkSignature k v b) :& r-runInstrImpl _ SHA256 (StkEl (VBytes b) _ _ :& r) =-  pure $ starNotesStkEl (VBytes $ sha256 b) :& r-runInstrImpl _ SHA512 (StkEl (VBytes b) _ _ :& r) =-  pure $ starNotesStkEl (VBytes $ sha512 b) :& r-runInstrImpl _ BLAKE2B (StkEl (VBytes b) _ _ :& r) =-  pure $ starNotesStkEl (VBytes $ blake2b b) :& r-runInstrImpl _ SHA3 (StkEl (VBytes b) _ _ :& r) =-  pure $ starNotesStkEl (VBytes $ sha3 b) :& r-runInstrImpl _ KECCAK (StkEl (VBytes b) _ _ :& r) =-  pure $ starNotesStkEl (VBytes $ keccak b) :& r-runInstrImpl _ HASH_KEY (StkEl (VKey k) _ _ :& r) =-  pure $ starNotesStkEl (VKeyHash $ hashKey k) :& r-runInstrImpl _ PAIRING_CHECK (StkEl (VList pairs) _ _ :& r) = do-  let pairs' = [ (g1, g2) | VPair (VBls12381G1 g1, VBls12381G2 g2) <- pairs ]-  pure $ starNotesStkEl (VBool $ checkPairing pairs') :& r-runInstrImpl _ SOURCE r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VAddress $ EpAddress ceSource DefEpName) :& r-runInstrImpl _ SENDER r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VAddress $ EpAddress ceSender DefEpName) :& r-runInstrImpl _ ADDRESS (StkEl (VContract a sepc) _ _ :& r) =-  pure $ starNotesStkEl (VAddress $ EpAddress a (sepcName sepc)) :& r-runInstrImpl _ CHAIN_ID r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VChainId ceChainId) :& r-runInstrImpl _ LEVEL r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VNat ceLevel) :& r-runInstrImpl _ SELF_ADDRESS r = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VAddress $ EpAddress ceSelf DefEpName) :& r-runInstrImpl _ TICKET (StkEl dat _ _ :& StkEl (VNat am) _ _ :& r) = do-  ContractEnv{..} <- ask-  pure $ starNotesStkEl (VTicket ceSelf dat am) :& r-runInstrImpl _ READ_TICKET (te@(StkEl (VTicket addr dat am) _ _) :& r) = do-  pure $-    starNotesStkEl-      (VPair (VAddress (EpAddress addr DefEpName), (VPair (dat, VNat am))))-    :& te :& r-runInstrImpl _ SPLIT_TICKET-    (StkEl tv@(VTicket addr dat am) _ _ :&-     StkEl (VPair (VNat am1, VNat am2)) _ _ :& r) = do-  let result = withValueTypeSanity tv $ VOption do-        guard (am1 + am2 == am)-        return $ VPair (VTicket addr dat am1, VTicket addr dat am2)-  pure $ starNotesStkEl result :& r-runInstrImpl _ JOIN_TICKETS-  (StkEl (VPair (tv1@(VTicket addr1 dat1 am1), VTicket addr2 dat2 am2)) _ _ :& r) = do-  let result = withValueTypeSanity tv1 $ VOption do-        guard (addr1 == addr2)-        guard (dat1 == dat2)-        return $ VTicket addr1 dat1 (am1 + am2)-  pure $ starNotesStkEl result :& r---- | Evaluates an arithmetic operation and either fails or proceeds.-runArithOp-  :: (ArithOp aop n m, EvalM monad)-  => proxy aop-  -> StkEl n-  -> StkEl m-  -> monad (StkEl (ArithRes aop n m))-runArithOp op l r = case evalOp op (seValue l) (seValue r) of-  Left  err -> throwError (MichelsonArithError err)-  Right res -> pure $ starNotesStkEl res---- | Unpacks given raw data into a typed value.-runUnpack-  :: forall t. (UnpackedValScope t)-  => ByteString-  -> Either UnpackError (T.Value t)-runUnpack bs =-  -- TODO [TM-80] Gas consumption here should depend on unpacked data size-  -- and size of resulting expression, errors would also spend some (all equally).-  -- Fortunately, the inner decoding logic does not need to know anything about gas use.-  unpackValue' bs--createOrigOp-  :: (ParameterScope param, StorageScope store)-  => Address-  -> Maybe (T.Value 'T.TKeyHash)-  -> Mutez-  -> Contract param store-  -> Value' Instr store-  -> OriginationOperation-createOrigOp originator mbDelegate bal contract storage =-  OriginationOperation-    { ooOriginator = originator-    , ooDelegate = unwrapMbKeyHash mbDelegate-    , ooBalance = bal-    , ooStorage = storage-    , ooContract = contract-    }--unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash-unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash--interpretExt :: EvalM m => InstrRunner m -> SomeItStack -> m ()-interpretExt _ (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do-  let getEl (Left l) = l-      getEl (Right str) = withStackElem str st (show . seValue)-      getMorleyLogs (MorleyLogs logs) = logs-  modifyInterpreterState (\s -> s {isMorleyLogs = MorleyLogs $ mconcat (map getEl pc) : getMorleyLogs (isMorleyLogs s)})--interpretExt runner (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do-  ost <- runInstrImpl runner instr st-  let ((seValue -> T.fromVal -> succeeded) :& _) = ost-  unless succeeded $ do-    interpretExt runner (SomeItStack (T.PRINT pc) st)-    throwError $ MichelsonFailedTestAssert $ "TEST_ASSERT " <> nm <> " failed"--interpretExt _ (SomeItStack T.DOC_ITEM{} _) = pass-interpretExt _ (SomeItStack T.COMMENT_ITEM{} _) = pass-interpretExt _ (SomeItStack T.STACKTYPE{} _) = pass---- | Access given stack reference (in CPS style).-withStackElem-  :: forall st a.-     T.StackRef st-  -> Rec StkEl st-  -> (forall t. StkEl t -> a)-  -> a-withStackElem (T.StackRef sn) vals cont =-  loop (vals, sn)-  where-    loop-      :: forall s (n :: Peano). (LongerThan s n)-      => (Rec StkEl s, PeanoNatural n) -> a-    loop = \case-      (e :& _, Zero) -> cont e-      (_ :& es, Succ n) -> loop (es, n)--assignBigMapIds' :: EvalM m => Value t -> m (Value t)-assignBigMapIds' val = do-  bigMapCounter0 <- view isBigMapCounterL <$> getInterpreterState-  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds val) bigMapCounter0-  modifyInterpreterState (set isBigMapCounterL bigMapCounter1)-  pure storageWithIds---- | All big_maps stored in a chain have a globally unique ID.------ We use this function to assign a new ID whenever a big_map is created.-assignBigMapIds :: MonadState BigMapCounter m => Value t -> m (Value t)-assignBigMapIds =-  dfsTraverseValue \case-    VBigMap _ vBigMap -> do-      bigMapId <- bigMapCounter <<+= 1-      pure $ VBigMap (Just bigMapId) vBigMap-    v -> pure v--(deriveGADTNFData ''MichelsonFailed)

− src/Michelson/Interpret/Pack.hs

@@ -1,44 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, carrying logic of @PACK@ instruction.------ This is nearly symmetric to adjacent Unpack.hs module.-module Michelson.Interpret.Pack-  ( packValue-  , packValue'-  , packValuePrefix-  , toBinary-  , toBinary'-  ) where--import Prelude hiding (EQ, GT, LT)--import Michelson.Typed-import Morley.Micheline.Binary (encodeExpression, encodeExpression')-import Morley.Micheline.Class (ToExpression(..))---- | Generic serializer.-toBinary :: ToExpression a => a -> LByteString-toBinary = encodeExpression . toExpression---- | Same as 'toBinary', for strict bytestring.-toBinary' :: ToExpression a => a -> ByteString-toBinary' = encodeExpression' . toExpression---- | Serialize a value given to @PACK@ instruction.-packValue :: PackedValScope t => Value t -> LByteString-packValue x =-  let uval = untypeValueHashable x-  in packValuePrefix <> (encodeExpression $ toExpression uval)---- | Same as 'packValue', for strict bytestring.-packValue' :: PackedValScope t => Value t -> ByteString-packValue' x =-  let uval = untypeValueHashable x-  in packValuePrefix <> (encodeExpression' $ toExpression uval)---- | Prefix prepended to the binary representation of a value.-packValuePrefix :: IsString s => s-packValuePrefix = "\x05"

− src/Michelson/Interpret/Unpack.hs

@@ -1,84 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{- | Module, carrying logic of @UNPACK@ instruction.--This is nearly symmetric to adjacent Pack.hs module.--When implementing this the following sources were used:--* https://pastebin.com/8gfXaRvp--* https://gitlab.com/tezos/tezos/-/blob/767de2b6665ec2cc21e41e6348f8a0b369d26450/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501--* https://github.com/tezbridge/tezbridge-crypto/blob/f7d93d8d04201557972e839967758cff5bbe5345/PsddFKi3/codec.js#L513---}-module Michelson.Interpret.Unpack-  ( UnpackError (..)-  , unpackInstr'-  , unpackUValue'-  , unpackValue'-  ) where--import Prelude hiding (EQ, Ordering(..), get)--import qualified Data.ByteString as BS-import Data.Constraint (Dict(..))-import Fmt (pretty)--import Michelson.Typed (UnpackedValScope)-import qualified Michelson.Typed as T-import Michelson.Untyped-import qualified Michelson.Untyped as U-import Morley.Micheline.Binary (eitherDecodeExpression)-import Morley.Micheline.Class (FromExpression(..))-import Util.Binary--{- Implementation notes:--* We need to know which exact type we unpack to.-For instance, serialized signatures are indistinguishable from-plain serialized bytes, so if we want to return "Value" (typed or untyped),-we need to know currently expected type. The reference implementation does-the same.--* It occurred to be easier to decode to typed values and untyped instructions.-When decoding lambda, we type check given instruction, and when decoding-@PUSH@ call we untype decoded value.-One may say that this gives unreasonable performance overhead, but with the-current definition of "Value" types (typed and untyped) we cannot avoid it-anyway, because when deserializing bytearray-like data (keys, signatures, ...),-we have to convert raw bytes to human-readable 'Text' and later parse them-to bytes back at type check stage.-We console ourselves that lambdas are rarely packed.---}---- | Deserialize bytes into the given value.--- Suitable for @UNPACK@ operation only.-unpackValue'-  :: forall t. (UnpackedValScope t)-  => ByteString -> Either UnpackError (T.Value t)-unpackValue' = unpackImpl @(T.Value t)-  where-    _reallyNeedThisConstraint = Dict @(UnpackedValScope t)---- | Deserialize an instruction into the given value.-unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]-unpackInstr' = unpackImpl @([ExpandedOp])---- | Deserialize bytes into 'Untyped.Value'.-unpackUValue' :: ByteString -> Either UnpackError U.Value-unpackUValue' = unpackImpl @U.Value--unpackImpl :: forall t. (FromExpression t)-           => ByteString-           -> Either UnpackError t-unpackImpl bs = do-  (tag, bs') <- maybeToRight (UnpackError "Empty bytes") (BS.uncons bs)-  when (tag /= 0x05) . Left . UnpackError $-    "Unexpected tag: '" <> (show tag) <> "'. '0x05' tag expected."-  expr <- eitherDecodeExpression bs'-  either (Left . UnpackError . pretty) Right $ fromExpression @t expr

− src/Michelson/Interpret/Utils.hs

@@ -1,43 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | General utilities used by interpreter.------ This is not supposed to import any Michelson modules.-module Michelson.Interpret.Utils-  ( encodeZarithNumber-  ) where--import Control.Exception (assert)-import qualified Data.Bits as Bits---- | Encode a number as tezos does this.------ In the Tezos reference implementation this encoding is called @zarith@.-encodeZarithNumber :: Integer -> NonEmpty Word8-encodeZarithNumber = doEncode True-  where-    {- Numbers, when packed by tezos, are represented as follows:--    byte 0:         1              _         ______   ||  lowest digits-            has continuation  is negative   payload   ||-                                                      ||-    byte 1:         1                       _______   ||-    ...             1                       _______   ||-    byte n:         0                       _______   ||-            has continuation                payload   \/  highest digits-    -}-    doEncode :: Bool -> Integer -> NonEmpty Word8-    doEncode isFirst a-      | a >= byteWeight =-          let (hi, lo) = a `divMod` byteWeight-              byte = Bits.setBit (fromIntegral @_ @Word8 lo) 7-          in byte :| toList (doEncode False hi)-      | a >= 0 =-          one (fromIntegral @_ @Word8 a)-      | otherwise = assert isFirst $-          let h :| t = doEncode True (-a)-          in Bits.setBit h 6 :| t-      where-        byteWeight = if isFirst then 64 else 128

− src/Michelson/Let.hs

@@ -1,31 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Let-  ( LetType (..)-  , LetValue (..)-  ) where--import Data.Aeson.TH (deriveJSON)-import qualified Data.Text as T--import Michelson.Macro (ParsedOp)-import Michelson.Untyped (Ty, Value')-import Util.Aeson---- | A programmer-defined constant-data LetValue = LetValue-  { lvName :: T.Text-  , lvSig :: Ty-  , lvVal :: (Value' ParsedOp)-  } deriving stock (Eq, Show)---- | A programmer-defined type-synonym-data LetType = LetType-  { ltName :: T.Text-  , ltSig :: Ty-  } deriving stock (Eq, Show)--deriveJSON morleyAesonOptions ''LetValue-deriveJSON morleyAesonOptions ''LetType

− src/Michelson/Macro.hs

@@ -1,469 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Macro-  (-  -- * Macros types-    CadrStruct (..)-  , PairStruct (..)-  , UnpairStruct (..)-  , Macro (..)-  , LetMacro (..)--  -- * Morley Parsed value types-  , ParsedValue--  -- * Morley Parsed instruction types-  , ParsedInstr-  , ParsedOp (..)-  , ParsedUExtInstr--    -- * For utilities-  , expandContract-  , expandValue--    -- * For parsing-  , mapPairLeaves--    -- * Internals exported for tests-  , expand-  , expandList-  , expandMacro-  , expandPapair-  , expandUnpapair-  , expandCadr-  , expandSetCadr-  , expandMapCadr-  ) where--import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import qualified Data.Text as T-import Fmt (Buildable(build), genericF, (+|), (+||), (|+), (||+))--import Michelson.ErrorPos-import Michelson.Printer (RenderDoc(..))-import Michelson.Untyped-import Util.Aeson-import Util.Generic-import Util.Positive---- | A programmer-defined macro-data LetMacro = LetMacro-  { lmName :: T.Text-  , lmSig :: StackFn-  , lmExpr :: [ParsedOp]-  } deriving stock (Eq, Show, Data, Generic)--instance Buildable LetMacro where-  build = genericF--instance NFData LetMacro--data PairStruct-  = F FieldAnn-  | P PairStruct PairStruct-  deriving stock (Eq, Show, Data, Generic)--instance NFData PairStruct--instance Buildable PairStruct where-  build = genericF--data UnpairStruct-  = UF-  | UP UnpairStruct UnpairStruct-  deriving stock (Eq, Show, Data, Generic)--instance NFData UnpairStruct--instance Buildable UnpairStruct where-  build = genericF--data CadrStruct-  = A-  | D-  deriving stock (Eq, Show, Data, Generic)--instance NFData CadrStruct--instance Buildable CadrStruct where-  build = genericF---- | Unexpanded instructions produced directly by the @ops@ parser, which--- contains primitive Michelson Instructions, inline-able macros and sequences-data ParsedOp-  = Prim ParsedInstr SrcPos -- ^ Primitive Michelson instruction-  | Mac Macro        SrcPos -- ^ Built-in Michelson macro defined by the specification-  | LMac LetMacro    SrcPos -- ^ User-defined macro with instructions to be inlined-  | Seq [ParsedOp]   SrcPos -- ^ A sequence of instructions-  deriving stock (Eq, Show, Data, Generic)--instance RenderDoc ParsedOp where-  renderDoc pn parsedOp = renderDoc pn $ expand [] parsedOp--instance Buildable ParsedOp where-  build = \case-    Prim parseInstr _ -> "<Prim: "+|parseInstr|+">"-    Mac macro _       -> "<Mac: "+|macro|+">"-    LMac letMacro _   -> "<LMac: "+|letMacro|+">"-    Seq parsedOps _   -> "<Seq: "+|parsedOps|+">"--instance NFData ParsedOp------------------------------------------ Types produced by parser----------------------------------------type ParsedUExtInstr = ExtInstrAbstract ParsedOp--type ParsedInstr = InstrAbstract ParsedOp--type ParsedValue = Value' ParsedOp---- | Built-in Michelson Macros defined by the specification-data Macro-  = CASE (NonEmpty [ParsedOp])-  | TAG Natural (NonEmpty Ty)-  | ACCESS Natural Positive-  | SET Natural Positive-  | CONSTRUCT (NonEmpty [ParsedOp])-  | VIEW [ParsedOp]-  | VOID [ParsedOp]-  | CMP ParsedInstr VarAnn-  | IFX ParsedInstr [ParsedOp] [ParsedOp]-  | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]-  | FAIL-  | PAPAIR PairStruct TypeAnn VarAnn-  | UNPAPAIR UnpairStruct-  | CADR [CadrStruct] VarAnn FieldAnn-  | CARN VarAnn Word-  | CDRN VarAnn Word-  | SET_CADR [CadrStruct] VarAnn FieldAnn-  | MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]-  | DIIP Word [ParsedOp]-  | DUUP Word VarAnn-  | ASSERT-  | ASSERTX ParsedInstr-  | ASSERT_CMP ParsedInstr-  | ASSERT_NONE-  | ASSERT_SOME-  | ASSERT_LEFT-  | ASSERT_RIGHT-  | IF_SOME [ParsedOp] [ParsedOp]-  | IF_RIGHT [ParsedOp] [ParsedOp]-  deriving stock (Eq, Show, Data, Generic)--instance Buildable Macro where-  build = \case-    TAG idx ty -> "<TAG: #"+||idx||+" from "+|toList ty|+""-    CASE parsedInstrs -> "<CASE: "+|toList parsedInstrs|+">"-    ACCESS idx size -> "<ACCESS: #"+||idx||+"/"+|size|+""-    SET idx size -> "<SET: #"+||idx||+"/"+|size|+""-    CONSTRUCT parsedInstrs -> "<CONSTRUCT: "+|toList parsedInstrs|+">"-    VIEW code -> "<VIEW: "+|code|+">"-    VOID code -> "<VOID: "+|code|+">"-    CMP parsedInstr carAnn -> "<CMP: "+|parsedInstr|+", "+|carAnn|+">"-    IFX parsedInstr parsedOps1 parsedOps2 -> "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"-    IFCMP parsedInstr varAnn parsedOps1 parsedOps2 -> "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"-    FAIL -> "FAIL"-    PAPAIR pairStruct typeAnn varAnn -> "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"-    UNPAPAIR pairStruct -> "<UNPAPAIR: "+|pairStruct|+">"-    CADR cadrStructs varAnn fieldAnn -> "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"-    CARN varAnn idx -> "<CAR: #"+||idx||+","+||varAnn||+">"-    CDRN varAnn idx -> "<CDR: #"+||idx||+","+||varAnn||+">"-    SET_CADR cadrStructs varAnn fieldAnn -> "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"-    MAP_CADR cadrStructs varAnn fieldAnn parsedOps -> "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"-    DIIP integer parsedOps -> "<DIIP: "+|integer|+", "+|parsedOps|+">"-    DUUP integer varAnn -> "<DUUP: "+|integer|+", "+|varAnn|+">"-    ASSERT -> "ASSERT"-    ASSERTX parsedInstr -> "<ASSERTX: "+|parsedInstr|+">"-    ASSERT_CMP parsedInstr -> "<ASSERT_CMP: "+|parsedInstr|+">"-    ASSERT_NONE  -> "ASSERT_NONE"-    ASSERT_SOME  -> "ASSERT_SOME"-    ASSERT_LEFT  -> "ASSERT_LEFT"-    ASSERT_RIGHT -> "ASSERT_RIGHT"-    IF_SOME parsedOps1 parsedOps2 -> "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"-    IF_RIGHT parsedOps1 parsedOps2 -> "<IF_RIGHT: "+|parsedOps1|+", "+|parsedOps2|+">"--instance NFData Macro--expandList :: [ParsedOp] -> [ExpandedOp]-expandList = fmap (expand [])---- | Expand all macros in parsed contract.-expandContract :: Contract' ParsedOp -> Contract-expandContract contract =-  contract { contractCode = expandList (contractCode contract) }---- Probably, some SYB can be used here-expandValue :: ParsedValue -> Value-expandValue = \case-  ValuePair l r -> ValuePair (expandValue l) (expandValue r)-  ValueLeft x -> ValueLeft (expandValue x)-  ValueRight x -> ValueRight (expandValue x)-  ValueSome x -> ValueSome (expandValue x)-  ValueNil -> ValueNil-  ValueSeq valueList -> ValueSeq (map expandValue valueList)-  ValueMap eltList -> ValueMap (map expandElt eltList)-  ValueLambda opList ->-    maybe ValueNil ValueLambda $-    nonEmpty (expandList $ toList opList)-  x -> fmap (expand []) x--expandElt :: Elt ParsedOp -> Elt ExpandedOp-expandElt (Elt l r) = Elt (expandValue l) (expandValue r)--expand :: LetCallStack -> ParsedOp -> ExpandedOp-expand cs = let ics pos = InstrCallStack cs pos in \case-  -- We handle this case specially, because it's essentially just PAIR.-  -- It's needed because we have a hack in parser: we parse PAIR as PAPAIR.-  -- We need to do something better eventually.-  (Mac (PAPAIR (P (F a) (F b)) t v) pos) ->-    WithSrcEx (ics pos) $ PrimEx (PAIR t v a b)-  -- DIIP is now always represented as a single instruction.-  -- `expandMacro` always returns a list which we wrap into `SeqEx`, so we-  -- can't use it.-  -- As the above comment says, we need to do something better eventually-  -- (e. g. to avoid `error` usage inside `expandMacro`).-  (Mac (DIIP n ops) pos) ->-    WithSrcEx (ics pos) $ PrimEx (DIPN n (expand cs <$> ops))-  -- Similarly to above, DUUP is now always represented as a single instruction.-  (Mac (DUUP n v) pos) ->-    WithSrcEx (ics pos) $ PrimEx $ DUPN v n-  (Mac m pos) -> WithSrcEx (ics pos) $ SeqEx $ expandMacro (ics pos) m-  (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand cs <$> i-  (Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand cs <$> s-  (LMac l pos) -> expandLetMac l-    where-      expandLetMac :: LetMacro -> ExpandedOp-      expandLetMac LetMacro {..} =-        let newCS = LetName lmName : cs in-        let ics' = InstrCallStack newCS pos in-        WithSrcEx ics' $ PrimEx . EXT . FN lmName lmSig $ expand newCS <$> lmExpr--expandMacro :: InstrCallStack -> Macro -> [ExpandedOp]-expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case-  VIEW a             -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)-                        , PrimEx (DIP $ oprimEx $ DUPN noAnn 2)-                        , PrimEx $ PAIR noAnn noAnn noAnn noAnn ] ++-                        (expand cs <$> a) ++-                        [ PrimEx (DIP [PrimEx $ AMOUNT noAnn])-                        , PrimEx $ TRANSFER_TOKENS noAnn-                        , PrimEx $ NIL noAnn noAnn (Ty TOperation noAnn)-                        , PrimEx $ SWAP-                        , PrimEx $ CONS noAnn-                        , PrimEx $ PAIR noAnn noAnn noAnn noAnn-                        ]-  VOID a             -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)-                        , PrimEx SWAP-                        , PrimEx $ DIP $ expand cs <$> a-                        , PrimEx SWAP-                        , PrimEx $ EXEC noAnn-                        , PrimEx FAILWITH-                        ]-  CASE ops           -> expandCase (map (expand cs) <$> ops)-  TAG idx uty        -> expandTag idx uty-  ACCESS idx size    -> expandAccess idx size-  SET idx size       -> expandSet idx size-  CONSTRUCT ops      -> expandConstruct (map (expand cs) <$> ops)-  CMP i v            -> [PrimEx (COMPARE v), xo i]-  IFX i bt bf        -> [xo i, PrimEx $ IF (xp bt) (xp bf)]-  IFCMP i v bt bf    -> PrimEx <$> [COMPARE v, expand cs <$> i, IF (xp bt) (xp bf)]-  IF_SOME bt bf      -> [PrimEx (IF_NONE (xp bf) (xp bt))]-  IF_RIGHT bt bf     -> [PrimEx (IF_LEFT (xp bf) (xp bt))]-  FAIL               -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH]-  ASSERT             -> oprimEx $ IF [] (expandMacro p FAIL)-  ASSERTX i          -> [expand cs $ mac $ IFX i [] [mac FAIL]]-  ASSERT_CMP i       -> [expand cs $ mac $ IFCMP i noAnn [] [mac FAIL]]-  ASSERT_NONE        -> oprimEx $ IF_NONE [] (expandMacro p FAIL)-  ASSERT_SOME        -> oprimEx $ IF_NONE (expandMacro p FAIL) []-  ASSERT_LEFT        -> oprimEx $ IF_LEFT [] (expandMacro p FAIL)-  ASSERT_RIGHT       -> oprimEx $ IF_LEFT (expandMacro p FAIL) []-  PAPAIR ps t v      -> expandPapair p ps t v-  UNPAPAIR ps        -> expandUnpapair p ps-  CADR c v f         -> expandCadr p c v f-  CARN v idx         -> [PrimEx (GETN v (2 * idx + 1))]-  CDRN v idx         -> [PrimEx (GETN v (2 * idx))]-  SET_CADR c v f     -> expandSetCadr p c v f-  MAP_CADR c v f ops -> expandMapCadr p c v f ops-  -- We handle DIIP and DUUP outside.-  DIIP {}            -> error "expandMacro DIIP is unreachable"-  DUUP {}            -> error "expandMacro DUUP is unreachable"--  where-    mac = flip Mac macroPos-    oprimEx = one . PrimEx-    xo = PrimEx . fmap (expand cs)-    xp = fmap (expand cs)---- | The macro expansion rules below were taken from: https://tezos.gitlab.io/008/michelson.html#syntactic-conveniences------ The correctness of type-annotation expansion is currently untested, as these--- expansions are not explicitly documented in the Michelson Specification.-expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp]-expandPapair ics ps t v = case ps of-  P (F a) (F b) -> [PrimEx $ PAIR t v a b]--  -- > PA(\right)R / S => DIP ((\right)R) ; PAIR / S-  P (F a) r     -> PrimEx <$> [ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)-                              , PAIR t v a noAnn]--  -- > P(\left)IR / S => (\left)R ; PAIR / S-  P l     (F b) -> expandMacro ics (PAPAIR l noAnn noAnn) ++-                   [PrimEx $ PAIR t v noAnn b]--  -- > P(\left)(\right)R =>  (\left)R ; DIP ((\right)R) ; PAIR / S-  P l     r     -> expandMacro ics (PAPAIR l noAnn noAnn) ++-                   [ PrimEx $ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)-                   , PrimEx $ PAIR t v noAnn noAnn]--  -- It's impossible from the structure of PairStruct and considered cases above,-  -- but if it accidentally happened let's just do nothing.-  F _           -> []---- | The macro expansion rules below were taken from: https://tezos.gitlab.io/008/michelson.html#syntactic-conveniences-expandUnpapair :: InstrCallStack -> UnpairStruct -> [ExpandedOp]-expandUnpapair ics = \case-  UP UF UF ->-    [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn) ]--  -- > UNPA(\right)R / S => UNPAIR ; DIP (UN(\right)R) / S-  UP UF r ->-    PrimEx <$> [ UNPAIR noAnn noAnn noAnn noAnn-               , DIP (expandMacro ics (UNPAPAIR r))-               ]--  -- > UNP(\left)IR / S => UNPAIR ; UN(\left)R / S-  UP l UF ->-    PrimEx (UNPAIR noAnn noAnn noAnn noAnn)-      : expandMacro ics (UNPAPAIR l)--  -- > UNP(\left)(\right)R => UNPAIR ; DIP (UN(\right)R) ; UN(\left)R / S-  UP l r ->-    [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)-    , PrimEx $ DIP $ expandMacro ics $ UNPAPAIR r-    ] ++-    expandMacro ics (UNPAPAIR l)--  -- It's impossible from the structure of UnpairStruct and considered cases above,-  -- but if it accidentally happened let's just do nothing.-  UF -> []--expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]-expandCadr ics cs v f = case cs of-  []    -> []-  [A]  -> [PrimEx $ CAR v f]-  [D]  -> [PrimEx $ CDR v f]-  A:css -> PrimEx (CAR noAnn noAnn) : expandMacro ics (CADR css v f)-  D:css -> PrimEx (CDR noAnn noAnn) : expandMacro ics (CADR css v f)--carNoAnn :: InstrAbstract op-carNoAnn = CAR [annQ|%%|] noAnn--cdrNoAnn :: InstrAbstract op-cdrNoAnn = CDR [annQ|%%|] noAnn--pairNoAnn :: VarAnn -> InstrAbstract op-pairNoAnn v = PAIR noAnn v [annQ|@|] [annQ|@|]--expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]-expandSetCadr ics cs v f = PrimEx <$> case cs of-  []    -> []-  [A]   -> [DUP noAnn, CAR noAnn f, DROP,-           -- ↑ These operations just check that the left element of pair has %f-           cdrNoAnn, SWAP, PAIR noAnn v f [annQ|@|]]-  [D]   -> [DUP noAnn, CDR noAnn f, DROP,-           -- ↑ These operations just check that the right element of pair has %f-           carNoAnn, PAIR noAnn v [annQ|@|] f]-  A:css -> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (SET_CADR css noAnn f)), cdrNoAnn, SWAP, pairNoAnn v]-  D:css -> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (SET_CADR css noAnn f)), carNoAnn, pairNoAnn v]--expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp]-expandMapCadr ics@InstrCallStack{icsCallStack=cls} cs v f ops = case cs of-  []    -> []-  [A]   -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand cls <$> ops)], SWAP, PAIR noAnn v f [annQ|@|]]-  [D]   -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand cls <$> ops)], PrimEx <$> [SWAP, carNoAnn, PAIR noAnn v [annQ|@|] f]]-  A:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), cdrNoAnn, SWAP, pairNoAnn v]-  D:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), carNoAnn, pairNoAnn v]--expandCase :: NonEmpty [ExpandedOp] -> [ExpandedOp]-expandCase = mkGenericTree (\_ l r -> one . PrimEx $ IF_LEFT l r)--expandTag :: Natural -> NonEmpty Ty -> [ExpandedOp]-expandTag idx unionTy =-  reverse . fst $ mkGenericTree merge (([], ) <$> unionTy)-  where-    merge i (li, lt) (ri, rt) =-      let ty = Ty (TOr noAnn noAnn lt rt) noAnn-      in if idx < i-          then (PrimEx (LEFT noAnn noAnn noAnn noAnn rt) : li, ty)-          else (PrimEx (RIGHT noAnn noAnn noAnn noAnn lt) : ri, ty)--expandAccess :: Natural -> Positive -> [ExpandedOp]-expandAccess idx size =-  mkGenericTree merge (replicateNE size [])-  where-    merge i li ri =-      if idx < i-        then PrimEx (CAR noAnn noAnn) : li-        else PrimEx (CDR noAnn noAnn) : ri--expandSet :: Natural -> Positive -> [ExpandedOp]-expandSet idx size =-  PrimEx <$>-  appEndo (mkGenericTree merge (replicateNE size base)) []-  where-    base = pre $ DIP [PrimEx DROP]-    merge i li ri = mconcat $-      if idx < i-        then [ pre $ DIP-                 (map PrimEx [DUP n, DIP [PrimEx $ CDR n n], CAR n n])-             , li-             , pre $ PAIR n n n n-             ]-        else [ pre $ DIP-                 (map PrimEx [DUP n, DIP [PrimEx $ CAR n n], CDR n n])-             , ri-             , pre $ SWAP-             , pre $ PAIR n n n n-             ]-    pre e = Endo (e :)-    n = noAnn--expandConstruct :: NonEmpty [ExpandedOp] -> [ExpandedOp]-expandConstruct ctors =-  appEndo (mkGenericTree merge $ map toBase ctors) []-  where-    toBase ops = Endo (ops ++)-    merge _ li ri =-      mconcat-        [ li-        , pre . PrimEx $ DIP (appEndo ri [])-        , pre . PrimEx $ PAIR noAnn noAnn noAnn noAnn-        ]-    pre e = Endo (e :)--mapPairLeaves :: [FieldAnn] -> PairStruct -> PairStruct-mapPairLeaves fs p = evalState (pairLeavesST p) fs--pairLeavesST :: PairStruct -> State [FieldAnn] PairStruct-pairLeavesST = \case-  (P l r) -> do-    l' <- pairLeavesST l-    r' <- pairLeavesST r-    return $ P l' r'-  (F _) -> do-    f <- state getLeaf-    return $ F f-    where-      getLeaf (a:as) = (a, as)-      getLeaf _      = (noAnn, [])--deriveJSON morleyAesonOptions ''ParsedOp-deriveJSON morleyAesonOptions ''LetMacro-deriveJSON morleyAesonOptions ''PairStruct-deriveJSON morleyAesonOptions ''UnpairStruct-deriveJSON morleyAesonOptions ''CadrStruct-deriveJSON morleyAesonOptions ''Macro

− src/Michelson/Optimizer.hs

@@ -1,553 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- NOTE this pragmas.--- We disable some wargnings for the sake of speed up.--- Write code with care.-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}---- | Optimizer for typed instructions.------ It's quite experimental and incomplete.--- List of possible improvements:--- 1. 'pushDrop', 'dupDrop', 'unitDrop' rules are essentially the--- same. It would be good to generalize them into one rule. The same--- applies to 'pushDip'.--- It probably can be done more efficiently.--module Michelson.Optimizer-  ( optimize-  , optimizeWithConf-  , defaultOptimizerConf-  , defaultRules-  , defaultRulesAndPushPack-  , orRule-  , orSimpleRule-  , Rule-  , OptimizerConf (..)-  , ocGotoValuesL-  ) where--import Prelude hiding (EQ, LT, GT)--import Control.Lens (makeLensesFor)-import Data.Constraint (Dict(..))-import Data.Default (Default(def))-import Data.Singletons (sing)--import Michelson.Interpret.Pack (packValue')-import Michelson.Typed.Aliases (Value)-import Michelson.Typed.Arith-import Michelson.Typed.Instr-import Michelson.Typed.Scope (PackedValScope)-import Michelson.Typed.Sing-import Michelson.Typed.T-import Michelson.Typed.Util (DfsSettings(..), dfsInstr)-import Michelson.Typed.Value-import Util.PeanoNatural--------------------------------------------------------------------------------- High level-------------------------------------------------------------------------------data OptimizerConf = OptimizerConf-  { ocGotoValues :: Bool-  , ocRuleset    :: Rule -> Rule-  }---- | Default config - all commonly useful rules will be applied to all the code.-defaultOptimizerConf :: OptimizerConf-defaultOptimizerConf = OptimizerConf-  { ocGotoValues = True-  , ocRuleset    = defaultRules-  }--instance Default OptimizerConf where-  def = defaultOptimizerConf---- | Optimize a typed instruction by replacing some sequences of--- instructions with smaller equivalent sequences.--- Applies default set of rewrite rules.-optimize :: Instr inp out -> Instr inp out-optimize = optimizeWithConf def---- | Optimize a typed instruction using a custom set of rules.-optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out-optimizeWithConf (OptimizerConf ocGotoValues rules)-  = (fst .)-  $ dfsInstr dfsSettings-  $ (adapter .)-  $ applyOnce-  $ fixpoint rules-  where-    dfsSettings = def{ dsGoToValues = ocGotoValues }--------------------------------------------------------------------------------- Rewrite rules--------------------------------------------------------------------------------- Type of a single rewrite rule. It takes an instruction and tries to--- optimize its head (first few instructions).  If optimization--- succeeds, it returns `Just` the optimized instruction, otherwise it--- returns `Nothing`.-type Rule = forall inp out. Instr inp out -> Maybe (Instr inp out)--defaultRules :: Rule -> Rule-defaultRules =-  flattenSeqLHS-    `orSimpleRule` removeNesting-    `orSimpleRule` removeExtStackType-    `orSimpleRule` flattenFn-    `orSimpleRule` dipDrop2swapDrop-    `orSimpleRule` ifNopNop2Drop-    `orSimpleRule` nopIsNeutralForSeq-    `orSimpleRule` variousNops-    `orSimpleRule` dupSwap2dup-    `orSimpleRule` noDipNeeded-    `orSimpleRule` branchShortCut-    `orSimpleRule` compareWithZero-    `orSimpleRule` simpleDrops-    `orSimpleRule` internalNop-    `orSimpleRule` simpleDips-    `orSimpleRule` adjacentDips-    `orSimpleRule` adjacentDrops-    `orSimpleRule` isSomeOnIf-    `orSimpleRule` specificPush-    `orSimpleRule` pairUnpair-    `orSimpleRule` unpairMisc-    `orSimpleRule` swapBeforeCommutative-    `orSimpleRule` justDrops---- | We do not enable 'pushPack' rule by default because it is--- potentially dangerous.--- There are various code processing functions that may depend on constants,--- e. g. string transformations.-defaultRulesAndPushPack :: Rule -> Rule-defaultRulesAndPushPack = defaultRules `orSimpleRule` pushPack--flattenSeqLHS :: Rule -> Rule-flattenSeqLHS toplevel = \case-  it@(Seq (Seq _ _) _) -> Just $ linearizeAndReapply toplevel it-  _                    -> Nothing--removeNesting :: Rule-removeNesting = \case-  Nested i -> Just i-  _        -> Nothing---- | STACKTYPE is currently a Nop and may safely be removed.-removeExtStackType :: Rule-removeExtStackType = \case-  Ext (STACKTYPE{}) -> Just Nop-  _                 -> Nothing--flattenFn :: Rule-flattenFn = \case-  Fn _ _ i -> Just i-  _        -> Nothing--dipDrop2swapDrop :: Rule-dipDrop2swapDrop = \case-  DIP DROP -> Just $ SWAP :# DROP-  _        -> Nothing--ifNopNop2Drop :: Rule-ifNopNop2Drop = \case-  IF Nop Nop -> Just DROP-  _          -> Nothing--nopIsNeutralForSeq :: Rule-nopIsNeutralForSeq = \case-  Nop :# i   -> Just i-  i   :# Nop -> Just i-  _          -> Nothing--variousNops :: Rule-variousNops = \case-  DUP                :# DROP :# c -> Just c-  DUPN _             :# DROP :# c -> Just c-  SWAP               :# SWAP :# c -> Just c-  PUSH _             :# DROP :# c -> Just c-  NONE               :# DROP :# c -> Just c-  UNIT               :# DROP :# c -> Just c-  NIL                :# DROP :# c -> Just c-  EMPTY_SET          :# DROP :# c -> Just c-  EMPTY_MAP          :# DROP :# c -> Just c-  EMPTY_BIG_MAP      :# DROP :# c -> Just c-  LAMBDA _           :# DROP :# c -> Just c-  SELF _             :# DROP :# c -> Just c-  NOW                :# DROP :# c -> Just c-  AMOUNT             :# DROP :# c -> Just c-  BALANCE            :# DROP :# c -> Just c-  TOTAL_VOTING_POWER :# DROP :# c -> Just c-  SOURCE             :# DROP :# c -> Just c-  SENDER             :# DROP :# c -> Just c-  CHAIN_ID           :# DROP :# c -> Just c-  LEVEL              :# DROP :# c -> Just c-  SELF_ADDRESS       :# DROP :# c -> Just c-  READ_TICKET        :# DROP :# c -> Just c--  DUP                :# DROP -> Just Nop-  DUPN _             :# DROP -> Just Nop-  SWAP               :# SWAP -> Just Nop-  PUSH _             :# DROP -> Just Nop-  NONE               :# DROP -> Just Nop-  UNIT               :# DROP -> Just Nop-  NIL                :# DROP -> Just Nop-  EMPTY_SET          :# DROP -> Just Nop-  EMPTY_MAP          :# DROP -> Just Nop-  EMPTY_BIG_MAP      :# DROP -> Just Nop-  LAMBDA _           :# DROP -> Just Nop-  SELF _             :# DROP -> Just Nop-  NOW                :# DROP -> Just Nop-  AMOUNT             :# DROP -> Just Nop-  BALANCE            :# DROP -> Just Nop-  TOTAL_VOTING_POWER :# DROP -> Just Nop-  SOURCE             :# DROP -> Just Nop-  SENDER             :# DROP -> Just Nop-  CHAIN_ID           :# DROP -> Just Nop-  LEVEL              :# DROP -> Just Nop-  SELF_ADDRESS       :# DROP -> Just Nop-  READ_TICKET        :# DROP -> Just Nop-  _                          -> Nothing--dupSwap2dup :: Rule-dupSwap2dup = \case-  DUP :# SWAP :# c -> Just (DUP :# c)-  DUP :# SWAP      -> Just DUP-  _                -> Nothing--noDipNeeded :: Rule-noDipNeeded = \case-  -- If we put a constant value on stack and then do something under it,-  -- we can do this "something" on original stack and then put that constant.-  PUSH x    :# DIP f :# c -> Just $ f :# PUSH x :# c-  PUSH x    :# DIP f      -> Just $ f :# PUSH x-  UNIT      :# DIP f :# c -> Just $ f :# UNIT :# c-  UNIT      :# DIP f      -> Just $ f :# UNIT-  NOW       :# DIP f :# c -> Just $ f :# NOW :# c-  NOW       :# DIP f      -> Just $ f :# NOW-  SENDER    :# DIP f :# c -> Just $ f :# SENDER :# c-  SENDER    :# DIP f      -> Just $ f :# SENDER-  EMPTY_MAP :# DIP f :# c -> Just $ f :# EMPTY_MAP :# c-  EMPTY_MAP :# DIP f      -> Just $ f :# EMPTY_MAP-  EMPTY_SET :# DIP f :# c -> Just $ f :# EMPTY_SET :# c-  EMPTY_SET :# DIP f      -> Just $ f :# EMPTY_SET--  -- If we do something ignoring top of the stack and then immediately-  -- drop top of the stack, we can drop that item in advance and-  -- not use 'DIP' at all.-  DIP f :# DROP :# c -> Just $ DROP :# f :# c-  DIP f :# DROP         -> Just $ DROP :# f--  _ -> Nothing--branchShortCut :: Rule-branchShortCut = \case-  LEFT  :# IF_LEFT f _ :# c -> Just (f :# c)-  RIGHT :# IF_LEFT _ f :# c -> Just (f :# c)-  CONS  :# IF_CONS f _ :# c -> Just (f :# c)-  NIL   :# IF_CONS _ f :# c -> Just (f :# c)-  NONE  :# IF_NONE f _ :# c -> Just (f :# c)-  SOME  :# IF_NONE _ f :# c -> Just (f :# c)--  PUSH (VBool True)  :# IF f _ :# c -> Just (f :# c)-  PUSH (VBool False) :# IF _ f :# c -> Just (f :# c)--  LEFT  :# IF_LEFT f _ -> Just f-  RIGHT :# IF_LEFT _ f -> Just f-  CONS  :# IF_CONS f _ -> Just f-  NIL   :# IF_CONS _ f -> Just f-  NONE  :# IF_NONE f _ -> Just f-  SOME  :# IF_NONE _ f -> Just f--  PUSH (VBool True)  :# IF f _ -> Just f-  PUSH (VBool False) :# IF _ f -> Just f--  _ -> Nothing--compareWithZero :: Rule-compareWithZero = \case-  PUSH (VInt 0) :# COMPARE :# EQ :# c -> Just $ EQ :# c-  PUSH (VNat 0) :# COMPARE :# EQ :# c -> Just $ INT :# EQ :# c-  PUSH (VInt 0) :# COMPARE :# EQ      -> Just $ EQ-  PUSH (VNat 0) :# COMPARE :# EQ      -> Just $ INT :# EQ-  _                                   -> Nothing--simpleDrops :: Rule-simpleDrops = \case-  -- DROP 0 is Nop-  DROPN Zero :# c -> Just c-  DROPN Zero -> Just Nop--  -- DROP 1 is DROP.-  -- @gromak: DROP seems to be cheaper (in my experiments it consumed 3 less gas).-  -- It is packed more efficiently.-  -- Unfortunately I do not know how to convince GHC that types match here.-  -- Specifically, it can not deduce that `inp` is not empty-  -- (`DROP` expects non-empty input).-  -- We have `LongerOrSameLength inp (S Z)` here, but that is not enough to-  -- convince GHC.-  -- I will leave this note and rule here in hope that someone will manage to-  -- deal with this problem one day.--  -- DROPN One :# c -> Just (DROP :# c)-  -- DROPN One -> Just DROP--  _ -> Nothing---- If an instruction takes another instruction as an argument and that--- internal instruction is 'Nop', sometimes the whole instruction is--- 'Nop'.--- For now we do it only for 'DIP', but ideally we should do it for--- 'MAP' as well (which is harder).-internalNop :: Rule-internalNop = \case-  DIP Nop      -> Just Nop-  DIP Nop :# c -> Just c--  _ -> Nothing--simpleDips :: Rule-simpleDips = \case-  -- DIP 0 is redundant-  DIPN Zero i :# c -> Just (i :# c)-  DIPN Zero i -> Just i--  -- @gromak: same situation as with `DROP 1` (see above).-  -- DIPN One i :# c -> Just (DIP i :# c)-  -- DIPN One i -> Just (DIP i)--  _ -> Nothing--adjacentDips :: Rule-adjacentDips = \case-  DIP f :# DIP g -> Just (DIP (f :# g))-  DIP f :# DIP g :# c -> Just (DIP (f :# g) :# c)--  _ -> Nothing---- TODO (#299): optimize sequences of more than 2 DROPs.--- | Sequences of @DROP@s can be turned into single @DROP n@.--- When @n@ is greater than 2 it saves size and gas.--- When @n@ is 2 it saves gas only.-adjacentDrops :: Rule-adjacentDrops = \case-  DROP :# DROP -> Just (DROPN Two)-  DROP :# DROP :# c -> Just (DROPN Two :# c)--  -- Does not compile, need to do something smart-  -- DROPN Two :# DROP -> Just (DROPN (Succ Two))--  _ -> Nothing--specificPush :: Rule-specificPush = \case-  push@PUSH{}         -> optimizePush push-  push@PUSH{} :# c -> (:# c) <$> optimizePush push--  _ -> Nothing-  where-    optimizePush :: Instr inp out -> Maybe (Instr inp out)-    optimizePush = \case-      PUSH v | _ :: Value v <- v -> case v of-        VUnit -> Just UNIT-        VMap m-          | null m -> case sing @v of STMap{} -> Just EMPTY_MAP-        VSet m-          | null m -> case sing @v of STSet{} -> Just EMPTY_SET-        _ -> Nothing--      _ -> Nothing---isSomeOnIf :: Rule-isSomeOnIf = \case-  IF (PUSH (VOption Just{})) (PUSH (VOption Nothing)) :# c -> case c of-    IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True)) :# s -> Just s-    IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True))      -> Just Nop-    _ -> Nothing-  _ -> Nothing--pairUnpair :: Rule-pairUnpair = \case-  PAIR :# UNPAIR :# c -> Just c-  PAIR :# UNPAIR      -> Just Nop--  UNPAIR :# PAIR :# c -> Just c-  UNPAIR :# PAIR      -> Just Nop--  _ -> Nothing--unpairMisc :: Rule-unpairMisc = \case-  DUP :# CAR :# DIP CDR      -> Just $ UNPAIR-  DUP :# CAR :# DIP CDR :# c -> Just $ UNPAIR :# c--  DUP :# CDR :# DIP CAR      -> Just $ UNPAIR :# SWAP-  DUP :# CDR :# DIP CAR :# c -> Just $ UNPAIR :# SWAP :# c--  UNPAIR :# DROP             -> Just CDR-  UNPAIR :# DROP :# c        -> Just $ CDR :# c-  _ -> Nothing--commuteArith ::-  forall n m s out. Instr (n ': m ': s) out -> Maybe (Instr (m ': n ': s) out)-commuteArith = \case-  ADD -> do Dict <- commutativityProof @Add @n @m; Just ADD-  MUL -> do Dict <- commutativityProof @Mul @n @m; Just MUL-  OR -> do Dict <- commutativityProof @Or @n @m; Just OR-  AND -> do Dict <- commutativityProof @And @n @m; Just AND-  XOR -> do Dict <- commutativityProof @Xor @n @m; Just XOR-  _ -> Nothing--swapBeforeCommutative :: Rule-swapBeforeCommutative = \case-  SWAP :# i :# c -> (:# c) <$> commuteArith i-  SWAP :# i -> commuteArith i--  _ -> Nothing--pushPack :: Rule-pushPack = \case-  PUSH x :# PACK -> Just (pushPacked x)-  PUSH x :# PACK :# c -> Just (pushPacked x :# c)--  _ -> Nothing-  where-    pushPacked :: PackedValScope t => Value t -> Instr s ('TBytes ': s)-    pushPacked = PUSH . VBytes . packValue'--justDrops :: Rule-justDrops = \case-  CAR              :# DROP :# c -> Just $ DROP :# c-  CDR              :# DROP :# c -> Just $ DROP :# c-  SOME             :# DROP :# c -> Just $ DROP :# c-  LEFT             :# DROP :# c -> Just $ DROP :# c-  RIGHT            :# DROP :# c -> Just $ DROP :# c-  SIZE             :# DROP :# c -> Just $ DROP :# c-  GETN _           :# DROP :# c -> Just $ DROP :# c-  CAST             :# DROP :# c -> Just $ DROP :# c-  RENAME           :# DROP :# c -> Just $ DROP :# c-  PACK             :# DROP :# c -> Just $ DROP :# c-  UNPACK           :# DROP :# c -> Just $ DROP :# c-  CONCAT'          :# DROP :# c -> Just $ DROP :# c-  ISNAT            :# DROP :# c -> Just $ DROP :# c-  ABS              :# DROP :# c -> Just $ DROP :# c-  NEG              :# DROP :# c -> Just $ DROP :# c-  NOT              :# DROP :# c -> Just $ DROP :# c-  EQ               :# DROP :# c -> Just $ DROP :# c-  NEQ              :# DROP :# c -> Just $ DROP :# c-  LT               :# DROP :# c -> Just $ DROP :# c-  GT               :# DROP :# c -> Just $ DROP :# c-  LE               :# DROP :# c -> Just $ DROP :# c-  GE               :# DROP :# c -> Just $ DROP :# c-  INT              :# DROP :# c -> Just $ DROP :# c-  CONTRACT _ _     :# DROP :# c -> Just $ DROP :# c-  SET_DELEGATE     :# DROP :# c -> Just $ DROP :# c-  IMPLICIT_ACCOUNT :# DROP :# c -> Just $ DROP :# c-  VOTING_POWER     :# DROP :# c -> Just $ DROP :# c-  SHA256           :# DROP :# c -> Just $ DROP :# c-  SHA512           :# DROP :# c -> Just $ DROP :# c-  BLAKE2B          :# DROP :# c -> Just $ DROP :# c-  SHA3             :# DROP :# c -> Just $ DROP :# c-  KECCAK           :# DROP :# c -> Just $ DROP :# c-  HASH_KEY         :# DROP :# c -> Just $ DROP :# c-  PAIRING_CHECK    :# DROP :# c -> Just $ DROP :# c-  ADDRESS          :# DROP :# c -> Just $ DROP :# c-  JOIN_TICKETS     :# DROP :# c -> Just $ DROP :# c--  CAR              :# DROP      -> Just DROP-  CDR              :# DROP      -> Just DROP-  SOME             :# DROP      -> Just DROP-  LEFT             :# DROP      -> Just DROP-  RIGHT            :# DROP      -> Just DROP-  SIZE             :# DROP      -> Just DROP-  GETN _           :# DROP      -> Just DROP-  CAST             :# DROP      -> Just DROP-  RENAME           :# DROP      -> Just DROP-  PACK             :# DROP      -> Just DROP-  UNPACK           :# DROP      -> Just DROP-  CONCAT'          :# DROP      -> Just DROP-  ISNAT            :# DROP      -> Just DROP-  ABS              :# DROP      -> Just DROP-  NEG              :# DROP      -> Just DROP-  NOT              :# DROP      -> Just DROP-  EQ               :# DROP      -> Just DROP-  NEQ              :# DROP      -> Just DROP-  LT               :# DROP      -> Just DROP-  GT               :# DROP      -> Just DROP-  LE               :# DROP      -> Just DROP-  GE               :# DROP      -> Just DROP-  INT              :# DROP      -> Just DROP-  CONTRACT _ _     :# DROP      -> Just DROP-  SET_DELEGATE     :# DROP      -> Just DROP-  IMPLICIT_ACCOUNT :# DROP      -> Just DROP-  VOTING_POWER     :# DROP      -> Just DROP-  SHA256           :# DROP      -> Just DROP-  SHA512           :# DROP      -> Just DROP-  BLAKE2B          :# DROP      -> Just DROP-  SHA3             :# DROP      -> Just DROP-  KECCAK           :# DROP      -> Just DROP-  HASH_KEY         :# DROP      -> Just DROP-  PAIRING_CHECK    :# DROP      -> Just DROP-  ADDRESS          :# DROP      -> Just DROP-  JOIN_TICKETS     :# DROP      -> Just DROP-  _                             -> Nothing---- | Append LHS of 'Seq' to RHS and re-run pointwise ocRuleset at each point.---   That might cause reinvocation of this function (see 'defaultRules'),---   but productivity ensures it will flatten any 'Seq'-tree right-to-left,---   while evaling no more than once on each node.------   The reason this function invokes ocRuleset is when you append an instr---   to already-optimised RHS of 'Seq', you might get an optimisable tree.------   The argument is a local, non-structurally-recursive ocRuleset.-linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out-linearizeAndReapply restart = \case-  Seq (Seq a b) c ->-    applyOnce restart $ Seq a (linearizeAndReapply restart (Seq b c))--  other -> applyOnce restart other--------------------------------------------------------------------------------- Generic functions working with rules--------------------------------------------------------------------------------- | Combine two rule fixpoints.-orRule :: (Rule -> Rule) -> (Rule -> Rule) -> (Rule -> Rule)-orRule l r topl x = l topl x <|> r topl x---- | Combine a rule fixpoint and a simple rule.-orSimpleRule :: (Rule -> Rule) -> Rule -> (Rule -> Rule)-orSimpleRule l r topl x = l topl x <|> r x---- | Turn rule fixpoint into rule.-fixpoint :: (Rule -> Rule) -> Rule-fixpoint r = go-  where-    go :: Rule-    go = whileApplies (r go)---- | Apply the rule once, if it fails, return the instruction unmodified.-applyOnce :: Rule -> Instr inp out -> Instr inp out-applyOnce r i = maybe i id (r i)---- | An adapter for `dfsInstr`.-adapter :: a -> (a, ())-adapter a = (a, ())---- | Apply a rule to the same code, until it fails.-whileApplies :: Rule -> Rule-whileApplies r = go-  where-    go i = maybe (Just i) go (r i)--------------------------------------------------------------------------------- TH-------------------------------------------------------------------------------makeLensesFor [("ocGotoValues", "ocGotoValuesL")] ''OptimizerConf

− src/Michelson/Parser.hs

@@ -1,330 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Parser-  ( -- * Main parser type-    Parser--  -- * Parsers-  , program-  , value--  -- * Errors-  , CustomParserException (..)-  , ParseErrorBundle-  , ParserException (..)-  , StringLiteralParserException (..)--  -- * Additional helpers-  , parseNoEnv-  , parseValue-  , parseExpandValue-  , parseValueFromFile-  , parseExpandValueFromFile--  -- * For tests-  , codeEntry-  , ops-  , type_-  , letInner-  , letType-  , stringLiteral-  , bytesLiteral-  , intLiteral-  , parsedOp-  , printComment--  -- * Quoters-  , utypeQ-  , uparamTypeQ--  -- * Re-exports-  , errorBundlePretty-  ) where--import Prelude hiding (try)--import qualified Language.Haskell.TH.Lift as TH-import qualified Language.Haskell.TH.Quote as TH-import Text.Megaparsec-  (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead,-  parse, try)-import Text.Megaparsec.Pos (SourcePos(..), unPos)--import Michelson.ErrorPos (SrcPos(..), unsafeMkPos)-import Michelson.Macro (LetMacro, Macro(..), ParsedInstr, ParsedOp(..), ParsedValue, expandValue)-import Michelson.Parser.Annotations (noteF)-import Michelson.Parser.Error-import Michelson.Parser.Ext-import Michelson.Parser.Instr-import Michelson.Parser.Let-import Michelson.Parser.Lexer-import Michelson.Parser.Macro-import Michelson.Parser.Type-import Michelson.Parser.Types-import Michelson.Parser.Value-import Michelson.Untyped-import qualified Michelson.Untyped as U--------------------------------------------------------------------------------- Helpers--------------------------------------------------------------------------------- | Parse with empty environment-parseNoEnv ::-     Parser a-  -> String-  -> Text-  -> Either (ParseErrorBundle Text CustomParserException) a-parseNoEnv p = parse (runReaderT p noLetEnv <* eof)------------------------------------------------------------------------------------ Parsers------------------------------------------------------------------------------------ Contract----------------------- | Michelson contract with let definitions-program :: Parsec CustomParserException Text (Contract' ParsedOp)-program = runReaderT programInner noLetEnv <* eof-  where-    programInner :: Parser (Contract' ParsedOp)-    programInner = do-      mSpace-      env <- fromMaybe noLetEnv <$> (optional (letBlock parsedOp))-      local (const env) contract--cbParameter :: Parser ParameterType-cbParameter = symbol "parameter" *> cbParameterBare--cbParameterBare :: Parser ParameterType-cbParameterBare = do-  prefixRootAnn <- optional noteF-  (inTypeRootAnn, t) <- field-  rootAnn <- case (prefixRootAnn, inTypeRootAnn) of-    -- TODO: [#310] Handle cases where there are 2 empty root annotations.-    -- For example: root % (unit %) which should throw the error.-    (Just a, b) | a == noAnn && b == noAnn -> pure noAnn-    (Just a, b) | b == noAnn -> pure a-    (Nothing, b) -> pure b-    (Just _, _) -> customFailure MultiRootAnnotationException-  pure $ ParameterType t rootAnn--cbStorage :: Parser Ty-cbStorage = symbol "storage" *> type_--cbCode :: Parser [ParsedOp]-cbCode = symbol "code" *> codeEntry--contractBlock :: Parser (ContractBlock ParsedOp)-contractBlock = choice-  [ (CBParam <$> cbParameter)-  , (CBStorage <$> cbStorage)-  , (CBCode <$> cbCode)-  ]---- | This ensures that the error message will point to the correct line.-ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()-ensureNotDuplicate blocks result =-  let-    failDuplicateField a = fail $ "Duplicate contract field: " <> a-  in-    case (result, blocks) of-      (CBParam _, CBParam _ : _) -> failDuplicateField "parameter"-      (CBStorage _, CBStorage _: _) -> failDuplicateField "storage"-      (CBCode _, CBCode _: _) -> failDuplicateField "code"-      (_, _:xs) -> ensureNotDuplicate xs result-      (_, []) -> pure ()---- | Michelson contract-contract :: Parser (Contract' ParsedOp)-contract = do-  mSpace-  result <- braces contractTuple <|> contractTuple-  case orderContractBlock result of-    Just contract' ->-      return contract'-    Nothing ->-      fail $ "Duplicate contract field: " <> show result-  where-    -- | @ensureNotDuplicate@ provides a better message and point to the correct line-    -- when the parser fails.-    contractTuple = do-      result1 <- contractBlock-      semicolon--      result2 <- do-        r <- contractBlock-        ensureNotDuplicate [result1] r-        pure r-      semicolon--      result3 <- do-        r <- contractBlock-        ensureNotDuplicate [result1, result2] r-        pure r-      optional semicolon-      pure (result1, result2, result3)---- Value---------------------value :: Parser ParsedValue-value = value' parsedOp---- | Parse untyped value from text which comes from something that is--- not a file (which is often the case). So we assume it does not need--- any parsing environment.------ >>> parseValue "{PUSH int aaa}"--- Left 1:11:---   |--- 1 | {PUSH int aaa}---   |           ^^^^--- unexpected "aaa}"--- expecting value--- <BLANKLINE>-parseValue :: Text -> Either ParserException ParsedValue-parseValue = first ParserException . parseNoEnv value ""---- | Like 'parseValue', but also expands macros.-parseExpandValue :: Text -> Either ParserException U.Value-parseExpandValue = fmap expandValue . parseValue---- | Like 'parseValue', but from text that comes from a file,--- for which we get the 'FilePath'.-parseValueFromFile :: FilePath -> Text -> Either ParserException ParsedValue-parseValueFromFile filePath = first ParserException . parseNoEnv value filePath -- TODO remove filPath?---- | Like 'parseValueFromFile', but also expands macros.-parseExpandValueFromFile :: FilePath -> Text -> Either ParserException U.Value-parseExpandValueFromFile filePath = fmap expandValue . parseValueFromFile filePath---- Primitive instruction---------------------prim :: Parser ParsedInstr-prim = primInstr contract parsedOp---- Parsed operations (primitive instructions, macros, extras, etc.)----------------------- | Parses code block after "code" keyword of a contract.------ This function is part of the module API, its semantics should not change.-codeEntry :: Parser [ParsedOp]-codeEntry = bracewrappedOps--bracewrappedOps :: Parser [ParsedOp]-bracewrappedOps = lookAhead (symbol "{") *> ops---- |--- >>> first ParserException $ parseNoEnv parsedOp "" "{a}"--- Left 1:2:---   |--- 1 | {a}---   |  ^--- unexpected 'a'--- expecting '{', '}', macro, morley instruction, or primitive instruction--- <BLANKLINE>-parsedOp :: Parser ParsedOp-parsedOp = do-  lms <- asks letMacros-  pos <- getSrcPos-  choice-    [ flip Prim pos <$> (EXT <$> extInstr ops)-    , lmacWithPos (mkLetMac lms)-    , flip Prim pos <$> prim-    , flip Mac pos <$> macro parsedOp-    , primOrMac-    , flip Seq pos <$> bracewrappedOps-    ]-  where-    lmacWithPos :: Parser LetMacro -> Parser ParsedOp-    lmacWithPos act = do-      srcPos <- getSrcPos-      flip LMac srcPos <$> act--getSrcPos :: Parser SrcPos-getSrcPos = do-  sp <- getSourcePos-  let l = unPos $ sourceLine sp-  let c = unPos $ sourceColumn sp-  -- reindexing starting from 0-  pure $ SrcPos (unsafeMkPos $ l - 1) (unsafeMkPos $ c - 1)--primWithPos :: Parser ParsedInstr -> Parser ParsedOp-primWithPos act = do-  srcPos <- getSrcPos-  flip Prim srcPos <$> act--macWithPos :: Parser Macro -> Parser ParsedOp-macWithPos act = do-  srcPos <- getSrcPos-  flip Mac srcPos <$> act--ops :: Parser [ParsedOp]-ops = ops' parsedOp------------------------------------------------------------------------------------ Mixed parsers--- These are needed for better error messages----------------------------------------------------------------------------------ifOrIfX :: Parser ParsedOp-ifOrIfX = do-  pos <- getSrcPos-  symbol' "IF"-  a <- eitherP cmpOp ops-  case a of-    Left cmp -> flip Mac pos <$> (IFX cmp <$> ops <*> ops)-    Right op -> flip Prim pos <$> (IF op <$> ops)---- Some of the operations and macros have the same prefixes in their names--- So this case should be handled separately-primOrMac :: Parser ParsedOp-primOrMac = hidden-   $  (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)-  <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))-  <|> (try (primWithPos pairOp) <|> try (primWithPos pairNOp) <|> macWithPos pairMac)-  <|> (try (macWithPos duupMac) <|> primWithPos dupOp)-  <|> (try (macWithPos carnMac) <|> try (macWithPos cdrnMac) <|> try (macWithPos cadrMac) <|> primWithPos carOp <|> primWithPos cdrOp)------------------------------------------------------------------------------------ Safe construction of Haskell values----------------------------------------------------------------------------------parserToQuasiQuoter :: TH.Lift a => Parser a -> TH.QuasiQuoter-parserToQuasiQuoter parser = TH.QuasiQuoter-  { TH.quoteExp = \s ->-      case parseNoEnv (mSpace *> parser) "QuasiQuoter" (toText s) of-        Left err -> fail $ errorBundlePretty err-        Right res -> [e| res |]-  , TH.quotePat = \_ -> fail "Cannot be used as pattern"-  , TH.quoteType = \_ -> fail "Cannot be used as type"-  , TH.quoteDec = \_ -> fail "Cannot be used as declaration"-  }----- | Creates 'U.Ty' by its Morley representation.------ >>> [utypeQ| (int :a | nat :b) |]--- Ty (TOr % % (Ty TInt :a) (Ty TNat :b)) :------ >>> [utypeQ|a|]--- <BLANKLINE>--- ...---   |--- 1 | a---   | ^--- unexpected 'a'--- expecting type--- ...-utypeQ :: TH.QuasiQuoter-utypeQ = parserToQuasiQuoter type_---- | Creates 'U.ParameterType' by its Morley representation.-uparamTypeQ :: TH.QuasiQuoter-uparamTypeQ = parserToQuasiQuoter cbParameterBare

− src/Michelson/Parser/Annotations.hs

@@ -1,96 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Parser.Annotations-  ( note-  , noteF-  , noteV-  , noteDef-  , noteV2Def-  , notesTVF-  , notesTVF2Def-  , notesVVFF-  , notesTV-  , notesTF-  , notesVF-  , fieldType-  , permute2Def-  , permute3Def-  ) where--import Prelude hiding (note)--import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)-import qualified Data.Text as T-import Text.Megaparsec (satisfy, takeWhileP)-import Text.Megaparsec.Char (string)--import Michelson.Parser.Helpers (parseDef)-import Michelson.Parser.Lexer-import Michelson.Parser.Types (Parser)-import Michelson.Untyped.Annotation-import Util.Default---- | General T/V/F Annotation parser, including Special Annotations-note :: forall tag. KnownAnnTag tag => Parser (Annotation tag)-note = lexeme $ string (annPrefix @tag) >> (specialNote <|> note' <|> emptyNote)-  where-    -- TODO [#48] these are special annotations and should not always be accepted-    specialVNote = unsafeMkAnnotation <$> asum (map string specialVarAnns)-    specialFNote = unsafeMkAnnotation <$> string specialFieldAnn-    specialNote = specialVNote <|> specialFNote-    emptyNote = pure noAnn-    note' = do-      a <- satisfy isValidAnnStart-      b <- takeWhileP Nothing isValidAnnBodyChar-      return . unsafeMkAnnotation $ T.cons a b--noteV :: Parser VarAnn-noteV = note--noteDef :: KnownAnnTag tag => Parser (Annotation tag)-noteDef = parseDef note--noteF :: Parser FieldAnn-noteF = note--noteV2Def :: Parser (VarAnn, VarAnn)-noteV2Def = permute2Def note note--notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn)-notesTVF = permute3Def note note note--notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))-notesTVF2Def = permute3Def note note (permute2Def note note)---- | Parse 0/1/2 var anns and 0/1/2 field anns.--- It doesn't matter which come first, so long as annotations of the same type appear together.------ E.g.:------ * "" is valid--- * "%a" is valid--- * "%a @c" is valid--- * "%a %b @c @d" is valid--- * "@c @d %a %b" is valid--- * "@c %a %b @d" is not valid, because the two var anns are not "grouped" together.--- * "%a @c @d %b" is not valid, because the two fields anns are not "grouped" together.-notesVVFF :: Parser ((VarAnn, VarAnn), (FieldAnn, FieldAnn))-notesVVFF = permute2Def (liftA2 (,) note noteDef) (liftA2 (,) note noteDef)--notesVF :: Parser (VarAnn, FieldAnn)-notesVF = permute2Def note note--notesTV :: Parser (TypeAnn, VarAnn)-notesTV = permute2Def note note--notesTF :: Parser (TypeAnn, FieldAnn)-notesTF = permute2Def note note--fieldType :: Default a-          => Parser a-          -> Parser (a, TypeAnn)-fieldType fp = runPermutation $-  (,) <$> toPermutationWithDefault  def     fp-      <*> toPermutationWithDefault noAnn note

− src/Michelson/Parser/Error.hs

@@ -1,74 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- |  Custom exceptions that can happen during parsing.--module Michelson.Parser.Error-  ( CustomParserException (..)-  , StringLiteralParserException (..)-  , ParseErrorBundle-  , ParserException (..)-  ) where--import Data.Data (Data(..))-import Fmt (Buildable(build), (+|), (|+))-import Text.Megaparsec (ParseErrorBundle, ShowErrorComponent(..), errorBundlePretty)-import qualified Text.Show (show)--import Util.Instances ()-import Util.Named ()-import Util.Positive--data CustomParserException-  = StringLiteralException StringLiteralParserException-  | OddNumberBytesException-  | WrongTagArgs Natural Positive-  | WrongAccessArgs Natural Positive-  | WrongSetArgs Natural Positive-  | ExcessFieldAnnotation-  | MultiRootAnnotationException-  deriving stock (Eq, Data, Ord, Show, Generic)--instance NFData CustomParserException--instance ShowErrorComponent CustomParserException where-  showErrorComponent (StringLiteralException e) = showErrorComponent e-  showErrorComponent OddNumberBytesException = "odd number bytes"-  showErrorComponent ExcessFieldAnnotation = "excess field annotation"-  showErrorComponent MultiRootAnnotationException = "unexpected multiple root annotations"-  showErrorComponent (WrongTagArgs idx size) =-    "TAG: too large index: " +| idx |+ " \-           \exceedes union size " +| size |+ ""-  showErrorComponent (WrongAccessArgs idx size) =-    "ACCESS: too large index: " +| idx |+ " \-           \exceedes tuple size " +| size |+ ""-  showErrorComponent (WrongSetArgs idx size) =-    "SET: too large index: " +| idx |+ " \-           \exceedes tuple size " +| size |+ ""--data StringLiteralParserException-  = InvalidEscapeSequence Char-  | InvalidChar Char-  deriving stock (Eq, Data, Ord, Show, Generic)--instance NFData StringLiteralParserException--instance ShowErrorComponent StringLiteralParserException where-  showErrorComponent (InvalidEscapeSequence c) =-    "invalid escape sequence '\\" <> [c] <> "'"-  showErrorComponent (InvalidChar c) =-    "invalid character '" <> [c] <> "'"--data ParserException =-  ParserException (ParseErrorBundle Text CustomParserException)-  deriving stock (Eq)--instance Show ParserException where-  show (ParserException bundle) = errorBundlePretty bundle--instance Exception ParserException where-  displayException (ParserException bundle) = errorBundlePretty bundle--instance Buildable ParserException where-  build = build @String . show

− src/Michelson/Parser/Ext.hs

@@ -1,72 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Parsing logic for extra instructions (Morley extensions)--module Michelson.Parser.Ext-  ( extInstr-  , stackType--  -- * For tests-  , printComment-  ) where--import Prelude hiding (try)--import Text.Megaparsec (choice, label, satisfy, try)-import Text.Megaparsec.Char (alphaNumChar, string)-import qualified Text.Megaparsec.Char.Lexer as L--import Michelson.Macro (ParsedOp(..), ParsedUExtInstr)-import Michelson.Parser.Lexer-import Michelson.Parser.Type-import Michelson.Parser.Types (Parser)-import qualified Michelson.Untyped as U--extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr-extInstr opsParser = label "morley instruction" $ choice [stackOp, testAssertOp opsParser, printOp]--stackOp :: Parser ParsedUExtInstr-stackOp = word' "STACKTYPE" U.STACKTYPE <*> stackType--testAssertOp :: Parser [ParsedOp] -> Parser ParsedUExtInstr-testAssertOp opsParser =-  word' "TEST_ASSERT" U.UTEST_ASSERT <*> testAssert opsParser--printOp :: Parser ParsedUExtInstr-printOp = word' "PRINT" U.UPRINT <*> printComment--testAssert :: Parser [ParsedOp] -> Parser (U.TestAssert ParsedOp)-testAssert opsParser = do-  n <- lexeme (toText <$> some alphaNumChar)-  c <- printComment-  o <- opsParser-  return $ U.TestAssert n c o--printComment :: Parser U.PrintComment-printComment = do-  string "\""-  let validChar = toText <$> some (satisfy (\x -> x /= '%' && x /= '"'))-  c <- many (Right <$> stackRef <|> Left <$> validChar)-  symbol "\""-  return $ U.PrintComment c--stackRef :: Parser U.StackRef-stackRef = do-  string "%"-  n <- brackets' L.decimal-  return $ U.StackRef n--stackType :: Parser U.StackTypePattern-stackType = symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)-  where-    emptyStk = try $ symbol "]" $> U.StkEmpty-    stkRest = try $ symbol "..." >> symbol "]" $> U.StkRest-    stkCons = try $ do-      t <- tyVar-      s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk-      return $ U.StkCons t s--tyVar :: Parser U.TyVar-tyVar = (U.TyCon <$> type_) <|> (U.VarID <$> varID)

− src/Michelson/Parser/Helpers.hs

@@ -1,51 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Parser.Helpers-  ( mkParser-  , sepEndBy1-  , sepBy2-  , parseDef-  , positive-  , mparens-  ) where--import Data.Default (Default(..))-import qualified Data.List.NonEmpty as NE-import qualified Text.Megaparsec as P-import Text.Megaparsec.Char.Lexer (decimal)--import Michelson.Parser.Lexer (parens, word')-import Michelson.Parser.Types (Parser)-import Util.Positive--sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)-sepEndBy1 = fmap NE.fromList ... P.sepEndBy1---- | @endBy2 p sep@ parses two or more occurrences of @p@, separated by @sep@.-sepBy2 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)-sepBy2 parser sep = do-  e <- parser-  void sep-  es <- P.sepBy1 parser sep-  return $ e :| es---- | Make a parser from a string-mkParser :: (a -> Text) -> a -> Parser a-mkParser f a = P.try $ word' (f a) a---- | Apply given parser and return default value if it fails.-parseDef :: Default a => Parser a -> Parser a-parseDef a = P.try a <|> pure def---- | Parse a positive number.-positive :: Parser Positive-positive = do-  n :: Integer <- decimal-  mkPositive n-    & either (fail . toString) pure---- | Parse expression which can be wrapped in parentheses.-mparens :: Parser a -> Parser a-mparens p = p <|> parens p

− src/Michelson/Parser/Instr.hs

@@ -1,443 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Parsing of Michelson instructions.--module Michelson.Parser.Instr-  ( primInstr-  , ops'-  -- * These are handled separately to have better error messages-  , mapOp-  , pairOp-  , unpairOp-  , pairNOp-  , cmpOp-  , dupOp-  , carOp-  , cdrOp-  ) where--import Prelude hiding (EQ, GT, LT, many, note, some, try)--import Text.Megaparsec (choice, label, notFollowedBy, sepEndBy, try)-import qualified Text.Megaparsec.Char.Lexer as L--import Michelson.Let (LetValue(..))-import Michelson.Macro (ParsedInstr, ParsedOp(..))-import Michelson.Parser.Annotations-import Michelson.Parser.Lexer-import Michelson.Parser.Type-import Michelson.Parser.Types (Parser, letValues)-import Michelson.Parser.Value-import Michelson.Untyped---- | Parser for primitive Michelson instruction (no macros and extensions).-primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr-primInstr contractParser opParser = label "primitive instruction" $ choice-  [ dropOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp-  , ifNoneOp opParser, leftOp, rightOp, ifLeftOp opParser, nilOp-  , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser-  , memOp, getAndUpdateOp, getOp, updateOp, loopLOp opParser, loopOp opParser-  , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp, levelOp-  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, selfAddressOp, addOp, subOp-  , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp-  , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp-  , transferTokensOp, setDelegateOp-  , createContractOp contractParser, implicitAccountOp, nowOp, amountOp-  , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp, pairingCheckOp-  , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp, neverOp-  , votingPowerOp, totalVotingPowerOp, try unpairNOp-  , unpairOp-  , ticketOp, readTicketOp, splitTicketOp, joinTicketsOp-  ]---- | Parse a sequence of instructions.-ops' :: Parser ParsedOp -> Parser [ParsedOp]-ops' opParser = (braces $ sepEndBy opParser (optional semicolon)) <|> (pure <$> opParser)---- Control Structures--failWithOp :: Parser ParsedInstr-failWithOp = word' "FAILWITH" FAILWITH--loopOp :: Parser ParsedOp -> Parser ParsedInstr-loopOp opParser = word' "LOOP" LOOP <*> ops' opParser--loopLOp :: Parser ParsedOp -> Parser ParsedInstr-loopLOp opParser = word' "LOOP_LEFT" LOOP_LEFT <*> ops' opParser--execOp :: Parser ParsedInstr-execOp = word' "EXEC" EXEC <*> noteDef--applyOp :: Parser ParsedInstr-applyOp = word' "APPLY" APPLY <*> noteDef---- Parses both `DIP` and `DIP n`.-dipOp :: Parser ParsedOp -> Parser ParsedInstr-dipOp opParser = parseWithOptionalParameter "DIP" DIPN DIP <*> ops' opParser---- Helper for instructions which have optional numeric non-negative parameter.-parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser instr-parseWithOptionalParameter instrName constructorWithParam constructorNoParam =-  symbol' instrName *>-  (try (constructorWithParam <$> lexeme L.decimal) <|> pure constructorNoParam)---- Stack Operations---- Parses both `DROP` and `DROP n`.-dropOp :: Parser ParsedInstr-dropOp = parseWithOptionalParameter "DROP" DROPN DROP--dupOp :: Parser ParsedInstr-dupOp = do-  symbol' "DUP"-  varAnn <- noteDef-  optional (lexeme L.decimal) <&> maybe (DUP varAnn) (DUPN varAnn)--swapOp :: Parser ParsedInstr-swapOp = word' "SWAP" SWAP--digOp :: Parser ParsedInstr-digOp = word' "DIG" DIG <*> lexeme L.decimal--dugOp :: Parser ParsedInstr-dugOp = word' "DUG" DUG <*> lexeme L.decimal--pushOp :: Parser ParsedOp -> Parser ParsedInstr-pushOp opParser = do-  symbol' "PUSH"-  v <- noteDef-  (try $ pushLet v) <|> (push' v)-  where-    pushLet v = do-      lvs <- asks letValues-      lv <- mkLetVal lvs-      return $ PUSH v (lvSig lv) (lvVal lv)-    push' v = PUSH v <$> type_ <*> value' opParser--unitOp :: Parser ParsedInstr-unitOp = do symbol' "UNIT"; (t, v) <- notesTV; return $ UNIT t v--lambdaOp :: Parser ParsedOp -> Parser ParsedInstr-lambdaOp opParser =-  word' "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser--neverOp :: Parser ParsedInstr-neverOp = word' "NEVER" NEVER--- Generic comparison--cmpOp :: Parser ParsedInstr-cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp--eqOp :: Parser ParsedInstr-eqOp = word' "EQ" EQ <*> noteDef--neqOp :: Parser ParsedInstr-neqOp = word' "NEQ" NEQ <*> noteDef--ltOp :: Parser ParsedInstr-ltOp = word' "LT" LT <*> noteDef--gtOp :: Parser ParsedInstr-gtOp = word' "GT" GT <*> noteDef--leOp :: Parser ParsedInstr-leOp = word' "LE" LE <*> noteDef--geOp :: Parser ParsedInstr-geOp = word' "GE" GE <*> noteDef---- ad-hoc comparison--compareOp :: Parser ParsedInstr-compareOp = word' "COMPARE" COMPARE <*> noteDef---- Operations on booleans--orOp :: Parser ParsedInstr-orOp = word' "OR"  OR <*> noteDef--andOp :: Parser ParsedInstr-andOp = word' "AND" AND <*> noteDef--xorOp :: Parser ParsedInstr-xorOp = word' "XOR" XOR <*> noteDef--notOp :: Parser ParsedInstr-notOp = word' "NOT" NOT <*> noteDef---- Operations on integers and natural numbers--addOp :: Parser ParsedInstr-addOp = word' "ADD" ADD <*> noteDef--subOp :: Parser ParsedInstr-subOp = word' "SUB" SUB <*> noteDef--mulOp :: Parser ParsedInstr-mulOp = word' "MUL" MUL <*> noteDef--edivOp :: Parser ParsedInstr-edivOp = word' "EDIV"EDIV <*> noteDef--absOp :: Parser ParsedInstr-absOp = word' "ABS" ABS <*> noteDef--negOp :: Parser ParsedInstr-negOp = word' "NEG" NEG <*> noteDef---- Bitwise logical operators--lslOp :: Parser ParsedInstr-lslOp = word' "LSL" LSL <*> noteDef--lsrOp :: Parser ParsedInstr-lsrOp = word' "LSR" LSR <*> noteDef---- Operations on string's--concatOp :: Parser ParsedInstr-concatOp = word' "CONCAT" CONCAT <*> noteDef--sliceOp :: Parser ParsedInstr-sliceOp = word' "SLICE" SLICE <*> noteDef---- Operations on pairs-pairOp :: Parser ParsedInstr-pairOp = do-  symbol' "PAIR"-  (t, v, (p, q)) <- notesTVF2Def--  -- Make sure this is a `PAIR` instruction,-  -- and not a `PAIR n` instruction.-  notFollowedBy (lexeme L.decimal :: Parser Word)--  return $ PAIR t v p q--unpairOp :: Parser ParsedInstr-unpairOp = do-  symbol' "UNPAIR"-  ((vn1, vn2), (fn1, fn2)) <- notesVVFF--  -- Make sure this is an `UNPAIR` instruction,-  -- and not an `UNPAIR n` instruction.-  notFollowedBy (lexeme L.decimal :: Parser Word)--  return $ UNPAIR vn1 vn2 fn1 fn2--pairNOp :: Parser ParsedInstr-pairNOp = do-  symbol' "PAIR"-  PAIRN-    <$> noteDef-    <*> lexeme L.decimal--unpairNOp :: Parser ParsedInstr-unpairNOp =-  word' "UNPAIR" UNPAIRN <*> lexeme L.decimal--carOp :: Parser ParsedInstr-carOp = do symbol' "CAR"; (v, f) <- notesVF; return $ CAR v f--cdrOp :: Parser ParsedInstr-cdrOp = do symbol' "CDR"; (v, f) <- notesVF; return $ CDR v f---- Operations on collections (sets, maps, lists)--emptySetOp :: Parser ParsedInstr-emptySetOp = do symbol' "EMPTY_SET"; (t, v) <- notesTV;-                EMPTY_SET t v <$> typeWithParen--emptyMapOp :: Parser ParsedInstr-emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- typeWithParen;-                EMPTY_MAP t v a <$> type_--emptyBigMapOp :: Parser ParsedInstr-emptyBigMapOp = do symbol' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- typeWithParen;-                   EMPTY_BIG_MAP t v a <$> type_--memOp :: Parser ParsedInstr-memOp = word' "MEM" MEM <*> noteDef--updateOp :: Parser ParsedInstr-updateOp = do-  symbol' "UPDATE"-  varAnn <- noteDef-  ix <- optional (lexeme L.decimal)-  pure $ maybe (UPDATE varAnn) (UPDATEN varAnn) ix--getAndUpdateOp :: Parser ParsedInstr-getAndUpdateOp = word' "GET_AND_UPDATE" GET_AND_UPDATE <*> noteDef--iterOp :: Parser ParsedOp -> Parser ParsedInstr-iterOp opParser = word' "ITER" ITER <*> ops' opParser--sizeOp :: Parser ParsedInstr-sizeOp = word' "SIZE" SIZE <*> noteDef--mapOp :: Parser ParsedOp -> Parser ParsedInstr-mapOp opParser = word' "MAP" MAP <*>  noteDef <*> ops' opParser--getOp :: Parser ParsedInstr-getOp = do-  symbol' "GET"-  varAnn <- noteDef-  ix <- optional (lexeme L.decimal)-  pure $ maybe (GET varAnn) (GETN varAnn) ix--nilOp :: Parser ParsedInstr-nilOp = do symbol' "NIL"; (t, v) <- notesTV; NIL t v <$> type_--consOp :: Parser ParsedInstr-consOp = do-  try . lexeme $ do-    void $ string' "CONS"-    notFollowedBy (string' "T")-  CONS <$> noteDef--ifConsOp :: Parser ParsedOp -> Parser ParsedInstr-ifConsOp opParser = word' "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser---- Operations on options--someOp :: Parser ParsedInstr-someOp = do symbol' "SOME"; (t, v) <- notesTV; return $ SOME t v--noneOp :: Parser ParsedInstr-noneOp = do symbol' "NONE"; (t, v) <- notesTV; NONE t v <$> type_--ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr-ifNoneOp opParser = word' "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser---- Operations on unions--leftOp :: Parser ParsedInstr-leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2Def;-               LEFT t v f f' <$> type_--rightOp :: Parser ParsedInstr-rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2Def;-               RIGHT t v f f' <$> type_--ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr-ifLeftOp opParser = word' "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser---- Operations on contracts--createContractOp :: Parser (Contract' ParsedOp) -> Parser ParsedInstr-createContractOp contractParser =-  word' "CREATE_CONTRACT" CREATE_CONTRACT-    <*> noteDef <*> noteDef <*> braces contractParser--transferTokensOp :: Parser ParsedInstr-transferTokensOp = word' "TRANSFER_TOKENS" TRANSFER_TOKENS <*> noteDef--setDelegateOp :: Parser ParsedInstr-setDelegateOp = word' "SET_DELEGATE" SET_DELEGATE <*> noteDef--balanceOp :: Parser ParsedInstr-balanceOp = word' "BALANCE" BALANCE <*> noteDef--contractOp :: Parser ParsedInstr-contractOp = word' "CONTRACT" CONTRACT <*> noteDef <*> noteDef <*> type_--sourceOp :: Parser ParsedInstr-sourceOp = word' "SOURCE" SOURCE <*> noteDef--senderOp :: Parser ParsedInstr-senderOp = word' "SENDER" SENDER <*> noteDef--amountOp :: Parser ParsedInstr-amountOp = word' "AMOUNT" AMOUNT <*> noteDef--votingPowerOp :: Parser ParsedInstr-votingPowerOp = word' "VOTING_POWER" VOTING_POWER <*> noteDef--totalVotingPowerOp :: Parser ParsedInstr-totalVotingPowerOp = word' "TOTAL_VOTING_POWER" TOTAL_VOTING_POWER <*> noteDef--implicitAccountOp :: Parser ParsedInstr-implicitAccountOp = word' "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef--selfOp :: Parser ParsedInstr-selfOp = word' "SELF" SELF <*> noteDef <*> noteDef--addressOp :: Parser ParsedInstr-addressOp = word' "ADDRESS" ADDRESS <*> noteDef--selfAddressOp :: Parser ParsedInstr-selfAddressOp = word' "SELF_ADDRESS" SELF_ADDRESS <*> noteDef---- Special Operations--nowOp :: Parser ParsedInstr-nowOp = word' "NOW" NOW <*> noteDef--levelOp :: Parser ParsedInstr-levelOp = word' "LEVEL" LEVEL <*> noteDef--chainIdOp :: Parser ParsedInstr-chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef---- Operations on bytes--packOp :: Parser ParsedInstr-packOp = word' "PACK" PACK <*> noteDef--unpackOp :: Parser ParsedInstr-unpackOp = do symbol' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_---- Cryptographic Primitives--checkSigOp :: Parser ParsedInstr-checkSigOp = word' "CHECK_SIGNATURE" CHECK_SIGNATURE <*> noteDef--blake2BOp :: Parser ParsedInstr-blake2BOp = word' "BLAKE2B" BLAKE2B <*> noteDef--sha256Op :: Parser ParsedInstr-sha256Op = word' "SHA256" SHA256 <*> noteDef--sha512Op :: Parser ParsedInstr-sha512Op = word' "SHA512" SHA512 <*> noteDef--sha3Op :: Parser ParsedInstr-sha3Op = word' "SHA3" SHA3 <*> noteDef--keccakOp :: Parser ParsedInstr-keccakOp = word' "KECCAK" KECCAK <*> noteDef--hashKeyOp :: Parser ParsedInstr-hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef--pairingCheckOp :: Parser ParsedInstr-pairingCheckOp = word' "PAIRING_CHECK" PAIRING_CHECK <*> noteDef---- Type operations--castOp :: Parser ParsedInstr-castOp = word' "CAST" CAST <*> noteDef <*> type_--renameOp :: Parser ParsedInstr-renameOp = word' "RENAME" RENAME <*> noteDef--isNatOp :: Parser ParsedInstr-isNatOp = word' "ISNAT" ISNAT <*> noteDef--intOp :: Parser ParsedInstr-intOp = word' "INT" INT <*> noteDef---- Ticket Operations--ticketOp :: Parser ParsedInstr-ticketOp = word' "TICKET" TICKET <*> noteDef--readTicketOp :: Parser ParsedInstr-readTicketOp = word' "READ_TICKET" READ_TICKET <*> noteDef--splitTicketOp :: Parser ParsedInstr-splitTicketOp = word' "SPLIT_TICKET" SPLIT_TICKET <*> noteDef--joinTicketsOp :: Parser ParsedInstr-joinTicketsOp = word' "JOIN_TICKETS" JOIN_TICKETS <*> noteDef

− src/Michelson/Parser/Let.hs

@@ -1,125 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Parsing of let blocks--module Michelson.Parser.Let-  ( letBlock-  , mkLetMac-  -- * For tests-  , letInner-  , letType-  ) where--import Prelude hiding (try)--import qualified Data.Char as Char-import qualified Data.Map as Map-import qualified Data.Set as Set--import Text.Megaparsec (choice, satisfy, try)-import Text.Megaparsec.Char (lowerChar, upperChar)--import Michelson.Let (LetType(..), LetValue(..))-import Michelson.Macro (LetMacro(..), ParsedOp(..))-import Michelson.Parser.Ext-import Michelson.Parser.Helpers-import Michelson.Parser.Instr-import Michelson.Parser.Lexer-import Michelson.Parser.Type-import Michelson.Parser.Types (LetEnv(..), Parser, noLetEnv)-import Michelson.Parser.Value-import Michelson.Untyped (StackFn(..), Ty(..), mkAnnotation, noAnn)---- | Element of a let block-data Let = LetM LetMacro | LetV LetValue | LetT LetType---- | let block parser-letBlock :: Parser ParsedOp -> Parser LetEnv-letBlock opParser = do-  symbol "let"-  symbol "{"-  ls <- local (const noLetEnv) (letInner opParser)-  symbol "}"-  semicolon-  return ls---- | Incrementally build the let environment-letInner :: Parser ParsedOp -> Parser LetEnv-letInner opParser = do-  env <- ask-  l <- lets opParser-  semicolon-  local (addLet l) (letInner opParser) <|> return (addLet l env)---- | Add a Let to the environment in the correct place-addLet :: Let -> LetEnv -> LetEnv-addLet l (LetEnv lms lvs lts) = case l of-  LetM lm -> LetEnv (Map.insert (lmName lm) lm lms) lvs lts-  LetV lv -> LetEnv lms (Map.insert (lvName lv) lv lvs) lts-  LetT lt -> LetEnv lms lvs (Map.insert (ltName lt) lt lts)--lets :: Parser ParsedOp -> Parser Let-lets opParser = choice-  [ (LetM <$> letMacro opParser)-  , (LetV <$> letValue opParser)-  , (LetT <$> letType)-  ]---- | Build a let name parser from a leading character parser-letName :: Parser Char -> Parser Text-letName p = lexeme $ do-  v <- p-  -- FIXME (#557): It is possible to define a let name such as "add3", but then-  -- the parser doesn't recognize when it's used as an instruction.-  let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')-  vs <- many (satisfy validChar)-  return $ toText (v:vs)--letMacro :: Parser ParsedOp -> Parser LetMacro-letMacro opParser = lexeme $ do-  n <- try $ do-    n <- letName lowerChar-    symbol "::"-    return n-  s <- stackFn-  symbol "="-  o <- ops' opParser-  return $ LetMacro n s o--letType :: Parser LetType-letType = lexeme $ do-  n <- try $ do-    symbol "type"-    n <- letName upperChar <|> letName lowerChar-    symbol "="-    return n-  t@(Ty t' a) <- type_-  if a == noAnn-    then case mkAnnotation n of-      Right an -> return $ LetType n (Ty t' an)-      Left err -> fail $ toString err-    else return $ LetType n t--letValue :: Parser ParsedOp -> Parser LetValue-letValue opParser = lexeme $ do-  n <- try $ do-    n <- letName upperChar-    symbol "::"-    return n-  t <- type_-  symbol "="-  v <- value' opParser-  return $ LetValue n t v--mkLetMac :: Map Text LetMacro -> Parser LetMacro-mkLetMac lms = choice $ mkParser lmName <$> (Map.elems lms)--stackFn :: Parser StackFn-stackFn = do-  vs <- (optional (symbol "forall" >> some varID <* symbol "."))-  a <- stackType-  symbol "->"-  b <- stackType-  return $ StackFn (Set.fromList <$> vs) a b

− src/Michelson/Parser/Lexer.hs

@@ -1,81 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Parser.Lexer-  ( lexeme-  , mSpace-  , symbol-  , symbol'-  , word-  , word'-  , string'-  , parens-  , braces-  , brackets-  , brackets'-  , semicolon-  , comma-  , varID-  ) where--import Data.Char (isDigit, isLower, toLower)-import qualified Data.Text as T-import Text.Megaparsec (MonadParsec, Tokens, between, satisfy)-import Text.Megaparsec.Char (lowerChar, space, space1, string)-import qualified Text.Megaparsec.Char.Lexer as L--import Michelson.Parser.Types (Parser)-import qualified Michelson.Untyped as U---- Lexing-lexeme :: Parser a -> Parser a-lexeme = L.lexeme mSpace--mSpace :: Parser ()-mSpace = L.space space1-  (L.skipLineComment "#")-  (L.skipBlockComment "/*" "*/" >> space >> void (optional semicolon))---symbol :: Tokens Text -> Parser ()-symbol = void . L.symbol mSpace--symbol' :: Text -> Parser ()-symbol' str = symbol str <|> symbol (T.map toLower str)--word :: Tokens Text -> a -> Parser a-word str val = symbol str $> val--word' :: Tokens Text -> a -> Parser a-word' str val = symbol' str $> val--string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text-string' str = string str <|> string (T.map toLower str)--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--braces :: Parser a -> Parser a-braces = between (symbol "{") (symbol "}")--brackets :: Parser a -> Parser a-brackets = between (symbol "[") (symbol "]")--brackets' :: Parser a -> Parser a-brackets' = between (string "[") (string "]")--semicolon :: Parser ()-semicolon = symbol ";"--comma :: Parser ()-comma = symbol ","--varID :: Parser U.Var-varID = lexeme $ do-  v <- lowerChar-  vs <- many lowerAlphaNumChar-  return $ U.Var (toText (v:vs))-  where-    lowerAlphaNumChar :: Parser Char-    lowerAlphaNumChar = satisfy (\x -> isLower x || isDigit x)

− src/Michelson/Parser/Macro.hs

@@ -1,169 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Parsing of built-in Michelson macros.--module Michelson.Parser.Macro-  ( macro-  -- * These are handled separately to have better error messages-  , duupMac-  , pairMac-  , ifCmpMac-  , mapCadrMac-  , cadrMac-  , carnMac-  , cdrnMac-  ) where--import Prelude hiding (note, try)--import Text.Megaparsec (customFailure, label, notFollowedBy, skipMany, try)-import Text.Megaparsec.Char.Lexer (decimal)--import Michelson.Macro (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..))-import qualified Michelson.Macro as Macro-import Michelson.Parser.Annotations-import Michelson.Parser.Error-import Michelson.Parser.Helpers-import Michelson.Parser.Instr-import Michelson.Parser.Lexer-import Michelson.Parser.Type-import Michelson.Parser.Types (Parser)-import Michelson.Untyped (T(..), Ty(..), noAnn)-import Util.Alternative (someNE)-import Util.Positive--macro :: Parser ParsedOp -> Parser Macro-macro opParser = label "macro"-   $  word' "CASE" CASE <*> someNE ops-  <|> symbol' "TAG" *> tagMac-  <|> symbol' "ACCESS" *> accessMac-  <|> symbol' "SET " *> setMac-  <|> word' "CONSTRUCT" CONSTRUCT <*> someNE ops-  <|> word' "VIEW" VIEW <*> ops-  <|> word' "VOID" VOID <*> ops-  <|> word' "CMP" CMP <*> cmpOp <*> noteDef-  <|> word' "IF_SOME" IF_SOME <*> ops <*> ops-  <|> word' "IF_RIGHT" IF_RIGHT <*> ops <*> ops-  <|> word' "FAIL" FAIL-  <|> word' "ASSERT_CMP" ASSERT_CMP <*> cmpOp-  <|> word' "ASSERT_NONE" ASSERT_NONE-  <|> word' "ASSERT_SOME" ASSERT_SOME-  <|> word' "ASSERT_LEFT" ASSERT_LEFT-  <|> word' "ASSERT_RIGHT" ASSERT_RIGHT-  <|> word' "ASSERT_" ASSERTX <*> cmpOp-  <|> word' "ASSERT" ASSERT-  <|> do string' "DI"; n <- num "I"; symbol' "P"; DIIP (n + 1) <$> ops-  <|> unpairMac-  <|> setCadrMac-  where-   ops = ops' opParser-   num str = fromIntegral . length <$> some (string' str)--duupMac :: Parser Macro-duupMac = do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef-  where-    num str = fromIntegral . length <$> some (string' str)--pairMacInner :: Parser PairStruct-pairMacInner = do-  string' "P"-  l <- (string' "A" $> F noAnn) <|> pairMacInner-  r <- (string' "I" $> F noAnn) <|> pairMacInner-  return $ P l r--pairMac :: Parser Macro-pairMac = do-  a <- pairMacInner-  symbol' "R"-  (tn, vn, fns) <- permute3Def noteDef note (some note)-  let ps = Macro.mapPairLeaves fns a-  return $ PAPAIR ps tn vn--unpairMacInner :: Parser UnpairStruct-unpairMacInner = do-  string' "P"-  l <- (string' "A" $> UF) <|> unpairMacInner-  r <- (string' "I" $> UF) <|> unpairMacInner-  return $ UP l r--unpairMac :: Parser Macro-unpairMac = do-  string' "UN"-  a <- unpairMacInner-  symbol' "R"-  skipMany $ (void noteF) <|> (void noteV)-  return $ UNPAPAIR a--cadrMac :: Parser Macro-cadrMac = lexeme $ do-  string' "C"-  a <- some $ try $ cadrInner <* notFollowedBy (string' "R")-  b <- cadrInner-  symbol' "R"-  (vn, fn) <- notesVF-  return $ CADR (a ++ pure b) vn fn--cadrInner :: Parser CadrStruct-cadrInner = (string' "A" $> A) <|> (string' "D" $> D)--carnMac :: Parser Macro-carnMac = symbol' "CAR" *> (CARN <$> noteDef <*> lexeme decimal)--cdrnMac :: Parser Macro-cdrnMac = symbol' "CDR" *> (CDRN <$> noteDef <*> lexeme decimal)--{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}-setCadrMac :: Parser Macro-setCadrMac = do-  string' "SET_C"-  a <- some cadrInner-  symbol' "R"-  (v, f) <- notesVF-  return $ SET_CADR a v f--mapCadrMac :: Parser ParsedOp -> Parser Macro-mapCadrMac opParser = do-  string' "MAP_C"-  a <- some cadrInner-  symbol' "R"-  (v, f) <- notesVF-  MAP_CADR a v f <$> ops' opParser--ifCmpMac :: Parser ParsedOp -> Parser Macro-ifCmpMac opParser =-  word' "IFCMP" IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser--tagMac :: Parser Macro-tagMac = do-  idx <- decimal-  mSpace-  ty <- type_-  let utys = unrollUnion ty []-  when (fromIntegral idx >= length utys) $-    customFailure $ WrongTagArgs idx (lengthNE utys)-  return $ TAG idx utys-  where-  unrollUnion ty =-    case ty of-      Ty (TOr _ _ l r) _ -> unrollUnion l . toList . unrollUnion r-      _ -> (ty :|)--accessMac :: Parser Macro-accessMac = do-  idx <- decimal-  mSpace-  size <- positive-  when (idx >= unPositive size) $-    customFailure $ WrongAccessArgs idx size-  return $ ACCESS idx size--setMac :: Parser Macro-setMac = do-  idx <- decimal-  mSpace-  size <- positive-  when (idx >= unPositive size) $-    customFailure $ WrongSetArgs idx size-  return $ SET idx size

− src/Michelson/Parser/Type.hs

@@ -1,305 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Parsing of Michelson types.--module Michelson.Parser.Type-  ( type_-  , typeWithParen-  , field-  ) where--import Prelude hiding (note, some, try)--import Data.Default (Default, def)-import qualified Data.Map as Map-import Fmt (pretty)-import Text.Megaparsec (choice, customFailure, label, sepBy)--import Michelson.Let (LetType(..))-import Michelson.Parser.Annotations-import Michelson.Parser.Error-import Michelson.Parser.Helpers-import Michelson.Parser.Lexer-import Michelson.Parser.Types (Parser, letTypes)-import Michelson.Untyped-import Util.Generic--type_ :: Parser Ty-type_ = snd <$> typeInner (pure noAnn)--field :: Parser (FieldAnn, Ty)-field = typeInner note--t_operator :: Parser FieldAnn -> Parser (FieldAnn, Ty)-t_operator fp = do-  whole <- parens do-    optional do-      ty   <- field-      rest <- optional do-        isOr <- (symbol' "|" >> return True)-            <|> (symbol' "," >> return False)-        others <- field `sepBy` symbol' if isOr then "|" else ","-        return (isOr, others)-      return (ty, rest)--  (f, t) <- fieldType fp-  case whole of-    Just (ty, Just (isOr, tys)) -> do-      let (f', Ty ty' _) = mkGenericTree (mergeTwo isOr) (ty :| tys)-      f'' <- mergeAnnots f f'-      return (f'', Ty ty' t)-    Just (res, _) -> do-      return res-    Nothing -> do-      return (f, Ty TUnit t)-  where-    mergeTwo isOr _ (l, a) (r, b) =-      (noAnn, Ty ((if isOr then TOr l r else TPair l r noAnn noAnn) a b) noAnn)--    mergeAnnots l r-      | l == def  = return r-      | r == def  = return l-      | otherwise = customFailure ExcessFieldAnnotation--typeInner-  :: Parser FieldAnn -> Parser (FieldAnn, Ty)-typeInner fp = label "type" $ lexeme $ choice $ (\x -> x fp) <$>-  [ t_int, t_nat, t_string, t_bytes, t_mutez, t_bool-  , t_keyhash, t_timestamp, t_address-  , t_key, t_unit, t_never, t_signature, t_chain_id-  , t_bls12381fr, t_bls12381g1, t_bls12381g2-  , t_option, t_list, t_set-  , t_operation, t_contract, t_ticket, t_pair, t_or-  , t_lambda, t_map, t_big_map, t_view-  , t_void, t_letType-  , t_operator-  ]--------------------------------------------------------------------------------- Comparable types-------------------------------------------------------------------------------typeWithParen :: Parser Ty-typeWithParen = mparens type_--------------------------------------------------------------------------------- Non-comparable types-------------------------------------------------------------------------------mkType :: T -> (a, TypeAnn) -> (a, Ty)-mkType t (a, ta) = (a, Ty t ta)---t_int :: (Default a) => Parser a -> Parser (a, Ty)-t_int fp = word' "Int" (mkType TInt) <*> fieldType fp--t_nat :: (Default a) => Parser a -> Parser (a, Ty)-t_nat fp = word' "Nat" (mkType TNat) <*> fieldType fp--t_string :: (Default a) => Parser a -> Parser (a, Ty)-t_string fp = word' "String" (mkType TString) <*> fieldType fp--t_bytes :: (Default a) => Parser a -> Parser (a, Ty)-t_bytes fp = word' "Bytes" (mkType TBytes) <*> fieldType fp--t_mutez :: (Default a) => Parser a -> Parser (a, Ty)-t_mutez fp = word' "Mutez" (mkType TMutez) <*> fieldType fp--t_bool :: (Default a) => Parser a -> Parser (a, Ty)-t_bool fp = word' "Bool" (mkType TBool) <*> fieldType fp--t_keyhash :: (Default a) => Parser a -> Parser (a, Ty)-t_keyhash fp = ((word' "KeyHash" (mkType TKeyHash)) <|> (word "key_hash" (mkType TKeyHash))) <*> fieldType fp--t_timestamp :: (Default a) => Parser a -> Parser (a, Ty)-t_timestamp fp = word' "Timestamp" (mkType TTimestamp) <*> fieldType fp--t_address :: (Default a) => Parser a -> Parser (a, Ty)-t_address fp = word' "Address" (mkType TAddress) <*> fieldType fp--t_key :: (Default a) => Parser a -> Parser (a, Ty)-t_key fp = word' "Key" (mkType TKey) <*> fieldType fp--t_signature :: (Default a) => Parser a -> Parser (a, Ty)-t_signature fp = word' "Signature" (mkType TSignature) <*> fieldType fp--t_bls12381fr :: (Default a) => Parser a -> Parser (a, Ty)-t_bls12381fr fp = do-  symbol' "bls12_381_fr" <|> symbol' "Bls12381Fr"-  mkType TBls12381Fr <$> fieldType fp--t_bls12381g1 :: (Default a) => Parser a -> Parser (a, Ty)-t_bls12381g1 fp = do-  symbol' "bls12_381_g1" <|> symbol' "Bls12381G1"-  mkType TBls12381G1 <$> fieldType fp--t_bls12381g2 :: (Default a) => Parser a -> Parser (a, Ty)-t_bls12381g2 fp = do-  symbol' "bls12_381_g2" <|> symbol' "Bls12381G2"-  mkType TBls12381G2 <$> fieldType fp--t_chain_id :: (Default a) => Parser a -> Parser (a, Ty)-t_chain_id fp = do-  symbol' "ChainId" <|> symbol' "chain_id"-  mkType TChainId <$> fieldType fp--t_operation :: (Default a) => Parser a -> Parser (a, Ty)-t_operation fp = word' "Operation" (mkType TOperation) <*> fieldType fp--t_contract :: (Default a) => Parser a -> Parser (a, Ty)-t_contract fp = do-  symbol' "Contract"-  (f, t) <- fieldType fp-  a <- type_-  return (f, Ty (TContract a) t)--t_ticket :: (Default a) => Parser a -> Parser (a, Ty)-t_ticket fp = do-  symbol' "Ticket"-  (f, t) <- fieldType fp-  a <- type_-  return (f, Ty (TTicket a) t)--t_unit :: (Default a) => Parser a -> Parser (a, Ty)-t_unit fp = do-  symbol' "Unit" <|> symbol' "()"-  (f,t) <- fieldType fp-  return (f, Ty TUnit t)--t_never :: (Default a) => Parser a -> Parser (a, Ty)-t_never fp = do-  symbol' "Never" <|> symbol' "⊥"-  (f,t) <- fieldType fp-  return (f, Ty TNever t)--t_pair :: (Default a) => Parser a -> Parser (a, Ty)-t_pair fp = do-  symbol' "Pair"-  (fieldAnn, typeAnn) <- fieldType fp-  fields <- many field-  tPair <- go fields-  pure $ (fieldAnn, Ty tPair typeAnn)-  where-    go :: [(FieldAnn, Ty)] -> Parser T-    go = \case-      [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."-      [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."-      [(fieldAnnL, typeL), (fieldAnnR, typeR)] ->-        pure $ TPair fieldAnnL fieldAnnR noAnn noAnn typeL typeR-      (fieldAnnL, typeL) : fields -> do-        rightCombedT <- go fields-        pure $ TPair fieldAnnL noAnn noAnn noAnn typeL (Ty rightCombedT noAnn)--t_or :: (Default a) => Parser a -> Parser (a, Ty)-t_or fp = do-  symbol' "Or"-  (f, t) <- fieldType fp-  (l, a) <- field-  (r, b) <- field-  return (f, Ty (TOr l r a b) t)--t_option :: (Default a) => Parser a -> Parser (a, Ty)-t_option fp = do-  symbol' "Option"-  (f, t) <- fieldType fp-  a <- mparens $ snd <$> typeInner (pure noAnn)-  return (f, Ty (TOption a) t)--t_lambda :: (Default a) => Parser a -> Parser (a, Ty)-t_lambda fp = core <|> slashLambda-  where-    core = do-      symbol' "Lambda"-      (f, t) <- fieldType fp-      a <- type_-      b <- type_-      return (f, Ty (TLambda a b) t)-    slashLambda = do-      symbol "\\"-      (f, t) <- fieldType fp-      a <- type_-      symbol "->"-      b <- type_-      return (f, Ty (TLambda a b) t)---- Container types-t_list :: (Default a) => Parser a -> Parser (a, Ty)-t_list fp = core <|> bracketList-  where-    core = do-      symbol' "List"-      (f, t) <- fieldType fp-      a <- type_-      return (f, Ty (TList a) t)-    bracketList = do-      a <- brackets type_-      (f, t) <- fieldType fp-      return (f, Ty (TList a) t)--t_set :: (Default a) => Parser a -> Parser (a, Ty)-t_set fp = core <|> braceSet-  where-    core = do-      symbol' "Set"-      (f, t) <- fieldType fp-      a <- typeWithParen-      return (f, Ty (TSet a) t)-    braceSet = do-      a <- braces typeWithParen-      (f, t) <- fieldType fp-      return (f, Ty (TSet a) t)--t_map_like-  :: Default a-  => Parser a -> Parser (Ty, Ty, a, TypeAnn)-t_map_like fp = do-  (f, t) <- fieldType fp-  a <- typeWithParen-  b <- type_-  return (a, b, f, t)--t_map :: (Default a) => Parser a -> Parser (a, Ty)-t_map fp = do-  symbol' "Map"-  (a, b, f, t) <- t_map_like fp-  return (f, Ty (TMap a b) t)--t_big_map :: (Default a) => Parser a -> Parser (a, Ty)-t_big_map fp = do-  symbol' "BigMap" <|> symbol "big_map"-  (a, b, f, t) <- t_map_like fp-  return (f, Ty (TBigMap a b) t)--------------------------------------------------------------------------------- Non-standard types (Morley extensions)-------------------------------------------------------------------------------t_view :: Default a => Parser a -> Parser (a, Ty)-t_view fp = do-  symbol' "View"-  a <- type_-  r <- type_-  (f, t) <- fieldType fp-  let c' = Ty (TContract r) noAnn-  return (f, Ty (TPair noAnn noAnn noAnn noAnn a c') t)--t_void :: Default a => Parser a -> Parser (a, Ty)-t_void fp = do-  symbol' "Void"-  a <- type_-  b <- type_-  (f, t) <- fieldType fp-  let c = Ty (TLambda b b) noAnn-  return (f, Ty (TPair noAnn noAnn noAnn noAnn a c) t)--t_letType :: Default fp => Parser fp -> Parser (fp, Ty)-t_letType fp = do-  lts <- asks letTypes-  lt <- ltSig <$> (mkLetType lts)-  f <- parseDef fp-  return (f, lt)--mkLetType :: Map Text LetType -> Parser LetType-mkLetType lts = choice $ mkParser ltName <$> (Map.elems lts)

− src/Michelson/Parser/Types.hs

@@ -1,34 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Core parser types--module Michelson.Parser.Types-  ( Parser-  , LetEnv (..)-  , noLetEnv-  ) where--import Data.Default (Default(..))-import qualified Data.Map as Map-import Text.Megaparsec (Parsec)--import Michelson.Let (LetType, LetValue)-import Michelson.Macro (LetMacro)-import Michelson.Parser.Error--type Parser = ReaderT LetEnv (Parsec CustomParserException Text)--instance Default a => Default (Parser a) where-  def = pure def---- | The environment containing lets from the let-block-data LetEnv = LetEnv-  { letMacros :: Map Text LetMacro-  , letValues :: Map Text LetValue-  , letTypes  :: Map Text LetType-  } deriving stock (Show, Eq)--noLetEnv :: LetEnv-noLetEnv = LetEnv Map.empty Map.empty Map.empty

− src/Michelson/Parser/Value.hs

@@ -1,152 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Parsing of untyped Michelson values.--module Michelson.Parser.Value-  ( value'-  , mkLetVal--  -- * For tests-  , stringLiteral-  , bytesLiteral-  , intLiteral-  ) where--import Prelude hiding (many, note, some, try)--import qualified Data.Char as Char-import qualified Data.Map as Map-import qualified Text.Hex as Hex--import Text.Megaparsec (anySingle, choice, customFailure, label, manyTill, satisfy, takeWhileP, try)-import Text.Megaparsec.Char (char, string)-import qualified Text.Megaparsec.Char.Lexer as L--import Michelson.Let (LetValue(..))-import Michelson.Macro (ParsedOp, ParsedValue)-import Michelson.Parser.Error-import Michelson.Parser.Helpers-import Michelson.Parser.Lexer-import Michelson.Parser.Types (Parser, letValues)-import Michelson.Text (isMChar, unsafeMkMText)-import qualified Michelson.Untyped as U---- | Parse untyped 'ParsedValue'. Take instruction parser as argument--- to avoid cyclic dependencies between modules, hence ' in its name.-value' :: Parser ParsedOp -> Parser ParsedValue-value' opParser = lexeme $ mparens valueInner'-  where-    valueInner' = valueInner opParser--valueInner :: Parser ParsedOp -> Parser ParsedValue-valueInner opParser = label "value" $ choice $-  [ stringLiteral, bytesLiteral, intLiteral, unitValue-  , trueValue, falseValue, pairValue opParser, leftValue opParser-  , rightValue opParser, someValue opParser, noneValue, nilValue-  , seqOrLambda opParser, mapValue opParser, dataLetValue-  ]--seqOrLambda :: Parser ParsedOp -> Parser ParsedValue-seqOrLambda opParser = try (lambdaValue opParser) <|> seqValue opParser--stringLiteral :: Parser ParsedValue-stringLiteral = U.ValueString . unsafeMkMText . toText <$> do-  _ <- try $ string "\""-  manyTill validChar (string "\"")-  where-      validChar :: Parser Char-      validChar = choice-        [ strEscape-        , satisfy (\x -> x /= '"' && isMChar x)-        , anySingle >>= stringLiteralFailure . InvalidChar-        ]--      strEscape :: Parser Char-      strEscape = try (char '\\') >> esc-        where-          esc = choice-            [ char '\\'-            , char '"'-            , char 'n' $> '\n'-            , anySingle >>= stringLiteralFailure . InvalidEscapeSequence-            ]-      stringLiteralFailure = customFailure . StringLiteralException---- It is safe not to use `try` here because bytesLiteral is the only--- thing that starts from 0x (at least for now)-bytesLiteral :: Parser (U.Value' op)-bytesLiteral = do-  string "0x"-  hexdigits <- takeWhileP Nothing Char.isHexDigit-  let mBytes = Hex.decodeHex hexdigits-  maybe-    (customFailure OddNumberBytesException)-    (return . U.ValueBytes . U.InternalByteString)-    mBytes--intLiteral :: Parser (U.Value' op)-intLiteral = try $ U.ValueInt <$> L.signed pass L.decimal--unitValue :: Parser ParsedValue-unitValue = word "Unit" U.ValueUnit--trueValue :: Parser ParsedValue-trueValue = word "True" U.ValueTrue--falseValue :: Parser ParsedValue-falseValue = word "False" U.ValueFalse--pairValue :: Parser ParsedOp -> Parser ParsedValue-pairValue opParser = core <|> tuple-  where-    core = symbol "Pair" *> tupleInner pass-    tuple = try $ parens (tupleInner comma)--    tupleInner :: Parser () -> Parser ParsedValue-    tupleInner sep = try $ do-      a <- value' opParser-      sep-      b <- tupleInner sep <|> value' opParser-      return $ U.ValuePair a b--leftValue :: Parser ParsedOp -> Parser ParsedValue-leftValue opParser = word "Left" U.ValueLeft <*> value' opParser--rightValue :: Parser ParsedOp -> Parser ParsedValue-rightValue opParser = word "Right" U.ValueRight <*> value' opParser--someValue :: Parser ParsedOp -> Parser ParsedValue-someValue opParser = word "Some" U.ValueSome <*> value' opParser--noneValue :: Parser ParsedValue-noneValue = word "None" U.ValueNone--nilValue :: Parser ParsedValue-nilValue = U.ValueNil <$ (try $ braces pass)--lambdaValue :: Parser ParsedOp -> Parser ParsedValue-lambdaValue opParser = U.ValueLambda <$> ops1-  where-    ops1 :: Parser (NonEmpty ParsedOp)-    ops1 = braces $ sepEndBy1 opParser semicolon--seqValue :: Parser ParsedOp -> Parser ParsedValue-seqValue opParser =-  U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon)--eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp)-eltValue opParser = word "Elt" U.Elt <*> value' opParser <*> value' opParser--mapValue :: Parser ParsedOp -> Parser ParsedValue-mapValue opParser =-  U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon)--dataLetValue :: Parser ParsedValue-dataLetValue = do-  lvs <- asks letValues-  lvVal <$> (mkLetVal lvs)--mkLetVal :: Map Text LetValue -> Parser LetValue-mkLetVal lvs = choice $ mkParser lvName <$> Map.elems lvs

− src/Michelson/Preprocess.hs

@@ -1,53 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Apply some transformations to Michelson code.--module Michelson.Preprocess-  ( transformStrings-  , transformBytes-  ) where--import Data.Default (def)--import Michelson.Text (MText)-import Michelson.Typed---- Note: we may add such transformation for long bytestrings as well if deemed necessary.--- And for other constants which may be arbitrarily large (e. g. lists).--- For now we need it only for strings and probably won't need for anything else.---- | Transform all strings in a typed instructions using given--- function. The first argument specifies whether we should go into--- arguments that contain instructions.-transformStrings :: Bool -> (MText -> MText) -> Instr inp out -> Instr inp out-transformStrings goToValues f = transformConstants goToValues mapStr-  where-    mapStr :: Value t -> Value t-    mapStr = \case-      VString str -> VString $ f str-      v -> v---- | Similar to 'transformStrings' but for bytes.-transformBytes :: Bool -> (ByteString -> ByteString) -> Instr inp out -> Instr inp out-transformBytes goToValues f = transformConstants goToValues mapBytes-  where-    mapBytes :: Value t -> Value t-    mapBytes = \case-      VBytes bytes -> VBytes $ f bytes-      v -> v--transformConstants ::-     forall inp out.-     Bool-  -> (forall t. Value t -> Value t)-  -- ^ Should transform only atomic values, 'dfsMapValue' will be applied to it.-  -> Instr inp out-  -> Instr inp out-transformConstants dsGoToValues f = fst . dfsInstr def{ dsGoToValues } step-  where-    step :: forall i o. Instr i o -> (Instr i o, ())-    step = (,()) . \case-      PUSH v -> PUSH (dfsMapValue f v)-      i -> i

− src/Michelson/Printer.hs

@@ -1,62 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Printer-  ( RenderDoc(..)-  , renderAnyBuildable-  , printDoc-  , printUntypedContract-  , printTypedContractCode-  , printTypedContract-  , printSomeContract-  , printTypedValue-  , printUntypedValue-  ) where--import Data.Constraint (withDict)-import Data.Singletons (SingI)-import qualified Data.Text.Lazy as TL--import Michelson.Printer.Util (RenderDoc(..), renderAnyBuildable, doesntNeedParens, printDoc)-import qualified Michelson.Typed as T-import qualified Michelson.Untyped as U---- | Convert an untyped contract into a textual representation which--- will be accepted by the OCaml reference client: tezos-client.-printUntypedContract :: (RenderDoc op) => Bool -> U.Contract' op -> TL.Text-printUntypedContract forceSingleLine = printDoc forceSingleLine . renderDoc doesntNeedParens---- | Convert a typed contract into a textual representation which--- will be accepted by the OCaml reference client: tezos-client.-printTypedContractCode :: (SingI p, SingI s) => Bool -> T.ContractCode p s -> TL.Text-printTypedContractCode forceSingleLine =-  printUntypedContract forceSingleLine . T.convertContractCode---- | Convert typed contract into a textual representation which--- will be accepted by the OCaml reference client: tezos-client.-printTypedContract :: Bool -> T.Contract p s -> TL.Text-printTypedContract forceSingleLine fc@T.Contract{} =-  printUntypedContract forceSingleLine $ T.convertContract fc---- | Convert typed value into a textual representation which--- will be accepted by the OCaml reference client: tezos-client.-printTypedValue-  :: forall t.-      (T.ProperPrintedValBetterErrors t)-  => Bool -> T.Value t -> TL.Text-printTypedValue forceSingleLine =-  withDict (T.properPrintedValEvi @t) $-  printUntypedValue forceSingleLine . T.untypeValue---- | Convert untyped value into a textual representation which--- will be accepted by the OCaml reference client: tezos-client.-printUntypedValue :: (RenderDoc op) => Bool -> U.Value' op -> TL.Text-printUntypedValue forceSingleLine =-  printDoc forceSingleLine . renderDoc doesntNeedParens---- | Convert 'SomeContract' into a textual representation which--- will be accepted by the OCaml reference client: tezos-client.-printSomeContract :: Bool -> T.SomeContract -> TL.Text-printSomeContract forceSingleLine (T.SomeContract fc) =-  printTypedContract forceSingleLine fc

− src/Michelson/Printer/Util.hs

@@ -1,156 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Printer.Util-  ( RenderDoc(..)-  , Prettier(..)-  , printDoc-  , printDocB-  , printDocS-  , renderOps-  , renderOpsList-  , renderOpsListNoBraces-  , renderAnyBuildable-  , spaces-  , wrapInParens-  , buildRenderDoc-  , buildRenderDocExtended-  , renderDocList--    -- * Smart parentheses-  , RenderContext-  , needsParens-  , doesntNeedParens-  , addParens-  , assertParensNotNeeded-  ) where--import Fmt (Buildable, pretty)-import Control.Exception (assert)-import qualified Data.Text.Lazy as LT-import Data.Text.Lazy.Builder (Builder)-import Text.PrettyPrint.Leijen.Text-  (Doc, SimpleDoc, align, braces, displayB, displayT, enclose, hcat, isEmpty, parens, punctuate,-  renderOneLine, renderPretty, semi, space, text, vcat, (<+>), lbracket, rbracket, encloseSep)---- | Environment carried during recursive rendering.-newtype RenderContext = RenderContext-  { _rcWillNeedParens :: Bool-    -- ^ Whether the current expression is going to be used as part of-    -- top-level expression or in a similar context.-    -- When set to 'True', you may need to wrap your rendered expression into-    -- parentheses.-  }---- | Generalize converting a type into a--- Text.PrettyPrint.Leijen.Text.Doc. Used to pretty print Michelson code--- and define Fmt.Buildable instances.-class RenderDoc a where-  renderDoc :: RenderContext -> a -> Doc--  -- | Whether a value can be represented in Michelson code.-  -- Normally either all values of some type are renderable or not renderable.-  -- However, in case of instructions we have extra instructions which should-  -- not be rendered.-  -- Note: it's not suficcient to just return 'mempty' for such instructions,-  -- because sometimes we want to print lists of instructions and we need to-  -- ignore them complete (to avoid putting redundant separators).-  isRenderable :: a -> Bool-  isRenderable _ = True---- | Renders a list of 'RenderDoc' elements surrounded with square brackets,--- separated by a comma and a space.-renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc-renderDocList context = encloseSep lbracket rbracket ", " . fmap (renderDoc context)--renderAnyBuildable :: Buildable a => a -> Doc-renderAnyBuildable = text . pretty---- | A new type that can wrap values so that the RenderDoc--- instances of the combined value can have a different--- behavior for the pretty printer.-newtype Prettier a = Prettier a---- | Convert 'Doc' to 'Text' with a line width of 80.-printDoc :: Bool -> Doc -> LT.Text-printDoc oneLine = displayT . doRender oneLine---- | Convert 'Doc' to 'Builder' in the same maner as 'printDoc'.-printDocB :: Bool -> Doc -> Builder-printDocB oneLine = displayB . doRender oneLine---- | Convert 'Doc' to 'String' in the same maner as 'printDoc'.-printDocS :: Bool -> Doc -> String-printDocS oneLine = toString . printDoc oneLine---- | Generic way to render the different op types that get passed--- to a contract.-renderOps :: (RenderDoc op) => Bool -> NonEmpty op -> Doc-renderOps oneLine = renderOpsList oneLine . toList--spacecat :: NonEmpty Doc -> Doc-spacecat = foldr (<+>) mempty--renderOpsList :: (RenderDoc op) => Bool -> [op] -> Doc-renderOpsList oneLine ops =-  braces $ enclose space space $ renderOpsListNoBraces oneLine ops--renderOpsListNoBraces :: RenderDoc op => Bool -> [op] -> Doc-renderOpsListNoBraces oneLine ops =-  cat' $ punctuate semi $-    renderDoc doesntNeedParens <$> filter isRenderable ops-  where-    cat' = if oneLine then maybe "" spacecat . nonEmpty else align . vcat---- | Create a specific number of spaces.-spaces :: Int -> Doc-spaces x = hcat $ replicate x space---- | Wrap documents in parentheses if there are two or more in the list.-wrapInParens :: RenderContext -> NonEmpty Doc -> Doc-wrapInParens (RenderContext pn) ds =-  let moreThanOne = length (filter (not . isEmpty) (toList ds)) > 1-  in  addParens (RenderContext (pn && moreThanOne)) $-        foldr (<+>) mempty ds---- | Turn something that is instance of `RenderDoc` into a `Builder`.--- It's formatted the same way as `printDoc` formats docs.-buildRenderDoc :: RenderDoc a => a -> Builder-buildRenderDoc = printDocB True . renderDoc doesntNeedParens---- | Works as 'buildRenderDoc' above, but doesn't force the doc to be printed in one line-buildRenderDocExtended :: RenderDoc a => a -> Builder-buildRenderDocExtended = printDocB False . renderDoc doesntNeedParens----- | Here using a page width of 80 and a ribbon width of 1.0--- https://hackage.haskell.org/package/wl-pprint-1.2.1/docs/Text-PrettyPrint-Leijen.html-doRender :: Bool -> Doc -> SimpleDoc-doRender oneLine = if oneLine then renderOneLine else renderPretty 1.0 80---- Smart parentheses-------------------------------------------------------------------------------{- Motivation:--Some expressions may need to be wrapped into parentheses, but only if they-are part of other expression, and are not already wrapped into braces or-brackets.--}---- | 'ParensNeeded' constant.-needsParens, doesntNeedParens :: RenderContext-needsParens = RenderContext True-doesntNeedParens = RenderContext False---- | Add parentheses if needed.-addParens :: RenderContext -> Doc -> Doc-addParens = \case-  RenderContext True -> parens-  RenderContext False -> id---- | Ensure parentheses are not required, for case when you cannot--- sensibly wrap your expression into them.-assertParensNotNeeded :: RenderContext -> a -> a-assertParensNotNeeded (RenderContext pn) = assert (not pn)

− src/Michelson/Runtime.hs

@@ -1,741 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Executor and typechecker of a contract in Morley language.--module Michelson.Runtime-  (-    -- * High level interface for end user-    originateContract-  , runContract-  , transfer--  -- * Other helpers-  , parseContract-  , parseExpandContract-  , readAndParseContract-  , prepareContract--  -- * Re-exports-  , ContractState (..)-  , AddressState (..)-  , VotingPowers-  , mkVotingPowers-  , mkVotingPowersFromMap-  , TxData (..)-  , TxParam (..)--  -- * For testing-  , ExecutorOp (..)-  , ExecutorRes (..)-  , ExecutorError' (..)-  , ExecutorError-  , ExecutorM-  , runExecutorM-  , runExecutorMWithDB-  , executeGlobalOperations-  , executeGlobalOrigination-  , executeOrigination-  , executeTransfer--  -- * To avoid warnings (can't generate lenses only for some fields)-  , erInterpretResults-  , erUpdates-  , erGState-  , erRemainingSteps-  , elInterpreterResults-  , elUpdates-  ) where--import Control.Lens (assign, at, makeLenses, (+=), (.=), (<>=))-import Control.Monad.Except (Except, liftEither, runExcept, throwError)-import Data.Binary.Put (putWord64be, runPut)-import qualified Data.ByteString.Lazy as BSL-import Data.Semigroup.Generic-import Data.Text.IO (getContents)-import qualified Data.Text.IO.Utf8 as Utf8 (readFile)-import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+))-import Named (arg, argDef, defaults, (!), (:!), (:?))-import Text.Megaparsec (parse)--import Michelson.Interpret-  (ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),-  RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret)-import qualified Michelson.Interpret.Pack as Pack-import Michelson.Macro (ParsedOp, expandContract)-import qualified Michelson.Parser as P-import Michelson.Runtime.GState-import Michelson.Runtime.TxData-import Michelson.TypeCheck-import Michelson.Typed-  (CreateContract(..), EntrypointCallT, EpAddress(..), EpName, Operation'(..), ParameterScope,-  SomeContractAndStorage(..), SomeStorage(..), SomeValue(..), TransferTokens(..), starNotes,-  starParamNotes, untypeValue)-import qualified Michelson.Typed as T-import Michelson.Typed.Origination-  (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash)-import Michelson.Untyped (Contract)-import qualified Michelson.Untyped as U-import Tezos.Address (Address(..), OriginationIndex(..))-import Tezos.Core-  (Mutez, Timestamp(..), getCurrentTime, unMutez, unsafeAddMutez, unsafeSubMutez, zeroMutez)-import Tezos.Crypto (KeyHash, blake2b, parseKeyHash)-import Util.Named ((.!))--------------------------------------------------------------------------------- Auxiliary types--------------------------------------------------------------------------------- | Operations executed by interpreter.--- In our model one Michelson's operation (`operation` type in Michelson)--- corresponds to 0 or 1 interpreter operation.------ Note: 'Address' is not part of 'TxData', because 'TxData' is--- supposed to be provided by the user, while 'Address' can be--- computed by our code.-data ExecutorOp-  = OriginateOp OriginationOperation-  -- ^ Originate a contract.-  | TransferOp Address TxData-  -- ^ Send a transaction to given address which is assumed to be the-  -- address of an originated contract.-  deriving stock (Show)---- | Result of a single execution of interpreter.-data ExecutorRes = ExecutorRes-  { _erGState :: GState-  -- ^ New 'GState'.-  , _erUpdates :: [GStateUpdate]-  -- ^ Updates applied to 'GState'.-  , _erInterpretResults :: [(Address, InterpretResult)]-  -- ^ During execution a contract can print logs and in the end it returns-  -- a pair. All logs and returned values are kept until all called contracts-  -- are executed. In the end they are printed.-  , _erRemainingSteps :: RemainingSteps-  -- ^ Now much gas all remaining executions can consume.-  } deriving stock (Show)--data ExecutorEnv = ExecutorEnv-  { _eeNow :: Timestamp-  , _eeLevel :: Natural-  }-  deriving stock (Show, Generic)--data ExecutorState = ExecutorState-  { _esGState :: GState-  , _esRemainingSteps :: RemainingSteps-  , _esOriginationNonce :: Int32-  , _esSourceAddress :: Maybe Address-  , _esLog :: ExecutorLog-  , _esOperationHash :: ~OperationHash-  }-  deriving stock (Show, Generic)--data ExecutorLog = ExecutorLog-  { _elUpdates :: [GStateUpdate]-  , _elInterpreterResults :: [(Address, InterpretResult)]-  }-  deriving stock (Show, Generic)-  deriving (Semigroup, Monoid) via GenericSemigroupMonoid ExecutorLog--makeLenses ''ExecutorRes-makeLenses ''ExecutorEnv-makeLenses ''ExecutorState-makeLenses ''ExecutorLog---- | Errors that can happen during contract interpreting.--- Type parameter @a@ determines how contracts will be represented--- in these errors, e.g. 'Address'.-data ExecutorError' a-  = EEUnknownContract a-  -- ^ The interpreted contract hasn't been originated.-  | EEInterpreterFailed a-                        InterpretError-  -- ^ Interpretation of Michelson contract failed.-  | EEAlreadyOriginated a-                        ContractState-  -- ^ A contract is already originated.-  | EEUnknownSender a-  -- ^ Sender address is unknown.-  | EEUnknownManager a-  -- ^ Manager address is unknown.-  | EENotEnoughFunds a Mutez-  -- ^ Sender doesn't have enough funds.-  | EEZeroTransaction a-  -- ^ Sending 0tz towards an address.-  | EEFailedToApplyUpdates GStateUpdateError-  -- ^ Failed to apply updates to GState.-  | EEIllTypedParameter a TCError-  -- ^ Contract parameter is ill-typed.-  | EEUnexpectedParameterType a T.T T.T-  -- ^ Contract parameter is well-typed, but its type does-  -- not match the entrypoint's type.-  | EEUnknownEntrypoint EpName-  -- ^ Specified entrypoint to run is not found.-  | EETransactionFromContract a Mutez-  -- ^ A transaction from an originated contract was attempted as a global operation.-  | EEWrongParameterType a-  -- ^ Type of parameter in transfer to an implicit account is not Unit.-  deriving stock (Show, Functor)--instance (Buildable a) => Buildable (ExecutorError' a) where-  build =-    \case-      EEUnknownContract addr -> "The contract is not originated " +| addr |+ ""-      EEInterpreterFailed addr err ->-        "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""-      EEAlreadyOriginated addr cs ->-        "The following contract is already originated: " +| addr |+-        ", " +| cs |+ ""-      EEUnknownSender addr -> "The sender address is unknown " +| addr |+ ""-      EEUnknownManager addr -> "The manager address is unknown " +| addr |+ ""-      EENotEnoughFunds addr amount ->-        "The sender (" +| addr |+-        ") doesn't have enough funds (has only " +| amount |+ ")"-      EEZeroTransaction addr ->-        "Transaction of 0ꜩ towards a key address " +| addr |+ " which has no code is prohibited"-      EEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""-      EEIllTypedParameter _ err -> "The contract parameter is ill-typed: " +| err |+ ""-      EEUnexpectedParameterType _ actualT expectedT ->-        "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n" <>-        "Expected: " +| expectedT |+ "\n" <>-        "Got: " +| actualT |+ ""-      EEUnknownEntrypoint epName -> "The contract does not contain entrypoint '" +| epName |+ "'"-      EETransactionFromContract addr amount ->-        "Global transaction of funds (" +| amount |+ ") from an originated contract (" +| addr |+ ") is prohibited."-      EEWrongParameterType addr ->-        "Bad contract parameter for: " +| addr |+ ""--type ExecutorError = ExecutorError' Address--instance (Typeable a, Show a, Buildable a) => Exception (ExecutorError' a) where-  displayException = pretty--------------------------------------------------------------------------------- Interface--------------------------------------------------------------------------------- | Parse a contract from 'Text'.-parseContract ::-     Maybe FilePath -> Text -> Either P.ParserException (U.Contract' ParsedOp)-parseContract mFileName =-  first P.ParserException . parse P.program (fromMaybe "<stdin>" mFileName)---- | Parse a contract from 'Text' and expand macros.-parseExpandContract ::-     Maybe FilePath -> Text -> Either P.ParserException Contract-parseExpandContract mFileName = fmap expandContract . parseContract mFileName---- | Read and parse a contract from give path or `stdin` (if the--- argument is 'Nothing'). The contract is not expanded.-readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp)-readAndParseContract mFilename = do-  code <- readCode mFilename-  either throwM pure $ parseContract mFilename code-  where-    readCode :: Maybe FilePath -> IO Text-    readCode = maybe getContents Utf8.readFile---- | Read a contract using 'readAndParseContract', expand and--- flatten. The contract is not type checked.-prepareContract :: Maybe FilePath -> IO Contract-prepareContract mFile = expandContract <$> readAndParseContract mFile---- | Originate a contract. Returns the address of the originated--- contract.-originateContract-  :: FilePath-  -> TypeCheckOptions-  -> Address-  -> Maybe KeyHash-  -> Mutez-  -> U.Value-  -> U.Contract-  -> "verbose" :! Bool-  -> IO Address-originateContract dbPath tcOpts originator delegate balance uStorage uContract verbose = do-  origination <- either throwM pure . typeCheckingWith tcOpts $-    mkOrigination <$> typeCheckContractAndStorage uContract uStorage-  -- pass 100500 as maxSteps, because it doesn't matter for origination,-  -- as well as 'now'-  fmap snd $ runExecutorMWithDB Nothing Nothing dbPath 100500 verbose ! defaults $ do-    executeGlobalOrigination origination-  where-    mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation-      { ooOriginator = originator-      , ooDelegate = delegate-      , ooBalance = balance-      , ooStorage = storage-      , ooContract = contract-      }---- | Run a contract. The contract is originated first (if it's not--- already) and then we pretend that we send a transaction to it.-runContract-  :: Maybe Timestamp-  -> Maybe Natural-  -> Word64-  -> Mutez-  -> FilePath-  -> TypeCheckOptions-  -> U.Value-  -> U.Contract-  -> TxData-  -> "verbose" :! Bool-  -> "dryRun" :! Bool-  -> IO SomeStorage-runContract maybeNow maybeLevel maxSteps initBalance dbPath tcOpts uStorage uContract txData-  verbose (arg #dryRun -> dryRun) = do-  origination <- either throwM pure . typeCheckingWith tcOpts $-    mkOrigination <$> typeCheckContractAndStorage uContract uStorage-  (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do-    -- Here we are safe to bypass executeGlobalOperations for origination,-    -- since origination can't generate more operations.-    addr <- executeGlobalOrigination origination-    let transferOp = TransferOp addr txData-    executeGlobalOperations tcOpts [transferOp]-    getContractStorage addr-  return newSt-  where-    -- We hardcode some random key hash here as delegate to make sure that:-    -- 1. Contract's address won't clash with already originated one (because-    -- it may have different storage value which may be confusing).-    -- 2. If one uses this functionality twice with the same contract and-    -- other data, the contract will have the same address.-    delegate =-      either (error . mappend "runContract can't parse delegate: " . pretty) id $-      parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"-    mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation-      { ooOriginator = genesisAddress-      , ooDelegate = Just delegate-      , ooBalance = initBalance-      , ooStorage = storage-      , ooContract = contract-      }--    getContractStorage :: Address -> ExecutorM SomeStorage-    getContractStorage addr = do-      addrs <- use (esGState . gsAddressesL)-      case addrs ^. at addr of-        Nothing -> error $ pretty addr <> " is unknown"-        Just (ASSimple {}) -> error $ pretty addr <> " is a simple address"-        Just (ASContract (ContractState{..})) -> return $ SomeStorage csStorage---- | Send a transaction to given address with given parameters.-transfer ::-     Maybe Timestamp-  -> Maybe Natural-  -> Word64-  -> FilePath-  -> TypeCheckOptions-  -> Address-  -> TxData-  -> "verbose" :! Bool-  -> "dryRun" :? Bool-  -> IO ()-transfer maybeNow maybeLevel maxSteps dbPath tcOpts destination txData verbose dryRun = do-  void $ runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose dryRun $-    executeGlobalOperations tcOpts [TransferOp destination txData]--------------------------------------------------------------------------------- Executor--------------------------------------------------------------------------------- | A monad in which contract executor runs.-type ExecutorM =-  ReaderT ExecutorEnv-    (StateT ExecutorState-      (Except ExecutorError)-    )---- | Run some executor action, returning its result and final executor state in 'ExecutorRes'.------ The action has access to the hash of currently executed global operation, in order to construct--- addresses of originated contracts. It is expected that the action uses @#isGlobalOp .! True@--- to specify this hash. Otherwise it is initialized with 'error'.-runExecutorM-  :: Timestamp-  -> Natural-  -> RemainingSteps-  -> GState-  -> ExecutorM a-  -> Either ExecutorError (ExecutorRes, a)-runExecutorM now level remainingSteps gState action =-  fmap preResToRes-    $ runExcept-    $ runStateT (runReaderT action $ ExecutorEnv now level)-      initialState-  where-    initialOpHash = error "Initial OperationHash touched"--    initialState = ExecutorState-      { _esGState = gState-      , _esRemainingSteps = remainingSteps-      , _esOriginationNonce = 0-      , _esSourceAddress = Nothing-      , _esLog = mempty-      , _esOperationHash = initialOpHash-      }--    preResToRes :: (a, ExecutorState) -> (ExecutorRes, a)-    preResToRes (r, ExecutorState{..}) =-      ( ExecutorRes-          { _erGState = _esGState-          , _erUpdates = _esLog ^. elUpdates-          , _erInterpretResults = _esLog ^. elInterpreterResults-          , _erRemainingSteps = _esRemainingSteps-          }-      , r-      )---- | Run some executor action, reading state from the DB on disk.------ Unless @dryRun@ is @False@, the final state is written back to the disk.------ If the executor fails with 'ExecutorError' it will be thrown as an exception.-runExecutorMWithDB-  :: Maybe Timestamp-  -> Maybe Natural-  -> FilePath-  -> RemainingSteps-  -> "verbose" :! Bool-  -> "dryRun" :? Bool-  -> ExecutorM a-  -> IO (ExecutorRes, a)-runExecutorMWithDB maybeNow maybeLevel dbPath remainingSteps-  (arg #verbose -> verbose)-  (argDef #dryRun False -> dryRun)-  action = do-  gState <- readGState dbPath-  now <- maybe getCurrentTime pure maybeNow-  let level = fromMaybe 0 maybeLevel-  (res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now level remainingSteps gState action--  unless dryRun $-    writeGState dbPath _erGState--  mapM_ printInterpretResult _erInterpretResults-  when (verbose && not (null _erUpdates)) $ do-    fmtLn $ nameF "Updates" (blockListF _erUpdates)-    putTextLn $ "Remaining gas: " <> pretty _erRemainingSteps <> "."--  return (res, a)-  where-    printInterpretResult-      :: (Address, InterpretResult) -> IO ()-    printInterpretResult (addr, InterpretResult {..}) = do-      putTextLn $ "Executed contract " <> pretty addr-      case iurOps of-        [] -> putTextLn "It didn't return any operations."-        _ -> fmt $ nameF "It returned operations" (blockListF iurOps)-      putTextLn $-        "It returned storage: " <> pretty (untypeValue iurNewStorage) <> "."-      let MorleyLogs logs = isMorleyLogs iurNewState-      unless (null logs) $-        mapM_ putTextLn logs-      putTextLn "" -- extra break line to separate logs from two sequence contracts---- | Execute a list of global operations, discarding their results.-executeGlobalOperations-  :: TypeCheckOptions-  -> [ExecutorOp]-  -> ExecutorM ()-executeGlobalOperations tcOpts = mapM_ $ \op ->-  executeMany (#isGlobalOp .! True) [op]-  where-    -- | Execute a list of operations and additional operations they return, until there are none.-    executeMany :: "isGlobalOp" :! Bool -> [ExecutorOp] -> ExecutorM ()-    executeMany isGlobalOp = \case-        [] -> pass-        (op:opsTail) -> do-          case op of-            OriginateOp origination -> void $ executeOrigination isGlobalOp origination-            TransferOp addr txData -> do-              moreOps <- executeTransfer isGlobalOp tcOpts addr txData-              executeMany (#isGlobalOp .! False) $ moreOps <> opsTail---- | Execute a global origination operation.-executeGlobalOrigination :: OriginationOperation -> ExecutorM Address-executeGlobalOrigination = executeOrigination ! #isGlobalOp True---- | Execute an origination operation.-executeOrigination-  :: "isGlobalOp" :! Bool-  -> OriginationOperation-  -> ExecutorM Address-executeOrigination (arg #isGlobalOp -> isGlobalOp) origination@(OriginationOperation _ _ bal st contract) = do-  when isGlobalOp $ do-    beginGlobalOperation-    assign esOperationHash $ mkOriginationOperationHash origination--  opHash <- use esOperationHash--  gs <- use esGState-  originationNonce <- use esOriginationNonce--  -- Add big_map IDS to storage-  let bigMapCounter0 = gs ^. gsBigMapCounterL-  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds st) bigMapCounter0--  let contractState = ContractState bal contract storageWithIds--  let originatorAddress = ooOriginator origination-  originatorBalance <- case gsAddresses gs ^. at originatorAddress of-    Nothing -> throwError (EEUnknownManager originatorAddress)-    Just (asBalance -> oldBalance)-      | oldBalance < ooBalance origination ->-        throwError $ EENotEnoughFunds originatorAddress oldBalance-      | otherwise ->-        -- Subtraction is safe because we have checked its-        -- precondition in guard.-        return $ oldBalance `unsafeSubMutez` ooBalance origination-  let-    address = mkContractAddress opHash (OriginationIndex originationNonce) (gsCounter gs)-    updates =-      catMaybes-        [ Just $ GSAddAddress address (ASContract contractState)-        , Just $ GSSetBalance originatorAddress originatorBalance-        , Just $ GSIncrementCounter-        , if bigMapCounter0 == bigMapCounter1-            then Nothing-            else Just $ GSSetBigMapCounter bigMapCounter1-        ]--  case applyUpdates updates gs of-    Left _ ->-      throwError $ EEAlreadyOriginated address contractState-    Right newGS -> do-      esGState .= newGS-      esOriginationNonce += 1--      esLog <>= ExecutorLog updates []--      return address---- | Execute a transfer operation.-executeTransfer-  :: "isGlobalOp" :! Bool-  -> TypeCheckOptions-  -> Address-  -> TxData-  -> ExecutorM [ExecutorOp]-executeTransfer (arg #isGlobalOp -> isGlobalOp) tcOpts addr txData = do-    when isGlobalOp $-      beginGlobalOperation--    now <- view eeNow-    level <- view eeLevel-    gs <- use esGState-    remainingSteps <- use esRemainingSteps-    mSourceAddr <- use esSourceAddress--    let addresses = gsAddresses gs-    let senderAddr = tdSenderAddress txData-    let sourceAddr = fromMaybe senderAddr mSourceAddr-    let isKeyAddress (KeyAddress _) = True-        isKeyAddress _ = False-    let isZeroTransfer = tdAmount txData == zeroMutez--    when (badParamToImplicitAccount addr $ tdParameter txData) $-      throwError $ EEWrongParameterType addr--    -- Transferring 0 XTZ to a key address is prohibited.-    when (isZeroTransfer && isKeyAddress addr) $-      throwError $ EEZeroTransaction addr-    mDecreaseSenderBalance <- case (isZeroTransfer, addresses ^. at senderAddr) of-      (True, _) -> pure Nothing-      (False, Nothing) -> throwError $ EEUnknownSender senderAddr-      (False, Just (asBalance -> balance))-        | balance < tdAmount txData ->-          throwError $ EENotEnoughFunds senderAddr balance-        | otherwise ->-          -- Subtraction is safe because we have checked its-          -- precondition in guard.-          return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData)-    when (not (isKeyAddress senderAddr) && isGlobalOp && not isZeroTransfer) $-      throwError $ EETransactionFromContract senderAddr $ tdAmount txData-    let onlyUpdates updates = return (updates, [], Nothing, remainingSteps)-    (otherUpdates, sideEffects, maybeInterpretRes :: Maybe InterpretResult, newRemSteps)-        <- case (addresses ^. at addr, addr) of-      (Nothing, ContractAddress _) ->-        throwError $ EEUnknownContract addr-      (Nothing, KeyAddress _) -> do-        let-          transferAmount = tdAmount txData-          addrState = ASSimple transferAmount-          upd = GSAddAddress addr addrState-        onlyUpdates [upd]-      (Just (ASSimple oldBalance), _) -> do-        -- can't overflow if global state is correct (because we can't-        -- create money out of nowhere)-        let-          newBalance = oldBalance `unsafeAddMutez` tdAmount txData-          upd = GSSetBalance addr newBalance-        onlyUpdates [upd]-      (Just (ASContract (ContractState {..})), _) -> do-        let-          existingContracts = extractAllContracts gs-          -- can't overflow if global state is correct (because we can't-          -- create money out of nowhere)-          newBalance = csBalance `unsafeAddMutez` tdAmount txData-          epName = tdEntrypoint txData--        T.MkEntrypointCallRes _ (epc :: EntrypointCallT cp epArg)-          <- T.mkEntrypointCall epName (T.cParamNotes csContract)-             & maybe (throwError $ EEUnknownEntrypoint epName) pure--        -- If the parameter has already been typechecked, simply check if-        -- its type matches the contract's entrypoint's type.-        -- Otherwise (e.g. if it was parsed from stdin via the CLI),-        -- we need to typecheck the parameter.-        typedParameter <--          case tdParameter txData of-            TxTypedParam (typedVal :: T.Value t) -> do-              T.castM @t @epArg typedVal (throwError ... EEUnexpectedParameterType addr)-            TxUntypedParam untypedVal ->-              liftEither $ first (EEIllTypedParameter addr) $ typeCheckingWith tcOpts $-                typeVerifyParameter @epArg existingContracts untypedVal--        let bigMapCounter0 = gs ^. gsBigMapCounterL-        let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds typedParameter) bigMapCounter0--        -- I'm not entirely sure why we need to pattern match on `()` here,-        -- but, if we don't, we get a compiler error that I suspect is somehow related-        -- to the existential types we're matching on a few lines above.-        ---        -- • Couldn't match type ‘a0’-        --                  with ‘(InterpretResult, RemainingSteps, [Operation], [GStateUpdate])’-        --     ‘a0’ is untouchable inside the constraints: StorageScope st1-        () <- when isGlobalOp $-          esOperationHash .= mkTransferOperationHash-            addr-            typedParameterWithIds-            (tdEntrypoint txData)-            (tdAmount txData)--        opHash <- use esOperationHash-        let-          contractEnv = ContractEnv-            { ceNow = now-            , ceMaxSteps = remainingSteps-            , ceBalance = newBalance-            , ceContracts = existingContracts-            , ceSelf = addr-            , ceSource = sourceAddr-            , ceSender = senderAddr-            , ceAmount = tdAmount txData-            , ceVotingPowers = gsVotingPowers gs-            , ceChainId = gsChainId gs-            , ceOperationHash = Just opHash-            , ceGlobalCounter = gsCounter gs-            , ceLevel = level-            }--        iur@InterpretResult-          { iurOps = sideEffects-          , iurNewStorage = newValue-          , iurNewState = InterpreterState _ newRemainingSteps _ bigMapCounter2-          }-          <- liftEither $ first (EEInterpreterFailed addr) $-             handleContractReturn $-                interpret-                  csContract-                  epc-                  typedParameterWithIds-                  csStorage-                  bigMapCounter1-                  contractEnv-        let-          updBalance-            | newBalance == csBalance = Nothing-            | otherwise = Just $ GSSetBalance addr newBalance-          updStorage-            | SomeValue newValue == SomeValue csStorage = Nothing-            | otherwise = Just $ GSSetStorageValue addr newValue-          updBigMapCounter-            | bigMapCounter0 == bigMapCounter2 = Nothing-            | otherwise = Just $ GSSetBigMapCounter bigMapCounter2-          updates = catMaybes-            [ updBalance-            , updStorage-            , updBigMapCounter-            ]-        return (updates, sideEffects, Just iur, newRemainingSteps)--    let-      -- According to the reference implementation, counter is incremented for transfers as well.-      updates = (maybe id (:) mDecreaseSenderBalance otherUpdates) ++ [GSIncrementCounter]--    newGState <- liftEither $ first EEFailedToApplyUpdates $ applyUpdates updates gs--    esGState .= newGState-    esRemainingSteps .= newRemSteps-    esSourceAddress .= Just sourceAddr--    esLog <>= ExecutorLog updates (maybe mempty (one . (addr, )) maybeInterpretRes)--    return $ mapMaybe (convertOp addr) sideEffects--------------------------------------------------------------------------------- Simple helpers-------------------------------------------------------------------------------mkTransferOperationHash :: ParameterScope t => Address -> T.Value t -> EpName -> Mutez -> OperationHash-mkTransferOperationHash to param epName amount =-  OperationHash $ blake2b packedOperation-  where-    -- In Tezos, transfer operations are encoded as 4-tuple of-    -- (amount, destination, entrypoint, value)-    ---    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L275-282-    packedOperation =-      BSL.toStrict $-        (runPut $ putWord64be $ unMutez amount)-        <> (Pack.toBinary $ T.toVal (EpAddress to epName))-        <> Pack.toBinary param---- The argument is the address of the contract that generated this operation.-convertOp :: Address -> T.Operation -> Maybe ExecutorOp-convertOp interpretedAddr =-  \case-    OpTransferTokens tt ->-      case ttContract tt of-        T.VContract destAddress sepc ->-          let txData =-                TxData-                  { tdSenderAddress = interpretedAddr-                  , tdEntrypoint = T.sepcName sepc-                  , tdParameter = TxTypedParam (ttTransferArgument tt)-                  , tdAmount = ttAmount tt-                  }-          in Just (TransferOp destAddress txData)-    OpSetDelegate {} -> Nothing-    OpCreateContract cc ->-      let origination = OriginationOperation-            { ooOriginator = ccOriginator cc-            , ooDelegate = ccDelegate cc-            , ooBalance = ccBalance cc-            , ooStorage = ccStorageVal cc-            , ooContract =-                T.Contract-                  { cCode = ccContractCode cc-                  , cParamNotes = starParamNotes-                  , cStoreNotes = starNotes-                  , cEntriesOrder = U.canonicalEntriesOrder-                  }-            }-       in Just (OriginateOp origination)---- | Reset nonce and source address before executing a global operation.-beginGlobalOperation :: ExecutorM ()-beginGlobalOperation = do-  esOriginationNonce .= 0-  esSourceAddress .= Nothing---- | Return True if address is an implicit account yet the param is not Unit.-badParamToImplicitAccount :: Address -> TxParam -> Bool-badParamToImplicitAccount (ContractAddress _) _                       = False-badParamToImplicitAccount (KeyAddress _) (TxTypedParam T.VUnit)       = False-badParamToImplicitAccount (KeyAddress _) (TxUntypedParam U.ValueUnit) = False-badParamToImplicitAccount _ _                                         = True

− src/Michelson/Runtime/Dummy.hs

@@ -1,77 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Dummy data to be used in tests or demos where it's not essential.--module Michelson.Runtime.Dummy-  ( dummyNow-  , dummyLevel-  , dummyMaxSteps-  , dummyVotingPowers-  , dummyBigMapCounter-  , dummyContractEnv-  , dummyOrigination-  ) where--import Michelson.Interpret (ContractEnv(..), RemainingSteps)-import Michelson.Runtime.GState (BigMapCounter, dummyVotingPowers, genesisAddress)-import Michelson.Typed (ParameterScope, StorageScope)-import qualified Michelson.Typed as T-import Michelson.Typed.Origination (OriginationOperation(..))-import Tezos.Core (Timestamp(..), dummyChainId, unsafeMkMutez)---- | Dummy timestamp, can be used to specify current `NOW` value or--- maybe something else.-dummyNow :: Timestamp-dummyNow = Timestamp 100--dummyLevel :: Natural-dummyLevel = 4000---- | Dummy value for maximal number of steps a contract can--- make. Intentionally quite large, because most likely if you use--- dummy value you don't want the interpreter to stop due to gas--- exhaustion. On the other hand, it probably still prevents the--- interpreter from working for eternity.-dummyMaxSteps :: RemainingSteps-dummyMaxSteps = 100500--dummyBigMapCounter :: BigMapCounter-dummyBigMapCounter = 0---- | Dummy 'ContractEnv' with some reasonable hardcoded values. You--- can override values you are interested in using record update--- syntax.-dummyContractEnv :: ContractEnv-dummyContractEnv = ContractEnv-  { ceNow = dummyNow-  , ceMaxSteps = dummyMaxSteps-  , ceBalance = unsafeMkMutez 100-  , ceContracts = mempty-  , ceSelf = genesisAddress-  , ceSource = genesisAddress-  , ceSender = genesisAddress-  , ceAmount = unsafeMkMutez 100-  , ceVotingPowers = dummyVotingPowers-  , ceChainId = dummyChainId-  , ceOperationHash = Nothing-  , ceGlobalCounter = 0-  , ceLevel = dummyLevel-  }---- | 'OriginationOperation' with most data hardcoded to some--- reasonable values. Contract and initial values must be passed--- explicitly, because otherwise it hardly makes sense.-dummyOrigination-  :: (ParameterScope cp, StorageScope st)-  => T.Value st-  -> T.Contract cp st-  -> OriginationOperation-dummyOrigination storage contract = OriginationOperation-  { ooOriginator = genesisAddress-  , ooDelegate = Nothing-  , ooBalance = unsafeMkMutez 100-  , ooStorage = storage-  , ooContract = contract-  }

− src/Michelson/Runtime/GState.hs

@@ -1,415 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Global blockchain state (emulated).--module Michelson.Runtime.GState-  (-    -- * Auxiliary types-    ContractState (..)-  , AddressState (..)-  , asBalance-  , VotingPowers (..)-  , vpPick-  , vpTotal-  , mkVotingPowers-  , mkVotingPowersFromMap-  , dummyVotingPowers-  , BigMapCounter(..)-  , bigMapCounter--  -- * GState-  , GState (..)-  , gsChainIdL-  , gsAddressesL-  , gsVotingPowersL-  , gsCounterL-  , gsBigMapCounterL-  , genesisAddresses-  , genesisKeyHashes-  , genesisAddress-  -- * More genesisAddresses which can be used in tests-  , genesisAddress1-  , genesisAddress2-  , genesisAddress3-  , genesisAddress4-  , genesisAddress5-  , genesisAddress6-  , genesisKeyHash-  -- * Genesis secret keys-  , genesisSecretKey-  , genesisSecrets--  , initGState-  , readGState-  , writeGState--  -- * Operations on GState-  , GStateUpdate (..)-  , GStateUpdateError (..)-  , applyUpdate-  , applyUpdates-  , extractAllContracts-  ) where--import Control.Lens (at, makeLenses)-import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.=))-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encode.Pretty as Aeson-import Data.Aeson.TH (deriveJSON)-import qualified Data.ByteString.Lazy as LBS-import Data.Default (def)-import Data.List.NonEmpty ((!!))-import qualified Data.Map.Strict as Map-import Data.Type.Equality ((:~:)(..))-import Fmt (Buildable(build), (+|), (|+), (||+))-import System.IO.Error (IOError, isDoesNotExistError)--import Michelson.TypeCheck-  (SomeParamType(..), TcOriginatedContracts,-  typeCheckContractAndStorage, typeCheckingWith)-import qualified Michelson.Typed as T-import Michelson.Typed.Existential (SomeContractAndStorage(..))-import Michelson.Typed.Scope-import Michelson.Untyped (Contract, Value)-import Tezos.Address (Address(..), ContractHash, GlobalCounter(..))-import Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId)-import Tezos.Crypto-import Util.Aeson-import Util.Lens-import Util.Sing (eqI)---- | State of a contract with code.-data ContractState =-  forall cp st. (ParameterScope cp, StorageScope st) => ContractState-  { csBalance :: Mutez-  -- ^ Amount of mutez owned by this contract.-  , csContract :: T.Contract cp st-  -- ^ Contract itself.-  , csStorage :: T.Value st-  -- ^ Storage value associated with this contract.-  }--deriving stock instance Show ContractState--instance ToJSON ContractState where-  toJSON ContractState{..} =-    object-    [ "balance" .= csBalance-    , "storage" .= T.untypeValue csStorage-    , "contract" .= T.convertContract csContract-    ]---- These instance is a bit hacky because it is quite painful to--- write proper JSON instances for typed `Instr` and `Value` so--- we typecheck untyped representation instead of parsing.-instance FromJSON ContractState where-  parseJSON =-    withObject "contractstate" $ \o -> do-      (balance :: Mutez) <- o .: "balance"-      (uStorage :: Value) <- o .: "storage"-      (uContract :: Contract) <- o .: "contract"-      case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of-        Right (SomeContractAndStorage contract storage) ->-          pure $ ContractState balance contract storage-        Left err -> fail $ "Unable to parse `ContractState`: " <> (show err)--instance Buildable ContractState where-  build ContractState{..} =-    "Contractstate:\n Balance: " +| csBalance |+-    "\n  Storage: " +| T.untypeValue csStorage ||+-    "\n  Contract: " +| T.convertContract csContract ||+ ""---- | State of an arbitrary address.-data AddressState-  = ASSimple Mutez-  -- ^ For contracts without code we store only its balance.-  | ASContract ContractState-  -- ^ For contracts with code we store more state represented by-  -- 'ContractState'.-  deriving stock (Show, Generic)--instance Buildable AddressState where-  build =-    \case-      ASSimple balance -> "Balance = " +| balance |+ ""-      ASContract cs -> build cs--deriveJSON morleyAesonOptions ''AddressState---- | Extract balance from 'AddressState'.-asBalance :: AddressState -> Mutez-asBalance =-  \case-    ASSimple b -> b-    ASContract cs -> csBalance cs---- | Distribution of voting power among the contracts.------ Voting power reflects the ability of bakers to accept, deny or pass new--- proposals for protocol updates. I.e. each baker has its vote weight.------ This datatype definition may change in future, so its internals are not--- exported.-newtype VotingPowers-  = VotingPowers (Map KeyHash Natural)-  deriving stock (Show)--deriveJSON morleyAesonOptions ''VotingPowers---- | Get voting power of the given address.-vpPick :: KeyHash -> VotingPowers -> Natural-vpPick key (VotingPowers distr) = Map.lookup key distr ?: 0---- | Get total voting power.-vpTotal :: VotingPowers -> Natural-vpTotal (VotingPowers distr) = sum distr---- | Create voting power distribution from map.-mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers-mkVotingPowersFromMap = VotingPowers---- | Create voting power distribution.------ If some key is encountered multiple times, voting power will be summed up.-mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers-mkVotingPowers = mkVotingPowersFromMap . Map.fromListWith (+)---- | All big_maps stored in a chain have a globally unique ID.------ We use this counter to keep track of how many big_maps have been created so far,--- and to generate new IDs whenever a new big_map is created.-newtype BigMapCounter = BigMapCounter { _bigMapCounter :: Natural }-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)-  deriving newtype (ToJSON, FromJSON, Num, Buildable)--makeLenses ''BigMapCounter---- | Persistent data passed to Morley contracts which can be updated--- as result of contract execution.-data GState = GState-  { gsChainId :: ChainId-  -- ^ Identifier of chain.-  , gsAddresses :: Map Address AddressState-  -- ^ All known addresses and their state.-  , gsVotingPowers :: VotingPowers-  -- ^ Voting power distribution.-  , gsCounter :: GlobalCounter-  -- ^ Ever increasing operation counter.-  , gsBigMapCounter :: BigMapCounter-  } deriving stock (Show)--makeLensesWith postfixLFields ''GState--deriveJSON morleyAesonOptions ''GState---- | Number of genesis addresses.-genesisAddressesNum :: Word-genesisAddressesNum = 10---- | Secrets from which genesis addresses are derived from.-genesisSecrets :: NonEmpty SecretKey-genesisSecrets = do-  i <- 1 :| [2 .. genesisAddressesNum]-  let seed = encodeUtf8 (show i :: Text)-  return $ detSecretKey seed---- | KeyHash of genesis address.-genesisKeyHashes :: NonEmpty KeyHash-genesisKeyHashes = hashKey . toPublic <$> genesisSecrets---- | Initially these addresses have a lot of money.-genesisAddresses :: NonEmpty Address-genesisAddresses = KeyAddress <$> genesisKeyHashes---- | One of genesis key hashes.-genesisKeyHash :: KeyHash-genesisKeyHash = head genesisKeyHashes---- | One of genesis addresses.-genesisAddress :: Address-genesisAddress = head genesisAddresses---- | Secret key assotiated with 'genesisAddress'.-genesisSecretKey :: SecretKey-genesisSecretKey = head genesisSecrets---- | More genesis addresses------ We know size of @genesisAddresses@, so it is safe to use @!!@-genesisAddress1, genesisAddress2, genesisAddress3 :: Address-genesisAddress4, genesisAddress5, genesisAddress6 :: Address-genesisAddress1 = genesisAddresses !! 1-genesisAddress2 = genesisAddresses !! 2-genesisAddress3 = genesisAddresses !! 3-genesisAddress4 = genesisAddresses !! 4-genesisAddress5 = genesisAddresses !! 5-genesisAddress6 = genesisAddresses !! 6---- | Dummy 'VotingPowers'. We give all the voting power to two genesis addreses--- as the addresses holding lot of money. Only two addresses are involved for--- simplicity.-dummyVotingPowers :: VotingPowers-dummyVotingPowers = case genesisKeyHashes of-  k1 :| k2 : _ -> mkVotingPowers [(k1, 50), (k2, 50)]-  _ -> error "Insufficient number of genesis addresses"---- | Initial 'GState'. It's supposed to be used if no 'GState' is--- provided. It puts plenty of money on each genesis address.-initGState :: GState-initGState =-  GState-  { gsChainId = dummyChainId-  , gsAddresses = Map.fromList-    [ (genesis, ASSimple money)-    | let (money, _) = maxBound @Mutez `divModMutezInt` genesisAddressesNum-                    ?: error "Number of genesis addresses is 0"-    , genesis <- toList genesisAddresses-    ]-  , gsVotingPowers = dummyVotingPowers-  , gsCounter = GlobalCounter 0-  , gsBigMapCounter = BigMapCounter 0-  }--data GStateParseError =-  GStateParseError String-  deriving stock (Show)--instance Exception GStateParseError where-  displayException (GStateParseError str) = "Failed to parse GState: " <> str---- | Read 'GState' from a file.-readGState :: FilePath -> IO GState-readGState fp = (LBS.readFile fp >>= parseFile) `catch` onExc-  where-    parseFile :: LByteString -> IO GState-    parseFile lByteString =-      if null lByteString-      then pure initGState-      else (either (throwM . GStateParseError) pure . Aeson.eitherDecode') lByteString-    onExc :: IOError -> IO GState-    onExc exc-      | isDoesNotExistError exc = pure initGState-      | otherwise = throwM exc---- | Write 'GState' to a file.-writeGState :: FilePath -> GState -> IO ()-writeGState fp gs = LBS.writeFile fp (Aeson.encodePretty' config gs)-  where-    config =-      Aeson.defConfig-      { Aeson.confTrailingNewline = True-      }---- | Updates that can be applied to 'GState'.-data GStateUpdate where-  GSAddAddress :: Address -> AddressState -> GStateUpdate-  GSSetStorageValue :: StorageScope st => Address -> T.Value st -> GStateUpdate-  GSSetBalance :: Address -> Mutez -> GStateUpdate-  GSIncrementCounter :: GStateUpdate-  GSSetBigMapCounter :: BigMapCounter -> GStateUpdate--deriving stock instance Show GStateUpdate--instance Buildable GStateUpdate where-  build =-    \case-      GSAddAddress addr st ->-        "Add address " +| addr |+ " with state " +| st |+ ""-      GSSetStorageValue addr tVal ->-        "Set storage value of address " +| addr |+ " to " +| T.untypeValue tVal |+ ""-      GSSetBalance addr balance ->-        "Set balance of address " +| addr |+ " to " +| balance |+ ""-      GSIncrementCounter ->-        "Increment internal counter after operation"-      GSSetBigMapCounter inc ->-        "Increment internal big_map counter by: " +| build inc--data GStateUpdateError-  = GStateAddressExists Address-  | GStateUnknownAddress Address-  | GStateNotContract Address-  | GStateStorageNotMatch Address-  deriving stock (Show)--instance Buildable GStateUpdateError where-  build =-    \case-      GStateAddressExists addr -> "Address already exists: " <> build addr-      GStateUnknownAddress addr -> "Unknown address: " <> build addr-      GStateNotContract addr -> "Address doesn't have contract: " <> build addr-      GStateStorageNotMatch addr ->-        "Storage type does not match the contract in run-time state\-        \ when updating new storage value to address: " <> build addr---- | Apply 'GStateUpdate' to 'GState'.-applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState-applyUpdate =-  \case-    GSAddAddress addr st ->-      maybeToRight (GStateAddressExists addr) . addAddress addr st-    GSSetStorageValue addr newValue ->-      setStorageValue addr newValue-    GSSetBalance addr newBalance -> setBalance addr newBalance-    GSIncrementCounter -> Right . over gsCounterL (+1)-    GSSetBigMapCounter bmCounter -> Right . set gsBigMapCounterL bmCounter---- | Apply a list of 'GStateUpdate's to 'GState'.-applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState-applyUpdates = flip (foldM (flip applyUpdate))---- | Add an address if it hasn't been added before.-addAddress :: Address -> AddressState -> GState -> Maybe GState-addAddress addr st gs-    | addr `Map.member` accounts = Nothing-    | otherwise = Just (gs {gsAddresses = accounts & at addr .~ Just st})-  where-    accounts = gsAddresses gs---- | Update storage value associated with given address.-setStorageValue :: forall st. (StorageScope st) =>-     Address -> T.Value st -> GState -> Either GStateUpdateError GState-setStorageValue addr newValue = updateAddressState addr modifier-  where-    modifier :: AddressState -> Either GStateUpdateError AddressState-    modifier (ASSimple _) = Left (GStateNotContract addr)-    modifier (ASContract (ContractState b c (_ :: T.Value st') )) = do-      case eqI @st @st' of-        Just Refl -> Right $ ASContract $ ContractState b c newValue-        _ -> Left $ GStateStorageNotMatch addr---- | Update storage value associated with given address.-setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState-setBalance addr newBalance = updateAddressState addr (Right . modifier)-  where-    modifier (ASSimple _) = ASSimple newBalance-    modifier (ASContract cs) = ASContract (cs {csBalance = newBalance})--updateAddressState ::-     Address-  -> (AddressState -> Either GStateUpdateError AddressState)-  -> GState-  -> Either GStateUpdateError GState-updateAddressState addr f gs =-  case addresses ^. at addr of-    Nothing -> Left (GStateUnknownAddress addr)-    Just as -> do-      newState <- f as-      return $ gs { gsAddresses = addresses & at addr .~ Just newState }-  where-    addresses = gsAddresses gs---- | Retrieve all contracts stored in GState-extractAllContracts :: GState -> TcOriginatedContracts-extractAllContracts = Map.fromList . mapMaybe extractContract . toPairs . gsAddresses- where-    extractContract-      :: (Address, AddressState) -> Maybe (ContractHash, SomeParamType)-    extractContract =-      \case (KeyAddress _, ASSimple {}) -> Nothing-            (KeyAddress _, _) -> error "broken GState"-            (ContractAddress ca, ASContract (ContractState{..})) ->-              Just (ca, SomeParamType sing $ T.cParamNotes $ csContract)-            (ContractAddress _, _) -> error "broken GState"

− src/Michelson/Runtime/Import.hs

@@ -1,205 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Runtime.Import-  (-    -- * Read, parse, typecheck contract-    readContract-  , readSomeContract-  , readUntypedContract-  , importContract-  , importSomeContract-  , importUntypedContract-  , ImportContractError(..)--    -- * Read, parse, typecheck value-  , readValue-  , importValue-  , importSomeValue-  , importUntypedValue-  , ImportValueError (..)--    -- * Generic helpers-  , importUsing-  ) where--import Data.Default (def)-import qualified Data.Text.IO.Utf8 as Utf8 (readFile)-import Fmt (Buildable(build), pretty, unlinesF, (+|), (|+))--import Michelson.Parser (parseExpandValueFromFile)-import Michelson.Parser.Error (ParserException(..))-import Michelson.Runtime (parseExpandContract)-import Michelson.TypeCheck-  (TCError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith,-  typeVerifyContract, typeVerifyTopLevelType)-import Michelson.Typed (Contract(..), SingI, SomeContract(..), SomeValue, Value)-import qualified Michelson.Untyped as U--------------------------------------------------------------------------------- Reading, parsing, typechecking contract--------------------------------------------------------------------------------- | Purely read an untyped contract from Michelson textual representation.------ 'FilePath' is accepted solely as a hint for error messages.-readUntypedContract-  :: FilePath-  -> Text-  -> Either ImportContractError U.Contract-readUntypedContract filePath txt = do-  first (ICEParse filePath) $ parseExpandContract (Just filePath) txt---- | Purely read a typed contract from Michelson textual representation.-readSomeContract-  :: FilePath-  -> Text-  -> Either ImportContractError SomeContract-readSomeContract filePath txt = do-  contract <- readUntypedContract filePath txt-  first (ICETypeCheck filePath) $-    typeCheckingWith def $ typeCheckContract contract---- | Purely read a typed contract from Michelson textual representation,--- failing if parameter or storage types mismatch with the expected ones.-readContract-  :: forall cp st .-     Each '[SingI] [cp, st]-  => FilePath-  -> Text-  -> Either ImportContractError (Contract cp st)-readContract filePath txt = do-  contract <- readUntypedContract filePath txt-  first (ICETypeCheck filePath) $-    typeCheckingWith def $ typeVerifyContract contract---- | Read a thing from a file, using the provided parsing function.-importUsing-  :: (Exception e)-  => (FilePath -> Text -> Either e a)-  -> FilePath -> IO a-importUsing readFn file =-  either throwM pure . readFn file =<< Utf8.readFile file---- | Import untyped contract from a given file path.------ This function reads file, and parses a contract.------ This function may throw 'IOException' and 'ImportContractError'.-importUntypedContract :: FilePath -> IO U.Contract-importUntypedContract = importUsing readUntypedContract---- | Import contract from a given file path.------ This function reads file, parses and type checks a contract.--- Within the typechecking we assume that no contracts are originated,--- otherwise a type checking error will be caused.------ This function may throw 'IOException' and 'ImportContractError'.-importContract-  :: forall cp st .-     Each '[SingI] [cp, st]-  => FilePath -> IO (Contract cp st)-importContract = importUsing readContract---- | Version of 'importContract' that doesn't require you to know--- contract's parameter and storage types.-importSomeContract :: FilePath -> IO SomeContract-importSomeContract = importUsing readSomeContract---- | Error type for 'importContract' function.-data ImportContractError-  = ICEParse FilePath ParserException-  | ICETypeCheck FilePath TCError-  deriving stock (Show, Eq)--instance Buildable ImportContractError where-  build =-    \case-      ICEParse filePath e -> unlinesF-        [ "Error at " <> build filePath-        , "Failed to parse the contract: " +| e |+ ""-        ]-      ICETypeCheck filePath e -> unlinesF-        [ "Error at " <> build filePath-        , "The contract is ill-typed: " +| e |+ ""-        ]--instance Exception ImportContractError where-  displayException = pretty--------------------------------------------------------------------------------- Reading, parsing, typechecking value--------------------------------------------------------------------------------- | Purely read an untyped Michelson value from textual representation.------ 'FilePath' is accepted solely as a hint for error messages.-readUntypedValue-  :: FilePath-  -> Text-  -> Either ImportValueError U.Value-readUntypedValue filePath txt = do-  first (IVEParse filePath) $ parseExpandValueFromFile filePath txt---- | Purely read a typed Michelson value from textual representation.------ Expected type is provided explicitly.-readSomeValue-  :: U.Ty-  -> FilePath-  -> Text-  -> Either ImportValueError SomeValue-readSomeValue ty filePath txt = do-  valueU <- readUntypedValue filePath txt-  first (IVETypeCheck filePath) $-    typeCheckingWith def $ typeCheckTopLevelType Nothing ty valueU---- | Purely read a typed Michelson value from textual representation.-readValue-  :: forall t. SingI t-  => FilePath-  -> Text-  -> Either ImportValueError (Value t)-readValue filePath txt = do-  valueU <- readUntypedValue filePath txt-  first (IVETypeCheck filePath) $-    typeCheckingWith def $ typeVerifyTopLevelType Nothing valueU---- | Import an untyped value from a given file path.-importUntypedValue :: FilePath -> IO U.Value-importUntypedValue = importUsing readUntypedValue---- | Import a typed value from a given file path.------ Expected type is provided explicitly.-importSomeValue :: U.Ty -> FilePath -> IO SomeValue-importSomeValue = importUsing . readSomeValue---- | Import a typed value from a given file path.-importValue-  :: forall t . SingI t-  => FilePath -> IO (Value t)-importValue = importUsing readValue---- | Error type for 'importValue' function.-data ImportValueError-  = IVEParse FilePath ParserException-  | IVETypeCheck FilePath TCError-  deriving stock (Show, Eq)--instance Buildable ImportValueError where-  build =-    \case-      IVEParse filePath e -> unlinesF-        [ "Error at " <> build filePath-        , "Failed to parse the value: " +| e |+ ""-        ]-      IVETypeCheck filePath e -> unlinesF-        [ "Error at " <> build filePath-        , "The value is ill-typed: " +| e |+ ""-        ]--instance Exception ImportValueError where-  displayException = pretty

− src/Michelson/Runtime/TxData.hs

@@ -1,41 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | 'TxData' type and associated functionality.--module Michelson.Runtime.TxData-       ( TxData (..)-       , TxParam(..)-       , tdSenderAddressL-       , tdParameterL-       , tdEntrypointL-       , tdAmountL-       ) where--import Control.Lens (makeLensesWith)--import Michelson.Typed (ParameterScope)-import qualified Michelson.Typed as T-import Michelson.Untyped (EpName)-import qualified Michelson.Untyped as U-import Tezos.Address (Address)-import Tezos.Core (Mutez)-import Util.Lens (postfixLFields)---- | A parameter associated with a particular transaction.-data TxParam where-  TxTypedParam :: forall t. ParameterScope t => T.Value t -> TxParam-  TxUntypedParam :: U.Value -> TxParam--deriving stock instance Show TxParam---- | Data associated with a particular transaction.-data TxData = TxData-  { tdSenderAddress :: Address-  , tdParameter :: TxParam-  , tdEntrypoint :: EpName-  , tdAmount :: Mutez-  } deriving stock Show--makeLensesWith postfixLFields ''TxData

− src/Michelson/Text.hs

@@ -1,216 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- deriving 'Container' automatically produces extra constraints.-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Strings compliant with Michelson constraints.------ When writting a Michelson contract, you can only mention characters with--- codes from @[32 .. 126]@ range in string literals. Same restriction applies--- to string literals passed to @tezos-client@.------ However, Michelson allows some control sequences: @"\n"@. You have to write--- it exactly in this form, and internally it will be transformed to line feed--- character (this behaviour can be observed when looking at @Pack@ed data).------ See tests for examples of good and bad strings.-module Michelson.Text-  ( MText (..)-  , mkMText-  , unsafeMkMText-  , mkMTextCut-  , writeMText-  , takeMText-  , dropMText-  , isMChar-  , minBoundMChar-  , maxBoundMChar--    -- * Misc-  , qqMText-  , mt-  , DoNotUseTextError-  , symbolToMText-  , labelToMText-  , mtextHeadToUpper-  ) where--import Data.Aeson (FromJSON(..), ToJSON(..))-import qualified Data.Char as C-import Data.Data (Data)-import qualified Data.Text as T-import Fmt (Buildable)-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Quote as TH--import Util.CLI-import Util.Label (Label(..), labelToText)-import Util.TypeLits---- | Michelson string value.------ This is basically a mere text with limits imposed by the language:--- <https://tezos.gitlab.io/whitedoc/michelson.html#constants>--- Although, this document seems to be not fully correct, and thus we applied--- constraints deduced empirically.------ You construct an item of this type using one of the following ways:------ * With QuasyQuotes when need to create a string literal.------ >>> [mt|Some text|]--- UnsafeMText {unMText = "Some text"}------ * With 'mkMText' when constructing from a runtime text value.------ * With 'unsafeMkMText' or 'UnsafeMText' when absolutelly sure that--- given string does not violate invariants.------ * With 'mkMTextCut' when not sure about text contents and want--- to make it compliant with Michelson constraints.-newtype MText = UnsafeMText { unMText :: Text }-  deriving stock (Show, Eq, Ord, Data, Generic)-  deriving newtype (Semigroup, Monoid, Container, Buildable, Hashable)--instance NFData MText--minBoundMChar, maxBoundMChar :: Int-minBoundMChar = 32-maxBoundMChar = 126---- | Constraint on literals appearing in Michelson contract code.-isMChar :: Char -> Bool-isMChar c = fromEnum c >= minBoundMChar && fromEnum c <= maxBoundMChar---- | Error message indicating bad character in a string literal.-invalidMCharError :: Char -> Text-invalidMCharError c = "Invalid character in string literal: " <> toText [c]---- | Wrap a Haskell text into 'MText', performing necessary checks.------ You can use e.g. @'\n'@ character directly in supplied argument,--- but attempt to use other bad characters like @'\r'@ will cause failure.-mkMText :: Text -> Either Text MText-mkMText txt = mapM checkMChar (toString txt) $> UnsafeMText txt-  where-    checkMChar c-      | isMChar c || c == '\n' = pass-      | otherwise = Left $ invalidMCharError c---- | Contruct 'MText' from a Haskell text, failing if provided Haskell text--- is invalid Michelson string.-unsafeMkMText :: HasCallStack => Text -> MText-unsafeMkMText = either error id . mkMText---- | Construct 'MText' from a Haskell text, eliminating all characters which--- should not appear in Michelson strings.--- Characters which can be displayed normally via escaping are preserved.-mkMTextCut :: Text -> MText-mkMTextCut txt =-  UnsafeMText . toText . filter isAllowed $ toString txt-  where-    isAllowed c = isMChar c || c == '\n'---- | Print 'MText' for Michelson code, with all unusual characters escaped.-writeMText :: MText -> Text-writeMText (UnsafeMText t) = t-  & T.replace "\\" "\\\\"-  & T.replace "\n" "\\n"-  & T.replace "\"" "\\\""--takeMText :: Int -> MText -> MText-takeMText n (UnsafeMText txt) = UnsafeMText $ T.take n txt--dropMText :: Int -> MText -> MText-dropMText n (UnsafeMText txt) = UnsafeMText $ T.drop n txt--instance ToText MText where-  toText = unMText--instance ToJSON MText where-  toJSON = toJSON . unMText-instance FromJSON MText where-  parseJSON v =-    either (fail . toString) pure . mkMText =<< parseJSON @Text v--instance HasCLReader MText where-  getReader = eitherReader (first toString . mkMText . toText)-  getMetavar = "MICHELSON STRING"---- | QuasyQuoter for constructing Michelson strings.------ Validity of result will be checked at compile time.--- Note:------ * slash must be escaped--- * newline character must appear as '\n'--- * use quotes as is--- * other special characters are not allowed.---- TODO: maybe enforce one space in the beginning and one in the end?--- compare:--- >>> [mt|mystuff|]--- vs--- >>> [mt| mystuff |]-mt :: TH.QuasiQuoter-mt = TH.QuasiQuoter-  { TH.quoteExp = \s ->-      case qqMText s of-        Left err -> fail $ toString err-        Right txt -> [e| UnsafeMText (toText @String txt) |]-  , TH.quotePat = \s ->-      case qqMText s of-        Left err -> fail $ toString err-        Right txt -> [p| UnsafeMText $(TH.litP $ TH.StringL txt) |]-  , TH.quoteType = \_ ->-      fail "Cannot use this QuasiQuoter at type position"-  , TH.quoteDec = \_ ->-      fail "Cannot use this QuasiQuoter at declaration position"-  }--{-# ANN module ("HLint: ignore Use list literal pattern" :: Text) #-}---- | Parser used in 'mt' quasi quoter.-qqMText :: String -> Either Text String-qqMText txt = scan txt-  where-  scan = \case-    '\\' : [] -> Left "Unterminated '\\' in string literal"-    '\\' : '\\' : s -> ('\\' :) <$> scan s-    '\\' : 'n'  : s -> ('\n' :) <$> scan s-    '\\' : c : _ -> Left $ "Unknown escape sequence: '\\" <> toText [c] <> "'"-    c : s-      | isMChar c -> (c :) <$> scan s-      | otherwise -> Left $ invalidMCharError c-    [] -> Right []---- | A type error asking to use 'MText' instead of 'Text'.-type family DoNotUseTextError where-  DoNotUseTextError = TypeError-    ( 'Text "`Text` is not isomorphic to Michelson strings," ':$$:-      'Text "consider using `MText` type instead"-    )---- | Create a 'MText' from type-level string.------ We assume that no unicode characters are used in plain Haskell code,--- so unless special tricky manipulations are used this should be safe.-symbolToMText :: forall name. KnownSymbol name => MText-symbolToMText = unsafeMkMText $ symbolValT' @name---- | Create a 'MText' from label.------ We assume that no unicode characters are used in plain Haskell code,--- so unless special tricky manipulations are used this should be safe.-labelToMText :: Label name -> MText-labelToMText = unsafeMkMText . labelToText---- | Leads first character of text to upper case.------ For empty text this will throw an error.-mtextHeadToUpper :: HasCallStack => MText -> MText-mtextHeadToUpper (UnsafeMText txt) = case T.uncons txt of-  Nothing -> error "Empty text"-  Just (c, cs) -> UnsafeMText $ T.cons (C.toUpper c) cs

− src/Michelson/TypeCheck.hs

@@ -1,33 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.TypeCheck-  ( typeCheckContract-  , typeCheckContractAndStorage-  , typeCheckExt-  , typeCheckInstr-  , typeCheckList-  , typeCheckListNoExcept-  , typeCheckParameter-  , typeCheckStorage-  , typeCheckTopLevelType-  , typeCheckValue-  , typeVerifyContract-  , typeVerifyParameter-  , typeVerifyStorage-  , typeVerifyTopLevelType-  , module E-  , module M-  , module T-  , eqType-  , matchTypes-  ) where--import Michelson.TypeCheck.Error as E-import Michelson.TypeCheck.Ext-import Michelson.TypeCheck.Instr-import Michelson.TypeCheck.TypeCheck as T-import Michelson.TypeCheck.Types as M--import Michelson.TypeCheck.Helpers (eqType, matchTypes)

− src/Michelson/TypeCheck/Error.hs

@@ -1,366 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Errors that can occur when some code is being typechecked.--module Michelson.TypeCheck.Error-  ( TypeContext (..)-  , TopLevelType (..)-  , TCTypeError (..)-  , TCError (..)-  , ExtError (..)-  , StackSize (..)-  , pairWithNodeIndex-  , pairWithElems-  ) where--import Fmt (Buildable(..), pretty, (+|), (|+), (||+))-import Named ((:!), arg)-import Prelude hiding ((<$>), empty)-import Text.PrettyPrint.Leijen.Text hiding (pretty, bool)-import qualified Text.Show (show)--import Michelson.ErrorPos (InstrCallStack(..))-import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable,-  buildRenderDoc, buildRenderDocExtended, doesntNeedParens, renderDoc, renderDocList)-import Michelson.TypeCheck.TypeCheckedOp (TypeCheckedOp)-import Michelson.TypeCheck.Types (SomeHST(..))-import qualified Michelson.Typed as T-import Michelson.Typed.Annotation (AnnConvergeError(..))-import Michelson.Untyped (StackFn, Ty, Var)-import qualified Michelson.Untyped as U-import Tezos.Address (Address)-import Tezos.Crypto (CryptoParseError)-import qualified Tezos.Crypto.BLS12381 as BLS---- | Contexts where type error can occur.-data TypeContext-  = LambdaArgument-  | LambdaCode-  | DipCode-  | ConsArgument-  | ComparisonArguments-  | ContractParameter-  | ContractStorage-  | ArithmeticOperation-  | Iteration-  | Cast-  | UnpairArgument-  | CarArgument-  | CdrArgument-  | If-  | ConcatArgument-  | ContainerKeyType-  | ContainerValueType-  | FailwithArgument-  | TicketsJoin-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)--instance RenderDoc TypeContext where-  renderDoc _ = \case-    LambdaArgument -> "argument to some lambda"-    LambdaCode -> "code in LAMBDA"-    DipCode -> "code in DIP"-    ConsArgument -> "argument to CONS"-    ComparisonArguments -> "arguments to comparison function"-    ContractParameter -> "contract parameter"-    ContractStorage -> "contract storage"-    ArithmeticOperation -> "arguments to arithmetic operation"-    Iteration -> "iteration (ITER / MAP / etc) code"-    Cast -> "argument to CAST"-    UnpairArgument -> "argument to UNPAIR"-    CarArgument -> "argument to CAR"-    CdrArgument -> "argument to CDR"-    If -> "conditional expression"-    ConcatArgument -> "argument to CONCAT"-    ContainerKeyType -> "container key type"-    ContainerValueType -> "container value type"-    FailwithArgument -> "argument to FAILWITH"-    TicketsJoin -> "join of two tickets"--data TopLevelType-  = TltParameterType-  | TltStorageType-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)--instance Buildable TopLevelType where-  build = buildRenderDoc--instance RenderDoc TopLevelType where-  renderDoc _ = \case-    TltParameterType -> "parameter"-    TltStorageType -> "storage"--instance Buildable TypeContext where-  build = buildRenderDoc---- | Data type that represents various errors--- which are related to type system.--- These errors are used to specify info about type check errors--- in @TCError@ data type.-data TCTypeError-  = AnnError AnnConvergeError-  -- ^ Annotation unify error-  | TypeEqError T.T T.T-  -- ^ Type equality error-  | StackEqError [T.T] [T.T]-  -- ^ Stacks equality error-  | UnsupportedTypeForScope T.T T.BadTypeForScope-  -- ^ Error that happens when type cannot be used in the corresponding scope.-  -- Argument of this constructor carries type which violates-  -- the restriction, e.g. @big_map@ in @UNPACK@, and a concrete reason why the-  -- type is unsuported.-  | NotNumericTypes T.T T.T-  -- ^ Arithmetic operation is applied to types, at least one of which is not numeric-  -- (e.g. @timestamp@ and @timestamp@ passed to @MUL@ instruction).-  | UnexpectedType (NonEmpty (NonEmpty Text))-  -- ^ Error that happens when actual types are different from the type that instruction expects.-  -- The param is an non-empty list of all expected stack types that the instruction would accept.-  -- Each expected stack types is represented as non-empty list as well.-  | UnexpectedTopLevelType TopLevelType ("expected" :! T.T) ("got" :! T.T)-  -- ^ Error that happens when the caller expected one top-level type, but-  -- the contract has another type specified.-  | InvalidInstruction U.ExpandedInstr Text-  -- ^ Some instruction is invalid or used in an invalid way.-  -- For example, @PAIR 0@ or @PAIR 1@, or a @SELF@ instruction was used in a @LAMBDA@.-  -- The 'Text' argument is a user-readable explanation of why this instruction is invalid.-  | InvalidValueType T.T-  -- ^ Error that happens when a `U.Value` is never a valid source for this type-  -- (e.g. @timestamp@ cannot be obtained from a `U.ValueTrue`)-  | NotEnoughItemsOnStack-  -- ^ There are not enough items on stack to perform a certain instruction.-  | IllegalEntrypoint T.EpNameFromRefAnnError-  -- ^ Invalid entrypoint name provided-  | UnknownContract Address-  -- ^ Contract with given address is not originated.-  | EntrypointNotFound T.EpName-  -- ^ Given entrypoint is not present.-  | IllegalParamDecl T.ParamEpError-  -- ^ Incorrect parameter declaration (with respect to entrypoints feature).-  | NegativeNat-  -- ^ Natural numbers cannot be negative-  | MutezOverflow-  -- ^ Exceeds the maximal mutez value-  | InvalidAddress T.ParseEpAddressError-  -- ^ Address couldn't be parsed from its textual representation-  | InvalidKeyHash CryptoParseError-  -- ^ KeyHash couldn't be parsed from its textual representation-  | InvalidBls12381Object BLS.DeserializationError-  -- ^ BLS12-381 primitive couldn't be parsed-  | InvalidTimestamp-  -- ^ Timestamp is not RFC339 compliant-  | CodeAlwaysFails-  -- ^ Code always fails, but shouldn't, like in ITER body.-  -- This is actually more general, any instruction that allows no continuation-  -- (like @NEVER@) cannot appear as part of another instruction's body.-  | EmptyCode-  -- ^ Empty block of code, like ITER body.-  | AnyError-  -- ^ Generic error when instruction does not match something sensible.-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)--instance Buildable TCTypeError where-  build = buildRenderDocExtended--instance RenderDoc TCTypeError where-  renderDoc context = \case-    AnnError e -> renderAnyBuildable e-    TypeEqError type1 type2 ->-      "Types not equal:" <+> (renderDoc context type1) <+> "/=" <+> (renderDoc context type2)-    StackEqError st1 st2 ->-      "Stacks not equal:"<+> (renderDocList context st1) <+> "/=" <+> (renderDocList context st2)-    UnsupportedTypeForScope typ reason ->-      "Type '" <> (renderDoc context typ) <> "' is unsupported here because it"-      <+> (renderDoc context reason)-    NotNumericTypes t1 t2 ->-      "Some of the types in an arithmetic operation are not numeric:"-      <+> (renderDoc context t1) <+> "and" <+> (renderDoc context t2)-    UnexpectedType (t :| ts) ->-      "Wrong stack type for instruction, expect stack type to begin with " <+>-        (cat $ punctuate "or"-          $ fmap (\(x :| xs) -> list $ fmap (renderAnyBuildable) (x:xs))-          $ (t:ts)-        )-    UnexpectedTopLevelType tyDesc (arg #expected -> expected) (arg #got -> got) ->-      "Unexpected" <+> renderDoc context tyDesc <+> "type:"-      <$$> renderLargeType got-      <$$> "Expected:"-      <$$> renderLargeType expected-    InvalidInstruction instr reason ->-      "Invalid instruction" <+> (renderDoc context instr)-      <$$> "Reason:" <+> textStrict reason-    InvalidValueType t ->-      "Value type is never a valid" <+> enclose "`" "`" (renderDoc context t)-    NotEnoughItemsOnStack ->-      "Not enough items on stack"-    UnknownContract addr ->-      "Contract is not registered:" <+> (renderAnyBuildable addr)-    IllegalEntrypoint err -> renderDoc context err-    EntrypointNotFound ep ->-      "No such entrypoint" <+> enclose "`" "`" (renderAnyBuildable ep)-    IllegalParamDecl err -> renderDoc context err-    NegativeNat -> "Natural number cannot be negative"-    MutezOverflow -> "Exceeds maximal value for mutez"-    InvalidAddress e -> renderDoc context e-    InvalidKeyHash e -> renderDoc context e-    InvalidBls12381Object e -> renderDoc context e-    InvalidTimestamp -> "Is not a valid RFC3339 timestamp"-    CodeAlwaysFails ->-      "Cannot use a terminate instruction (like FAILWITH) as part of another \-      \instruction's body"-    EmptyCode -> "Code block is empty"-    AnyError -> "Some of the arguments have invalid types"-    where-      renderLargeType :: T.T -> Doc-      renderLargeType = indent 2 . renderDoc doesntNeedParens . T.toUType---- | Type check error-data TCError-  = TCFailedOnInstr U.ExpandedInstr SomeHST InstrCallStack (Maybe TypeContext) (Maybe TCTypeError)-  | TCFailedOnValue U.Value T.T Text InstrCallStack (Maybe TCTypeError)-  | TCContractError Text (Maybe TCTypeError)-  | TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp)-  | TCExtError SomeHST InstrCallStack ExtError-  | TCIncompletelyTyped TCError (U.Contract' TypeCheckedOp)-  deriving stock (Eq, Generic)--instance NFData TCError--instance Buildable TCError where-  build = buildRenderDocExtended--instance RenderDoc TCError where-  renderDoc context = \case-    TCFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTCTypeError -> line-      <> "Error checking expression:"-      <> surroundWithNewLines (renderDoc context instr)-      <> "against input stack type:"-      <> surroundWithNewLines (renderDoc context t)-      <> maybe "" (\c -> "Error in" <+> renderDoc context c) mbTCTypeContext-      <> maybe "" (\e -> ":" <+> (renderDoc context e) <> "." <$$> line) mbTCTypeError-      <> (renderDoc context ics)-    TCFailedOnValue v t custom ics mbTCTypeError ->-      "Error checking value"-      <$$> (renderDoc context v) <+> "against type"-      <+> (renderDoc context t) <> (bool (":" <+> (renderAnyBuildable custom)) "." (null custom))-      <+> (maybe "" (\e -> line <> (renderDoc context e) <> line) mbTCTypeError)-      <+> (renderDoc context ics)-    TCContractError msg typeError ->-      "Error occurred during contract typecheck:"-      <$$> (renderAnyBuildable msg) <> (maybe "" (\e -> " " <> (renderDoc context e)) typeError)-    TCUnreachableCode ics instrs ->-      "Unreachable code:" <$$> buildTruncated 3 (toList instrs) <> "."-      <+> (renderDoc context ics)-    TCExtError (SomeHST t) ics e ->-      "Error occurred during Morley extension typecheck:" <>-      (renderAnyBuildable e) <+> "on stack" <+> (renderDoc context t) <> "."-      <+> (renderDoc context ics)-    TCIncompletelyTyped err contract ->-      line-      <> renderDoc doesntNeedParens contract-      <$> renderDoc context err-    where-    buildTruncated k l-      | null (drop k l) = renderDocList context l-      | otherwise = (renderDocList context (take k l)) <> " ..."--    -- | Helper to format a line using empty lines at the end and at the beginning,-    -- and 4-space indents for the line itself-    surroundWithNewLines :: Doc -> Doc-    surroundWithNewLines l =-      line-      <$$> indent 4 l-      <$$> line--instance Show TCError where-  show = pretty--instance Exception TCError--newtype StackSize = StackSize Natural-  deriving stock (Show, Eq, Generic)--instance NFData StackSize---- | Various type errors possible when checking Morley extension commands-data ExtError =-    LengthMismatch U.StackTypePattern-  | VarError Text StackFn-  | TypeMismatch U.StackTypePattern Int TCTypeError-  | TyVarMismatch Var Ty U.StackTypePattern Int TCTypeError-  | StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError-  | TestAssertError Text-  | InvalidStackReference U.StackRef StackSize-  deriving stock (Eq, Generic)--instance NFData ExtError--instance Buildable ExtError where-  build = \case-    LengthMismatch stk ->-      "Unexpected length of stack: pattern "-      +| stk |+ " has length "-      +| (length . fst . U.stackTypePatternToList) stk |+ ""-    VarError t sf ->-      "In defenition of " +| t |+ ": VarError "-      +| sf |+ ""-    TypeMismatch stk i e ->-      "TypeMismatch: Pattern " +| stk |+ " at index "-      +| i |+ " with error: " +| e |+ ""-    TyVarMismatch v t stk i e ->-      "TyVarMismach: Variable " +| v |+ " is bound to type "-      +| t |+ " but pattern " +| stk |+ " failed at index "-      +| i |+ " with error: " +| e |+ ""-    StkRestMismatch stk (SomeHST r) (SomeHST r') e ->-      "StkRestMismatch in pattern " +| stk |+-      " against stacks " +| r ||+ " and " +| r' ||+-      " with error: " +| e |+ ""-    TestAssertError t ->-      "TestAssertError: " +| t |+ ""-    InvalidStackReference i lhs ->-      "InvalidStackReference: reference is out of the stack: "-      +| i ||+ " >= " +| lhs ||+ ""--------------------------------------------------------------------------------- Helpers for formatting types--------------------------------------------------------------------------------- | Given a node index @ix@, creates a string representing the--- smallest possible right-combed pair with at least @ix+1@ nodes.------ Since the node index 0 is valid even for non-pair values--- (e.g. we can run @GET 0@ on a @string@ or an @int@),--- we simply return a type variable @'a@ in this case.------ >>> pairWithNodeIndex 0--- "'a"------ >>> pairWithNodeIndex 4--- "pair 'a1 'a2 'a3"------ >>> pairWithNodeIndex 5--- "pair 'a1 'a2 'a3 'a4"-pairWithNodeIndex :: Word -> Text-pairWithNodeIndex = \case-  0 -> "'a"-  ix -> pairWithElems (minPairLength ix)-  where-    -- | Given a node index @ix@, calculates the minimum number of-    -- elements a pair must have for that index to be valid.-    minPairLength :: Word -> Word-    minPairLength = \case-      0 -> 2-      ix -> (ix + 3) `div` 2---- | Given a number @n@, creates a string representing a--- right-combed pair of arity @n@.------ > pairType 3 == "pair 'a1 'a2 'a3"-pairWithElems :: Word -> Text-pairWithElems n =-  "pair "-  <> mconcat (intersperse " " ([1 .. n] <&> \i -> "'a" <> show i))

− src/Michelson/TypeCheck/Ext.hs

@@ -1,187 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Type-checking of Morley extension.-module Michelson.TypeCheck.Ext-  ( typeCheckExt-  ) where--import Control.Lens ((%=))-import Control.Monad.Except (MonadError, liftEither, throwError)-import Data.Constraint (Dict(..))-import Data.Map.Lazy (insert, lookup)-import Data.Singletons (SingI)-import Data.Typeable ((:~:)(..))--import Michelson.ErrorPos-import Michelson.TypeCheck.Error-import Michelson.TypeCheck.Helpers-import Michelson.TypeCheck.TypeCheck-import Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..))-import Michelson.TypeCheck.Types-import Michelson.Typed (Notes(..), converge, mkUType, notesT, withUType)-import qualified Michelson.Typed as T-import Michelson.Untyped-  (ExpandedOp, StackFn, TyVar(..), Ty, Var, VarAnn, sfnInPattern, sfnOutPattern,-  sfnQuantifiedVars, varSet)-import qualified Michelson.Untyped as U-import Util.PeanoNatural (PeanoNatural(..))---- | Perform some, possibly throwing, action presumably making use of a supplied--- external instruction. In case of an error, return @IllTypedSeq@ wrapping the--- thrown error and the instruction. If the action successfully returns--- @SomeInstr@, wrap it in a @WellTypedSeq@.-workOnInstr-  :: U.ExpandedExtInstr-  -> TypeCheckInstr (SomeInstr s)-  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)-workOnInstr ext = tcEither-  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx $ U.EXT ext])-  (pure . WellTypedSeq)--typeCheckExt-  :: forall s. SingI s-  => TcInstrHandler-  -> U.ExpandedExtInstr-  -> HST s-  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)-typeCheckExt tcInstr ext hst = do-  instrPos <- ask-  case ext of-    U.STACKTYPE s -> workOnInstr ext $-      liftExtError hst $ stackTypeSomeInstr s <$ checkStackType noBoundVars s hst-    U.FN t sf op  -> checkFn tcInstr t sf op hst instrPos-    U.UPRINT pc   -> workOnInstr ext $-      verifyPrint pc <&> \tpc -> toSomeInstr (T.PRINT tpc)-    U.UTEST_ASSERT U.TestAssert{..} -> do-      let cons = U.EXT . U.UTEST_ASSERT . U.TestAssert tassName tassComment-      preserving (typeCheckImpl tcInstr tassInstrs hst) cons $ \(_ :/ si) -> case si of-        AnyOutInstr _ -> throwError $ TCExtError (SomeHST hst) instrPos $ TestAssertError-                         "TEST_ASSERT has to return Bool, but it always fails"-        instr ::: (((_ :: (T.Notes b, Dict (T.WellTyped b), VarAnn)) ::& _)) -> do-          Refl <- liftEither $ first-            (const $ TCExtError (SomeHST hst) instrPos $-              TestAssertError "TEST_ASSERT has to return Bool, but returned something else")-            (eqType @b @'T.TBool)-          tcom <- verifyPrint tassComment-          pure . toSomeInstr $ T.TEST_ASSERT $ T.TestAssert tassName tcom instr-        _ ->-          throwError $ TCExtError (SomeHST hst) instrPos $-            TestAssertError "TEST_ASSERT has to return Bool, but the stack is empty"--    U.UCOMMENT t ->-      -- TODO if we are going to analyze/parse programs from files,-      -- there should be parsing of string and creation of FunctionStarted/FunctionFinished/etc-      pure $ WellTypedSeq $ toSomeInstr $ T.COMMENT_ITEM $ T.JustComment t-  where-    verifyPrint :: U.PrintComment -> TypeCheckInstr (T.PrintComment s)-    verifyPrint (U.PrintComment pc) = do-      let checkStRef (Left txt)             = pure $ Left txt-          checkStRef (Right (U.StackRef i)) = Right <$> createStackRef i hst-      T.PrintComment <$> traverse checkStRef pc--    toSomeInstr ext' = hst :/ T.Ext ext' ::: hst-    stackTypeSomeInstr s = hst :/ T.Ext (T.STACKTYPE s) ::: hst--liftExtError :: SingI s => HST s -> Either ExtError a -> TypeCheckInstr a-liftExtError hst ei = do-  instrPos <- ask-  liftEither $ first (TCExtError (SomeHST hst) instrPos) ei---- | Check that the optional "forall" variables are consistent if present-checkVars :: Text -> StackFn -> Either ExtError ()-checkVars t sf = case sfnQuantifiedVars sf of-  Just qs-    | varSet (sfnInPattern sf) /= qs -> Left $ VarError t sf-  _ -> pass---- | Executes function body, pushing @ExtFrame@ onto the state and checks--- the pattern in @FN@.-checkFn-  :: SingI inp-  => TcInstrHandler-  -> Text-  -> StackFn-  -> [ExpandedOp]-  -> HST inp-  -> InstrCallStack-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-checkFn tcInstr t sf body inp loc = do-  guarding (con body) (checkStart inp) $ \vars ->-    preserving (typeCheckImplStripped tcInstr body inp) con $ \someI@(_ :/ instrAndOut) ->-      case instrAndOut of-        _ ::: out -> checkEnd vars out $> mapSomeInstr (T.WithLoc loc . T.Fn t sf) someI-        AnyOutInstr{} -> pure someI-  where-    checkStart hst = do-      liftExtError hst $ checkVars t sf-      vars <- liftExtError hst $ checkStackType noBoundVars (sfnInPattern sf) hst-      tcExtFramesL %= (vars :)-      return vars--    checkEnd :: SingI out => BoundVars -> HST out -> TypeCheckInstr ()-    checkEnd vars out = liftExtError out $-      void $ checkStackType vars (sfnOutPattern sf) out--    con :: [op] -> U.InstrAbstract op-    con = U.EXT . U.FN t sf---- | Check that a @StackTypePattern@ matches the type of the current stack-checkStackType-  :: SingI xs-  => BoundVars-  -> U.StackTypePattern-  -> HST xs-  -> Either ExtError BoundVars-checkStackType (BoundVars vars boundStkRest) s hst = go vars 0 s hst-  where-    go :: SingI xs => Map Var Ty -> Int -> U.StackTypePattern -> HST xs-       -> Either ExtError BoundVars-    go m _ U.StkRest sr = case boundStkRest of-      Nothing -> pure $ BoundVars m (Just $ SomeHST sr)-      Just si@(SomeHST sr') ->-        bimap (StkRestMismatch s (SomeHST sr) si)-              (const $ BoundVars m (Just si))-              (eqHST sr sr')-    go m _ U.StkEmpty SNil = pure $ BoundVars m Nothing-    go _ _ U.StkEmpty _    = Left $ LengthMismatch s-    go _ _ _ SNil        = Left $ LengthMismatch s-    go m n (U.StkCons tyVar ts) ((xann :: Notes xt, _, _) ::& xs) =-      let-        handleType :: U.Ty -> Either ExtError BoundVars-        handleType t =-          withUType t $ \(tann :: Notes t) -> do-            Refl <- first-              (\_ -> TypeMismatch s n $ TypeEqError (notesT xann) (notesT tann))-              (eqType @xt @t)-            void $ first (TypeMismatch s n . AnnError) (converge tann xann)-            go m (n + 1) ts xs-      in case tyVar of-        TyCon t -> handleType t-        VarID v -> case lookup v m of-          Nothing -> let t = mkUType xann in go (insert v t m) (n + 1) ts xs-          Just t -> handleType t---- | Create stack reference accessing element with a given index.------ Fails when index is too large for the given stack.-createStackRef-  :: (MonadError TCError m, MonadReader InstrCallStack m, SingI s)-  => Natural -> HST s -> m (T.StackRef s)-createStackRef idx hst =-  case doCreate (hst, idx) of-    Just sr -> pure sr-    Nothing -> do-      instrPos <- ask-      throwError $-        TCExtError (SomeHST hst) instrPos $-          InvalidStackReference (U.StackRef idx) (StackSize $ lengthHST hst)-  where-    doCreate :: forall s. (HST s, Natural) -> Maybe (T.StackRef s)-    doCreate = \case-      (SNil, _) -> Nothing-      ((_ ::& _), 0) -> Just (T.StackRef Zero)-      ((_ ::& st), i) -> do-        T.StackRef ns <- doCreate (st, i - 1)-        return $ T.StackRef (Succ ns)

− src/Michelson/TypeCheck/Helpers.hs

@@ -1,964 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.TypeCheck.Helpers-    ( deriveSpecialVN-    , deriveSpecialFNs-    , deriveVN-    , deriveNsOr-    , deriveNsOption-    , convergeHSTEl-    , convergeHST-    , hstToTs-    , eqHST-    , eqHST1-    , lengthHST--    , ensureDistinctAsc-    , eqType-    , onTypeCheckInstrAnnErr-    , onTypeCheckInstrErr-    , onScopeCheckInstrErr-    , typeCheckInstrErr-    , typeCheckInstrErr'-    , typeCheckImpl-    , typeCheckImplStripped-    , matchTypes--    , memImpl-    , getImpl-    , updImpl-    , getUpdImpl-    , sliceImpl-    , concatImpl-    , concatImpl'-    , sizeImpl-    , arithImpl-    , addImpl-    , subImpl-    , mulImpl-    , edivImpl-    , unaryArithImpl-    , unaryArithImplAnnotated-    , withCompareableCheck-    ) where--import Prelude hiding (EQ, GT, LT)--import Control.Lens (unsnoc)-import Control.Monad.Except (MonadError, throwError)-import Data.Constraint (Dict(..), withDict)-import Data.Default (def)-import Data.Singletons (Sing, SingI(sing), demote)-import Data.Singletons.Decide-import qualified Data.Text as T-import Data.Vinyl (Rec(..))-import Fmt ((+||), (||+))--import Michelson.ErrorPos (InstrCallStack)-import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..), TypeContext(..))-import Michelson.TypeCheck.TypeCheck-import Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..))-import Michelson.TypeCheck.Types-import Michelson.Typed-  (BadTypeForScope(..), CommentType(StackTypeComment), Comparable, ExtInstr(COMMENT_ITEM),-  Instr(..), Notes(..), SingT(..), T(..), WellTyped, converge, getComparableProofS, notesT,-  requireEq, starNotes)-import Michelson.Typed.Annotation (AnnConvergeError, isStar)-import Michelson.Typed.Arith (Add, ArithOp(..), Mul, Sub, UnaryArithOp(..))-import Michelson.Typed.Polymorphic-  (ConcatOp, EDivOp(..), GetOp(..), MemOp(..), SizeOp, SliceOp, UpdOp(..))-import qualified Michelson.Untyped as Un-import Michelson.Untyped.Annotation-  (Annotation(..), FieldAnn, VarAnn, annQ, noAnn, orAnn, unsafeMkAnnotation)-import Util.Sing (eqI)-import Util.Type (onFirst)---- | Function which derives special annotations--- for PAIR instruction.------ Namely, it does following transformation:------ > PAIR %@ %@ [ @p.a int : @p.b int : .. ]--- > ~--- > [ @p pair (int %a) (int %b) : .. ]------ All relevant cases (e.g. @PAIR %myf %@@ @)--- are handled as they should be according to spec.-deriveSpecialFNs-  :: FieldAnn -> FieldAnn-  -> VarAnn -> VarAnn-  -> VarAnn-  -> (VarAnn, FieldAnn, FieldAnn)-deriveSpecialFNs pfn qfn pvn qvn vn = (vn', pfn', qfn')-  where-    (vn1, pfn') = bool (vn, pfn) (splitLastDot pvn) (unAnnotation pfn == "@")-    (vn2, qfn') = bool (vn, qfn) (splitLastDot qvn) (unAnnotation qfn == "@")-    vn' = bool vn (commonPrefix vn1 vn2) (vn == def)--    splitLastDot :: VarAnn -> (VarAnn, FieldAnn)-    splitLastDot v = case unsnoc $ T.splitOn "." $ unAnnotation v of-      Nothing      -> def-      Just (_, "") -> (def, Un.convAnn v)-      Just (vs, l) -> (foldMap unsafeMkAnnotation vs, bool (unsafeMkAnnotation l) def (l == "car" || l == "cdr"))--    commonPrefix :: VarAnn -> VarAnn -> VarAnn-    commonPrefix = curry \case-      (v1, v2) | v1 == v2 -> v1-      (v1, v2) | v2 == noAnn -> v1-      (v1, v2) | v1 == noAnn -> v2-      _ -> def---- | Function which derives special annotations--- for CDR / CAR instructions.-deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn-deriveSpecialVN vn elFn pairVN elVn-  | (unAnnotation vn) == "%" = Un.convAnn elFn-  -- TODO [#534]:-  -- In the `%%` branch, if the pair's field annotation (`elFn`) is empty, we should default it to "cdr"/"car".-  -- See: <https://tezos.gitlab.io/008/michelson.html#automatic-variable-and-field-annotations-inferring>-  | (unAnnotation vn) == "%%" = pairVN <> Un.convAnn elFn-  | otherwise = vn `orAnn` elVn---- | Append suffix to variable annotation (if it's not empty)-deriveVN :: VarAnn -> VarAnn -> VarAnn-deriveVN suffix vn = bool (suffix <> vn) def (vn == def)---- | Function which extracts annotations for @or@ type--- (for left and right parts).------ It extracts field/type annotations and also auto-generates variable--- annotations if variable annotation is not provided as second argument.-deriveNsOr :: Notes ('TOr a b) -> VarAnn -> (Notes a, Notes b, VarAnn, VarAnn)-deriveNsOr (NTOr _ afn bfn an bn) ovn =-  let avn = deriveVN (Un.convAnn afn `orAnn` [annQ|left|]) ovn-      bvn = deriveVN (Un.convAnn bfn `orAnn` [annQ|right|]) ovn-   in (an, bn, avn, bvn)---- | Function which extracts annotations for @option t@ type.------ It extracts field/type annotations and also auto-generates variable--- annotation for @Some@ case if it is not provided as second argument.-deriveNsOption :: Notes ('TOption a) -> VarAnn -> (Notes a, VarAnn)-deriveNsOption (NTOption _ an) ovn =-  let avn = deriveVN [annQ|some|] ovn-   in (an, avn)--convergeHSTEl-  :: (Notes t, Dict (WellTyped t), VarAnn)-  -> (Notes t, Dict (WellTyped t), VarAnn)-  -> Either AnnConvergeError (Notes t, Dict (WellTyped t), VarAnn)-convergeHSTEl (an, d@Dict, avn) (bn, _, bvn) =-  (,,) <$> converge an bn <*> pure d-      <*> pure (bool def avn $ avn == bvn)---- | Combine annotations from two given stack types-convergeHST :: HST ts -> HST ts -> Either AnnConvergeError (HST ts)-convergeHST SNil SNil = pure SNil-convergeHST (a ::& as) (b ::& bs) =-    liftA2 (::&) (convergeHSTEl a b) (convergeHST as bs)---- | Extract singleton for each single type of the given stack.-hstToTs :: HST st -> [T]-hstToTs = \case-  SNil -> []-  (notes, _, _) ::& hst -> notesT notes : hstToTs hst---- | Check whether the given stack types are equal.-eqHST-  :: forall as bs. (SingI as, SingI bs)-  => HST as -> HST bs -> Either TCTypeError (as :~: bs)-eqHST (hst :: HST xs) (hst' :: HST ys) = do-  case eqI @as @bs of-    Nothing -> Left $ StackEqError (hstToTs hst) (hstToTs hst')-    Just Refl -> do-      void $ convergeHST hst hst' `onFirst` AnnError-      return Refl---- | Check whether the given stack has size 1 and its only element matches the--- given type. This function is a specialized version of `eqHST`.-eqHST1-  :: forall t st. (SingI st, WellTyped t)-  => HST st -> Either TCTypeError (st :~: '[t])-eqHST1 hst = do-  let hst' = sing @t -:& SNil-  case eqI @'[t] @st of-    Nothing -> Left $ StackEqError (hstToTs hst') (hstToTs hst)-    Just Refl -> Right Refl--lengthHST :: HST xs -> Natural-lengthHST (_ ::& xs) = 1 + lengthHST xs-lengthHST SNil = 0------------------------------------------------- Typechecker auxiliary------------------------------------------------- | Check whether elements go in strictly ascending order and--- return the original list (to keep only one pass on the original list).-ensureDistinctAsc :: (Ord b, Show a) => (a -> b) -> [a] -> Either Text [a]-ensureDistinctAsc toCmp = \case-  (e1 : e2 : l) ->-    if toCmp e1 < toCmp e2-    then (e1 :) <$> ensureDistinctAsc toCmp (e2 : l)-    else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ ")"-  l -> Right l---- | Function @eqType@ is a simple wrapper around @Data.Singletons.decideEquality@ suited--- for use within @Either TCTypeError a@ applicative.-eqType-  :: forall (a :: T) (b :: T). (Each '[SingI] [a, b])-  => Either TCTypeError (a :~: b)-eqType =-  requireEq @a @b $ Left ... TypeEqError--onTypeCheckInstrErr-  :: (MonadReader InstrCallStack m, MonadError TCError m)-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext-  -> Either TCTypeError a -> m a-onTypeCheckInstrErr instr hst mContext ei = do-  either (typeCheckInstrErr' instr hst mContext) return ei--onScopeCheckInstrErr-  :: forall (t :: T) m a.-      (MonadReader InstrCallStack m, MonadError TCError m, SingI t)-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext-  -> Either BadTypeForScope a -> m a-onScopeCheckInstrErr instr hst mContext = \case-  Right a -> return a-  Left e -> do-    pos <- ask-    throwError $ TCFailedOnInstr instr hst pos mContext $-      Just $ UnsupportedTypeForScope (demote @t) e--typeCheckInstrErr-  :: (MonadReader InstrCallStack m, MonadError TCError m)-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext-  -> m a-typeCheckInstrErr instr hst mContext = do-  pos <- ask-  throwError $ TCFailedOnInstr instr hst pos mContext Nothing--typeCheckInstrErr'-  :: (MonadReader InstrCallStack m, MonadError TCError m)-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext-  -> TCTypeError -> m a-typeCheckInstrErr' instr hst mContext err = do-  pos <- ask-  throwError $ TCFailedOnInstr instr hst pos mContext (Just err)--onTypeCheckInstrAnnErr-  :: (MonadReader InstrCallStack m, MonadError TCError m, SingI ts)-  => Un.ExpandedInstr -> HST ts -> Maybe TypeContext-  -> Either AnnConvergeError a -> m a-onTypeCheckInstrAnnErr instr i mContext ei =-  onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onFirst` AnnError)--withCompareableCheck-  :: forall a m v ts. (SingI ts, MonadReader InstrCallStack m, MonadError TCError m)-  => Sing a-  -> Un.ExpandedInstr-  -> HST ts-  -> (Comparable a => v)-  -> m v-withCompareableCheck sng instr i act = case getComparableProofS sng of-  Just d@Dict -> pure $ withDict d act-  Nothing -> typeCheckInstrErr instr (SomeHST i) $ Just ComparisonArguments--typeCheckOpImpl-  :: forall inp. SingI inp-  => TcInstrHandler-  -> Un.ExpandedOp-  -> HST inp-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-typeCheckOpImpl tcInstr op' hst = case op' of-  Un.WithSrcEx _ op@Un.WithSrcEx{} -> typeCheckOpImpl tcInstr op hst-  Un.WithSrcEx loc (Un.PrimEx op)  -> typeCheckPrimWithLoc loc op-  Un.WithSrcEx loc (Un.SeqEx sq)   -> typeCheckSeqWithLoc loc sq-  Un.PrimEx op                     -> typeCheckPrim op-  Un.SeqEx sq                      -> typeCheckSeq sq-  where-    -- If we know source location from the untyped instruction, keep it in the typed one.-    typeCheckPrimWithLoc :: InstrCallStack -> Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    typeCheckPrimWithLoc loc op = local (const loc)-      (wrapWithLoc loc <$> typeCheckPrim op)--    typeCheckPrim :: Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    typeCheckPrim op = tcInstr op hst <&> mapSeq addNotes--    typeCheckSeqWithLoc :: InstrCallStack -> [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    typeCheckSeqWithLoc loc = fmap (wrapWithLoc loc) . local (const loc) . typeCheckSeq--    typeCheckSeq :: [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    typeCheckSeq sq = typeCheckImpl tcInstr sq hst-                  <&> mapSeq (addNotes . mapSomeInstr Nested)--    addNotes :: SomeInstr inp -> SomeInstr inp-    addNotes (inp :/ i ::: out) = inp :/ wrapWithNotes out i ::: out-    addNotes i = i--    wrapWithNotes :: HST d -> Instr c d -> Instr c d-    wrapWithNotes outputStack instr = case instr of-      -- Abstractions for instructions:-      Nop -> instr'-      Seq _ _ -> instr'-      Nested _ -> instr'-      DocGroup _ _ -> instr'-      Ext _ -> instr'-      FrameInstr _ _ -> instr'-      WithLoc _ _ -> instr'-      Fn {} -> instr'-      -- These three shouldn't happen, since annotations are added here.-      InstrWithNotes {} -> instr'-      InstrWithVarAnns _ _ -> instr'-      InstrWithVarNotes _ _ -> instr'--      -- Instructions that don't produce notes:-      DROP -> instr'-      DROPN _ -> instr'-      SWAP -> instr'-      DIG _ -> instr'-      DUG _ -> instr'-      IF_NONE _ _ -> instr'-      IF_LEFT _ _ -> instr'-      IF_CONS _ _ -> instr'-      ITER _ -> instr'-      IF _ _ -> instr'-      LOOP _ -> instr'-      LOOP_LEFT _ -> instr'-      DIP _ -> instr'-      DIPN _ _ -> instr'-      FAILWITH -> instr'-      NEVER -> instr'--      -- These instructions technically may have one/two explicit var anns, BUT because they support special var anns,-      -- the var anns are stored directly inside the instruction's constructor.-      -- For this reason, they must NOT be wrapped in `InstrWithVarNotes`.-      AnnCAR _ _ -> instr'-      AnnCDR _ _ -> instr'-      AnnUNPAIR{} ->-        case outputStack of-          (notes1, _, varAnn1) ::& (notes2, _, varAnn2) ::& _ ->-            let withNotes-                  | isStar notes1 && isStar notes2 = id-                  | isStar notes2 = InstrWithNotes Proxy (notes1 :& RNil)-                  | otherwise = InstrWithNotes Proxy (notes1 :& notes2 :& RNil)-                withVarAnns-                  | varAnn1 == def && varAnn2 == def = id-                  | varAnn2 == def = InstrWithVarAnns $ Un.OneVarAnn varAnn1-                  | otherwise = InstrWithVarAnns (Un.TwoVarAnns varAnn1 varAnn2)-            in withNotes $ withVarAnns instr--      -- We purposefully don't wrap `UNPAIRN` in meta-instructions-      -- like `InstrWithNotes` and `InstrWithVarAnns`.-      -- See !769 for a lengthy explanation.-      UNPAIRN _ -> instr--      -- Instructions that produce at most two notes:-      CREATE_CONTRACT _ -> case outputStack of-        ((np, _, vp) ::& (_, _, vs) ::& _) ->-          let withNotes = if isStar np then id else InstrWithNotes Proxy (np :& RNil)-              withVarNotes = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarNotes (vp :| [vs])-              withVarNotes' = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns vp vs-           in withNotes . withVarNotes . withVarNotes' $ instr--      GET_AND_UPDATE -> case outputStack of-        ((valNotes, _, valVarAnn) ::& (mapNotes, _, mapVarAnn) ::& _) ->-          let-              -- `GET_AND_UPDATE` can have one var ann argument (e.g. 'GET_AND_UPDATE @var'),-              -- which is applied to the 2nd element of the stack (the updated map).-              withVarNotes = if mapVarAnn == Un.noAnn then id else InstrWithVarNotes (one mapVarAnn)-              -- `GET_AND_UPDATE` puts two elements on the top of the stack, both of which-              -- can have type/field/var annotations.-              withNotes = if isStar valNotes && isStar mapNotes then id else InstrWithNotes Proxy (valNotes :& mapNotes :& RNil)-              withVarNotes' = if valVarAnn == Un.noAnn && mapVarAnn == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns valVarAnn mapVarAnn-          in  withNotes . withVarNotes . withVarNotes' $ instr--      DUP -> instr''-      DUPN _ -> instr''-      PUSH _ -> instr''-      UNIT -> instr''-      SOME -> instr''-      NONE -> instr''-      AnnPAIR{} -> instr''-      AnnLEFT{} -> instr''-      AnnRIGHT{} -> instr''-      NIL -> instr''-      CONS -> instr''-      SIZE -> instr''-      MAP _ -> instr''-      MEM -> instr''-      EMPTY_SET -> instr''-      EMPTY_MAP -> instr''-      EMPTY_BIG_MAP -> instr''-      UPDATE -> instr''-      UPDATEN _ -> instr''-      GET -> instr''-      GETN _ -> instr''-      LAMBDA _ -> instr''-      EXEC -> instr''-      ADD -> instr''-      SUB -> instr''-      CONCAT -> instr''-      CONCAT' -> instr''-      MUL -> instr''-      OR -> instr''-      AND -> instr''-      XOR -> instr''-      NOT -> instr''-      ABS -> instr''-      ISNAT -> instr''-      INT -> instr''-      NEG -> instr''-      EDIV -> instr''-      LSL -> instr''-      LSR -> instr''-      COMPARE -> instr''-      EQ -> instr''-      NEQ -> instr''-      LT -> instr''-      GT -> instr''-      LE -> instr''-      GE -> instr''-      ADDRESS -> instr''-      CONTRACT _ _ -> instr''-      SET_DELEGATE -> instr''-      IMPLICIT_ACCOUNT -> instr''-      NOW -> instr''-      LEVEL -> instr''-      AMOUNT -> instr''-      BALANCE -> instr''-      HASH_KEY -> instr''-      CHECK_SIGNATURE -> instr''-      BLAKE2B -> instr''-      SOURCE -> instr''-      SENDER -> instr''-      SELF _ -> instr''-      SELF_ADDRESS -> instr''-      CAST -> instr''-      RENAME -> instr''-      CHAIN_ID -> instr''-      APPLY -> instr''-      PAIRN _ -> instr''-      PACK -> instr''-      UNPACK -> instr''-      SLICE -> instr''-      TRANSFER_TOKENS -> instr''-      VOTING_POWER -> instr''-      TOTAL_VOTING_POWER -> instr''-      SHA256 -> instr''-      SHA512 -> instr''-      SHA3 -> instr''-      KECCAK -> instr''-      PAIRING_CHECK -> instr''-      TICKET -> instr''-      READ_TICKET -> instr''-      SPLIT_TICKET -> instr''-      JOIN_TICKETS -> instr''-      where-        instr' = addNotesNoVarAnn outputStack instr-        instr'' = addNotesOneVarAnn outputStack instr--    addNotesOneVarAnn :: HST d -> Instr c d -> Instr c d-    addNotesOneVarAnn outputStack instr = case outputStack of-      ((n, _, v) ::& _) ->-        let withNotes = if isStar n then id else InstrWithNotes Proxy (n :& RNil)-            withVarNotes = if v == Un.noAnn then id else InstrWithVarNotes (one v)-            withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v-         in withNotes . withVarNotes . withVarNotes' $ instr-      SNil -> instr--    addNotesNoVarAnn :: HST d -> Instr c d -> Instr c d-    addNotesNoVarAnn outputStack instr = case outputStack of-      ((n, _, v) ::& _) ->-          let withNotes = if isStar n then id else InstrWithNotes Proxy (n :& RNil)-              withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v-           in withNotes . withVarNotes' $ instr-      SNil -> instr---- | Like 'typeCheckImpl' but doesn't add a stack type comment after the--- sequence.-typeCheckImplNoLastTypeComment-  :: forall inp . SingI inp-  => TcInstrHandler-  -> [Un.ExpandedOp]-  -> HST inp-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-typeCheckImplNoLastTypeComment _ [] inputStack-  = pure (WellTypedSeq (inputStack :/ Nop ::: inputStack))-typeCheckImplNoLastTypeComment tcInstr [op] inputStack = do-  typeCheckOpImpl tcInstr op inputStack-      >>= mapMSeq prependStackTypeComment-typeCheckImplNoLastTypeComment tcInstr (op : ops) inputStack = do-  done <- typeCheckOpImpl tcInstr op inputStack-      >>= mapMSeq prependStackTypeComment-  continueTypeChecking tcInstr done ops--continueTypeChecking-  :: forall inp. ()-  => TcInstrHandler-  -> TypeCheckedSeq inp-  -> [Un.ExpandedOp]-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-continueTypeChecking tcInstr done rest = case done of-  WellTypedSeq instr -> handleFirst instr-  MixedSeq i e left -> pure (MixedSeq i e (left <> map NonTypedInstr rest))-  IllTypedSeq e left -> pure (IllTypedSeq e (left <> map NonTypedInstr rest))-  where-    handleFirst :: SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    handleFirst packedInstr@(inputStack :/ instrAndOutputStack) = do-      case instrAndOutputStack of-        instr ::: outputStack -> do-          nextPiece <- typeCheckImplNoLastTypeComment tcInstr rest outputStack-          let combiner = combine inputStack instr-          pure case nextPiece of-            WellTypedSeq nextInstr -> WellTypedSeq (combiner nextInstr)-            MixedSeq nextInstr err left -> MixedSeq (combiner nextInstr) err left-            IllTypedSeq err left -> MixedSeq packedInstr err left-        AnyOutInstr{} -> pure case rest of-          [] -> WellTypedSeq packedInstr-          op : ops -> (MixedSeq-                        packedInstr-                        (TCUnreachableCode (extractOpPos op) (op :| ops))-                        (map NonTypedInstr ops))--    combine inp Nop (_ :/ nextPart) = inp :/ nextPart-    combine inp i1 (_ :/ nextPart) = inp :/ mapSomeInstrOut (Seq i1) nextPart--    extractOpPos :: Un.ExpandedOp -> InstrCallStack-    extractOpPos (Un.WithSrcEx loc _) = loc-    extractOpPos _ = def---- | Like 'typeCheckImpl' but without the first and the last stack type--- comments. Useful to reduce duplication of stack type comments.-typeCheckImplStripped-  :: forall inp . SingI inp-  => TcInstrHandler-  -> [Un.ExpandedOp]-  -> HST inp-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-typeCheckImplStripped tcInstr [] inp-  = typeCheckImplNoLastTypeComment tcInstr [] inp-typeCheckImplStripped tcInstr (op : ops) inp = do-  done <- typeCheckOpImpl tcInstr op inp-  continueTypeChecking tcInstr done ops--typeCheckImpl-  :: forall inp . SingI inp-  => TcInstrHandler-  -> [Un.ExpandedOp]-  -> HST inp-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-typeCheckImpl tcInstr ops inputStack = do-  tcSeq <- typeCheckImplNoLastTypeComment tcInstr ops inputStack-  mapMSeq appendTypeComment tcSeq-  where-    appendTypeComment packedI@(inp :/ iAndOut) = do-      verbose <- lift (asks tcVerbose)-      pure case (verbose, iAndOut) of-        (True, i ::: out) -> inp :/ Seq i (stackTypeComment out) ::: out-        (True, AnyOutInstr i) -> inp :/ AnyOutInstr (Seq i noStackTypeComment)-        _ -> packedI---prependStackTypeComment-  :: SomeInstr inp -> TypeCheckInstrNoExcept (SomeInstr inp)-prependStackTypeComment packedInstr@(inp :/ _) = do-  verbose <- lift (asks tcVerbose)-  pure if verbose && (not (isNop' packedInstr))-    then mapSomeInstr (Seq (stackTypeComment inp)) packedInstr-    else packedInstr--isNop' :: SomeInstr inp -> Bool-isNop' (_ :/ i ::: _) = isNop i-isNop' (_ :/ AnyOutInstr i) = isNop i--isNop :: Instr inp out -> Bool-isNop (WithLoc _ i) = isNop i-isNop (InstrWithNotes _ _ i) = isNop i-isNop (InstrWithVarNotes _ i) = isNop i-isNop (FrameInstr _ i) = isNop i-isNop (Seq i1 i2) = isNop i1 && isNop i2-isNop (Nested i) = isNop i-isNop Nop = True-isNop (Ext _) = True-isNop _ = False--mapMSeq-  :: Applicative f-  => (SomeInstr inp -> f (SomeInstr inp'))-  -> TypeCheckedSeq inp-  -> f (TypeCheckedSeq inp')-mapMSeq f v = case v of-  WellTypedSeq instr -> f instr <&> WellTypedSeq-  MixedSeq instr err tail' -> f instr <&> \instr' -> MixedSeq instr' err tail'-  IllTypedSeq err tail' -> pure $ IllTypedSeq err tail'--mapSeq-  :: (SomeInstr inp -> SomeInstr inp')-  -> TypeCheckedSeq inp-  -> TypeCheckedSeq inp'-mapSeq f = runIdentity . mapMSeq (Identity . f)--stackTypeComment :: HST st -> Instr st st-stackTypeComment = Ext . COMMENT_ITEM . StackTypeComment . Just . hstToTs--noStackTypeComment :: Instr st st-noStackTypeComment = Ext (COMMENT_ITEM (StackTypeComment Nothing))--wrapWithLoc :: InstrCallStack -> TypeCheckedSeq inp -> TypeCheckedSeq inp-wrapWithLoc loc = mapSeq $ \someInstr -> case someInstr of-  (_ :/ WithLoc{} ::: _) -> someInstr-  (inp :/ instr ::: out) -> inp :/ WithLoc loc instr ::: out-  (inp :/ AnyOutInstr instr) -> inp :/ (AnyOutInstr $ WithLoc loc instr)---- | Check whether given types are structurally equal and annotations converge.-matchTypes-  :: forall t1 t2.-      (Each '[SingI] [t1, t2])-  => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)-matchTypes n1 n2 = do-  Refl <- eqType @t1 @t2-  nr <- converge n1 n2 `onFirst` AnnError-  return (Refl, nr)------------------------------------------------- Some generic instruction implementation------------------------------------------------- | Generic implementation for MEMeration-memImpl-  :: forall c memKey rs inp m .-    ( MemOp c-    , SingI (MemOpKey c)-    , inp ~ (memKey : c : rs)-    , SingI rs-    , MonadReader InstrCallStack m-    , MonadError TCError m-    )-  => Notes (MemOpKey c)-  -> HST inp-  -> VarAnn-  -> m (SomeInstr inp)-memImpl cKeyNotes inputHST@(hst0 ::& _ ::& hstTail) varAnn =-  case eqType @memKey @(MemOpKey c) of-    Right Refl -> do-      _ <- onTypeCheckInstrAnnErr uInstr inputHST-        (Just ContainerKeyType) (converge memKeyNotes cKeyNotes)-      pure $ inputHST :/-        MEM ::: ((starNotes, Dict, varAnn) ::& hstTail)-    Left m ->-      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m-  where-    (memKeyNotes, Dict, _) = hst0-    uInstr = Un.MEM varAnn--getImpl-  :: forall c getKey rs inp m .-    ( GetOp c, SingI (GetOpKey c)-    , WellTyped (GetOpVal c)-    , inp ~ (getKey : c : rs)-    , SingI rs-    , MonadReader InstrCallStack m-    , MonadError TCError m-    )-  => Notes (GetOpKey c)-  -> HST inp-  -> Notes (GetOpVal c)-  -> VarAnn-  -> m (SomeInstr inp)-getImpl notesKeyC inputHST@(hst0 ::& _ ::& hstTail) valueNotes varAnn =-  case eqType @getKey @(GetOpKey c) of-    Right Refl -> do-      _ <- onTypeCheckInstrAnnErr uInstr inputHST-        (Just ContainerKeyType) (converge getKeyNotes notesKeyC)-      pure $ inputHST :/-        GET ::: ((NTOption def valueNotes, Dict, varAnn) ::& hstTail)-    Left m ->-      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m-  where-    (getKeyNotes, Dict, _) = hst0-    uInstr = Un.GET varAnn--updImpl-  :: forall c updKey updParams rs inp m .-    ( UpdOp c-    , SingI (UpdOpKey c), SingI (UpdOpParams c)-    , SingI rs-    , inp ~ (updKey : updParams : c : rs)-    , MonadReader InstrCallStack m-    , MonadError TCError m-    )-  => Notes (UpdOpKey c)-  -> HST inp-  -> Notes (UpdOpParams c)-  -> VarAnn-  -> m (SomeInstr inp)-updImpl cKeyNotes inputHST@(hst0 ::& hst1 ::& cTuple ::& hstTail) cValueNotes varAnn =-  case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of-    (Right Refl, Right Refl) -> do-      _ <- onTypeCheckInstrAnnErr uInstr inputHST-        (Just ContainerKeyType) (converge updKeyNotes cKeyNotes)-      _ <- onTypeCheckInstrAnnErr uInstr inputHST-        (Just ContainerValueType) (converge updValueNotes cValueNotes)-      let vn = varAnn `orAnn` (cTuple ^. _3)-      pure $ inputHST :/-        UPDATE ::: ((cTuple & _3 .~ vn) ::& hstTail)-    (Left m, _) ->-      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m-    (_, Left m) ->-      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerValueType) m-  where-    (updKeyNotes, Dict, _) = hst0-    (updValueNotes, Dict, _) = hst1-    uInstr = Un.UPDATE varAnn--getUpdImpl-  :: forall c updKey updParams rs inp m .-    ( UpdOp c, GetOp c-    , SingI (UpdOpKey c)-    , SingI (GetOpVal c)-    , inp ~ (updKey : updParams : c : rs)-    , SingI rs-    , GetOpKey c ~ UpdOpKey c-    , UpdOpParams c ~ 'TOption (GetOpVal c)-    , MonadReader InstrCallStack m-    , MonadError TCError m-    )-  => Notes (UpdOpKey c)-  -> HST inp-  -> Notes (UpdOpParams c)-  -> VarAnn-  -> m (SomeInstr inp)-getUpdImpl cKeyNotes inputHST@(hst0 ::& hst1 ::& cTuple ::& hstTail) cValueNotes varAnn =-  case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of-    (Right Refl, Right Refl) -> do-      _ <- onTypeCheckInstrAnnErr uInstr inputHST-        (Just ContainerKeyType) (converge updKeyNotes cKeyNotes)-      _ <- onTypeCheckInstrAnnErr uInstr inputHST-        (Just ContainerValueType) (converge updValueNotes cValueNotes)-      let vn = varAnn `orAnn` (cTuple ^. _3)-      pure $ inputHST :/-        GET_AND_UPDATE ::: (hst1 ::& (cTuple & _3 .~ vn) ::& hstTail)-    (Left m, _) ->-      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m-    (_, Left m) ->-      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerValueType) m-  where-    (updKeyNotes, Dict, _) = hst0-    (updValueNotes, Dict, _) = hst1-    uInstr = Un.GET_AND_UPDATE varAnn--sizeImpl-  :: (SizeOp c, inp ~ (c ': rs), Monad m)-  => HST inp-  -> VarAnn-  -> m (SomeInstr inp)-sizeImpl i@(_ ::& rs) vn =-  pure $ i :/ SIZE ::: ((starNotes, Dict, vn) ::& rs)--sliceImpl-  :: (SliceOp c, inp ~ ('TNat ': 'TNat ': c ': rs), Monad m)-  => HST inp-  -> Un.VarAnn-  -> m (SomeInstr inp)-sliceImpl i@(_ ::& _ ::& (cn, Dict, cvn) ::& rs) vn = do-  let vn' = vn `orAnn` deriveVN [annQ|slice|] cvn-      rn = NTOption def cn-  pure $ i :/ SLICE ::: ((rn, Dict, vn') ::& rs)--concatImpl'-  :: (ConcatOp c, WellTyped c, inp ~ ('TList c : rs), Monad m)-  => HST inp-  -> Un.VarAnn-  -> m (SomeInstr inp)-concatImpl' i@((NTList _ n, Dict, _) ::& rs) vn = do-  pure $ i :/ CONCAT' ::: ((n, Dict, vn) ::& rs)--concatImpl-  :: ( ConcatOp c, inp ~ (c ': c ': rs)-     , WellTyped c-     , MonadReader InstrCallStack m-     , MonadError TCError m-     )-  => HST inp-  -> Un.VarAnn-  -> m (SomeInstr inp)-concatImpl i@((cn1, _, _) ::& (cn2, _, _) ::& rs) vn = do-  cn <- onTypeCheckInstrAnnErr (Un.CONCAT vn) i (Just ConcatArgument) (converge cn1 cn2)-  pure $ i :/ CONCAT ::: ((cn, Dict, vn) ::& rs)---- | Helper function to construct instructions for binary arithmetic--- operations.-arithImpl-  :: forall aop inp m n s t.-     ( ArithOp aop n m-     , WellTyped (ArithRes aop n m)-     , inp ~ (n ': m ': s)-     , MonadReader InstrCallStack t-     , MonadError TCError t-     )-  => Instr inp (ArithRes aop n m ': s)-  -> HST inp-  -> VarAnn-  -> Un.ExpandedInstr-  -> t (SomeInstr inp)-arithImpl mkInstr i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do-  case convergeArith (Proxy @aop) an bn of-    Right cn ->-      pure $ i :/ mkInstr ::: ((cn, Dict, vn) ::& rs)-    Left err -> do-      typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err--addImpl-  :: forall a b inp rs m.-     ( Each '[SingI] [a, b]-     , inp ~ (a ': b ': rs)-     , SingI rs-     , MonadReader InstrCallStack m-     , MonadError TCError m-     )-  => Sing a -> Sing b-  -> HST inp-  -> VarAnn-  -> Un.ExpandedInstr-  -> m (SomeInstr inp)-addImpl t1 t2 = case (t1, t2) of-  (STInt, STInt) -> arithImpl @Add ADD-  (STInt, STNat) -> arithImpl @Add ADD-  (STNat, STInt) -> arithImpl @Add ADD-  (STNat, STNat) -> arithImpl @Add ADD-  (STInt, STTimestamp) -> arithImpl @Add ADD-  (STTimestamp, STInt) -> arithImpl @Add ADD-  (STMutez, STMutez) -> arithImpl @Add ADD-  (STBls12381Fr, STBls12381Fr) -> arithImpl @Add ADD-  (STBls12381G1, STBls12381G1) -> arithImpl @Add ADD-  (STBls12381G2, STBls12381G2) -> arithImpl @Add ADD-  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $-    NotNumericTypes (demote @a) (demote @b)--edivImpl-  :: forall a b inp rs m.-     ( SingI rs-     , Each '[SingI] [a, b]-     , inp ~ (a ': b ': rs)-     , MonadReader InstrCallStack m-     , MonadError TCError m-     )-  => Sing a -> Sing b-  -> HST inp-  -> VarAnn-  -> Un.ExpandedInstr-  -> m (SomeInstr inp)-edivImpl t1 t2 = case (t1, t2) of-  (STInt, STInt) -> edivImplDo-  (STInt, STNat) -> edivImplDo-  (STNat, STInt) -> edivImplDo-  (STNat, STNat) -> edivImplDo-  (STMutez, STMutez) -> edivImplDo-  (STMutez, STNat) -> edivImplDo-  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $-    NotNumericTypes (demote @a) (demote @b)--edivImplDo-  :: ( EDivOp n m-     , WellTyped (EModOpRes n m)-     , WellTyped (EDivOpRes n m)-     , inp ~ (n ': m ': s)-     , MonadReader InstrCallStack t-     , MonadError TCError t-     )-  => HST inp-  -> VarAnn-  -> Un.ExpandedInstr-  -> t (SomeInstr inp)-edivImplDo i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do-  case convergeEDiv an bn of-    Right cn ->-      pure $ i :/ EDIV ::: ((cn, Dict, vn) ::& rs)-    Left err -> do-      typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err--subImpl-  :: forall a b inp rs m.-     ( Each '[SingI] [a, b]-     , inp ~ (a ': b ': rs)-     , SingI rs-     , MonadReader InstrCallStack m-     , MonadError TCError m-     )-  => Sing a -> Sing b-  -> HST inp-  -> VarAnn-  -> Un.ExpandedInstr-  -> m (SomeInstr inp)-subImpl t1 t2 = case (t1, t2) of-  (STInt, STInt) -> arithImpl @Sub SUB-  (STInt, STNat) -> arithImpl @Sub SUB-  (STNat, STInt) -> arithImpl @Sub SUB-  (STNat, STNat) -> arithImpl @Sub SUB-  (STTimestamp, STTimestamp) -> arithImpl @Sub SUB-  (STTimestamp, STInt) -> arithImpl @Sub SUB-  (STMutez, STMutez) -> arithImpl @Sub SUB-  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $-    NotNumericTypes (demote @a) (demote @b)--mulImpl-  :: forall a b inp rs m.-     ( Each '[SingI] [a, b]-     , inp ~ (a ': b ': rs)-     , SingI rs-     , MonadReader InstrCallStack m-     , MonadError TCError m-     )-  => Sing a -> Sing b-  -> HST inp-  -> VarAnn-  -> Un.ExpandedInstr-  -> m (SomeInstr inp)-mulImpl t1 t2 = case (t1, t2) of-  (STInt, STInt) -> arithImpl @Mul MUL-  (STInt, STNat) -> arithImpl @Mul MUL-  (STNat, STInt) -> arithImpl @Mul MUL-  (STNat, STNat) -> arithImpl @Mul MUL-  (STNat, STMutez) -> arithImpl @Mul MUL-  (STMutez, STNat) -> arithImpl @Mul MUL-  (STInt, STBls12381Fr) -> arithImpl @Mul MUL-  (STNat, STBls12381Fr) -> arithImpl @Mul MUL-  (STBls12381Fr, STInt) -> arithImpl @Mul MUL-  (STBls12381Fr, STNat) -> arithImpl @Mul MUL-  (STBls12381Fr, STBls12381Fr) -> arithImpl @Mul MUL-  (STBls12381G1, STBls12381Fr) -> arithImpl @Mul MUL-  (STBls12381G2, STBls12381Fr) -> arithImpl @Mul MUL-  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $-    NotNumericTypes (demote @a) (demote @b)---- | Helper function to construct instructions for unary arithmetic--- operations.-unaryArithImpl-  :: ( WellTyped (UnaryArithRes aop n)-     , inp ~ (n ': s)-     , Monad t-     )-  => Instr inp (UnaryArithRes aop n ': s)-  -> HST inp-  -> VarAnn-  -> t (SomeInstr inp)-unaryArithImpl mkInstr i@(_ ::& rs) vn = do-  pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs)---- | Helper function to construct instructions for unary arithmetic--- operations that should preserve annotations.-unaryArithImplAnnotated-  :: ( WellTyped (UnaryArithRes aop n)-     , inp ~ (n ': s)-     , Monad t-     , n ~ UnaryArithRes aop n-     )-  => Instr inp (UnaryArithRes aop n ': s)-  -> HST inp-  -> VarAnn-  -> t (SomeInstr inp)-unaryArithImplAnnotated mkInstr i@((n, _, _) ::& rs) vn = do-  pure $ i :/ mkInstr ::: ((n, Dict, vn) ::& rs)

− src/Michelson/TypeCheck/Instr.hs

@@ -1,1717 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, providing functions for conversion from--- instruction and value representation from @Michelson.Type@ module--- to strictly-typed GADT-based representation from @Michelson.Value@ module.------ This conversion is labeled as type check because that's what we are obliged--- to do on our way.------ Type check algorithm relies on the property of Michelson language that each--- instruction on a given input stack type produces a definite output stack--- type.--- Michelson contract defines concrete types for storage and parameter, from--- which input stack type is deduced. Then this type is being combined with--- each subsequent instruction, producing next stack type after each--- application.------ Function @typeCheck@ takes list of instructions and returns value of type--- @Instr inp out@ along with @HST inp@ and @HST out@ all wrapped into--- @SomeInstr@ data type. This wrapping is done to satsify Haskell type--- system (which has no support for dependent types).--- Functions @typeCheckInstr@, @typeCheckValue@ behave similarly.------ When a recursive call is made within @typeCheck@, @typeCheckInstr@ or--- @typeCheckValue@, result of a call is unwrapped from @SomeInstr@ and type--- information from @HST inp@ and @HST out@ is being used to assert that--- recursive call returned instruction of expected type--- (error is thrown otherwise).-module Michelson.TypeCheck.Instr-    ( typeCheckContract-    , typeCheckContractAndStorage-    , typeCheckInstr-    , typeCheckList-    , typeCheckListNoExcept-    , typeCheckParameter-    , typeCheckStorage-    , typeCheckTopLevelType-    , typeCheckValue-    , typeVerifyContract-    , typeVerifyParameter-    , typeVerifyStorage-    , typeVerifyTopLevelType-    ) where--import Prelude hiding (EQ, GT, LT)--import Control.Monad.Except (MonadError, catchError, liftEither, throwError)-import Data.Default (def)-import Data.Generics (everything, mkQ)-import Data.Singletons (Sing, demote, withSingI, withSomeSing)-import Data.Typeable ((:~:)(..))-import Fmt (pretty)-import Named ((!))--import Michelson.ErrorPos-import Michelson.TypeCheck.Error-import Michelson.TypeCheck.Ext-import Michelson.TypeCheck.Helpers-import Michelson.TypeCheck.TypeCheck-import Michelson.TypeCheck.TypeCheckedSeq-  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), someInstrToOp,-  tcsEither)-import Michelson.TypeCheck.Types-import Michelson.TypeCheck.Value-import Michelson.Typed.Value--import Michelson.Typed hiding (Branch(..))-import Util.Peano-import Util.PeanoNatural-import Util.Sing (SingI1(..))-import Util.Type (onFirst, type (++))--import qualified Michelson.Untyped as U-import Michelson.Untyped.Annotation (FieldTag, VarAnn, VarTag, annQ, convAnn, orAnn)---- | Type check a contract and verify that the given storage--- is of the type expected by the contract.-typeCheckContractAndStorage-  :: U.Contract -> U.Value -> TypeCheckResult SomeContractAndStorage-typeCheckContractAndStorage uContract uStorage = do-  SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract uContract-  storage <- typeVerifyStorage @st uStorage-  pure $ SomeContractAndStorage contract storage--typeCheckContract-  :: U.Contract-  -> TypeCheckResult SomeContract-typeCheckContract c = do-  paramType <- liftEither $ mkSomeParamType (U.contractParameter c)-  runTypeCheck (TypeCheckContract paramType) $ typeCheckContractImpl c--typeVerifyContract-  :: forall cp st.-     (SingI cp, SingI st)-  => U.Contract -> TypeCheckResult (Contract cp st)-typeVerifyContract uContract = do-  SomeContract tContract@(Contract{} :: Contract cp' st') <--    typeCheckContract uContract-  Refl <- requireEq @cp' @cp (mkErr TltParameterType)-  Refl <- requireEq @st' @st (mkErr TltParameterType)-  return tContract-  where-    mkErr :: TopLevelType -> T -> T -> TypeCheckResult any-    mkErr tyDesc got expected =-      throwError $ TCContractError "error in contract type" $ Just $-          UnexpectedTopLevelType tyDesc-            ! #expected expected-            ! #got got--withWTP :: forall t a. SingI t => (WellTyped t => TypeCheck a) -> TypeCheck a-withWTP fn = case getWTP @t of-  Right Dict -> fn-  Left (NotWellTyped t cause) -> throwError $ TCContractError-    ("Not a well typed value: '" <> show t <> "' because it " <> pretty cause) Nothing--withWTPInstr_ :: forall t a. SingI t => U.ExpandedInstr -> SomeHST -> (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a-withWTPInstr_ v t fn = case getWTP @t of-  Right Dict -> fn-  Left (NotWellTyped badType cause) -> do-    loc <- ask-    throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType cause)--withWTPInstr'_-  :: forall t inp. SingI t-  => U.ExpandedInstr-  -> SomeHST-  -> (WellTyped t => TypeCheckInstrNoExcept (TypeCheckedSeq inp))-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-withWTPInstr'_ v t fn = case getWTP @t of-  Right Dict -> fn-  Left (NotWellTyped badType cause) -> do-    loc <- ask-    let err = TCFailedOnInstr v t loc Nothing-              (Just $ UnsupportedTypeForScope badType cause)-    pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx v]--typeCheckContractImpl-  :: U.Contract-  -> TypeCheck SomeContract-typeCheckContractImpl (U.Contract wholeParam@(U.ParameterType mParam rootAnn) mStorage pCode entriesOrder) = do-  _ <- maybe (throwError $ TCContractError "no instructions in contract code" $ Just EmptyCode)-                pure (nonEmpty pCode)-  withUType mParam $ \(paramNote :: Notes param) ->-    withUType mStorage $ \(storageNote :: Notes st) -> do-      withWTP @st $ do-        withWTP @param $ do-          Dict <- either (hasTypeError @param "parameter") pure-            $ checkScope @(ParameterScope param)-          Dict <- either (hasTypeError @st "storage") pure-            $ checkScope @(StorageScope st)-          let param = [annQ|parameter|]-          let store = [annQ|storage|]-          let inpNote = NTPair def def def param store paramNote storageNote-          let inp = (inpNote, Dict, def) ::& SNil--          codeRes <- usingReaderT def $-                     liftNoExcept $-                     typeCheckImpl typeCheckInstr pCode inp-          codeRes & tcsEither-            (onFailedTypeCheck)-            (onSuccessfulTypeCheck (NTPair def def def def def starNotes storageNote))-  where-    hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a-    hasTypeError name reason = throwError $-      TCContractError ("contract " <> name <> " type error") $-      Just $ UnsupportedTypeForScope (demote @t) reason--    onFailedTypeCheck :: [TypeCheckedOp] -> TCError -> TypeCheck SomeContract-    onFailedTypeCheck ops err = do-      verbose <- asks tcVerbose-      throwError if verbose-        then TCIncompletelyTyped err U.Contract-             { contractParameter = wholeParam-             , contractStorage = mStorage-             , contractCode = ops-             , entriesOrder = entriesOrder-             }-        else err--    onSuccessfulTypeCheck-      :: forall st param-      . (ParameterScope param, StorageScope st, WellTyped st)-      => Notes (ContractOut1 st)-      -> SomeInstr (ContractInp param st)-      -> TypeCheck SomeContract-    onSuccessfulTypeCheck outNote i@(inp' :/ instrOut) = wrapErrorsIfVerbose i $ do-      let (paramNotesRaw, cStoreNotes) = case inp' of-            (NTPair _ _ _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes)-      cParamNotes <--        liftEither $-        mkParamNotes paramNotesRaw rootAnn `onFirst`-            (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl)-      case instrOut of-        instr ::: out -> liftEither $ do-          case eqHST1 @(ContractOut1 st) out of-            Right Refl -> do-              let (outN, _, _) ::& SNil = out-              _ <- converge outN outNote-                      `onFirst`-                  ((TCContractError "contract output type violates convention:") . Just . AnnError)-              pure $ SomeContract Contract-                { cCode = instr-                , cParamNotes-                , cStoreNotes-                , cEntriesOrder = entriesOrder-                }-            Left err -> Left $ TCContractError "contract output type violates convention:" $ Just err-        AnyOutInstr instr ->-          pure $ SomeContract Contract-            { cCode = instr-            , cParamNotes-            , cStoreNotes-            , cEntriesOrder = entriesOrder-            }--    wrapErrorsIfVerbose :: SomeInstr inp -> TypeCheck SomeContract -> TypeCheck SomeContract-    wrapErrorsIfVerbose instr action =-      action `catchError` (onFailedTypeCheck [someInstrToOp instr])---- | Function @typeCheckList@ converts list of Michelson instructions--- given in representation from @Michelson.Type@ module to representation--- in strictly typed GADT.------ Types are checked along the way which is neccessary to construct a--- strictly typed value.------ As a second argument, @typeCheckList@ accepts input stack type representation.-typeCheckList-  :: (SingI inp)-  => [U.ExpandedOp]-  -> HST inp-  -> TypeCheck (SomeInstr inp)-typeCheckList = throwingTCError' ... typeCheckListNoExcept---- | Function @typeCheckListNoExcept@ converts list of Michelson instructions--- given in representation from @Michelson.Type@ module to representation in a--- partially typed tree. See @TypeCheckedSeq@ and @TypeCheckedOp@.------ Types are checked along the way. It is necessary to embed well typed node as--- well as type checking errors into the tree.-typeCheckListNoExcept-  :: (SingI inp)-  => [U.ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)-typeCheckListNoExcept = usingReaderT def ... typeCheckImpl typeCheckInstr---- | Function @typeCheckValue@ converts a single Michelson value--- given in representation from @Michelson.Untyped@ module hierarchy to--- representation in strictly typed GADT.------ @typeCheckValue@ is polymorphic in the expected type of value.------ Type checking algorithm pattern-matches on parse value representation,--- expected type @t@ and constructs @Value t@ value.------ If there was no match on a given pair of value and expected type,--- that is interpreted as input of wrong type and type check finishes with--- error.-typeCheckValue-  :: forall t. SingI t-  => U.Value-  -> TypeCheckInstr (Value t)-typeCheckValue = typeCheckValImpl @t Nothing typeCheckInstr--typeVerifyParameter-  :: SingI t-  => TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)-typeVerifyParameter originatedContracts = typeVerifyTopLevelType (Just originatedContracts)--typeVerifyStorage-  :: SingI t-  => U.Value -> TypeCheckResult (Value t)-typeVerifyStorage = typeVerifyTopLevelType Nothing--typeVerifyTopLevelType-  :: forall t. SingI t-  => Maybe TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)-typeVerifyTopLevelType mOriginatedContracts valueU =-  runTypeCheck (TypeCheckValue (valueU, demote @t)) $ usingReaderT def $-    typeCheckValImpl mOriginatedContracts typeCheckInstr valueU---- | Like 'typeCheckValue', but for values to be used as parameter.------ Also accepts a 'TcOriginatedContracts' in order to be able to type-check--- @contract p@ values (which can only be part of a parameter).-typeCheckParameter-  :: TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult SomeValue-typeCheckParameter originatedContracts = typeCheckTopLevelType (Just originatedContracts)---- | Like 'typeCheckValue', but for values to be used as storage.-typeCheckStorage-  :: U.Ty -> U.Value -> TypeCheckResult SomeValue-typeCheckStorage = typeCheckTopLevelType Nothing--typeCheckTopLevelType-  :: Maybe TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult SomeValue-typeCheckTopLevelType mOriginatedContracts typeU valueU =-  withSomeSing (fromUType typeU) $ \(s :: Sing t) ->-    withSingI s $ SomeValue <$> typeVerifyTopLevelType @t mOriginatedContracts valueU---- | Helper data type we use to typecheck DUPN.-data TCDupNHelper inp where-  TCDupNHelper ::-    forall (n :: Peano) inp out a.-    (SingI out, ConstraintDUPN n inp out a, DupableScope a) =>-    PeanoNatural n -> HST out -> TCDupNHelper inp---- | Helper data type we use to typecheck DROPN.-data TCDropHelper inp where-  TCDropHelper ::-    forall (n :: Peano) inp out.-    (SingI out, LongerOrSameLength inp n, Drop n inp ~ out) =>-    PeanoNatural n -> HST out -> TCDropHelper inp---- | Helper data type we use to typecheck DIG.-data TCDigHelper inp where-  TCDigHelper ::-    forall (n :: Peano) inp out a.-    (SingI out, ConstraintDIG n inp out a) =>-    PeanoNatural n -> HST out -> TCDigHelper inp---- | Helper data type we use to typecheck DUG.-data TCDugHelper inp where-  TCDugHelper ::-    forall (n :: Peano) inp out a.-    (SingI out, ConstraintDUG n inp out a) =>-    PeanoNatural n -> HST out -> TCDugHelper inp---- | Helper data type we use to typecheck PAIRN.------ It holds all the necessary data to construct a typed PAIRN--- instruction once we're done traversing the stack.-data TCPairNHelper inp where-  TCPairNHelper ::-    forall (n :: Peano) (inp :: [T]).-    (SingI (PairN n inp), ConstraintPairN n inp) =>-    PeanoNatural n -> HST (PairN n inp) -> TCPairNHelper inp---- | Helper data type we use to typecheck UNPAIRN.------ It holds all the necessary data to construct a typed UNPAIRN--- instruction once we're done traversing the pair.-data TCUnpairNHelper (inp :: [T]) where-  TCUnpairNHelper ::-    forall (n :: Peano) (a :: T) (b :: T) (rest :: [T]).-    (SingI (UnpairN n ('TPair a b) ++ rest), ConstraintUnpairN n ('TPair a b)) =>-    PeanoNatural n -> HST (UnpairN n ('TPair a b) ++ rest) -> TCUnpairNHelper ('TPair a b : rest)---- | Helper data type we use to typecheck GETN.------ It holds all the necessary data to construct a typed GETN--- instruction once we're done traversing the pair.-data TCGetNHelper (inp :: [T]) where-  TCGetNHelper ::-    forall (ix :: Peano) (pair :: T) (rest :: [T]).-    (SingI (GetN ix pair ': rest), ConstraintGetN ix pair) =>-    PeanoNatural ix -> HST (GetN ix pair ': rest) -> TCGetNHelper (pair : rest)---- | Helper data type we use to typecheck UPDATEN.------ It holds all the necessary data to construct a typed UPDATEN--- instruction once we're done traversing the pair.-data TCUpdateNHelper (inp :: [T]) where-  TCUpdateNHelper ::-    forall (ix :: Peano) (val :: T) (pair :: T) (rest :: [T]).-    (SingI (UpdateN ix val pair ': rest), ConstraintUpdateN ix pair) =>-    PeanoNatural ix -> HST (UpdateN ix val pair ': rest) -> TCUpdateNHelper (val : pair : rest)---- | Helper function to convert a simple throwing typechecking action into a--- non-throwing one, embedding possible errors into the type checking tree.-workOnInstr-  :: U.ExpandedInstr-  -> TypeCheckInstr (SomeInstr s)-  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)-workOnInstr instr = tcEither-  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr])-  (pure . WellTypedSeq)---- | Less verbose version of `lift ... typeCheckListNoExcept`.-tcList-  :: (SingI inp)-  => [U.ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-tcList ops stack = lift $ typeCheckListNoExcept ops stack---- | Function @typeCheckInstr@ converts a single Michelson instruction--- given in representation from @Michelson.Type@ module to representation--- in strictly typed GADT.------ As a second argument, @typeCheckInstr@ accepts input stack type representation.------ Type checking algorithm pattern-matches on given instruction, input stack--- type and constructs strictly typed GADT value, checking necessary type--- equalities when neccessary.------ If there was no match on a given pair of instruction and input stack,--- that is interpreted as input of wrong type and type check finishes with--- error.-typeCheckInstr :: TcInstrHandler-typeCheckInstr uInstr inp = case (uInstr, inp) of-  (U.EXT ext, si) ->-    typeCheckExt typeCheckInstr ext si--  (U.DROP, _ ::& rs) -> workOnInstr uInstr $ pure $ inp :/ DROP ::: rs--  (U.DROP, SNil) -> notEnoughItemsOnStack--  (U.DROPN nTotal, inputHST) -> workOnInstr uInstr $-    go nTotal inputHST <&> \case-      TCDropHelper s out -> inputHST :/ DROPN s ::: out-    where-      go :: forall inp. SingI inp-        => Word-        -> HST inp-        -> TypeCheckInstr (TCDropHelper inp)-      go = curry \case-        (0, i) -> pure (TCDropHelper Zero i)--        (_, SNil) -> notEnoughItemsOnStack'--        (n, (_ ::& iTail)) -> do-          go (n - 1) iTail <&> \(TCDropHelper s out) -> TCDropHelper (Succ s) out--  (U.DUP vn1, a@(n :: Notes t, d, _vn2) ::& rs) -> workOnInstr uInstr $ do-    Dict <--      onScopeCheckInstrErr @t uInstr (SomeHST inp) Nothing $-      checkScope @(DupableScope t)-    pure (inp :/ DUP ::: ((n, d, vn1) ::& a ::& rs))--  (U.DUP _vn, SNil) -> notEnoughItemsOnStack--  (U.DUPN vn nTotal, inputHST) -> workOnInstr uInstr $-    go nTotal inputHST <&> \(TCDupNHelper s out) -> inputHST :/ DUPN s ::: out-    where-      go :: forall inp. SingI inp-        => Word-        -> HST inp-        -> TypeCheckInstr (TCDupNHelper inp)-      go = curry \case-        (_, SNil) -> notEnoughItemsOnStack'--        (0, _) ->-          typeCheckInstrErr' uInstr (SomeHST inp) Nothing (InvalidInstruction uInstr "'DUP n' expects n > 0")--        -- Don't bind whatever variable annotation is here because DUP n doesn't-        -- duplicate variable annotations. This is consistent with tezos-client.-        (1, i@((an :: Notes a, dict, _) ::& _)) -> do-          Dict <--            onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing $-            checkScope @(DupableScope a)-          pure (TCDupNHelper One ((an, dict, vn) ::& i))--        (n, (b ::& iTail)) ->-          go (n - 1) iTail <&> \(TCDupNHelper s@(Succ _) (a ::& resTail)) ->-            TCDupNHelper (Succ s) (a ::& b ::& resTail)--  (U.SWAP, a ::& b ::& rs) -> workOnInstr uInstr $-    pure (inp :/ SWAP ::: (b ::& a ::& rs))--  (U.SWAP, _) -> notEnoughItemsOnStack--  (U.DIG nTotal, inputHST) -> workOnInstr uInstr $-    go nTotal inputHST <&> \(TCDigHelper s out) -> inputHST :/ DIG s ::: out-    where-      go :: forall inp. SingI inp-        => Word-        -> HST inp-        -> TypeCheckInstr (TCDigHelper inp)-      go = curry \case-        -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).-        (_, SNil) -> notEnoughItemsOnStack'--        (0, i@(_ ::& _)) -> pure (TCDigHelper Zero i)--        (n, (b ::& iTail)) ->-          go (n - 1) iTail <&> \(TCDigHelper s (a ::& resTail)) ->-            TCDigHelper (Succ s) (a ::& b ::& resTail)--  (U.DUG nTotal, inputHST) -> workOnInstr uInstr $-    go nTotal inputHST <&> \(TCDugHelper s out) -> inputHST :/ DUG s ::: out-    where-      go :: forall inp. SingI inp-        => Word-        -> HST inp-        -> TypeCheckInstr (TCDugHelper inp)-      go = curry \case-        (0, i@(_ ::& _)) -> pure (TCDugHelper Zero i)--        (n, (a ::& b ::& iTail)) ->-          go (n - 1) (a ::& iTail) <&> \(TCDugHelper s resTail) ->-            TCDugHelper (Succ s) (b ::& resTail)--        -- Two cases:-        -- 1. Input stack is empty.-        -- 2. n > 0 and input stack has exactly 1 item.-        _ -> notEnoughItemsOnStack'--  (U.PUSH vn mt mval, i) -> workOnInstr uInstr $-    withUType mt $ \(nt :: Notes t) -> do-      val <- typeCheckValue @t mval-      proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST i) Nothing-        $ checkScope @(ConstantScope t)-      case proofScope of-        Dict -> withWTPInstr @t $ pure $ i :/ PUSH val ::: ((nt, Dict, vn) ::& i)--  (U.SOME tn vn, (an, Dict, _) ::& rs) -> workOnInstr uInstr $-    pure (inp :/ SOME ::: ((NTOption tn an, Dict, vn) ::& rs))--  (U.SOME _ _, SNil) -> notEnoughItemsOnStack--  (U.NONE tn vn elMt, _) -> workOnInstr uInstr $-    withUType elMt $ \(elNotes :: Notes t) ->-      withWTPInstr @t $-        pure $ inp :/ NONE ::: ((NTOption tn elNotes, Dict, vn) ::& inp)--  (U.UNIT tn vn, _) -> workOnInstr uInstr $-    pure $ inp :/ UNIT ::: ((NTUnit tn, Dict, vn) ::& inp)--  (U.IF_NONE mp mq, (STOption{}, (ons :: Notes ('TOption a)), Dict, ovn) ::&+ rs) -> do-    let (an, avn) = deriveNsOption ons ovn-    withWTPInstr' @a $-      genericIf IF_NONE U.IF_NONE mp mq rs ((an, Dict, avn) ::& rs) inp--  (U.IF_NONE _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ ("option 'a" :| []) :| []--  (U.IF_NONE _ _, SNil) -> notEnoughItemsOnStack--  (U.PAIR tn vn pfn qfn, (an :: Notes a, _, avn) ::& (bn :: Notes b, _, bvn) ::& rs) -> workOnInstr uInstr $ do-    let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn vn-    withWTPInstr @('TPair a b) $-      pure (inp :/ AnnPAIR tn pfn qfn ::: ((NTPair tn pfn' qfn' avn bvn an bn, Dict, vn') ::& rs))--  (U.PAIR {}, _) -> notEnoughItemsOnStack-  (U.UNPAIR instrVn1 instrVn2 instrFn1 instrFn2, (NTPair _ fn1 fn2 vn1 vn2 n1 n2, Dict, vn) ::& rs) ->-    workOnInstr uInstr $ do-      -- We purposefully ignore the result of `convergeDestrAnns` here.-      -- We're only interested in checking that the instruction's field ann matches the pair's field ann,-      -- we don't need to "unify" them.-      _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn1 instrFn1)-      _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn2 instrFn2)--      let vn1' = deriveSpecialVN instrVn1 fn1 vn vn1-      let vn2' = deriveSpecialVN instrVn2 fn2 vn vn2-      pure $-        inp :/ AnnUNPAIR instrVn1 instrVn2 instrFn1 instrFn2 :::-          ( (n1, Dict, vn1') ::&-            (n2, Dict, vn2') ::&-            rs-          )--  (U.UNPAIR {}, _ ::& _) ->-    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []--  (U.UNPAIR {}, _) -> notEnoughItemsOnStack-  (U.PAIRN varAnn nTotal, _) -> workOnInstr uInstr $ do-    go nTotal inp <&> \case-      TCPairNHelper s out -> inp :/ PAIRN s ::: addVarAnn out-    where-      go :: forall inp. Word -> HST inp -> TypeCheckInstr (TCPairNHelper inp)-      go n hst-        | n < 2 =-            typeCheckInstrErr' uInstr (SomeHST inp) Nothing-              (InvalidInstruction uInstr "'PAIR n' expects n ≥ 2")-        | n == 2 =-            case hst of-              (an :: Notes a, _, _) ::& (bn :: Notes b, _, _) ::& hstTail -> do-                withWTPInstr @('TPair a b) $ do-                  pure $ TCPairNHelper Two $-                    (mkNotes an bn, Dict, U.noAnn) ::& hstTail-              _ -> notEnoughItemsOnStack'-        | otherwise =-            case hst of-              (an :: Notes a, _, _) ::& hstTail@(_ ::& _ ::& _) -> do-                go (n - 1) hstTail >>= \case-                  TCPairNHelper nSing@(Succ (Succ _)) ((bn :: Notes b, _, _) ::& hstTail') -> do-                    withWTPInstr @('TPair a b) $ do-                      pure $ TCPairNHelper (Succ nSing) $-                        (mkNotes an bn, Dict, U.noAnn) ::& hstTail'-              _ -> notEnoughItemsOnStack'--      mkNotes :: forall a b. Notes a -> Notes b -> Notes ('TPair a b)-      mkNotes an bn =-        NTPair U.noAnn-          U.noAnn U.noAnn-          U.noAnn U.noAnn-          an bn--      -- | If a @PAIR n@ instruction has a variable annotation,-      -- the var annotation should be added ONLY to the top-most @pair@ value.-      ---      -- > /* [ nat : nat : nat ] */ ;-      -- > PAIR @aa 3-      -- > /* [ @aa pair nat nat nat ] */ ;-      addVarAnn :: forall a inp. HST (a ': inp) -> HST (a ': inp)-      addVarAnn = \case-        (an, dict, _) ::& hstTail -> (an, dict, varAnn) ::& hstTail--  (U.UNPAIRN _, SNil) -> notEnoughItemsOnStack-  (U.UNPAIRN nTotal, _ ::& _) -> workOnInstr uInstr $ do-    go nTotal inp <&> \case-      TCUnpairNHelper s out ->-        inp :/ UNPAIRN s ::: out-    where-      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCUnpairNHelper (x : xs))-      go n hst-        | n < 2 =-            typeCheckInstrErr' uInstr (SomeHST inp) Nothing-              (InvalidInstruction uInstr "UNPAIR expects an argument of at least 2.")-        | n == 2 =-            case hst of-              (NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes, Dict, _) ::& rest -> do-                pure $ TCUnpairNHelper Two $-                  (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn)-                  ::& (bNotes, Dict, convAnn @FieldTag @VarTag bFieldAnn)-                  ::& rest-              _ -> unexpectedType-        | otherwise =-            case hst of-              (NTPair _ aFieldAnn _ _ _ aNotes bNotes, Dict, _) ::& rest -> do-                go (n - 1) ((bNotes, Dict, U.noAnn) ::& rest) >>= \case-                  TCUnpairNHelper nSing@(Succ (Succ _)) out -> do-                    pure $ TCUnpairNHelper (Succ nSing) $-                      (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn) ::& out-              _ -> unexpectedType--      unexpectedType :: TypeCheckInstr a-      unexpectedType = failWithErr' $ UnexpectedType $ (pairWithElems nTotal :| []) :| []--  (U.CAR vn fn, (STPair{}, NTPair _ pfn _ pvn _ pns _, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do-    -- We purposefully ignore the result of `convergeDestrAnns` here.-    -- We're only interested in checking that the instruction's field ann matches the pair's field ann,-    -- we don't need to "unify" them.-    _ <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeDestrAnns fn pfn)-    let vn' = deriveSpecialVN vn pfn pairVN pvn-    pure $ inp :/ AnnCAR vn fn ::: ((pns, Dict, vn') ::& rs)--  (U.CAR _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []--  (U.CAR _ _, SNil) -> notEnoughItemsOnStack--  (U.CDR vn fn, (STPair{}, NTPair _ _ qfn _ qvn _ qns, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do-    -- We purposefully ignore the result of `convergeDestrAnns` here.-    -- We're only interested in checking that the instruction's field ann matches the pair's field ann,-    -- we don't need to "unify" them.-    _ <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeDestrAnns fn qfn)-    let vn' = deriveSpecialVN vn qfn pairVN qvn-    pure $ inp :/ AnnCDR vn fn ::: ((qns, Dict, vn') ::& rs)--  (U.CDR _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []--  (U.CDR _ _, SNil) -> notEnoughItemsOnStack--  (U.LEFT tn vn pfn qfn bMt, (an :: Notes l, Dict, avn) ::& rs) ->-    withUType bMt $ \(bn :: Notes r) -> workOnInstr uInstr $ do-      let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn U.noAnn vn-      withWTPInstr @r $ do-        let ns = NTOr tn pfn' qfn' an bn-        pure (inp :/ AnnLEFT tn pfn qfn ::: ((ns, Dict, vn') ::& rs))--  (U.LEFT {}, SNil) -> notEnoughItemsOnStack--  (U.RIGHT tn vn pfn qfn aMt, (bn :: Notes r, Dict, bvn) ::& rs) ->-    withUType aMt $ \(an :: Notes l) -> workOnInstr uInstr $ do-      let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn U.noAnn bvn vn-      withWTPInstr @l $ do-        let ns = NTOr tn pfn' qfn' an bn-        pure (inp :/ AnnRIGHT tn pfn qfn ::: ((ns, Dict, vn') ::& rs))--  (U.RIGHT {}, SNil) -> notEnoughItemsOnStack--  (U.IF_LEFT mp mq, (STOr lt rt, ons, _, ovn) ::&+ rs) -> do-    case deriveNsOr ons ovn of-      (an :: Notes a, bn :: Notes b, avn, bvn) -> withSingI lt $ withSingI rt $-        withWTPInstr' @a $-          withWTPInstr' @b $ do-            let-              ait = (an, Dict, avn) ::& rs-              bit = (bn, Dict, bvn) ::& rs-            genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp--  (U.IF_LEFT _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ ("or 'a 'b" :| []) :| []--  (U.IF_LEFT _ _, SNil) -> notEnoughItemsOnStack--  (U.NIL tn vn elMt, i) -> workOnInstr uInstr $-    withUType elMt $ \(elNotes :: Notes t) ->-      withWTPInstr @('TList t) $-        pure $ i :/ NIL ::: ((NTList tn elNotes, Dict, vn) ::& i)--  (U.CONS vn, ((an :: Notes a), _, _)-                ::& ((ln :: Notes l), _, _) ::& rs) -> workOnInstr uInstr-    case eqType @('TList a) @l of-      Right Refl -> do-        (n :: Notes t) <- onTypeCheckInstrAnnErr uInstr inp (Just ConsArgument) (converge ln (NTList def an))-        withWTPInstr @t $-          pure $ inp :/ CONS ::: ((n, Dict, vn) ::& rs)-      Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just ConsArgument) m--  (U.CONS _, _) -> notEnoughItemsOnStack--  (U.IF_CONS mp mq, (STList{}, ns, Dict, vn) ::&+ rs) -> do-    case ns of-      NTList _ (an :: Notes t1) -> withWTPInstr' @t1 $ do-        let ait = (an, Dict, vn) ::& (ns, Dict, vn) ::& rs-        genericIf IF_CONS U.IF_CONS mp mq ait rs inp--  (U.IF_CONS _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ ("list 'a" :| []) :| []--  (U.IF_CONS _ _, SNil)-> notEnoughItemsOnStack--  (U.SIZE vn, (NTList{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn-  (U.SIZE vn, (NTSet{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn-  (U.SIZE vn, (NTMap{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn-  (U.SIZE vn, (NTString{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn-  (U.SIZE vn, (NTBytes{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn-  (U.SIZE _, _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("list 'a" :| []) :|-      [ ("set 'a" :| [])-      , ("map 'k 'v" :| [])-      , ("string" :| [])-      , ("bytes" :| [])-      ]--  (U.SIZE _, SNil) -> notEnoughItemsOnStack--  (U.EMPTY_SET tn vn mv, i) -> workOnInstr uInstr $-    withUType mv $ \(vns :: Notes v) ->-      withWTPInstr @('TSet v) $-        withCompareableCheck (notesSing vns) uInstr inp $ i :/ EMPTY_SET ::: ((STSet sing, NTSet tn vns, Dict, vn) ::&+ i)--  (U.EMPTY_MAP tn vn mk mv, i) -> workOnInstr uInstr $ do-    withUType mv $ \(vns :: Notes v)  ->-      withUType mk $ \(ktn :: Notes k) ->-        withWTPInstr @('TMap k v) $-          withCompareableCheck (notesSing ktn) uInstr inp $ i :/ EMPTY_MAP ::: ((STMap sing sing, NTMap tn ktn vns, Dict, vn) ::&+ i)--  (U.EMPTY_BIG_MAP tn vn mk mv, i) -> workOnInstr uInstr $-    withUType mv $ \(vns :: Notes v)  ->-      withUType mk $ \(ktn :: Notes k) ->-        withWTPInstr @('TBigMap k v) $-          withCompareableCheck (notesSing ktn) uInstr inp $ i :/ EMPTY_BIG_MAP ::: ((STBigMap sing sing, NTBigMap tn ktn vns, Dict, vn) ::&+ i)--  (U.MAP vn mp, (STList l, NTList _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> withSingI l $ do-    withWTPInstr' @t1 $-      mapImpl (U.MAP vn) vns uInstr mp inp-        (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $ (NTList def rn, Dict, vn) ::& hst)--  (U.MAP vn mp, (STMap k v, NTMap _ kns vns, Dict, _vn) ::&+ _) -> withSingI k $ withSingI v $ do-    case NTPair def def def def def kns vns of-      (pns :: Notes ('TPair k v1)) ->-        withWTPInstr' @('TPair k v1) $-          mapImpl (U.MAP vn) pns uInstr mp inp-             (\(rn :: Notes v) hst -> withWTPInstr @('TMap k v) $ pure $ (NTMap def kns rn, Dict, vn) ::& hst)--  (U.MAP _ _, _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("list 'a" :| []) :|-      [ ("map 'k 'v" :| [])-      ]--  (U.MAP _ _, SNil) -> notEnoughItemsOnStack--  (U.ITER is, (STSet (s :: Sing t1), NTSet _ en, _, _) ::&+ _) -> withSingI s $ do-    withWTPInstr' @t1 $-      iterImpl en uInstr is inp--  (U.ITER is, (STList (l :: Sing t1), NTList _ en, _, _) ::&+ _) -> withSingI l $ do-    withWTPInstr' @t1 $-      iterImpl en uInstr is inp--  (U.ITER is, (STMap k v, NTMap _ kns vns, _, _) ::&+ _) -> withSingI k $ withSingI v $ do-    case NTPair def def def def def kns vns of-      (en :: Notes ('TPair a b)) ->-        withWTPInstr' @('TPair a b) $ iterImpl en uInstr is inp--  (U.ITER _, _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("set 'a" :| []) :|-      [ ("list 'a" :| [])-      , ("map 'k 'v" :| [])-      ]--  (U.ITER _, SNil) -> notEnoughItemsOnStack--  (U.MEM varNotes,-   _ ::& (STSet s, NTSet _ notesK, _, _) ::&+ _) -> withSingI s $ workOnInstr uInstr $-    memImpl notesK inp varNotes-  (U.MEM varNotes,-   _ ::& (STMap k v, NTMap _ notesK _, _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $-    memImpl notesK inp varNotes-  (U.MEM varNotes,-   _ ::& (STBigMap k v, NTBigMap _ notesK _, _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $-    memImpl notesK inp varNotes-  (U.MEM _, _ ::& _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("'a" :| ["set 'a"]) :|-      [ ("'k" :| ["map 'k 'v"])-      , ("'k" :| ["big_map 'k 'v"])-      ]--  (U.MEM _, _) -> notEnoughItemsOnStack--  (U.GET varNotes,-   _ ::& (STMap k v, NTMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $-      getImpl notesK inp notesV varNotes-  (U.GET varNotes,-   _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $-      getImpl notesK inp notesV varNotes--  (U.GET _, _ ::& _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("'k" :| ["map 'k 'v"]) :|-      [ ("'k" :| ["big_map 'k 'v"])-      ]--  (U.GET _, _) -> notEnoughItemsOnStack--  (U.GETN _ _, SNil) -> notEnoughItemsOnStack-  (U.GETN getNVarAnn ix0, _ ::& _) -> workOnInstr uInstr $ do-    go ix0 inp <&> \case-      TCGetNHelper s out ->-        inp :/ GETN s ::: out-    where-      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCGetNHelper (x : xs))-      go 0 ((a, Dict, _) ::& rest) =-        pure $ TCGetNHelper Zero ((a, Dict, getNVarAnn) ::& rest)-      go 1 ((NTPair _ _ _ _ _ leftNotes _, Dict, _) ::& rest) =-        pure $ TCGetNHelper One $ (leftNotes, Dict, getNVarAnn) ::& rest-      go ix ((NTPair _ _ _ _ _ _ rightNotes, Dict, _) ::& rest) =-        go (ix - 2) ((rightNotes, Dict, U.noAnn) ::& rest) <&> \(TCGetNHelper ixSing out) ->-          TCGetNHelper (Succ (Succ ixSing)) out-      go _ _ = failWithErr' $ UnexpectedType $ (pairWithNodeIndex ix0 :| []) :| []--  (U.UPDATE varAnn,-   _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn-  (U.UPDATE varAnn,-   _ ::& _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn-  (U.UPDATE varAnn,-   _ ::& _ ::& (STSet s, NTSet _ (notesK :: Notes k), _, _) ::&+ _) ->-    withSingI s $ workOnInstr uInstr $ updImpl notesK inp (NTBool U.noAnn) varAnn--  (U.UPDATE _, _ ::& _ ::& _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("'a" :| ["bool", "set 'a"]) :|-      [ ("'k" :| ["option 'v", "map 'k 'v"])-      , ("'k" :| ["option 'v", "big_map 'k 'v"])-      ]--  (U.UPDATE _, _) -> notEnoughItemsOnStack--  (U.UPDATEN updateNVarAnn ix0, _ ::& _ ::& _) -> workOnInstr uInstr $ do-    go ix0 inp <&> \case-      TCUpdateNHelper s out ->-        inp :/ UPDATEN s ::: out-    where-      go :: forall val pair rest. Word -> HST (val : pair : rest) -> TypeCheckInstr (TCUpdateNHelper (val : pair : rest))-      go 0 ((valNotes, Dict, _) ::& (_, _, _) ::& rest) =-        pure $ TCUpdateNHelper Zero $-          (valNotes, Dict, updateNVarAnn) ::& rest-      go 1 ((valNotes, Dict, _) ::& (NTPair pairTA leftFA rightFA leftVA rightVA _ rightNotes, Dict, _) ::& rest) =-        pure $ TCUpdateNHelper One $-          (NTPair pairTA leftFA rightFA leftVA rightVA valNotes rightNotes, Dict, updateNVarAnn) ::& rest-      go ix (val ::& (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes rightNotes, Dict, _) ::& rest) =-        go (ix - 2) (val ::& (rightNotes, Dict, U.noAnn) ::& rest) <&>-          \(TCUpdateNHelper ixSing ((updatedRightNotes, Dict, _) ::& outRest)) ->-            TCUpdateNHelper (Succ (Succ ixSing)) $-              (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes updatedRightNotes, Dict, updateNVarAnn) ::& outRest-      go _ _ = failWithErr' $ UnexpectedType $ ("'val" :| [pairWithNodeIndex ix0]) :| []-  (U.UPDATEN _ _, _) -> notEnoughItemsOnStack--  (U.GET_AND_UPDATE varAnn,-   _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $-      withWTPInstr @v $-        getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn-  (U.GET_AND_UPDATE varAnn,-   _ ::& _ ::& (STBigMap k v, (NTBigMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->-    withSingI k $ withSingI v $ workOnInstr uInstr $-      withWTPInstr @v $-        getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn-  (U.GET_AND_UPDATE _, _ ::& _ ::& _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("'k" :| ["option 'v", "map 'k 'v"]) :|-      [ ("'k" :| ["option 'v", "big_map 'k 'v"])-      ]-  (U.GET_AND_UPDATE _, _) -> notEnoughItemsOnStack--  (U.IF mp mq, (NTBool{}, _, _) ::& rs) ->-    genericIf IF U.IF mp mq rs rs inp--  (U.IF _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ ("bool" :| []) :| []--  (U.IF _ _, SNil) -> notEnoughItemsOnStack--  (U.LOOP is, (NTBool{}, _, _) ::& (rs :: HST rs)) -> do-    preserving (tcList is rs) U.LOOP $ \(_ :/ tp) ->-      case tp of-        subI ::: (o :: HST o) -> do-          case eqHST o (sing @'TBool -:& rs) of-            Right Refl -> pure $ inp :/ LOOP subI ::: rs-            Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m-        AnyOutInstr subI ->-          pure $ inp :/ LOOP subI ::: rs--  (U.LOOP _, _ ::& _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("bool" :| []) :| []--  (U.LOOP _, _) -> notEnoughItemsOnStack--  (U.LOOP_LEFT is, (os@STOr{}, ons, Dict, ovn) ::&+ rs) -> do-    case deriveNsOr ons ovn of-      (an :: Notes t, bn :: Notes b, avn, bvn) -> do-        withWTPInstr' @t $ withWTPInstr' @b $ do-          let ait = (an, Dict, avn) ::& rs-          preserving (tcList is ait) U.LOOP_LEFT $ \(_ :/ tp) ->-            case tp of-              subI ::: o -> do-                case (eqHST o (os -:& rs), o) of-                  (Right Refl, ((ons', Dict, ovn') ::& rs')) -> do-                      let (_, bn', _, bvn') = deriveNsOr ons' ovn'-                      br <- onTypeCheckInstrAnnErr uInstr inp-                              (Just Iteration)-                              (convergeHSTEl (bn, Dict, bvn) (bn', Dict, bvn'))-                      pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs')-                  (Left m, _) -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m-              AnyOutInstr subI -> do-                let br = (bn, Dict, bvn)-                pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs)--  (U.LOOP_LEFT _, _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("or 'a 'b" :| []) :| []--  (U.LOOP_LEFT _, _) -> notEnoughItemsOnStack--  (U.LAMBDA vn p1@(AsUType (ins :: Notes t)) p2@(AsUType (ons :: Notes u)) is, i) -> do-    -- further processing is extracted into another function just not to-    -- litter our main typechecking logic-    withWTPInstr' @t $-      withWTPInstr' @u $-        lamImpl (U.LAMBDA vn p1 p2) uInstr is vn ins ons i--  (U.EXEC vn, ((tn :: Notes t1), _, _)-                              ::& ( STLambda v b-                                  , NTLambda _ (t1n :: Notes t1') (t2n :: Notes t2')-                                  , _-                                  , _-                                  )-                              ::&+ rs) -> withSingI v $ withSingI b $ workOnInstr uInstr $ do-    Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)-                  (eqType @t1 @t1')-    (Refl, _) <- errM $ matchTypes tn t1n-    withWTPInstr @t2' $ pure $ inp :/ EXEC ::: ((t2n, Dict, vn) ::& rs)-      where-        errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a-        errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)--  (U.EXEC _, _ ::& _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("'a" :| ["lambda 'a 'b"]) :| []--  (U.EXEC _, _) -> notEnoughItemsOnStack--  (U.APPLY vn, ((_ :: Notes a'), _, _)-                  ::& ( STLambda (STPair lt rt) b-                      , NTLambda vann (NTPair _ _ _ _ _ (_ :: Notes a) (nb :: Notes b)) sc-                      , _-                      , _)-                  ::&+ rs) -> withSingI lt $ withSingI rt $ withSingI b $ workOnInstr uInstr $ do-    case NTLambda vann nb sc of-      (l2n :: Notes ('TLambda t1 t2)) -> withWTPInstr @('TLambda t1 t2) $ do--        proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)-                      (eqType @a' @a)-        proofScope <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just LambdaArgument)-          $ checkScope @(ConstantScope a)-        case (proofArgEq, proofScope) of-          (Refl, Dict) ->-            pure $ inp :/ (APPLY @a) ::: ((l2n, Dict, vn) ::& rs)--  (U.APPLY _, _ ::& _ ::& _) ->-    failWithErr $ UnexpectedType-      $ ("'a" :| ["lambda (pair 'a 'b) 'c"]) :| []--  (U.APPLY _, _) -> notEnoughItemsOnStack--  (U.DIP is, a ::& s) -> do-    typeCheckDipBody U.DIP uInstr is s-      (IllTypedSeq)-      (\subI t -> WellTypedSeq $ inp :/ DIP subI ::: (a ::& t))--  (U.DIP _is, SNil) -> notEnoughItemsOnStack--  (U.DIPN nTotal instructions, inputHST) ->-    go nTotal inputHST <&> \case-      TCDipHelperErr err rest -> IllTypedSeq err rest-      TCDipHelperOk s subI out -> WellTypedSeq $ inputHST :/ DIPN s subI ::: out-    where-      go :: forall inp. SingI inp-        => Word-        -> HST inp-        -> TypeCheckInstrNoExcept (TCDipHelper inp)-      go n curHST = case (n, curHST) of-        (0, _) -> typeCheckDipBody (U.DIPN nTotal) uInstr instructions curHST-          (TCDipHelperErr)-          (TCDipHelperOk Zero)-        (_, SNil) -> do-          pos <- ask-          let err = TCFailedOnInstr uInstr (SomeHST inp) pos Nothing (Just NotEnoughItemsOnStack)-          pure $ TCDipHelperErr err [NonTypedInstr $ U.PrimEx uInstr]-        (_, hstHead ::& hstTail) ->-          go (n - 1) hstTail <&> \case-          TCDipHelperOk s subI out -> TCDipHelperOk (Succ s) subI (hstHead ::& out)-          TCDipHelperErr err rest -> TCDipHelperErr err rest--  (u, v) -> case (u, v) of -- Workaround for not exceeding -fmax-pmcheck-iterations limit-    (U.FAILWITH, ((_ :: Notes a, _, _) ::& _)) -> workOnInstr uInstr $ do-      Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just FailwithArgument)-        $ checkScope @(ConstantScope a)-      pure $ inp :/ AnyOutInstr FAILWITH--    (U.FAILWITH, _) -> notEnoughItemsOnStack--    (U.CAST vn (AsUType (castToNotes :: Notes t)), (en, _, evn) ::& rs) ->-      workOnInstr uInstr $ do-        (Refl, _) <- errM $ matchTypes en castToNotes-        withWTPInstr @t $-          pure $ inp :/ CAST ::: ((castToNotes, Dict, vn `orAnn` evn) ::& rs)-      where-        errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a-        errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just Cast)--    (U.CAST _ _, _) -> notEnoughItemsOnStack--    (U.RENAME vn, (an, Dict, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ RENAME ::: ((an, Dict, vn) ::& rs)--    (U.RENAME _, SNil) -> notEnoughItemsOnStack--    (U.UNPACK tn vn mt, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $-      withUType mt $ \(tns :: Notes tn) -> do-        case NTOption tn tns of-          (ns :: Notes ('TOption t1)) -> withWTPInstr @('TOption t1) $ do-            Dict <- onScopeCheckInstrErr @tn uInstr (SomeHST inp) Nothing-              $ checkScope @(UnpackedValScope tn)-            pure $ inp :/ UNPACK ::: ((ns, Dict, vn) ::& rs)--    (U.UNPACK {}, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []--    (U.UNPACK {}, SNil) -> notEnoughItemsOnStack--    (U.PACK vn, (_ :: Notes a, _, _) ::& rs) -> workOnInstr uInstr $ do-      Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing-        $ checkScope @(PackedValScope a)-      pure $ inp :/ PACK ::: ((starNotes, Dict, vn) ::& rs)--    (U.PACK _, SNil) -> notEnoughItemsOnStack--    (U.CONCAT vn, (NTBytes{}, _, _) ::& (NTBytes{}, _, _) ::& _) ->-      workOnInstr uInstr $ concatImpl inp vn-    (U.CONCAT vn, (NTString{}, _, _) ::& (NTString{}, _, _) ::& _) ->-      workOnInstr uInstr $ concatImpl inp vn-    (U.CONCAT vn, (STList STBytes, _, _, _) ::&+ _) ->-      workOnInstr uInstr $ concatImpl' inp vn-    (U.CONCAT vn, (STList STString, _, _, _) ::&+ _) ->-      workOnInstr uInstr $ concatImpl' inp vn-    (U.CONCAT _, _ ::& _) ->-      failWithErr $ UnexpectedType-        $ ("string" :| ["string"]) :|-        [ ("bytes" :| ["bytes"])-        , ("list string" :| ["list string"])-        , ("list bytes" :| ["list bytes"])-        ]-    (U.CONCAT _, SNil) -> notEnoughItemsOnStack--    (U.SLICE vn, (NTNat{}, _, _) ::&-                 (NTNat{}, _, _) ::&-                 (NTString{}, _, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn-    (U.SLICE vn, (NTNat{}, _, _) ::&-                 (NTNat{}, _, _) ::&-                 (NTBytes{}, _, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn--    (U.SLICE _, _ ::& _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType-        $ ("nat" :| ["nat", "string"]) :|-        [ ("nat" :| ["nat", "bytes"])-        ]-    (U.SLICE _, _) -> notEnoughItemsOnStack--    (U.ISNAT vn', (NTInt{}, _, oldVn) ::& rs) -> workOnInstr uInstr $ do-      let vn = vn' `orAnn` oldVn-      pure $ inp :/ ISNAT ::: ((starNotes, Dict, vn) ::& rs)--    (U.ISNAT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []--    (U.ISNAT _, SNil)-> notEnoughItemsOnStack--    -- Type checking is already done inside `addImpl`.-    (U.ADD vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $-      addImpl a b inp vn uInstr--    (U.ADD _, _) -> notEnoughItemsOnStack--    (U.SUB vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $-      subImpl a b inp vn uInstr--    (U.SUB _, _) -> notEnoughItemsOnStack--    (U.MUL vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $-      mulImpl a b inp vn uInstr--    (U.MUL _, _) -> notEnoughItemsOnStack--    (U.EDIV vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $-      edivImpl a b inp vn uInstr--    (U.EDIV _, _) -> notEnoughItemsOnStack--    (U.ABS vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImpl @Abs ABS inp vn-    (U.ABS _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []--    (U.ABS _, SNil) -> notEnoughItemsOnStack--    (U.NEG vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImplAnnotated @Neg NEG inp vn-    (U.NEG vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImpl @Neg NEG inp vn-    (U.NEG vn, (STBls12381Fr, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImplAnnotated @Neg NEG inp vn-    (U.NEG vn, (STBls12381G1, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImplAnnotated @Neg NEG inp vn-    (U.NEG vn, (STBls12381G2, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImplAnnotated @Neg NEG inp vn-    (U.NEG _, _ ::& _) ->-      failWithErr $ UnexpectedType-        $ ("int" :| []) :|-        [ ("nat" :| [])-        , ("bls12_381_fr" :| [])-        , ("bls12_381_g1" :| [])-        , ("bls12_381_g2" :| [])-        ]-    (U.NEG _, SNil) -> notEnoughItemsOnStack--    (U.LSL vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @Lsl LSL inp vn uInstr-    (U.LSL _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []-    (U.LSL _, _) -> notEnoughItemsOnStack--    (U.LSR vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @Lsr LSR inp vn uInstr-    (U.LSR _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []-    (U.LSR _, _) -> notEnoughItemsOnStack--    (U.OR vn, (STBool, _, _, _) ::&+-              (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @Or OR inp vn uInstr-    (U.OR vn, (STNat, _, _, _) ::&+-              (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @Or OR inp vn uInstr-    (U.OR _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType-        $ ("bool" :| ["bool"]) :|-        [ ("nat" :| ["nat"])-        ]-    (U.OR _, _) -> notEnoughItemsOnStack--    (U.AND vn, (STInt, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @And AND inp vn uInstr-    (U.AND vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @And AND inp vn uInstr-    (U.AND vn, (STBool, _, _, _) ::&+-               (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @And AND inp vn uInstr-    (U.AND _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType-        $ ("int" :| ["nat"]) :|-        [ ("nat" :| ["nat"])-        , ("bool" :| ["bool"])-        ]-    (U.AND _, _) -> notEnoughItemsOnStack--    (U.XOR vn, (STBool, _, _, _) ::&+-               (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @Xor XOR inp vn uInstr-    (U.XOR vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      arithImpl @Xor XOR inp vn uInstr-    (U.XOR _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType-        $ ("bool" :| ["bool"]) :|-        [ ("nat" :| ["nat"])-        ]-    (U.XOR _, _) -> notEnoughItemsOnStack--    (U.NOT vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImpl @Not NOT inp vn-    (U.NOT vn, (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImplAnnotated @Not NOT inp vn-    (U.NOT vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImplAnnotated @Not NOT inp vn-    (U.NOT _, _ ::& _) ->-      failWithErr $ UnexpectedType-        $ ("nat" :| []) :|-        [ ("bool" :| [])-        , ("int" :| [])-        ]-    (U.NOT _, SNil) -> notEnoughItemsOnStack--    (U.COMPARE vn,-          (an :: Notes aT, _, _)-      ::& (bn :: Notes bT, _, _)-      ::& rs-      )-      -> workOnInstr uInstr $ do-      case eqType @aT @bT of-        Right Refl -> do-          void . errConv $ converge an bn-          proofScope <- onScopeCheckInstrErr @aT (U.COMPARE vn) (SomeHST inp) (Just ComparisonArguments)-            $ checkScope @(ComparabilityScope aT)-          case proofScope of-            Dict ->-              pure $ inp :/ COMPARE ::: ((starNotes, Dict, vn) ::& rs)--        Left err -> do-          typeCheckInstrErr' uInstr (SomeHST inp) (Just ComparisonArguments) err-      where-        errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a-        errConv = onTypeCheckInstrAnnErr uInstr inp (Just ComparisonArguments)--    (U.COMPARE _, _) -> notEnoughItemsOnStack--    (U.EQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $-      unaryArithImpl @Eq' EQ inp vn-    (U.EQ _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []-    (U.EQ _, SNil) -> notEnoughItemsOnStack--    (U.NEQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $-      unaryArithImpl @Neq NEQ inp vn-    (U.NEQ _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []-    (U.NEQ _, SNil) -> notEnoughItemsOnStack--    (U.LT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $-      unaryArithImpl @Lt LT inp vn-    (U.LT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []-    (U.LT _, SNil) -> notEnoughItemsOnStack--    (U.GT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $-      unaryArithImpl @Gt GT inp vn-    (U.GT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []-    (U.GT _, SNil) -> notEnoughItemsOnStack--    (U.LE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $-      unaryArithImpl @Le LE inp vn-    (U.LE _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []-    (U.LE _, SNil) -> notEnoughItemsOnStack--    (U.GE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $-      unaryArithImpl @Ge GE inp vn-    (U.GE _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("int" :| []) :| []-    (U.GE _, SNil) -> notEnoughItemsOnStack--    (U.INT vn, (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs)-    (U.INT vn, (NTBls12381Fr{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs)-    (U.INT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("nat" :| []) :| ["bls12_381_fr" :| []]-    (U.INT _, SNil) -> notEnoughItemsOnStack--    (U.SELF vn fn, _) -> workOnInstr uInstr $ do-      mode <- gets tcMode-      case mode of-        TypeCheckValue (value, ty) ->-          tcFailedOnValue value ty "The SELF instruction cannot appear in a lambda." Nothing-        TypeCheckContract (SomeParamType _ notescp) -> do-          let epName = U.epNameFromSelfAnn fn-          MkEntrypointCallRes (argNotes :: Notes arg) epc <--            mkEntrypointCall epName notescp-              & maybeToRight (EntrypointNotFound epName)-              & onTypeCheckInstrErr uInstr (SomeHST inp) Nothing--          case NTContract U.noAnn argNotes of-                  (ntRes :: Notes ('TContract t1)) ->-                    withWTPInstr @('TContract t1) $-                      pure $ inp :/ SELF @arg (SomeEpc epc) ::: ((ntRes, Dict, vn) ::& inp)-        TypeCheckTest ->-          error "'SELF' appears in test typechecking."-        TypeCheckPack ->-          error "'SELF' appears in packed data."-    (U.CONTRACT vn fn mt, (NTAddress{}, _, _) ::& rs) -> workOnInstr uInstr $-      withUType mt $ \(tns :: Notes t) -> do-        proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter)-          $ checkScope @(ParameterScope t)-        let ns = NTOption def $ NTContract def tns-        epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing-          $ epNameFromRefAnn fn `onFirst` IllegalEntrypoint-        case proofScope of-          Dict ->-            withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs)--    (U.CONTRACT {}, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("address" :| []) :| []-    (U.CONTRACT {}, SNil) -> notEnoughItemsOnStack--    (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _, _)-      ::& (NTMutez{}, _, _)-      ::& (STContract (s :: Sing p), _, _, _) ::&+ rs) -> withSingI s $ workOnInstr uInstr $ do-      proofScope <- onScopeCheckInstrErr @p uInstr (SomeHST inp) (Just ContractParameter)-        $ checkScope @(ParameterScope p)-      case (eqType @p @p', proofScope) of-        (Right Refl, Dict) ->-          pure $ inp :/ TRANSFER_TOKENS ::: ((starNotes, Dict, vn) ::& rs)-        (Left m, _) ->-          typeCheckInstrErr' uInstr (SomeHST inp) (Just ContractParameter) m--    (U.TRANSFER_TOKENS _, _ ::& _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ ("'p" :| ["mutez", "contract 'p"]) :| []--    (U.TRANSFER_TOKENS _, _) -> notEnoughItemsOnStack--    (U.SET_DELEGATE vn,-      (STOption STKeyHash, NTOption _ NTKeyHash{}, _, _)-      ::&+ rs) -> workOnInstr uInstr $ do-        pure $ inp :/ SET_DELEGATE ::: ((starNotes, Dict, vn) ::& rs)--    (U.SET_DELEGATE _,  _ ::& _) ->-      failWithErr $ UnexpectedType $ ("option key_hash" :| []) :| []--    (U.SET_DELEGATE _, _) -> notEnoughItemsOnStack--    (U.CREATE_CONTRACT ovn avn contract,-      (STOption STKeyHash, NTOption _ (_ :: Notes ('TKeyHash)), _, _)-      ::&+ (NTMutez{}, _, _)-      ::& (gn :: Notes g, Dict, _) ::& rs) -> workOnInstr uInstr $ do-        (SomeContract-          (Contract-            (contr :: ContractCode p' g')-            paramNotes-            storeNotes-            entriesOrder))-          <- lift $ typeCheckContractImpl contract-        Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage)-          $ eqType @g @g'-        void $ onTypeCheckInstrAnnErr uInstr inp (Just ContractStorage) (converge gn storeNotes)-        pure-          $ inp :/ CREATE_CONTRACT (Contract contr paramNotes storeNotes entriesOrder)-          ::: ((starNotes, Dict, ovn) ::& (starNotes, Dict, avn) ::& rs)--    (U.CREATE_CONTRACT {}, _ ::& _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ ("option key_hash" :| ["mutez", "'a"]) :| []--    (U.CREATE_CONTRACT {},  _) -> notEnoughItemsOnStack--    (U.IMPLICIT_ACCOUNT vn, (NTKeyHash{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ IMPLICIT_ACCOUNT ::: ((starNotes, Dict, vn) ::& rs)--    (U.IMPLICIT_ACCOUNT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("key_hash" :| []) :| []-    (U.IMPLICIT_ACCOUNT _, SNil) -> notEnoughItemsOnStack--    (U.NOW vn, _) -> workOnInstr uInstr $-      pure $ inp :/ NOW ::: ((starNotes, Dict, vn) ::& inp)--    (U.AMOUNT vn, _) -> workOnInstr uInstr $-      pure $ inp :/ AMOUNT ::: ((starNotes, Dict, vn) ::& inp)--    (U.BALANCE vn, _) -> workOnInstr uInstr $-      pure $ inp :/ BALANCE ::: ((starNotes, Dict, vn) ::& inp)--    (U.VOTING_POWER vn, (NTKeyHash{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ VOTING_POWER ::: ((starNotes, Dict, vn) ::& rs)--    (U.TOTAL_VOTING_POWER vn, _) -> workOnInstr uInstr $-      pure $ inp :/ TOTAL_VOTING_POWER ::: ((starNotes, Dict, vn) ::& inp)--    (U.CHECK_SIGNATURE vn,-               (NTKey _, _, _)-               ::& (NTSignature _, _, _) ::& (NTBytes{}, _, _) ::& rs) ->-      workOnInstr uInstr $-        pure $ inp :/ CHECK_SIGNATURE ::: ((starNotes, Dict, vn) ::& rs)--    (U.CHECK_SIGNATURE _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ ("key" :| ["signature", "bytes"]) :| []-    (U.CHECK_SIGNATURE _, _) -> notEnoughItemsOnStack--    (U.SHA256 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ SHA256 ::: ((starNotes, Dict, vn) ::& rs)-    (U.SHA256 _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []-    (U.SHA256 _, SNil) -> notEnoughItemsOnStack--    (U.SHA512 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ SHA512 ::: ((starNotes, Dict, vn) ::& rs)-    (U.SHA512 _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []-    (U.SHA512 _, SNil) -> notEnoughItemsOnStack--    (U.BLAKE2B vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ BLAKE2B ::: ((starNotes, Dict, vn) ::& rs)-    (U.BLAKE2B _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []-    (U.BLAKE2B _, SNil) -> notEnoughItemsOnStack--    (U.SHA3 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ SHA3 ::: ((starNotes, Dict, vn) ::& rs)-    (U.SHA3 _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []-    (U.SHA3 _, SNil) -> notEnoughItemsOnStack--    (U.KECCAK vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ KECCAK ::: ((starNotes, Dict, vn) ::& rs)-    (U.KECCAK _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []-    (U.KECCAK _, SNil) -> notEnoughItemsOnStack--    (U.HASH_KEY vn, (NTKey{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ HASH_KEY ::: ((starNotes, Dict, vn) ::& rs)-    (U.HASH_KEY _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("key" :| []) :| []-    (U.HASH_KEY _, SNil) -> notEnoughItemsOnStack--    (U.PAIRING_CHECK vn, (NTList _ (NTPair _ _ _ _ _ (NTBls12381G1 _)-                                                     (NTBls12381G2 _)), _, _) ::& rs) ->-      workOnInstr uInstr $-        pure $ inp :/ PAIRING_CHECK ::: ((starNotes, Dict, vn) ::& rs)-    (U.PAIRING_CHECK _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("list (pair bls12_381_g1 bls12_381_g2)" :| []) :| []-    (U.PAIRING_CHECK _, SNil) -> notEnoughItemsOnStack--    (U.SOURCE vn, _) -> workOnInstr uInstr $-      pure $ inp :/ SOURCE ::: ((starNotes, Dict, vn) ::& inp)--    (U.SENDER vn, _) -> workOnInstr uInstr $-      pure $ inp :/ SENDER ::: ((starNotes, Dict, vn) ::& inp)--    (U.ADDRESS vn, (NTContract{}, _, _) ::& rs) -> workOnInstr uInstr $-      pure $ inp :/ ADDRESS ::: ((starNotes, Dict, vn) ::& rs)--    (U.ADDRESS _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("contract 'p" :| []) :| []-    (U.ADDRESS _, SNil) -> notEnoughItemsOnStack--    (U.CHAIN_ID vn, _) -> workOnInstr uInstr $-      pure $ inp :/ CHAIN_ID ::: ((starNotes, Dict, vn) ::& inp)--    (U.LEVEL vn, _) -> workOnInstr uInstr $-      pure $ inp :/ LEVEL ::: ((starNotes, Dict, vn) ::& inp)--    (U.SELF_ADDRESS vn, _) -> workOnInstr uInstr $-      pure $ inp :/ SELF_ADDRESS ::: ((starNotes, Dict, vn) ::& inp)--    (U.NEVER, (NTNever{}, _, _) ::& _) -> workOnInstr uInstr $-      pure $ inp :/ AnyOutInstr NEVER--    (U.TICKET vn, (stVal :: Sing v, _, _, _) ::&+ (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $-      withWTPInstr @v $-      withCompareableCheck stVal uInstr inp $-        inp :/ TICKET ::: ((starNotes, Dict, vn) ::& rs)-    (U.TICKET _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ ("a'" :| ["nat"]) :| []-    (U.TICKET _, _) -> notEnoughItemsOnStack--    (U.READ_TICKET vn, ticket@(ntTicket@NTTicket{}, Dict, _) ::& rs) -> workOnInstr uInstr $-      case notesSing ntTicket of-        STTicket{} ->-          pure $ inp :/ READ_TICKET ::: ((starNotes, Dict, vn) ::& ticket ::& rs)-    (U.READ_TICKET _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("ticket 'a" :| []) :| []-    (U.READ_TICKET _, _) -> notEnoughItemsOnStack--    (U.SPLIT_TICKET vn, (NTTicket{}, Dict, _) ::& (NTPair _ _ _ _ _ NTNat{} NTNat{}, _, _) ::& rs) ->-      workOnInstr uInstr $-        pure $ inp :/ SPLIT_TICKET ::: ((starNotes, Dict, vn) ::& rs)-    (U.SPLIT_TICKET _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ ("pair nat nat" :| ["ticket 'a"]) :| []-    (U.SPLIT_TICKET _, _) -> notEnoughItemsOnStack--    (U.JOIN_TICKETS vn,-       (STPair{}, NTPair _ _ _ _ _ nt1@NTTicket{} nt2@NTTicket{}, Dict, _) ::&+ rs) ->-      workOnInstr uInstr $ do-        (Refl, nt) <--          onTypeCheckInstrErr uInstr (SomeHST inp) (Just TicketsJoin) $-            matchTypes nt1 nt2-        pure $ inp :/ JOIN_TICKETS ::: ((NTOption U.noAnn nt, Dict, vn) ::& rs)-    (U.JOIN_TICKETS _, _ ::& _) ->-      failWithErr $ UnexpectedType $ ("pair (ticket 'a) (ticket 'a)" :| []) :| []-    (U.JOIN_TICKETS _, _) -> notEnoughItemsOnStack--    -- Could not get rid of the catch all clause due to this warning:-    -- @-    -- Pattern match checker exceeded (2000000) iterations in-    -- a case alternative. (Use -fmax-pmcheck-iterations=n-    -- to set the maximum number of iterations to n)-    -- @-    i ->-      error $ "Pattern matches should be exhaustive, but instead got: " <> show i-  where-    withWTPInstr'-      :: forall t inp. SingI t-      => (WellTyped t => TypeCheckInstrNoExcept (TypeCheckedSeq inp))-      -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    withWTPInstr' = withWTPInstr'_ @t uInstr (SomeHST inp)--    withWTPInstr-      :: forall t a. SingI t => (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a-    withWTPInstr = withWTPInstr_ @t uInstr (SomeHST inp)--    failWithErr :: TCTypeError -> TypeCheckInstrNoExcept (TypeCheckedSeq a)-    failWithErr = workOnInstr uInstr . failWithErr'--    failWithErr' :: TCTypeError -> TypeCheckInstr a-    failWithErr' = typeCheckInstrErr' uInstr (SomeHST inp) Nothing--    notEnoughItemsOnStack :: TypeCheckInstrNoExcept (TypeCheckedSeq a)-    notEnoughItemsOnStack = failWithErr NotEnoughItemsOnStack--    notEnoughItemsOnStack' :: TypeCheckInstr a-    notEnoughItemsOnStack' = failWithErr' NotEnoughItemsOnStack---- | Helper function for two-branch if where each branch is given a single--- value.-genericIf-  :: forall bti bfi cond rs .-    (SingI bti, SingI bfi)-  => (forall s'.-        Instr bti s' ->-        Instr bfi s' ->-        Instr (cond ': rs) s'-     )-  -> (forall op. [op] -> [op] -> U.InstrAbstract op)-  -> [U.ExpandedOp]-  -> [U.ExpandedOp]-  -> HST bti-  -> HST bfi-  -> HST (cond ': rs)-  -> TypeCheckInstrNoExcept (TypeCheckedSeq (cond ': rs))-genericIf cons mCons mbt mbf bti bfi i@(_ ::& _) = do-  let cons1 opsT = mCons opsT (map (IllTypedOp . NonTypedInstr) mbf)-  preserving' (tcList mbt bti) cons1 $ \tInstr@(_ :/ pinstr) -> do-    let cons2 opsF = mCons [someInstrToOp tInstr] opsF-    preserving (tcList mbf bfi) cons2 $ \(_ :/ qinstr) -> do-      fmap (i :/) $ case (pinstr, qinstr) of-        (p ::: po, q ::: qo) -> do-          let instr = mCons mbt mbf-          Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just If)-            $ eqHST po qo-          o <- onTypeCheckInstrAnnErr instr i (Just If) (convergeHST po qo)-          pure $ cons p q ::: o-        (AnyOutInstr p, q ::: qo) -> do-          pure $ cons p q ::: qo-        (p ::: po, AnyOutInstr q) -> do-          pure $ cons p q ::: po-        (AnyOutInstr p, AnyOutInstr q) ->-          pure $ AnyOutInstr (cons p q)--mapImpl-  :: forall c rs.-    ( MapOp c-    , WellTyped (MapOpInp c)-    , SingI1 (MapOpRes c)-    )-  => ([TypeCheckedOp] -> TypeCheckedInstr)-  -> Notes (MapOpInp c)-  -> U.ExpandedInstr-  -> [U.ExpandedOp]-  -> HST (c ': rs)-  -> (forall v'. (SingI v') =>-        Notes v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs)))-  -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs))-mapImpl cons vn instr mp i@(_ ::& rs) mkRes = do-  preserving (tcList mp ((vn, Dict, def) ::& rs)) cons $ \(_ :/ subp) ->-    case subp of-      sub ::: subo ->-        case subo of-          (bn :: Notes v', _, _bvn) ::& rs' -> do-            Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration)-              $ eqHST rs rs'-            x <- mkRes bn rs'-            pure $ i :/ withSingI1 @(MapOpRes c) @v' (MAP sub ::: x)-          _ -> typeCheckInstrErr instr (SomeHST i) (Just Iteration)-      AnyOutInstr _ ->-        typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails--iterImpl-  :: forall c rs .-    ( IterOp c-    , WellTyped (IterOpEl c)-    )-  => Notes (IterOpEl c)-  -> U.ExpandedInstr-  -> [U.ExpandedOp]-  -> HST (c ': rs)-  -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs))-iterImpl en instr mp i@((_, _, lvn) ::& rs) = do-  let evn = deriveVN [annQ|elt|] lvn-  let tcAction = case mp of-        [] -> workOnInstr instr-          (typeCheckInstrErr' instr (SomeHST i) (Just Iteration) EmptyCode)-        _ -> typeCheckImpl typeCheckInstr mp ((en, Dict, evn) ::& rs)-  preserving tcAction U.ITER $ \(_ :/ subp) -> case subp of-    subI ::: o -> do-      Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration) $ eqHST o rs-      pure $ i :/ ITER subI ::: o-    AnyOutInstr _ ->-      typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails--lamImpl-  :: forall it ot ts .-    ( WellTyped it, WellTyped ot-    , SingI ts-    )-  => ([TypeCheckedOp] -> TypeCheckedInstr)-  -> U.ExpandedInstr-  -> [U.ExpandedOp]-  -> VarAnn-  -> Notes it-  -> Notes ot-  -> HST ts-  -> TypeCheckInstrNoExcept (TypeCheckedSeq ts)-lamImpl cons instr is vn ins ons i =-  guarding_ instr-    (whenJust (getFirst $ foldMap hasSelf is) $ \selfInstr -> do-      let err = InvalidInstruction selfInstr "SELF instruction cannot be used in a LAMBDA"-      typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) err) $-    preserving (tcList is ((ins, Dict, def) ::& SNil)) cons $ \(_ :/ lamI) -> do-      let lamNotes onsr = NTLambda def ins onsr-      let lamSt onsr = (lamNotes onsr, Dict, vn) ::& i-      fmap (i :/) $ case lamI of-        lam ::: lo -> do-          case eqHST1 @ot lo of-            Right Refl -> do-                let (ons', _, _) ::& SNil = lo-                onsr <- onTypeCheckInstrAnnErr instr i (Just LambdaCode) (converge ons ons')-                pure (LAMBDA (VLam $ RfNormal lam) ::: lamSt onsr)-            Left m -> typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) m-        AnyOutInstr lam ->-          pure (LAMBDA (VLam $ RfAlwaysFails lam) ::: lamSt ons)-  where-    hasSelf :: U.ExpandedOp -> First U.ExpandedInstr-    hasSelf = everything (<>)-      (mkQ (First Nothing)-       (\case-           selfInstr@(U.SELF{} :: U.InstrAbstract U.ExpandedOp) -> First $ Just selfInstr-           _ -> First Nothing-       )-      )--------------------------------------------------------------------------------- Helpers for DIP (n) typechecking--------------------------------------------------------------------------------- Helper data type we use to typecheck DIPN.-data TCDipHelper inp where-  TCDipHelperOk ::-    forall (n :: Peano) inp out s s'.-    (SingI out, ConstraintDIPN n inp out s s') =>-    PeanoNatural n -> Instr s s' -> HST out -> TCDipHelper inp-  TCDipHelperErr :: TCError -> [IllTypedInstr] -> TCDipHelper inp--typeCheckDipBody-  :: SingI inp-  => ([TypeCheckedOp] -> TypeCheckedInstr)-  -> U.ExpandedInstr-  -> [U.ExpandedOp]-  -> HST inp-  -> (TCError -> [IllTypedInstr] -> r)-  -> (forall out. SingI out => Instr inp out -> HST out -> r)-  -> TypeCheckInstrNoExcept r-typeCheckDipBody cons mainInstr instructions inputHST onErr onOk = do-  listRes <- lift $ typeCheckListNoExcept instructions inputHST-  pos <- ask-  pure $ listRes & tcsEither-    (\tcOps err -> onErr err [SemiTypedInstr $ cons tcOps])-    (\someInstr@(_ :/ iAndOut) -> case iAndOut of-        AnyOutInstr _ ->-        -- This may seem like we throw error because of despair, but in fact,-        -- the reference implementation seems to behave exactly in this way --        -- if output stack of code block within @DIP@ occurs to be any, an-        -- error "FAILWITH must be at tail position" is raised.-        -- It is not allowed even in `DIP 0`.-          let err = TCFailedOnInstr mainInstr-                                    (SomeHST inputHST)-                                    pos-                                    (Just DipCode)-                                    (Just CodeAlwaysFails)-          in onErr err [SemiTypedInstr $ cons [someInstrToOp someInstr]]-        subI ::: t -> onOk subI t)

− src/Michelson/TypeCheck/TypeCheck.hs

@@ -1,280 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.TypeCheck.TypeCheck-  ( TcInstrHandler-  , TcOriginatedContracts-  , TypeCheckEnv(..)-  , TypeCheckOptions(..)-  , TypeCheck-  , TypeCheckNoExcept-  , TypeCheckResult-  , runTypeCheck-  , TypeCheckInstr-  , TypeCheckInstrNoExcept-  , runTypeCheckIsolated-  , runTypeCheckInstrIsolated-  , typeCheckingWith-  , liftNoExcept-  , liftNoExcept'-  , throwingTCError-  , throwingTCError'-  , preserving-  , preserving'-  , guarding-  , guarding_-  , tcEither--  , tcExtFramesL-  , tcModeL-  , TypeCheckMode(..)-  , SomeParamType(..)-  , mkSomeParamType-  , unsafeMkSomeParamType-  ) where---import Control.Monad.Except (Except, mapExceptT, runExcept, throwError)-import Control.Monad.Reader (mapReaderT)-import Data.Default (Default(..))-import Data.Singletons (Sing)-import Fmt (Buildable, build, pretty)-import qualified Text.Show--import Michelson.ErrorPos (InstrCallStack)-import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))-import Michelson.TypeCheck.TypeCheckedSeq-  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), someInstrToOp,-  tcsEither)-import Michelson.TypeCheck.Types-import qualified Michelson.Typed as T-import Michelson.Typed (SingI)-import qualified Michelson.Untyped as U-import Tezos.Address (ContractHash)-import Util.Lens--type TypeCheck =-  (ReaderT TypeCheckOptions-    (ExceptT TCError-      (State TypeCheckEnv)))---- | A non-throwing alternative for @TypeCheck@. Mainly meant to be used for--- construction of a partially typed tree (see @TypeCheckedSeq@).-type TypeCheckNoExcept =-  (ReaderT TypeCheckOptions-    (State TypeCheckEnv))---- | Monad for performing some typechecking operations with the same options.------ Unlike 'TypeCheck' monad, this does not carry the context of intra-contract--- or intra-value typechecking.--- TODO [this MR]: probably come up with a better name? IntraTypeCheck?-type TypeCheckResult =-  (ReaderT TypeCheckOptions-    (Except TCError))--data SomeParamType = forall t. (T.ParameterScope t) =>-  SomeParamType (Sing t) (T.ParamNotes t)---- | @Show@ instance of @SomeParamType@, mainly used in test.-instance Show SomeParamType where-  show = show . someParamToParameterType---- | @Eq@ instance of @SomeParamType@, mainly used in test.-instance Eq SomeParamType where-  s1 == s2 = someParamToParameterType s1 == someParamToParameterType s2---- | @Buildable@ instance of @SomeParamType@, mainly used in test.-instance Buildable SomeParamType where-  build = build . someParamToParameterType---- | Helper function means to provide a quick way for creating instance--- of @SomeParamType@ needed in test.-someParamToParameterType :: SomeParamType -> U.ParameterType-someParamToParameterType (SomeParamType s T.UnsafeParamNotes{..}) =-  U.ParameterType (T.AsUTypeExt s pnNotes) pnRootAnn---- | Construct @SomeParamType@ from @ParameterType@, mainly used in test.-unsafeMkSomeParamType :: HasCallStack => U.ParameterType -> SomeParamType-unsafeMkSomeParamType p =-  case mkSomeParamType p of-    Right sp -> sp-    Left err -> error $ "Illegal type in parameter of env contract: " <> pretty err--mkSomeParamType :: U.ParameterType -> Either TCError SomeParamType-mkSomeParamType (U.ParameterType t ann) =-  T.withUType t $ \(notescp :: T.Notes t) -> do-    case T.checkScope @(T.ParameterScope t) of-      Right T.Dict ->-        case T.mkParamNotes notescp ann of-          Right paramNotes -> Right $ SomeParamType T.sing paramNotes-          Left err ->-            Left $ TCContractError "invalid parameter declaration: " $ Just $ IllegalParamDecl err-      Left err -> Left $ TCContractError ("Parameter type is invalid: " <> pretty err) Nothing--type TcOriginatedContracts = Map ContractHash SomeParamType---- | Typechecking mode that tells the type checker whether it is typechecking--- contract code in actual contract, lambda, or test.-data TypeCheckMode-  = TypeCheckValue (U.Value, T.T)-  | TypeCheckContract SomeParamType-  | TypeCheckTest-  | TypeCheckPack---- | The typechecking state-data TypeCheckEnv = TypeCheckEnv-  { tcExtFrames :: ~TcExtFrames-  , tcMode :: ~TypeCheckMode-  }--data TypeCheckOptions = TypeCheckOptions-  { tcVerbose :: Bool-    -- ^ Whether to add stack type comments after every-    -- instruction a la tezos-client.-  , tcStrict :: Bool-    -- ^ Whether should we behave like in test run or real run-    -- (real run is more strict).-    ---    -- @tezos-client run@'s behaviour can slightly differ from the behaviour-    -- of @tezos-client originate@ and @tezos-client transfer@. For instance,-    -- some values can be "forged" in test run, but not in a real one,-    -- see: Note [Tickets forging].-    ---    -- Set this to @True@ when need to match the behaviour in the network,-    -- and to @False@ if you prefer providing the user with some convenient-    -- features.-  }--instance Default TypeCheckOptions where-  def = TypeCheckOptions{ tcVerbose = False, tcStrict = True }--makeLensesWith postfixLFields ''TypeCheckEnv--runTypeCheck :: TypeCheckMode -> TypeCheck a -> TypeCheckResult a-runTypeCheck mode =-  mapReaderT $ mapExceptT $ evaluatingStateT (TypeCheckEnv [] mode)---- | Run type checker as if it worked isolated from other world ---- no access to environment of the current contract is allowed.------ Use this function for test purposes only or for some utilities when--- environment does not matter. In particular, it is assumed that--- whatever we typecheck does not depend on the parameter type of the--- contract which is being typechecked (because there is no contract--- that we are typechecking).-runTypeCheckIsolated :: TypeCheck a -> TypeCheckResult a-runTypeCheckIsolated = runTypeCheck TypeCheckTest--typeCheckingWith :: TypeCheckOptions -> TypeCheckResult a -> Either TCError a-typeCheckingWith options = runExcept . usingReaderT options--type TypeCheckInstr =-  ReaderT InstrCallStack TypeCheck--type TypeCheckInstrNoExcept =-  ReaderT InstrCallStack TypeCheckNoExcept---- | Similar to 'runTypeCheckIsolated', but for 'TypeCheckInstr.'-runTypeCheckInstrIsolated :: TypeCheckInstr a -> TypeCheckResult a-runTypeCheckInstrIsolated = runTypeCheckIsolated . flip runReaderT def--liftNoExcept :: TypeCheckInstrNoExcept a -> TypeCheckInstr a-liftNoExcept action = (pure action)-                 <**> (usingReaderT <$> ask)-                 <**> (usingReaderT <$> lift ask)-                 <**> (evaluatingState <$> get)--liftNoExcept' :: TypeCheckNoExcept a -> TypeCheck a-liftNoExcept' action = (pure action)-                  <**> (usingReaderT <$> ask)-                  <**> (evaluatingState <$> get)--throwingTCError-  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> TypeCheckInstr (SomeInstr inp)-throwingTCError action = liftNoExcept action-  >>= tcsEither (const throwError) (pure)--throwingTCError'-  :: TypeCheckNoExcept (TypeCheckedSeq inp) -> TypeCheck (SomeInstr inp)-throwingTCError' action = liftNoExcept' action-  >>= tcsEither (const throwError) (pure)--tcEither-  :: (TCError -> TypeCheckInstrNoExcept a) -- ^ Call this if the action throws-  -> (b -> TypeCheckInstrNoExcept a) -- ^ Call this if it doesn't-  -> TypeCheckInstr b -- ^ The action to perform-  -> TypeCheckInstrNoExcept a -- ^ A non-throwing action-tcEither onErr onOk action = do-  res <- (pure action)-    <**> (usingReaderT <$> ask)-    <**> (usingReaderT <$> lift ask)-    <**> (pure runExceptT)-    <**> (evaluatingState <$> get)-  either onErr onOk res---- | Perform a throwing action on an acquired instruction. Preserve the acquired--- result by embedding it into a type checking tree with a specified parent--- instruction.-preserving-  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp)-  -- ^ Acquiring computation-  -> ([TypeCheckedOp] -> TypeCheckedInstr)-  -- ^ The parent instruction constructor-  -> (SomeInstr inp -> TypeCheckInstr (SomeInstr inp'))-  -- ^ The throwing action-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')-preserving acquire con action = preserving' acquire con-  (\instr -> action instr & tcEither-    (\err -> pure $ IllTypedSeq err [SemiTypedInstr $ con [someInstrToOp instr]])-    (pure . WellTypedSeq))---- | Perform a non-throwing action on an acquired instruction. Preserve the--- acquired result even if the action does not succeed. Embed the result into a--- type checking tree with a specified parent instruction.-preserving'-  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp)-  -- ^ Acquiring computation-  -> ([TypeCheckedOp] -> TypeCheckedInstr)-  -- ^ The parent instruction constructor-  -> (SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp'))-  -- ^ The action-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')-preserving' acquire con action =-  acquire >>= tcsEither-    (\tcOps err -> pure $ IllTypedSeq err [SemiTypedInstr $ con tcOps])-    (action)---- | Acquire a resource. If successfully, call a follow-up action on it,--- otherwise embed the error into a type checking tree along with a specified--- untyped instruction.-guarding-  :: U.ExpandedInstr -- ^ Untyped instruction-  -> TypeCheckInstr a -- ^ Acquiring computation-  -> (a -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)) -- ^ Follow-up action-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-guarding instr cond action = do-  cond & tcEither-    (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr])-    (action)---- | Same as @guarding@ but doesn't pass an acquired result to a follow-up--- action.-guarding_-  :: U.ExpandedInstr-  -> TypeCheckInstr a-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-guarding_ instr cond action = guarding instr cond (const action)---- pva701: it's really painful to add arguments to TcInstrHandler--- due to necessity to refactor @typeCheckInstr@.--- Also functions which are being called from @typeCheckInstr@ would--- have to be refactored too.--- Therefore, I am using ReaderT over TypeCheck.-type TcInstrHandler-   = forall inp. (SingI inp, HasCallStack)-      => U.ExpandedInstr-      -> HST inp-      -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

− src/Michelson/TypeCheck/TypeCheckedOp.hs

@@ -1,62 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- This module provides data types for representing partially typed--- instructions.-module Michelson.TypeCheck.TypeCheckedOp-  ( TypeCheckedInstr-  , TypeCheckedOp(..)-  , IllTypedInstr(..)-  , someInstrToOp-  ) where--import Data.Singletons (SingI)--import Michelson.Printer.Util (RenderDoc(..), renderOpsListNoBraces)-import Michelson.TypeCheck.Types (HST(..), SomeInstr(..), SomeInstrOut(..))-import Michelson.Typed.Convert (instrToOps)-import Michelson.Typed.Instr (Instr, castInstr)-import Michelson.Untyped.Instr (ExpandedOp, InstrAbstract(..))-import Util.TH (deriveGADTNFData)---- | Represents a root of a partially typed operation tree.-type TypeCheckedInstr = InstrAbstract TypeCheckedOp---- | Represents nodes of a partially typed operation tree.-data TypeCheckedOp where-  -- | Constructs well-typed node.-  WellTypedOp :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp-  -- | Constructs ill-typed node which might in turn contain well-typed and-  -- non-typed operations.-  IllTypedOp :: IllTypedInstr -> TypeCheckedOp--instance Eq TypeCheckedOp where-  WellTypedOp i1 == WellTypedOp i2 = castInstr i1 == Just i2-  IllTypedOp i1 == IllTypedOp i2 = i1 == i2-  _ == _ = False---- | Represents a non-well-typed operation-data IllTypedInstr-  = SemiTypedInstr TypeCheckedInstr -- ^ Constructs a partialy typed operation.-  | NonTypedInstr ExpandedOp  -- ^ Constructs a completely untyped operation.-  deriving stock (Eq, Generic)--deriving anyclass instance NFData TypeCheckedOp => NFData IllTypedInstr--instance RenderDoc TypeCheckedOp where-  renderDoc _ (WellTypedOp instr) = renderOpsListNoBraces False (instrToOps instr)-  renderDoc pn (IllTypedOp (SemiTypedInstr instr)) = renderDoc pn instr-  renderDoc pn (IllTypedOp (NonTypedInstr op)) = renderDoc pn op---- | Makes a well-typed node out of `SomeInstr`-someInstrToOp :: SomeInstr inp -> TypeCheckedOp-someInstrToOp (hst :/ rest) = case hst of-  SNil -> go rest-  (::&){} -> go rest-  where-    go :: forall inp. SingI inp => SomeInstrOut inp -> TypeCheckedOp-    go (i ::: _) = WellTypedOp i-    go (AnyOutInstr i) = WellTypedOp (i @'[])--$(deriveGADTNFData ''TypeCheckedOp)

− src/Michelson/TypeCheck/TypeCheckedSeq.hs

@@ -1,51 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | This module provides a data type for representing a partially typed--- sequence of instructions.------ It is needed to represent the fact that there can only be one well-typed node--- in a sequence and it is the first one. Also, it serves its role to remove--- @TCError@ usage from @TypeCheckedOp@.-module Michelson.TypeCheck.TypeCheckedSeq-  ( TypeCheckedInstr-  , TypeCheckedOp(..)-  , IllTypedInstr(..)-  , TypeCheckedSeq(..)-  , tcsEither-  , seqToOps-  , someInstrToOp-  ) where--import Michelson.TypeCheck.Error (TCError)-import Michelson.TypeCheck.TypeCheckedOp-  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), someInstrToOp)-import Michelson.TypeCheck.Types (SomeInstr(..))---- | Represents a partiall typed sequence of instructions.-data TypeCheckedSeq inp-  -- | A fully well-typed sequence.-  = WellTypedSeq (SomeInstr inp)-  -- | A well-typed prefix followed by some error and semi-typed instructions.-  | MixedSeq (SomeInstr inp) TCError [IllTypedInstr]-  -- | There is no well-typed prefix, only an error and semi-typed instructions.-  | IllTypedSeq TCError [IllTypedInstr]--seqToOps :: TypeCheckedSeq inp -> [TypeCheckedOp]-seqToOps = \case-  WellTypedSeq instr -> [someInstrToOp instr]-  MixedSeq instr _ tail' -> someInstrToOp instr : map IllTypedOp tail'-  IllTypedSeq _ tail' -> map IllTypedOp tail'---- | Case analysis for @TypeCheckedSeq@.-tcsEither-  :: ([TypeCheckedOp] -> TCError -> a)-     -- ^ On error, with all already typechecked operations-  -> (SomeInstr inp -> a) -- ^ On well-typed instruction-  -> TypeCheckedSeq inp -- ^ The sequence to dispatch on-  -> a-tcsEither onErr onInstr v = case v of-  WellTypedSeq instr -> onInstr instr-  MixedSeq _ err _ -> onErr (seqToOps v) err-  IllTypedSeq err _ -> onErr (seqToOps v) err

− src/Michelson/TypeCheck/Types.hs

@@ -1,310 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.TypeCheck.Types-    ( HST (..)-    , (-:&)-    , pattern (::&+)-    , SomeHST (..)-    , SomeInstrOut (..)-    , SomeInstr (..)-    , BoundVars (..)-    , TcExtFrames-    , NotWellTyped (..)-    , getWTP-    , getWTP_-    , withWTPm-    , unsafeWithWTP-    , mapSomeContract-    , mapSomeInstr-    , mapSomeInstrOut-    , noBoundVars-    ) where--import Data.Constraint (Dict(..))-import qualified Data.Map.Lazy as Map-import Data.Singletons (Sing, SingI(..), demote, withSingI)-import Fmt (Buildable(..), pretty)-import Prelude hiding (EQ, GT, LT)-import qualified Text.Show-import Text.PrettyPrint.Leijen.Text hiding (pretty)---import Michelson.Typed (Notes(..), SingT(..), SomeContract(..), T(..), notesT, starNotes)-import qualified Michelson.Typed as T-import Michelson.Typed.Haskell.Value (WellTyped)-import Michelson.Typed.Instr-import Michelson.Printer.Util-import Michelson.Untyped (Ty, Var, noAnn)-import Michelson.Untyped.Annotation (VarAnn)-import Util.Sing (eqParamSing)---- | Data type holding type information for stack (Heterogeneous Stack Type).------ This data type is used along with instruction data type @Instr@--- to carry information about its input and output stack types.------ That is, if there is value @instr :: Instr inp out@, along with this--- @instr@ one may carry @inpHST :: HST inp@ and @outHST :: HST out@ which will--- contain whole information about input and output stack types for @instr@.------ Data type @HST@ is very similar to @Data.Vinyl.Rec@,--- but is specialized for a particular purpose.--- In particular, definition of @HST (t1 ': t2 ': ... tn ': '[])@ requires--- constraints @(Typeable t1, Typeable t2, ..., Typeable tn)@ as well as--- constraints @(Typeable '[ t1 ], Typeable '[ t1, t2 ], ...)@.--- These applications of @Typeable@ class are required for convenient usage--- of type encoded by @HST ts@ with some functions from @Data.Typeable@.------ Data type @HST@ (Heterogeneous Stack Type) is a heterogenuous list of tuples.--- First element of tuple is a structure, holding field and type annotations--- for a given type.--- Second element of tuple is an optional variable annotation for the stack--- element.--- Additionally constructor keeps 'SingI' constraint for the current type.-data HST (ts :: [T])  where-  SNil :: HST '[]-  (::&) :: (T.SingI x, T.SingI xs)-        => (Notes x, Dict (WellTyped x), VarAnn)-        -> HST xs-        -> HST (x ': xs)--instance NFData (HST ts) where-  rnf (SNil) = ()-  rnf ((a, d, b) ::& hst) = rnf (a, d, b, hst)--instance Show (HST ts) where-  show SNil = "[]"-  show (r ::& rs) = "[ " <> showDo (r ::& rs) <> " ]"-    where-      showDo :: HST (t ': ts_) -> String-      showDo ((notesT -> t, Dict, _vn) ::& (b ::& c)) =-          show t <> ", " <> showDo (b ::& c)-      showDo ((notesT -> t, Dict, _vn) ::& SNil) = show t--instance Buildable (HST ts) where-  build = buildRenderDocExtended--instance RenderDoc (HST ts) where-  renderDoc _ SNil = "[]"-  renderDoc context (r ::& rs) = "[" <+> doRender (r ::& rs) <+> "]"-    where-      doRender :: HST (t ': ts_) -> Doc-      doRender ((notesT -> t, Dict, _vn) ::& (b ::& c)) =-          renderDoc context t <> "," <+> doRender (b ::& c)-      doRender ((notesT -> t, Dict, _vn) ::& SNil) = renderDoc context t-infixr 7 ::&--instance Eq (HST ts) where-  SNil == SNil = True-  (n1, Dict, a1) ::& h1 == (n2, Dict, a2) ::& h2 =-    n1 == n2 && a1 == a2 && h1 == h2---- | Append a type to 'HST', assuming that notes and annotations--- for this type are unknown.-(-:&)-  :: (WellTyped x, SingI xs)-  => Sing x-  -> HST xs-  -> HST (x ': xs)-_ -:& hst = (starNotes, Dict, noAnn) ::& hst-infixr 7 -:&---- | Extended pattern-match - adds @Sing x@ argument.-infixr 7 ::&+-pattern (::&+)-  :: ()-  => ( ys ~ (x ': xs)-     , SingI x, SingI xs-     )-  => (Sing x, Notes x, Dict (WellTyped x), VarAnn)-  -> HST xs-  -> HST ys-pattern x ::&+ hst <- ((\(n, d, v) -> (T.notesSing n, n, d, v)) -> x) ::& hst-  where (_, n, d, v) ::&+ hst = (n, d, v) ::& hst---- | No-argument type wrapper for @HST@ data type.-data SomeHST where-  SomeHST :: SingI ts => HST ts -> SomeHST--deriving stock instance Show SomeHST-instance NFData SomeHST where-  rnf (SomeHST h) = rnf h--instance Eq SomeHST where-  SomeHST hst1 == SomeHST hst2 = hst1 `eqParamSing` hst2---- | This data type keeps part of type check result - instruction and--- corresponding output stack.-data SomeInstrOut inp where-  -- | Type-check result with concrete output stack, most common case.-  ---  -- Output stack type is wrapped inside the type and @Typeable@-  -- constraint is provided to allow convenient unwrapping.-  (:::)-    :: SingI out-    => Instr inp out-    -> HST out-    -> SomeInstrOut inp--  -- | Type-check result which matches against arbitrary output stack.-  -- Information about annotations in the output stack is absent.-  ---  -- This case is only possible when the corresponding code terminates-  -- with @FAILWITH@ instruction in all possible executions.-  -- The opposite may be not true though (example: you push always-failing-  -- lambda and immediatelly execute it - stack type is known).-  AnyOutInstr-    :: (forall out. Instr inp out)-    -> SomeInstrOut inp-infix 9 :::--instance Show (ExtInstr inp) => Show (SomeInstrOut inp) where-  show (i ::: out) = show i <> " :: " <> show out-  show (AnyOutInstr i) = show i <> " :: *"---- | Data type keeping the whole type check result: instruction and--- type representations of instruction's input and output.-data SomeInstr inp where-  (:/) :: HST inp -> SomeInstrOut inp -> SomeInstr inp-infix 8 :/--mapSomeInstrOut-  :: (forall out. Instr inp out -> Instr inp' out)-  -> SomeInstrOut inp-  -> SomeInstrOut inp'-mapSomeInstrOut f (i ::: out) = f i ::: out-mapSomeInstrOut f (AnyOutInstr i) = AnyOutInstr (f i)--mapSomeInstr-  :: (forall out. Instr inp out -> Instr inp out)-  -> SomeInstr inp-  -> SomeInstr inp-mapSomeInstr f (inp :/ instrAndOut) = inp :/ mapSomeInstrOut f instrAndOut--instance Show (ExtInstr inp) => Show (SomeInstr inp) where-  show (inp :/ out) = show inp <> " -> " <> show out--mapSomeContract ::-  (forall inp out. Instr inp out -> Instr inp out)-  -> SomeContract-  -> SomeContract-mapSomeContract f (SomeContract fc) = SomeContract $ mapContractCode f fc---- | Set of variables defined in a let-block.-data BoundVars = BoundVars (Map Var Ty) (Maybe SomeHST)--noBoundVars :: BoundVars-noBoundVars = BoundVars Map.empty Nothing---- | State for type checking @nop@-type TcExtFrames = [BoundVars]---- | Error type for when a value is not well-typed.-data NotWellTyped = NotWellTyped-  { nwtBadType :: T-  , nwtCause :: T.BadTypeForScope-  }--instance Buildable NotWellTyped where-  build (NotWellTyped t c) =-    "Given type is not well typed because '" <> (build t) <> "' " <> (build c)--fromEDict :: Either e (Dict a) -> (a => Either e (Dict b)) -> Either e (Dict b)-fromEDict ma b = ma >>= (\Dict -> b)---- | Given a type, provide evidence that it is well typed w.r.t to the---  Michelson rules regarding where comparable types are required.-getWTP :: forall t. (SingI t) => Either NotWellTyped (Dict (WellTyped t))-getWTP = case sing @t of-  STKey -> Right Dict-  STUnit -> Right Dict-  STSignature -> Right Dict-  STChainId -> Right Dict-  STOption s -> withSingI s $ fromEDict (getWTP_ s) (Right Dict)-  STList s -> withSingI s $ fromEDict (getWTP_ s) (Right Dict)-  STSet (s :: Sing si) ->-    withSingI s $-    fromEDict (getWTP_ s) $-    fromEDict-        ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s-        ) $ Right Dict-  STOperation  -> Right Dict-  STContract (s :: Sing si) ->-    withSingI s $ fromEDict (getWTP_ s) $-    fromEDict-        ( maybeToRight (NotWellTyped (demote @si) T.BtIsOperation) $ T.opAbsense s-        ) $ Right Dict--  STTicket (s :: Sing si) ->-    withSingI s $ fromEDict (getWTP_ s) $-    fromEDict-        ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s-        ) $ Right Dict-  STPair s1 s2 ->-    withSingI s1 $-    withSingI s2 $-    fromEDict (getWTP_ s1) $-    fromEDict (getWTP_ s2) $ Right Dict-  STOr s1 s2 ->-    withSingI s1 $-    withSingI s2 $-    fromEDict (getWTP_ s1) $-    fromEDict (getWTP_ s2) $ Right Dict-  STLambda s1 s2 ->-    withSingI s1 $-    withSingI s2 $-    fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict-  STMap (s1 :: Sing si) s2 ->-      withSingI s1 $-      withSingI s2 $-      fromEDict (getWTP_ s1) $-      fromEDict (getWTP_ s2) $-      fromEDict-        ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s1-        ) $ Right Dict-  STBigMap (s1 :: Sing si) (s2 :: Sing si2) ->-      withSingI s1 $-      withSingI s2 $-      fromEDict (getWTP_ s1) $-      fromEDict (getWTP_ s2) $-      fromEDict-      ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s1-      ) $-      fromEDict-      ( maybeToRight (NotWellTyped (demote @si2) T.BtIsOperation) $ T.opAbsense s2-      ) $-      fromEDict-      ( maybeToRight (NotWellTyped (demote @si2) T.BtHasBigMap) $ T.bigMapAbsense s2-      ) $ Right Dict-  STInt -> Right Dict-  STNat -> Right Dict-  STString -> Right Dict-  STBytes -> Right Dict-  STMutez -> Right Dict-  STBool -> Right Dict-  STKeyHash -> Right Dict-  STBls12381Fr -> Right Dict-  STBls12381G1 -> Right Dict-  STBls12381G2 -> Right Dict-  STTimestamp -> Right Dict-  STAddress -> Right Dict-  STNever -> Right Dict---- | Version of 'getWTP' that accepts 'Sing' at term-level.-getWTP_ :: forall t. Sing t -> Either NotWellTyped (Dict (WellTyped t))-getWTP_ s = withSingI s $ getWTP @t---- | Given a type and an action that requires evidence that the type is well typed,---  generate the evidence and execute the action, or else fail with an error.-withWTPm :: forall t m a. (MonadFail m, SingI t) => (WellTyped t => m a) -> m a-withWTPm a = case getWTP @t of-  Right Dict -> a-  Left e -> fail (pretty e)---- | Similar to @withWTPm@ but is meant to be used within tests.-unsafeWithWTP :: forall t a. SingI t => (WellTyped t => a) -> a-unsafeWithWTP fn = case getWTP @t of-  Right Dict -> fn-  Left e -> error $ pretty e

− src/Michelson/TypeCheck/Value.hs

@@ -1,387 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.TypeCheck.Value-    ( typeCheckValImpl-    , tcFailedOnValue-    ) where--import Control.Monad.Except (liftEither, throwError)-import Data.Constraint (Dict(..))-import Data.Default (def)-import qualified Data.List.NonEmpty as NE-import qualified Data.Map as M-import qualified Data.Set as S-import Data.Singletons (Sing, SingI(..), demote, fromSing, withSingI)-import Data.Typeable ((:~:)(..))-import Fmt (pretty)-import Prelude hiding (EQ, GT, LT)--import Michelson.Text-import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))-import Michelson.TypeCheck.Helpers-import Michelson.TypeCheck.TypeCheck-  (SomeParamType(..), TcInstrHandler, TcOriginatedContracts, TypeCheckInstr, TypeCheckOptions(..),-  throwingTCError)-import Michelson.TypeCheck.Types-import Michelson.Typed-  (EpAddress(..), Notes(..), SingT(..), Value'(..), starNotes)-import qualified Michelson.Typed as T-import qualified Michelson.Untyped as U-import Tezos.Address (Address(..))-import Tezos.Core-import Tezos.Crypto-import qualified Tezos.Crypto.BLS12381 as BLS-import Util.Type (onFirst)--tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a-tcFailedOnValue v t msg err = do-  loc <- ask-  throwError $ TCFailedOnValue v t msg loc err---- | Function @typeCheckValImpl@ converts a single Michelson value--- given in representation from @Michelson.Type@ module to representation--- in strictly typed GADT.------ @typeCheckValImpl@ is polymorphic in the expected type of value.------ Type checking algorithm pattern-matches on parse value representation,--- expected type @t@ and constructs @Val t@ value.------ If there was no match on a given pair of value and expected type,--- that is interpreted as input of wrong type and type check finishes with--- error.------ @typeCheckValImpl@ also has a 'Maybe TcOriginatedContracts' argument that--- should contain the originated contracts when typechecking a parameter and--- 'Nothing' otherwise.-typeCheckValImpl-  :: forall ty.-     SingI ty-  => Maybe TcOriginatedContracts-  -> TcInstrHandler-  -> U.Value-  -> TypeCheckInstr (T.Value ty)-typeCheckValImpl mOriginatedContracts tcDo = doTypeCheckVal-  where-    doTypeCheckVal :: forall tz. SingI tz => U.Value -> TypeCheckInstr (T.Value tz)-    doTypeCheckVal uvalue = case (uvalue, sing @tz) of-      (U.ValueInt i, STInt) -> pure $ T.VInt i-      (v@(U.ValueInt i), t@STNat)-        | i >= 0 -> pure $ VNat (fromInteger i)-        | otherwise -> tcFailedOnValue v (fromSing t) "" (Just NegativeNat)-      (v@(U.ValueInt i), t@STMutez) -> case mkMutez $ fromInteger i of-        Just m -> pure $ VMutez m-        Nothing -> tcFailedOnValue v (fromSing t) "" (Just InvalidTimestamp)-      (U.ValueString s, STString) -> pure $ VString s-      (v@(U.ValueString s), t@STAddress) -> case T.parseEpAddress (unMText s) of-        Right addr -> pure $ VAddress addr-        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidAddress err)-      (v@(U.ValueBytes b), t@STAddress) -> case T.parseEpAddressRaw (U.unInternalByteString b) of-        Right addr -> pure $ VAddress addr-        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidAddress err)-      (v@(U.ValueString s), t@STKeyHash) -> case parseKeyHash (unMText s)  of-        Right kHash -> pure $ VKeyHash kHash-        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)-      (v@(U.ValueBytes b), t@STKeyHash) ->-        case parseKeyHashRaw (U.unInternalByteString b) of-          Right kHash -> pure $ VKeyHash kHash-          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)-      (U.ValueInt i, STBls12381Fr) ->-        pure $ VBls12381Fr (fromIntegral i)-      (v@(U.ValueBytes b), t@STBls12381Fr) ->-        case BLS.fromMichelsonBytes (U.unInternalByteString b) of-          Right val -> pure $ VBls12381Fr val-          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)-      (v@(U.ValueBytes b), t@STBls12381G1) ->-        case BLS.fromMichelsonBytes (U.unInternalByteString b) of-          Right val -> pure $ VBls12381G1 val-          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)-      (v@(U.ValueBytes b), t@STBls12381G2) ->-        case BLS.fromMichelsonBytes (U.unInternalByteString b) of-          Right val -> pure $ VBls12381G2 val-          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)-      (v@(U.ValueString s), t@STTimestamp) -> case parseTimestamp $ unMText s of-        Just tstamp -> pure $ VTimestamp tstamp-        Nothing -> tcFailedOnValue v (fromSing t) "" (Just InvalidTimestamp)-      (U.ValueInt i, STTimestamp) -> pure $ VTimestamp (timestampFromSeconds i)-      (U.ValueBytes (U.InternalByteString s), STBytes) -> pure $ VBytes s-      (U.ValueTrue, STBool) -> pure $ VBool True-      (U.ValueFalse, STBool) -> pure $ VBool False--      (U.ValueString (parsePublicKey . unMText -> Right s), STKey) ->-        pure $ T.VKey s-      (U.ValueBytes (parsePublicKeyRaw . U.unInternalByteString -> Right s), STKey) ->-        pure $ VKey s--      (U.ValueString (parseSignature . unMText -> Right s), STSignature) ->-        pure $ VSignature s-      (U.ValueBytes (parseSignatureRaw . U.unInternalByteString  -> Right s), STSignature) ->-        pure $ VSignature s--      (U.ValueString (parseChainId . unMText -> Right ci), STChainId) ->-        pure $ VChainId ci-      (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci), STChainId) ->-        pure $ VChainId ci--      (cv@(U.ValueString (T.parseEpAddress . unMText -> Right addr))-        , STContract pc) -> withSingI pc $ typecheckContractValue cv addr pc-      (cv@(U.ValueBytes (T.parseEpAddressRaw . U.unInternalByteString -> Right addr))-        , STContract pc) -> withSingI pc $ typecheckContractValue cv addr pc--      (cv, s@(STTicket vt)) -> withSingI vt $ lift (asks tcStrict) >>= \case-        -- Note [Tickets forging]-        -- Normally, ticket values cannot be constructed manually (i.e. forged)-        -- by design, and the only valid way to make a ticket is calling-        -- @TICKET@ instruction.-        ---        -- However @tezos-client run@ adds an exception, it allows passing a-        -- manually constructed ticket value as parameter or initial storage.-        True ->-          tcFailedOnValue cv (demote @tz)-            "ticket values cannot be forged in real operations"-            Nothing-        False -> case cv of-          U.ValuePair addrV (U.ValuePair datV amV) -> withComparable vt cv s $ do-            addrValue <- doTypeCheckVal @'T.TAddress addrV-            dat <- doTypeCheckVal datV-            amountValue <- doTypeCheckVal @'T.TNat amV-            case (addrValue, amountValue) of-              (VAddress (EpAddress addr ep), VNat am) -> do-                unless (U.isDefEpName ep) $-                  tcFailedOnValue cv (demote @tz)-                    "it is pointless to provide an address with entrypoint as a \-                    \ticketer, we do not support that"-                    Nothing-                -- ↑ Tezos allows passing addresses with entrypoint, but it is-                -- not possible to sanely work with them after that anyway,-                -- since @TICKET@ instruction (the only valid way of constructing-                -- tickets in real run) uses @SELF_ADDRESS@ result as ticketer.-                return $ VTicket addr dat am-          _ ->-            tcFailedOnValue cv (demote @tz)-              "ticket type expects a value of type `(pair address <data> nat)`"-              Nothing--      (U.ValueUnit, STUnit) -> pure $ VUnit-      (U.ValuePair ml mr, STPair lt rt) -> withSingI lt $ withSingI rt $ do-        l <- doTypeCheckVal ml-        r <- doTypeCheckVal mr-        pure $ VPair (l, r)-      (U.ValueLeft ml, STOr lt rt) -> withSingI lt $ withSingI rt $ do-        l <- doTypeCheckVal ml-        pure $ VOr (Left l)-      (U.ValueRight mr, STOr lt rt) -> withSingI lt $ withSingI rt $ do-        r <- doTypeCheckVal mr-        pure $ VOr (Right r)-      (U.ValueSome mv, STOption op) -> withSingI op $ do-        v <- doTypeCheckVal mv-        pure $ VOption (Just v)-      (U.ValueNone, STOption op) -> withSingI op $ do-        pure $ VOption Nothing--      (U.ValueNil, STList l) -> withSingI l $-        pure $ T.VList []--      -- If ValueSeq contains at least 2 elements, it can be type checked as a-      -- right combed pair.-      (U.ValueSeq vals@(_ :| (_ : _)), STPair l r) ->-        withSingI l $ withSingI r $ doTypeCheckVal $ seqToRightCombedPair vals--      (U.ValueSeq (toList -> mels), STList l) -> withSingI l $ do-        els <- typeCheckValsImpl mels-        pure $ VList els--      (U.ValueNil, STSet (s :: Sing st)) -> withSingI s $ do-        instrPos <- ask-        case T.getComparableProofS s of-          Just Dict -> pure (T.VSet S.empty)-          Nothing -> throwError $ TCFailedOnValue uvalue (demote @st) "Non comparable types are not allowed in Sets"-            instrPos (Just $ UnsupportedTypeForScope (demote @st) T.BtNotComparable)--      (sq@(U.ValueSeq (toList -> mels)), s@(STSet (vt :: Sing st))) ->-        withComparable vt sq s $ withSingI vt $ do-        instrPos <- ask--        els <- typeCheckValsImpl mels-        elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els-                  `onFirst` \msg -> TCFailedOnValue sq (fromSing vt) msg instrPos Nothing-        pure $ VSet elsS--      (v@U.ValueNil, s@(STMap (st :: Sing st) vt)) ->-        withSingI st $ withSingI vt $ withComparable st v s $ pure $ T.VMap M.empty--      (sq@(U.ValueMap (toList -> mels)), s@(STMap (kt :: Sing st) vt)) ->-        withSingI kt $ withSingI vt $ withComparable kt sq s $ do-        keyOrderedElts <- typeCheckMapVal mels sq kt-        pure $ VMap (M.fromDistinctAscList keyOrderedElts)--      (v@U.ValueNil, s@(STBigMap (st1 :: Sing st) (st2 :: Sing st2))) ->-        withSingI st1 $ withSingI st2 $ withComparable st1 v s $ withBigMapAbsence st2 v s $-          pure $ VBigMap Nothing M.empty--      (sq@(U.ValueMap (toList -> mels)), s@(STBigMap (kt :: Sing st) (vt :: Sing vt))) ->-        withSingI kt $ withSingI vt $-        withComparable kt sq s $ withBigMapAbsence vt sq s $ do-          keyOrderedElts <- typeCheckMapVal mels sq kt-          pure $ VBigMap Nothing (M.fromDistinctAscList keyOrderedElts)--      -- `{ {} }` can be typechecked either as `VLam` or `VList`.-      (U.ValueLambda s, (STList l :: Sing st)) -> withSingI l $-        case emptyLambdaAsList s of-          Just xs -> doTypeCheckVal @st xs-          Nothing -> tcFailedOnValue uvalue (demote @st) "" Nothing--      (U.ValueSeq s, ((STLambda (i :: Sing inp) (o :: Sing out))) :: Sing l) ->-        withSingI i $ withSingI o $ case emptyListAsLambda s of-          Just xs -> doTypeCheckVal @l xs-          Nothing -> tcFailedOnValue uvalue (demote @l) "" Nothing--      (v, STLambda (var :: Sing it) (b :: Sing ot)) -> withSingI var $ withSingI b $ do-        mp <- case v of-          U.ValueNil       -> pure []-          U.ValueLambda mp -> pure $ toList mp-          _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing-        _ :/ instr <--          withWTP @it uvalue $ throwingTCError $-            typeCheckImpl tcDo mp ((starNotes @it, Dict, def) ::& SNil)-        case instr of-          lam ::: (lo :: HST lo) -> withWTP @ot uvalue $ do-            case eqHST1 @ot lo of-              Right Refl -> do-                pure $ VLam (T.RfNormal lam)-              Left m ->-                tcFailedOnValue v (demote @ty)-                        "wrong output type of lambda's value:" (Just m)-          AnyOutInstr lam ->-            pure $ VLam (T.RfAlwaysFails lam)--      (v, t) -> tcFailedOnValue v (fromSing t) "unknown value" Nothing--    seqToRightCombedPair :: (NonEmpty $ U.Value) -> U.Value-    seqToRightCombedPair (x :| [y]) = U.ValuePair x y-    seqToRightCombedPair (x :| xs) = U.ValuePair x $ seqToRightCombedPair (NE.fromList xs)--    -- Converts a lambda containing only empty 'SeqEx's (possibly nested)-    -- to a list of empty lists.-    emptyLambdaAsList :: NonEmpty U.ExpandedOp -> Maybe U.Value-    emptyLambdaAsList ops =-      let-        opToMaybeList :: U.ExpandedOp -> Maybe U.Value-        opToMaybeList = \case-          U.SeqEx []      -> Just U.ValueNil-          U.SeqEx xs      -> U.ValueSeq . NE.fromList <$> traverse opToMaybeList xs-          U.PrimEx {}     -> Nothing-          U.WithSrcEx _ i -> opToMaybeList i-      in-        U.ValueSeq <$> traverse opToMaybeList ops--    -- Converts a list containing only empty lists (possibly nested)-    -- to a lambda of empty 'SeqEx's.-    emptyListAsLambda :: NonEmpty U.Value -> Maybe U.Value-    emptyListAsLambda ops =-      let-        listToMaybeOp :: U.Value -> Maybe U.ExpandedOp-        listToMaybeOp = \case-          U.ValueNil      -> Just $ U.SeqEx []-          U.ValueSeq xs   -> U.SeqEx . toList <$> traverse listToMaybeOp xs-          _               -> Nothing-      in-        U.ValueLambda <$> traverse listToMaybeOp ops--    withWTP-      :: forall t a. SingI t-      => U.Value-      -> (T.WellTyped t => TypeCheckInstr a)-      -> TypeCheckInstr a-    withWTP uvalue fn = case getWTP @t of-      Right Dict -> fn-      Left (NotWellTyped t cause) -> tcFailedOnValue uvalue (demote @ty)-                  ("Value is not well typed: '" <> show t <> "' because it " <> pretty cause) Nothing--    typeCheckValsImpl-      :: forall t . (SingI t)-      => [U.Value]-      -> TypeCheckInstr [T.Value t]-    typeCheckValsImpl mvs =-      fmap reverse $ foldM (\res mv -> (: res) <$> doTypeCheckVal @t mv) [] mvs--    -- Typechecks given list of @Elt@s and ensures that its keys are in ascending order.-    ---    -- It return list of pairs (key, value) with keys in ascending order-    -- so it is safe to call @fromDistinctAscList@ on returned list-    typeCheckMapVal-      :: forall kt vt. (SingI vt)-      => [U.Elt U.ExpandedOp]-      -> U.Value-      -> Sing kt-      -> TypeCheckInstr [(T.Value kt, T.Value vt)]-    typeCheckMapVal mels sq kt = withSingI kt $ withComparable kt sq kt $ do-      instrPos <- ask-      ks <- typeCheckValsImpl @kt (map (\(U.Elt k _) -> k) mels)-      vals <- typeCheckValsImpl @vt (map (\(U.Elt _ v) -> v) mels)-      ksS <- liftEither $ ensureDistinctAsc id ks-            `onFirst` \msg -> TCFailedOnValue sq (fromSing kt) msg instrPos Nothing-      pure $ zip ksS vals--    typecheckContractValue-      :: forall cp tz. (tz ~ 'T.TContract cp)-      => U.Value -> EpAddress -> Sing cp -> TypeCheckInstr (T.Value tz)-    typecheckContractValue cv (EpAddress addr epName) pc = do--      instrPos <- ask-      let ensureTypeMatches :: forall t'. SingI t' => TypeCheckInstr (cp :~: t')-          ensureTypeMatches = liftEither @_ @TypeCheckInstr $-            first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $-              (withSingI pc $ eqType @cp @t')-      let unsupportedType :: T.BadTypeForScope -> TCError-          unsupportedType reason = TCFailedOnValue cv (fromSing pc)-            "Unsupported type in type argument of 'contract' type" instrPos $-              Just $ UnsupportedTypeForScope (fromSing pc) reason-      case addr of-        KeyAddress _ -> do-          Refl <- ensureTypeMatches @'T.TUnit-          pure $ VContract addr T.sepcPrimitive-        ContractAddress ca -> case mOriginatedContracts of-          Nothing -> liftEither . Left $ unsupportedType T.BtHasContract-          Just originatedContracts -> case M.lookup ca originatedContracts of-            Just (SomeParamType (_ :: Sing cp') paramNotes) ->-              case T.mkEntrypointCall epName paramNotes of-                Nothing ->-                  throwError $-                  TCFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $-                  EntrypointNotFound epName-                Just (T.MkEntrypointCallRes (_ :: Notes t') epc) -> do-                  Refl <- ensureTypeMatches @t'-                  pure $ VContract addr (T.SomeEpc epc)-            Nothing ->-              throwError $ TCFailedOnValue cv (demote @ty) "Contract literal unknown"-                instrPos (Just $ UnknownContract addr)--withComparable-  :: forall a (t :: T.T) ty. Sing a-  -> U.Value-  -> Sing t-  -> (T.Comparable a => TypeCheckInstr ty)-  -> TypeCheckInstr ty-withComparable s uv t act = case T.getComparableProofS s of-  Just Dict -> act-  Nothing -> do-    instrPos <- ask-    liftEither . Left $-      TCFailedOnValue uv (fromSing t) "Require a comparable type here" instrPos Nothing--withBigMapAbsence-  :: forall a (t :: T.T) ty. Sing a-  -> U.Value-  -> Sing t-  -> (T.HasNoBigMap a => TypeCheckInstr ty)-  -> TypeCheckInstr ty-withBigMapAbsence s uv t act = case T.bigMapAbsense s of-  Just Dict -> act-  Nothing -> do-    instrPos <- ask-    liftEither . Left $-      TCFailedOnValue uv (fromSing t) "Require a type which doesn't contain `big_map` here"-        instrPos Nothing

− src/Michelson/Typed.hs

@@ -1,25 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Typed-  ( module Exports-  ) where--import Michelson.Typed.Aliases as Exports-import Michelson.Typed.Annotation as Exports-import Michelson.Typed.Arith as Exports-import Michelson.Typed.Convert as Exports-import Michelson.Typed.Doc as Exports-import Michelson.Typed.Entrypoints as Exports-import Michelson.Typed.Existential as Exports-import Michelson.Typed.Extract as Exports-import Michelson.Typed.Haskell as Exports-import Michelson.Typed.Instr as Exports-import Michelson.Typed.OpSize as Exports-import Michelson.Typed.Polymorphic as Exports-import Michelson.Typed.Scope as Exports-import Michelson.Typed.Sing as Exports-import Michelson.Typed.T as Exports-import Michelson.Typed.Util as Exports-import Michelson.Typed.Value as Exports

− src/Michelson/Typed/Aliases.hs

@@ -1,14 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Typed.Aliases-  ( Value-  , Operation-  ) where--import Michelson.Typed.Instr-import Michelson.Typed.Value--type Value = Value' Instr-type Operation = Operation' Instr

− src/Michelson/Typed/Annotation.hs

@@ -1,309 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, providing @Notes t@ data type, which holds annotations for a--- given type @t@.------ Annotation type @Notes t@ is a tree, each leaf is either a star (@*@) or a--- constructor holding some annotation data for a given type @t@.--- Star corresponds to the case when given Michelson type contains no--- annotations.------ This module also provides type class 'Converge' along with some--- utility functions which are used to combine two annotations trees--- `a` and `b` into a new one `c` in such a way that `c` can be obtained from--- both `a` and `b` by replacing some @*@ leafs with type or/and field--- annotations.--module Michelson.Typed.Annotation-  ( Notes (..)-  , AnnConvergeError(..)-  , converge-  , convergeAnns-  , convergeDestrAnns-  , insertTypeAnn-  , isStar-  , starNotes-  , notesSing-  , notesT-  ) where--import Data.Singletons (Sing, SingI(..), fromSing, withSingI)-import Fmt (Buildable(..), (+|), (|+))-import Text.PrettyPrint.Leijen.Text (Doc, (<+>))-import qualified Text.Show--import Michelson.Printer.Util-  (RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens, printDocS)-import Michelson.Typed.Sing-import Michelson.Typed.T (T(..))-import Michelson.Untyped.Annotation-  (Annotation, FieldAnn, TypeAnn, VarAnn, convergeVarAnns, fullAnnSet, noAnn, singleAnnSet,-  unifyAnn, unifyPairFieldAnn)-import Util.TH-import Util.Typeable---- | Data type, holding annotation data for a given Michelson type @t@.------ Each constructor corresponds to exactly one constructor of 'T'--- and holds all type and field annotations that can be attributed to a--- Michelson type corresponding to @t@.-data Notes t where-  NTKey       :: TypeAnn -> Notes 'TKey-  NTUnit      :: TypeAnn -> Notes 'TUnit-  NTSignature :: TypeAnn -> Notes 'TSignature-  NTChainId   :: TypeAnn -> Notes 'TChainId-  NTOption    :: TypeAnn -> Notes t -> Notes ('TOption t)-  NTList      :: TypeAnn -> Notes t -> Notes ('TList t)-  NTSet       :: TypeAnn -> Notes t -> Notes ('TSet t)-  NTOperation :: TypeAnn -> Notes 'TOperation-  NTContract  :: TypeAnn -> Notes t -> Notes ('TContract t)-  NTTicket    :: TypeAnn -> Notes t -> Notes ('TTicket t)-  NTPair      :: TypeAnn -> FieldAnn -> FieldAnn-              -> VarAnn -> VarAnn-              -> Notes p -> Notes q -> Notes ('TPair p q)-  NTOr        :: TypeAnn -> FieldAnn -> FieldAnn-              -> Notes p -> Notes q -> Notes ('TOr p q)-  NTLambda    :: TypeAnn -> Notes p -> Notes q -> Notes ('TLambda p q)-  NTMap       :: TypeAnn -> Notes k -> Notes v -> Notes ('TMap k v)-  NTBigMap    :: TypeAnn -> Notes k -> Notes v -> Notes ('TBigMap k v)-  NTInt       :: TypeAnn -> Notes 'TInt-  NTNat       :: TypeAnn -> Notes 'TNat-  NTString    :: TypeAnn -> Notes 'TString-  NTBytes     :: TypeAnn -> Notes 'TBytes-  NTMutez     :: TypeAnn -> Notes 'TMutez-  NTBool      :: TypeAnn -> Notes 'TBool-  NTKeyHash   :: TypeAnn -> Notes 'TKeyHash-  NTBls12381Fr :: TypeAnn -> Notes 'TBls12381Fr-  NTBls12381G1 :: TypeAnn -> Notes 'TBls12381G1-  NTBls12381G2 :: TypeAnn -> Notes 'TBls12381G2-  NTTimestamp :: TypeAnn -> Notes 'TTimestamp-  NTAddress   :: TypeAnn -> Notes 'TAddress-  NTNever     :: TypeAnn -> Notes 'TNever--deriving stock instance Eq (Notes t)-$(deriveGADTNFData ''Notes)---instance Show (Notes t) where-  show = printDocS True . renderDoc doesntNeedParens--instance Buildable (Notes t) where-  build = buildRenderDoc--instance RenderDoc (Notes t) where-  renderDoc pn n = addParens pn $ case n of-    NTInt ta                -> "NTInt" <+> rendT ta-    NTNat ta                -> "NTNat" <+> rendT ta-    NTString ta             -> "NTString" <+> rendT ta-    NTBytes ta              -> "NTBytes" <+> rendT ta-    NTMutez ta              -> "NTMutez" <+> rendT ta-    NTBool ta               -> "NTBool" <+> rendT ta-    NTKeyHash ta            -> "NTKeyHash" <+> rendT ta-    NTBls12381Fr ta         -> "NTBls12381Fr" <+> rendT ta-    NTBls12381G1 ta         -> "NTBls12381G1" <+> rendT ta-    NTBls12381G2 ta         -> "NTBls12381G2" <+> rendT ta-    NTTimestamp ta          -> "NTTimestamp" <+> rendT ta-    NTAddress ta            -> "NTAddress" <+> rendT ta-    NTKey ta                -> "NTKey" <+> rendT ta-    NTUnit ta               -> "NTUnit" <+> rendT ta-    NTSignature ta          -> "NTSignature" <+> rendT ta-    NTChainId ta            -> "NTChainId" <+> rendT ta-    NTNever ta              -> "NTNever" <+> rendT ta-    NTOption ta nt          -> "NTOption" <+> rendT ta <+> rendN nt-    NTList ta nt            -> "NTList" <+> rendT ta <+> rendN nt-    NTSet ta nt             -> "NTSet" <+> rendT ta <+> rendN nt-    NTOperation ta          -> "NTOperation" <+> rendT ta-    NTContract ta nt        -> "NTContract" <+> rendT ta <+> rendN nt-    NTTicket ta nt          -> "NTTicket" <+> rendT ta <+> rendN nt-    NTPair ta fa1 fa2 va1 va2 np nq -> "NTPair" <+> rendTFV2 ta fa1 fa2 va1 va2 <+> rendN np <+> rendN nq-    NTOr ta fa1 fa2 np nq   -> "NTOr" <+> rendTF2 ta fa1 fa2 <+> rendN np <+> rendN nq-    NTLambda ta np nq       -> "NTLambda" <+> rendT ta <+> rendN np <+> rendN nq-    NTMap ta np nq          -> "NTMap" <+> rendT ta <+> rendN np <+> rendN nq-    NTBigMap ta np nq       -> "NTBigMap" <+> rendT ta <+> rendN np <+> rendN nq-    where-      rendN :: Notes n -> Doc-      rendN = renderDoc needsParens--      rendT :: TypeAnn -> Doc-      rendT = renderDoc doesntNeedParens . singleAnnSet--      rendTF2 :: TypeAnn -> FieldAnn -> FieldAnn -> Doc-      rendTF2 t f1 f2 = renderDoc doesntNeedParens $ fullAnnSet [t] [f1, f2] []--      rendTFV2 :: TypeAnn -> FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> Doc-      rendTFV2 t f1 f2 v1 v2 = renderDoc doesntNeedParens $ fullAnnSet [t] [f1, f2] [v1, v2]---- | Forget information about annotations, pick singleton with the same type.------ Note: currently we cannot derive 'Sing' from 'Notes' without 'SingI' because--- for comparable types notes do not remember which exact comparable was used.-notesSing :: SingI t => Notes t -> Sing t-notesSing _ = sing---- | Get term-level type of notes.-notesT :: SingI t => Notes t -> T-notesT = fromSing . notesSing---- | In memory of `NStar` constructor.---   Generates notes with no annotations.-starNotes :: forall t. SingI t => Notes t-starNotes = case sing @t of-  STInt -> NTInt noAnn-  STNat -> NTNat noAnn-  STString -> NTString noAnn-  STBytes -> NTBytes noAnn-  STMutez -> NTMutez noAnn-  STBool -> NTBool noAnn-  STKeyHash -> NTKeyHash noAnn-  STBls12381Fr -> NTBls12381Fr noAnn-  STBls12381G1 -> NTBls12381G1 noAnn-  STBls12381G2 -> NTBls12381G2 noAnn-  STTimestamp -> NTTimestamp noAnn-  STAddress -> NTAddress noAnn-  STKey -> NTKey noAnn-  STUnit -> NTUnit noAnn-  STNever -> NTNever noAnn-  STSignature -> NTSignature noAnn-  STChainId -> NTChainId noAnn-  STOperation -> NTOperation noAnn-  STSet t -> NTSet noAnn (withSingI t starNotes)-  STList t -> NTList noAnn (withSingI t starNotes)-  STOption t -> NTOption noAnn (withSingI t starNotes)-  STContract t -> NTContract noAnn (withSingI t starNotes)-  STTicket t -> NTTicket noAnn (withSingI t starNotes)-  STMap t t' ->-    NTMap noAnn (withSingI t starNotes) (withSingI t' starNotes)-  STBigMap t t' ->-    NTBigMap noAnn (withSingI t starNotes) (withSingI t' starNotes)-  STPair t t' ->-    NTPair noAnn noAnn noAnn noAnn noAnn (withSingI t starNotes) (withSingI t' starNotes)-  STOr t t' ->-    NTOr noAnn noAnn noAnn (withSingI t starNotes) (withSingI t' starNotes)-  STLambda t t' ->-    NTLambda noAnn (withSingI t starNotes) (withSingI t' starNotes)---- | Checks if no annotations are present.-isStar :: SingI t => Notes t -> Bool-isStar = (== starNotes)---- | Combines two annotations trees `a` and `b` into a new one `c`--- in such a way that `c` can be obtained from both `a` and `b` by replacing--- some empty leaves with type or/and field annotations.-converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t)-converge n1 n2 = case (n1, n2) of-  (NTInt a, NTInt b) -> NTInt <$> convergeAnns a b-  (NTNat a, NTNat b) -> NTNat <$> convergeAnns a b-  (NTString a, NTString b) -> NTString <$> convergeAnns a b-  (NTBytes a, NTBytes b) -> NTBytes <$> convergeAnns a b-  (NTMutez a, NTMutez b) -> NTMutez <$> convergeAnns a b-  (NTBool a, NTBool b) -> NTBool <$> convergeAnns a b-  (NTKeyHash a, NTKeyHash b) -> NTKeyHash <$> convergeAnns a b-  (NTBls12381Fr a, NTBls12381Fr b) -> NTBls12381Fr <$> convergeAnns a b-  (NTBls12381G1 a, NTBls12381G1 b) -> NTBls12381G1 <$> convergeAnns a b-  (NTBls12381G2 a, NTBls12381G2 b) -> NTBls12381G2 <$> convergeAnns a b-  (NTTimestamp a, NTTimestamp b) -> NTTimestamp <$> convergeAnns a b-  (NTAddress a, NTAddress b) -> NTAddress <$> convergeAnns a b-  (NTKey a, NTKey b) -> NTKey <$> convergeAnns a b-  (NTUnit a, NTUnit b) -> NTUnit <$> convergeAnns a b-  (NTNever a, NTNever b) -> NTNever <$> convergeAnns a b-  (NTSignature a, NTSignature b) ->-    NTSignature <$> convergeAnns a b-  (NTChainId a, NTChainId b) ->-    NTChainId <$> convergeAnns a b-  (NTOption a n, NTOption b m) ->-    NTOption <$> convergeAnns a b <*> converge n m-  (NTList a n, NTList b m) ->-    NTList <$> convergeAnns a b <*> converge n m-  (NTSet a n, NTSet b m) ->-    NTSet <$> convergeAnns a b <*> converge n m-  (NTOperation a, NTOperation b) ->-    NTOperation <$> convergeAnns a b-  (NTContract a n, NTContract b m) ->-    NTContract <$> convergeAnns a b <*> converge n m-  (NTTicket a n, NTTicket b m) ->-    NTTicket <$> convergeAnns a b <*> converge n m-  (NTPair a pF qF pV qV pN qN, NTPair b pG qG pW qW pM qM) ->-    NTPair <$> convergeAnns a b-           <*> convergeAnns pF pG <*> convergeAnns qF qG-           <*> pure (convergeVarAnns pV pW) <*> pure (convergeVarAnns qV qW)-           <*> converge pN pM <*> converge qN qM-  (NTOr a pF qF pN qN, NTOr b pG qG pM qM) ->-    NTOr <$> convergeAnns a b <*> convergeAnns pF pG <*> convergeAnns qF qG-         <*> converge pN pM <*> converge qN qM-  (NTLambda a pN qN, NTLambda b pM qM) ->-    NTLambda <$> convergeAnns a b <*> converge pN pM <*> converge qN qM-  (NTMap a kN vN, NTMap b kM vM) ->-    NTMap <$> convergeAnns a b <*> converge kN kM <*> converge vN vM-  (NTBigMap a kN vN, NTBigMap b kM vM) ->-    NTBigMap <$> convergeAnns a b <*> converge kN kM <*> converge vN vM---- | Insert the provided type annotation into the provided notes.-insertTypeAnn :: forall (b :: T). TypeAnn -> Notes b -> Notes b-insertTypeAnn nt s = case s of-  NTInt _ -> NTInt nt-  NTNat _ -> NTNat nt-  NTString _ -> NTString nt-  NTBytes _ -> NTBytes nt-  NTMutez _ -> NTMutez nt-  NTBool _ -> NTBool nt-  NTKeyHash _ -> NTKeyHash nt-  NTBls12381Fr _ -> NTBls12381Fr nt-  NTBls12381G1 _ -> NTBls12381G1 nt-  NTBls12381G2 _ -> NTBls12381G2 nt-  NTTimestamp _ -> NTTimestamp nt-  NTAddress _ -> NTAddress nt-  NTKey _ -> NTKey nt-  NTUnit _ -> NTUnit nt-  NTSignature _ -> NTSignature nt-  NTOption _ n1  -> NTOption nt n1-  NTList _ n1 -> NTList nt n1-  NTSet _ n1 -> NTSet nt n1-  NTOperation _ -> NTOperation nt-  NTContract _ n1 -> NTContract nt n1-  NTTicket _ n1 -> NTTicket nt n1-  NTPair _ n1 n2 n3 n4 n5 n6 -> NTPair nt n1 n2 n3 n4 n5 n6-  NTOr _ n1 n2 n3 n4 -> NTOr nt n1 n2 n3 n4-  NTLambda _ n1 n2 -> NTLambda nt n1 n2-  NTMap _ n1 n2 -> NTMap nt n1 n2-  NTBigMap _ n1 n2 -> NTBigMap nt n1 n2-  NTChainId _ -> NTChainId nt-  NTNever _ -> NTNever nt--data AnnConvergeError where-  AnnConvergeError-    :: forall (tag :: Type).-       (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)-    => Annotation tag -> Annotation tag -> AnnConvergeError--deriving stock instance Show AnnConvergeError--instance Eq AnnConvergeError where-  AnnConvergeError ann1 ann2 == AnnConvergeError ann1' ann2' =-    (ann1 `eqParam1` ann1') && (ann2 `eqParam1` ann2')--instance Buildable AnnConvergeError where-  build (AnnConvergeError ann1 ann2) =-    "Annotations do not converge: " +| ann1 |+ " /= " +| ann2 |+ ""--convergeAnnsImpl-  :: forall (tag :: Type).-     (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)-  => (Annotation tag -> Annotation tag -> Maybe (Annotation tag))-  -> Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)-convergeAnnsImpl unify a b = maybe (Left $ AnnConvergeError a b) pure $ unify a b---- | Converge two type or field notes (which may be wildcards).-convergeAnns-  :: forall (tag :: Type).-     (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)-  => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)-convergeAnns = convergeAnnsImpl unifyAnn---- | Converge two field notes in CAR, CDR or UNPAIR, given that one of them may be a--- special annotation.-convergeDestrAnns :: FieldAnn -> FieldAnn -> Either AnnConvergeError FieldAnn-convergeDestrAnns = convergeAnnsImpl unifyPairFieldAnn--$(deriveGADTNFData ''AnnConvergeError)

− src/Michelson/Typed/Arith.hs

@@ -1,469 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, containing some boilerplate for support of--- arithmetic operations in Michelson language.--module Michelson.Typed.Arith-  ( ArithOp (..)-  , UnaryArithOp (..)-  , ToIntArithOp (..)-  , ArithError (..)-  , ShiftArithErrorType (..)-  , MutezArithErrorType (..)-  , Add-  , Sub-  , Mul-  , Abs-  , Neg-  , Or-  , And-  , Xor-  , Not-  , Lsl-  , Lsr-  , Compare-  , Eq'-  , Neq-  , Lt-  , Gt-  , Le-  , Ge-  , compareOp--  -- * Misc-  , Bls12381MulBadOrder-  ) where--import Data.Bits (complement, shift, (.&.), (.|.))-import Data.Constraint (Dict(..))-import Fmt (Buildable(build))--import Michelson.Typed.Annotation (AnnConvergeError, Notes(..), converge, convergeAnns, starNotes)-import Michelson.Typed.T (T(..))-import Michelson.Typed.Value (Comparable, Value'(..))-import Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds)-import qualified Tezos.Crypto.BLS12381 as BLS-import Util.TypeLits---- | Class for binary arithmetic operation.------ Takes binary operation marker as @op@ parameter,--- types of left operand @n@ and right operand @m@.------ 'Typeable' constraints in superclass are necessary for error messages.-class (Typeable n, Typeable m) =>-      ArithOp aop (n :: T) (m :: T) where--  -- | Type family @ArithRes@ denotes the type resulting from-  -- computing operation @op@ from operands of types @n@ and @m@.-  ---  -- For instance, adding integer to natural produces integer,-  -- which is reflected in following instance of type family:-  -- @ArithRes Add CNat CInt = CInt@.-  type ArithRes aop n m :: T--  -- | Converge the notes of given operands.-  convergeArith-    :: proxy aop-    -> Notes n-    -> Notes m-    -> Either AnnConvergeError (Notes (ArithRes aop n m))--  -- | Evaluate arithmetic operation on given operands.-  evalOp-    :: proxy aop-    -> Value' instr n-    -> Value' instr m-    -> Either (ArithError (Value' instr n) (Value' instr m)) (Value' instr (ArithRes aop n m))--  -- | An operation can marked as commutative, it does not affect its-  -- runtime behavior, but enables certain optimization in the optimizer.-  -- We conservatively consider operations non-commutative by default.-  ---  -- Note that there is one unusual case: @AND@ works with @int : nat@-  -- but not with @nat : int@. That's how it's specified in Michelson.-  commutativityProof :: Maybe $ Dict (ArithRes aop n m ~ ArithRes aop m n, ArithOp aop m n)-  commutativityProof = Nothing---- | Denotes the error type occurred in the arithmetic shift operation.-data ShiftArithErrorType-  = LslOverflow-  | LsrUnderflow-  deriving stock (Show, Eq, Ord, Generic)--instance NFData ShiftArithErrorType---- | Denotes the error type occurred in the arithmetic operation involving mutez.-data MutezArithErrorType-  = AddOverflow-  | MulOverflow-  | SubUnderflow-  deriving stock (Show, Eq, Ord, Generic)--instance NFData MutezArithErrorType---- | Represents an arithmetic error of the operation.-data ArithError n m-  = MutezArithError MutezArithErrorType n m-  | ShiftArithError ShiftArithErrorType n m-  deriving stock (Show, Eq, Ord, Generic)--instance (NFData n, NFData m) => NFData (ArithError n m)---- | Class for unary arithmetic operation.-class UnaryArithOp aop (n :: T) where-  type UnaryArithRes aop n :: T-  evalUnaryArithOp :: proxy aop -> Value' instr n -> Value' instr (UnaryArithRes aop n)---- | Class for conversions to an integer value.-class ToIntArithOp (n :: T) where-  evalToIntOp :: Value' instr n -> Value' instr 'TInt--data Add-data Sub-data Mul-data Abs-data Neg--data Or-data And-data Xor-data Not-data Lsl-data Lsr--data Compare-data Eq'-data Neq-data Lt-data Gt-data Le-data Ge---- For implementation hints see the reference implementation:--- (note that you may need to change the branch)--- https://gitlab.com/metastatedev/tezos/blob/master/src/proto_alpha/lib_protocol/script_ir_translator.ml#L4601--instance ArithOp Add 'TNat 'TInt where-  type ArithRes Add 'TNat 'TInt = 'TInt-  convergeArith _ _ n2 = Right n2-  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i + j)-  commutativityProof = Just Dict-instance ArithOp Add 'TInt 'TNat where-  type ArithRes Add 'TInt 'TNat = 'TInt-  convergeArith _ n1 _ = Right n1-  evalOp _ (VInt i) (VNat j) = Right $ VInt (i + toInteger j)-  commutativityProof = Just Dict-instance ArithOp Add 'TNat 'TNat where-  type ArithRes Add 'TNat 'TNat = 'TNat-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VNat i) (VNat j) = Right $ VNat (i + j)-  commutativityProof = Just Dict-instance ArithOp Add 'TInt 'TInt where-  type ArithRes Add 'TInt 'TInt = 'TInt-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VInt i) (VInt j) = Right $ VInt (i + j)-  commutativityProof = Just Dict-instance ArithOp Add 'TTimestamp 'TInt where-  type ArithRes Add 'TTimestamp 'TInt = 'TTimestamp-  convergeArith _ n1 _ = Right n1-  evalOp _ (VTimestamp i) (VInt j) =-    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i + j-  commutativityProof = Just Dict-instance ArithOp Add 'TInt 'TTimestamp where-  type ArithRes Add 'TInt 'TTimestamp = 'TTimestamp-  convergeArith _ _ n2 = Right n2-  evalOp _ (VInt i) (VTimestamp j) =-    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds j + i-  commutativityProof = Just Dict-instance ArithOp Add 'TMutez 'TMutez where-  type ArithRes Add 'TMutez 'TMutez = 'TMutez-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ n@(VMutez i) m@(VMutez j) = res-    where-      res = maybe (Left $ MutezArithError AddOverflow n m) (Right . VMutez) $ i `addMutez` j-  commutativityProof = Just Dict-instance ArithOp Add 'TBls12381Fr 'TBls12381Fr where-  type ArithRes Add 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VBls12381Fr i) (VBls12381Fr j) =-    Right $ VBls12381Fr (BLS.add i j)-  commutativityProof = Just Dict-instance ArithOp Add 'TBls12381G1 'TBls12381G1 where-  type ArithRes Add 'TBls12381G1 'TBls12381G1 = 'TBls12381G1-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VBls12381G1 i) (VBls12381G1 j) =-    Right $ VBls12381G1 (BLS.add i j)-  commutativityProof = Just Dict-instance ArithOp Add 'TBls12381G2 'TBls12381G2 where-  type ArithRes Add 'TBls12381G2 'TBls12381G2 = 'TBls12381G2-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VBls12381G2 i) (VBls12381G2 j) =-    Right $ VBls12381G2 (BLS.add i j)-  commutativityProof = Just Dict--instance ArithOp Sub 'TNat 'TInt where-  type ArithRes Sub 'TNat 'TInt = 'TInt-  convergeArith _ _ n2 = Right n2-  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i - j)-instance ArithOp Sub 'TInt 'TNat where-  type ArithRes Sub 'TInt 'TNat = 'TInt-  convergeArith _ n1 _ = Right n1-  evalOp _ (VInt i) (VNat j) = Right $ VInt (i - toInteger j)-instance ArithOp Sub 'TNat 'TNat where-  type ArithRes Sub 'TNat 'TNat = 'TInt-  -- | Subtraction between @Nat@ and @Nat@ does not retain annotation.-  convergeArith _ n1 n2 = (const starNotes) <$> converge n1 n2-  evalOp _ (VNat i) (VNat j) = Right $ VInt (toInteger i - toInteger j)-instance ArithOp Sub 'TInt 'TInt where-  type ArithRes Sub 'TInt 'TInt = 'TInt-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VInt i) (VInt j) = Right $ VInt (i - j)-instance ArithOp Sub 'TTimestamp 'TInt where-  type ArithRes Sub 'TTimestamp 'TInt = 'TTimestamp-  convergeArith _ n1 _ = Right n1-  evalOp _ (VTimestamp i) (VInt j) =-    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i - j-instance ArithOp Sub 'TTimestamp 'TTimestamp where-  type ArithRes Sub 'TTimestamp 'TTimestamp = 'TInt-  convergeArith _ (NTTimestamp a) (NTTimestamp b) = NTInt <$> (convergeAnns a b)-  evalOp _ (VTimestamp i) (VTimestamp j) =-    Right $ VInt $ timestampToSeconds i - timestampToSeconds j-instance ArithOp Sub 'TMutez 'TMutez where-  type ArithRes Sub 'TMutez 'TMutez = 'TMutez-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ n@(VMutez i) m@(VMutez j) = res-    where-      res = maybe (Left $ MutezArithError SubUnderflow n m) (Right . VMutez) $ i `subMutez` j--instance ArithOp Mul 'TNat 'TInt where-  type ArithRes Mul 'TNat 'TInt = 'TInt-  convergeArith _ _ n2 = Right n2-  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i * j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TInt 'TNat where-  type ArithRes Mul 'TInt 'TNat = 'TInt-  convergeArith _ n1 _ = Right n1-  evalOp _ (VInt i) (VNat j) = Right $ VInt (i * toInteger j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TNat 'TNat where-  type ArithRes Mul 'TNat 'TNat = 'TNat-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VNat i) (VNat j) = Right $ VNat (i * j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TInt 'TInt where-  type ArithRes Mul 'TInt 'TInt = 'TInt-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VInt i) (VInt j) = Right $ VInt (i * j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TNat 'TMutez where-  type ArithRes Mul 'TNat 'TMutez = 'TMutez-  convergeArith _ _ n2 = Right n2-  evalOp _ n@(VNat i) m@(VMutez j) = res-    where-      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ j `mulMutez` i-  commutativityProof = Just Dict-instance ArithOp Mul 'TMutez 'TNat where-  type ArithRes Mul 'TMutez 'TNat = 'TMutez-  convergeArith _ n1 _ = Right n1-  evalOp _ n@(VMutez i) m@(VNat j) = res-    where-      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ i `mulMutez` j-  commutativityProof = Just Dict-instance ArithOp Mul 'TInt 'TBls12381Fr where-  type ArithRes Mul 'TInt 'TBls12381Fr = 'TBls12381Fr-  convergeArith _ (NTInt n1) _ = Right $ (NTBls12381Fr n1)-  evalOp _ (VInt i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegral i * j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TNat 'TBls12381Fr where-  type ArithRes Mul 'TNat 'TBls12381Fr = 'TBls12381Fr-  convergeArith _ (NTNat n1) _ = Right (NTBls12381Fr n1)-  evalOp _ (VNat i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegral i * j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TBls12381Fr 'TInt where-  type ArithRes Mul 'TBls12381Fr 'TInt = 'TBls12381Fr-  convergeArith _ n1 _ = Right n1-  evalOp _ (VBls12381Fr i) (VInt j) = Right $ VBls12381Fr (i * fromIntegral j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TBls12381Fr 'TNat where-  type ArithRes Mul 'TBls12381Fr 'TNat = 'TBls12381Fr-  convergeArith _ n1 _ = Right n1-  evalOp _ (VBls12381Fr i) (VNat j) = Right $ VBls12381Fr (i * fromIntegral j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TBls12381Fr 'TBls12381Fr where-  type ArithRes Mul 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr-  convergeArith _ n1 _ = Right n1-  evalOp _ (VBls12381Fr i) (VBls12381Fr j) = Right $ VBls12381Fr (i * j)-  commutativityProof = Just Dict-instance ArithOp Mul 'TBls12381G1 'TBls12381Fr where-  type ArithRes Mul 'TBls12381G1 'TBls12381Fr = 'TBls12381G1-  convergeArith _ n1 _ = Right n1-  evalOp _ (VBls12381G1 i) (VBls12381Fr j) = Right $ VBls12381G1 (BLS.multiply j i)-  commutativityProof = Nothing-instance ArithOp Mul 'TBls12381G2 'TBls12381Fr where-  type ArithRes Mul 'TBls12381G2 'TBls12381Fr = 'TBls12381G2-  convergeArith _ n1 _ = Right n1-  evalOp _ (VBls12381G2 i) (VBls12381Fr j) = Right $ VBls12381G2 (BLS.multiply j i)-  commutativityProof = Nothing-instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G1 =>-         ArithOp Mul 'TBls12381Fr 'TBls12381G1 where-  type ArithRes Mul 'TBls12381Fr 'TBls12381G1 = 'TBls12381G1-  convergeArith = error "impossible"-  evalOp = error "impossible"-  commutativityProof = error "impossible"-instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G2 =>-         ArithOp Mul 'TBls12381Fr 'TBls12381G2 where-  type ArithRes Mul 'TBls12381Fr 'TBls12381G2 = 'TBls12381G2-  convergeArith = error "impossible"-  evalOp = error "impossible"-  commutativityProof = error "impossible"--type family Bls12381MulBadOrder a1 a2 where-  Bls12381MulBadOrder a1 a2 = TypeError-    ('Text "Multiplication of "-       ':<>: 'ShowType a2 ':<>: 'Text " and "-       ':<>: 'ShowType a1 ':<>: 'Text " works only other way around"-    )--instance UnaryArithOp Abs 'TInt where-  type UnaryArithRes Abs 'TInt = 'TNat-  evalUnaryArithOp _ (VInt i) = VNat (fromInteger $ abs i)--instance UnaryArithOp Neg 'TInt where-  type UnaryArithRes Neg 'TInt = 'TInt-  evalUnaryArithOp _ (VInt i) = VInt (-i)-instance UnaryArithOp Neg 'TNat where-  type UnaryArithRes Neg 'TNat = 'TInt-  evalUnaryArithOp _ (VNat i) = VInt (- fromIntegral i)-instance UnaryArithOp Neg 'TBls12381Fr where-  type UnaryArithRes Neg 'TBls12381Fr = 'TBls12381Fr-  evalUnaryArithOp _ (VBls12381Fr i) = VBls12381Fr (BLS.negate i)-instance UnaryArithOp Neg 'TBls12381G1 where-  type UnaryArithRes Neg 'TBls12381G1 = 'TBls12381G1-  evalUnaryArithOp _ (VBls12381G1 i) = VBls12381G1 (BLS.negate i)-instance UnaryArithOp Neg 'TBls12381G2 where-  type UnaryArithRes Neg 'TBls12381G2 = 'TBls12381G2-  evalUnaryArithOp _ (VBls12381G2 i) = VBls12381G2 (BLS.negate i)--instance ArithOp Or 'TNat 'TNat where-  type ArithRes Or 'TNat 'TNat = 'TNat-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VNat i) (VNat j) = Right $ VNat (i .|. j)-  commutativityProof = Just Dict-instance ArithOp Or 'TBool 'TBool where-  type ArithRes Or 'TBool 'TBool = 'TBool-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VBool i) (VBool j) = Right $ VBool (i .|. j)-  commutativityProof = Just Dict--instance ArithOp And 'TInt 'TNat where-  type ArithRes And 'TInt 'TNat = 'TNat-  convergeArith _ _ n2 = Right n2-  evalOp _ (VInt i) (VNat j) = Right $ VNat (fromInteger (i .&. toInteger j))-instance ArithOp And 'TNat 'TNat where-  type ArithRes And 'TNat 'TNat = 'TNat-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VNat i) (VNat j) = Right $ VNat (i .&. j)-  commutativityProof = Just Dict-instance ArithOp And 'TBool 'TBool where-  type ArithRes And 'TBool 'TBool = 'TBool-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VBool i) (VBool j) = Right $ VBool (i .&. j)-  commutativityProof = Just Dict--instance ArithOp Xor 'TNat 'TNat where-  type ArithRes Xor 'TNat 'TNat = 'TNat-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VNat i) (VNat j) = Right $ VNat (i `xor` j)-  commutativityProof = Just Dict-instance ArithOp Xor 'TBool 'TBool where-  type ArithRes Xor 'TBool 'TBool = 'TBool-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ (VBool i) (VBool j) = Right $ VBool (i `xor` j)-  commutativityProof = Just Dict--instance ArithOp Lsl 'TNat 'TNat where-  type ArithRes Lsl 'TNat 'TNat = 'TNat-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ n@(VNat i) m@(VNat j) =-    if j > 256-    then Left $ ShiftArithError LslOverflow n m-    else Right $ VNat (fromInteger $ shift (toInteger i) (fromIntegral j))--instance ArithOp Lsr 'TNat 'TNat where-  type ArithRes Lsr 'TNat 'TNat = 'TNat-  convergeArith _ n1 n2 = converge n1 n2-  evalOp _ n@(VNat i) m@(VNat j) =-    if j > 256-    then Left $ ShiftArithError LsrUnderflow n m-    else Right $ VNat (fromInteger $ shift (toInteger i) (-(fromIntegral j)))--instance UnaryArithOp Not 'TInt where-  type UnaryArithRes Not 'TInt = 'TInt-  evalUnaryArithOp _ (VInt i) = VInt (complement i)-instance UnaryArithOp Not 'TNat where-  type UnaryArithRes Not 'TNat = 'TInt-  evalUnaryArithOp _ (VNat i) = VInt (complement $ toInteger i)-instance UnaryArithOp Not 'TBool where-  type UnaryArithRes Not 'TBool = 'TBool-  evalUnaryArithOp _ (VBool i) = VBool (not i)---- | Implementation for 'COMPARE' instruction.-compareOp :: Comparable t => Value' i t -> Value' i t -> Integer-compareOp a b =-  -- If at some point we need to return a number outside of [-1; 1] range,-  -- let's extend 'tcompare' respectively and use it here.-  -- Such situation seems unlikely to happen though, our previous communication-  -- with the Tezos developers shows that even if in Tezos 'COMPARE' returns-  -- something unusual, that is probably a bug.-  toInteger $ fromEnum (compare a b) - 1--instance UnaryArithOp Eq' 'TInt where-  type UnaryArithRes Eq' 'TInt = 'TBool-  evalUnaryArithOp _ (VInt i) = VBool (i == 0)--instance UnaryArithOp Neq 'TInt where-  type UnaryArithRes Neq 'TInt = 'TBool-  evalUnaryArithOp _ (VInt i) = VBool (i /= 0)---instance UnaryArithOp Lt 'TInt where-  type UnaryArithRes Lt 'TInt = 'TBool-  evalUnaryArithOp _ (VInt i) = VBool (i < 0)--instance UnaryArithOp Gt 'TInt where-  type UnaryArithRes Gt 'TInt = 'TBool-  evalUnaryArithOp _ (VInt i) = VBool (i > 0)--instance UnaryArithOp Le 'TInt where-  type UnaryArithRes Le 'TInt = 'TBool-  evalUnaryArithOp _ (VInt i) = VBool (i <= 0)--instance UnaryArithOp Ge 'TInt where-  type UnaryArithRes Ge 'TInt = 'TBool-  evalUnaryArithOp _ (VInt i) = VBool (i >= 0)--instance ToIntArithOp 'TNat where-  evalToIntOp (VNat i) = VInt (toInteger i)--instance ToIntArithOp 'TBls12381Fr where-  evalToIntOp (VBls12381Fr i) = VInt (toInteger i)--instance Buildable ShiftArithErrorType where-  build = \case-    LslOverflow -> "lsl overflow"-    LsrUnderflow -> "lsr underflow"--instance Buildable MutezArithErrorType where-  build = \case-    AddOverflow -> "add overflow"-    MulOverflow -> "mul overflow"-    SubUnderflow -> "sub underflow"--instance (Show n, Show m) => Buildable (ArithError n m) where-  build (MutezArithError errType n m) = "Mutez "-    <> build errType <> " with " <> show n <> ", " <> show m-  build (ShiftArithError errType n m) =-    build errType <> " with " <> show n <> ", " <> show m

− src/Michelson/Typed/Convert.hs

@@ -1,856 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Michelson.Typed.Convert-  ( convertParamNotes-  , convertContractCode-  , convertContract-  , instrToOps-  , instrToOpsOptimized-  , untypeDemoteT-  , untypeValue-  , untypeValueHashable-  , untypeValueOptimized--  -- Helper for generating documentation-  , sampleTypedValue--  -- * Misc-  , flattenEntrypoints-  ) where--import qualified Data.ByteArray as ByteArray-import Data.Constraint (Dict(..))-import Data.List.NonEmpty ((<|))-import qualified Data.Map as Map-import Data.Singletons (Sing, demote, withSingI)-import Data.Vinyl (Rec(..))-import Fmt (Buildable(..), Builder, blockListF, fmt, indentF, listF, pretty, unlinesF)---import Michelson.Text-import Michelson.Typed.Aliases-import Michelson.Typed.Annotation (Notes(..))-import Michelson.Typed.Entrypoints-import Michelson.Typed.Extract (mkUType, toUType)-import Michelson.Typed.Instr as Instr-import Michelson.Typed.Scope-import Michelson.Typed.Sing (SingT(..))-import Michelson.Typed.T (T(..))-import Michelson.Typed.Value-import Michelson.Printer.Util-import qualified Michelson.Untyped as U-import Michelson.Untyped.Annotation (Annotation(unAnnotation))-import Tezos.Address (Address(..), ContractHash(..))-import Tezos.Core-  (ChainId(unChainId), mformatChainId, parseChainId, timestampFromSeconds, timestampToSeconds,-  unMutez, unsafeMkMutez)-import Tezos.Crypto-import qualified Tezos.Crypto.BLS12381 as BLS-import qualified Tezos.Crypto.Ed25519 as Ed25519-import qualified Tezos.Crypto.P256 as P256-import qualified Tezos.Crypto.Secp256k1 as Secp256k1-import Util.PeanoNatural (fromPeanoNatural)-import Util.Sing (eqParamSing, eqParamSing2)--convertParamNotes :: SingI cp => ParamNotes cp -> U.ParameterType-convertParamNotes (ParamNotes notes rootAnn) =-  U.ParameterType (mkUType notes) rootAnn--convertContractCode-  :: forall param store . (SingI param, SingI store)-  => ContractCode param store -> U.Contract-convertContractCode contract =-  U.Contract-    { contractParameter = U.ParameterType (untypeDemoteT @param) U.noAnn-    , contractStorage = untypeDemoteT @store-    , contractCode = instrToOps contract-    , entriesOrder = U.canonicalEntriesOrder-    }--convertContract :: Contract param store -> U.Contract-convertContract fc@Contract{} =-  let c = convertContractCode (cCode fc)-  in c { U.contractParameter = convertParamNotes (cParamNotes fc)-       , U.contractStorage = mkUType (cStoreNotes fc)-       , U.entriesOrder = cEntriesOrder fc-       }---- Note: if you change this type, check 'untypeValueImpl' wildcard patterns.-data UntypingOptions-  = Readable-  -- ^ Convert value to human-readable representation-  | Optimized-  -- ^ Convert value to optimized representation-  | Hashable-  -- ^ Like 'Optimized', but without list notation for pairs.-  -- Created to match 'tezos-client hash data' behavior for typed values.-  -- See https://gitlab.com/morley-framework/morley/-/issues/611-  deriving stock (Eq, Show)--untypeValue :: (SingI t, HasNoOp t) => Value' Instr t -> U.Value-untypeValue = untypeValueImpl Readable--untypeValueHashable :: (SingI t, HasNoOp t) => Value' Instr t -> U.Value-untypeValueHashable = untypeValueImpl Hashable--untypeValueOptimized :: (SingI t, HasNoOp t) => Value' Instr t -> U.Value-untypeValueOptimized = untypeValueImpl Optimized---- | Convert a typed 'Val' to an untyped 'Value'.------ For full isomorphism type of the given 'Val' should not contain--- 'TOperation' - a compile error will be raised otherwise.--- You can analyse its presence with 'checkOpPresence' function.-untypeValueImpl ::-     forall t . (SingI t, HasNoOp t)-  => UntypingOptions-  -> Value' Instr t-  -> U.Value-untypeValueImpl opts val = case (val, sing @t) of-  (VInt i, _) -> U.ValueInt i-  (VNat i, _) -> U.ValueInt $ toInteger i-  (VString s, _) -> U.ValueString s-  (VBytes b, _) -> U.ValueBytes $ U.InternalByteString b-  (VMutez m, _) -> U.ValueInt $ toInteger $ unMutez m-  (VBool True, _) -> U.ValueTrue-  (VBool False, _) -> U.ValueFalse-  (VKeyHash h, _) ->-    case opts of-      Readable  -> U.ValueString $ mformatKeyHash h-      _         -> U.ValueBytes $ U.InternalByteString $ keyHashToBytes h-  (VBls12381Fr v, _) ->-    case opts of-      Readable  -> U.ValueInt $ toInteger v-      _         -> U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v-  (VBls12381G1 v, _) ->-    U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v-  (VBls12381G2 v, _) ->-    U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v-  (VTimestamp t, _) ->-    case opts of-      Readable   -> U.ValueString . unsafeMkMText $ pretty t-      _          -> U.ValueInt $ timestampToSeconds t-  (VAddress a, _) ->-    case opts of-      Readable  -> U.ValueString $ mformatEpAddress a-      _         -> U.ValueBytes . U.InternalByteString  $ encodeEpAddress a-  (VKey b, _) ->-    case opts of-      Readable  -> U.ValueString $ mformatPublicKey b-      _         -> U.ValueBytes . U.InternalByteString $ keyToBytes b-  (VUnit, _) ->-    U.ValueUnit-  (VSignature b, _) ->-    case opts of-      Readable  -> U.ValueString $ mformatSignature b-      _         -> U.ValueBytes . U.InternalByteString $ signatureToBytes b-  (VChainId b, _) ->-    case opts of-      Readable  -> U.ValueString $ mformatChainId b-      _         ->-        U.ValueBytes . U.InternalByteString $ ByteArray.convert (unChainId b)-  (VOption (Just x), STOption _) ->-    U.ValueSome (untypeValueImpl opts x)-  (VOption Nothing, STOption _) ->-    U.ValueNone-  (VList l, STList _) ->-    vList U.ValueSeq $ map (untypeValueImpl opts) l-  (VSet s, STSet (st :: SingT st)) ->-    case checkOpPresence st of-      OpAbsent -> vList U.ValueSeq $ map (untypeValueImpl @st opts) $ toList s-  (VContract addr sepc, _) ->-    case opts of-      Readable  ->-        U.ValueString . mformatEpAddress $ EpAddress addr (sepcName sepc)-      _         -> U.ValueBytes . U.InternalByteString . encodeEpAddress $-        EpAddress addr (sepcName sepc)-  (VTicket s v a, _) ->-    case valueTypeSanity v of-      Dict ->-        let us = untypeValueImpl opts $ VAddress (EpAddress s DefEpName)-            uv = untypeValueImpl opts v-            ua = untypeValueImpl opts $ VNat a-        in case opts of-          Optimized -> U.ValueSeq $ us :| [uv, ua]-          _         -> U.ValuePair us (U.ValuePair uv ua)-  p@(VPair (l, r), STPair lt rt) ->-    withSingI lt $-    withSingI rt $-    case checkOpPresence lt of-      OpAbsent -> case opts of-        Optimized -> U.ValueSeq $ pairToSeq p-        _         -> U.ValuePair (untypeValueImpl opts l) (untypeValueImpl opts r)--  (VOr (Left x), STOr lt _) ->-    case checkOpPresence lt of-      OpAbsent -> U.ValueLeft (untypeValueImpl opts x)--  (VOr (Right x), STOr lt _) ->-    case checkOpPresence lt of-      OpAbsent -> U.ValueRight (untypeValueImpl opts x)--  (VLam (rfAnyInstr -> ops :: Instr '[inp] '[out]), _) ->-    vList U.ValueLambda $ instrToOpsImpl opts ops--  (VMap m, STMap kt vt) ->-    case (checkOpPresence kt, checkOpPresence vt) of-      (OpAbsent, OpAbsent) ->-        vList U.ValueMap $ Map.toList m <&> \(k, v) ->-        U.Elt (untypeValueImpl opts k) (untypeValueImpl opts v)--  (VBigMap _ m, STBigMap kt vt) ->-    case (checkOpPresence kt, checkOpPresence vt) of-      (OpAbsent, OpAbsent) ->-        vList U.ValueMap $ Map.toList m <&> \(k, v) ->-        U.Elt (untypeValueImpl opts k) (untypeValueImpl opts v)-  where-    vList ctor = maybe U.ValueNil ctor . nonEmpty--    pairToSeq :: (SingI ty, HasNoOp ty)-              => (Value ty, Sing ty)-              -> NonEmpty U.Value-    pairToSeq = \case-      (VPair (a, b), STPair l r) -> withSingI l $ withSingI r $-        case checkOpPresence l of-          OpAbsent -> untypeValueImpl opts a <| pairToSeq (b, r)-      (v, _) -> untypeValueImpl opts v :| []--    keyHashToBytes :: KeyHash -> ByteString-    keyHashToBytes kh = (<> (khBytes kh)) $-      case khTag kh of-        KeyHashEd25519 -> "\x00"-        KeyHashSecp256k1 -> "\x01"-        KeyHashP256 -> "\x02"--    keyToBytes :: PublicKey -> ByteString-    keyToBytes = \case-      PublicKeyEd25519 pk -> "\x00" <> Ed25519.publicKeyToBytes pk-      PublicKeySecp256k1 pk -> "\x01" <> Secp256k1.publicKeyToBytes pk-      PublicKeyP256 pk -> "\x02" <> P256.publicKeyToBytes pk--    encodeEpAddress :: EpAddress -> ByteString-    encodeEpAddress (EpAddress addr epName) =-      encodeAddress addr <> encodeEpName epName--    encodeAddress :: Address -> ByteString-    encodeAddress = \case-      KeyAddress keyHash ->-        "\x00" <> keyHashToBytes keyHash-      ContractAddress (ContractHash address) ->-        "\x01" <> address <> "\x00"--    encodeEpName :: EpName -> ByteString-    encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn . canonicalize-      where-        canonicalize :: EpName -> EpName-        canonicalize (UnsafeEpName "default") = DefEpName-        canonicalize epName                   = epName--untypeDemoteT :: forall (t :: T). SingI t => U.Ty-untypeDemoteT = toUType $ demote @t--instrToOpsOptimized :: HasCallStack => Instr inp out -> [U.ExpandedOp]-instrToOpsOptimized = instrToOpsImpl Optimized--instrToOps :: HasCallStack => Instr inp out -> [U.ExpandedOp]-instrToOps = instrToOpsImpl Readable--instrToOpsImpl :: HasCallStack-               => UntypingOptions-               -> Instr inp out-               -> [U.ExpandedOp]-instrToOpsImpl opts = \case-  Nop -> []-  Seq i1 i2 -> instrToOpsImpl opts i1 <> instrToOpsImpl opts i2-  Nested sq -> one $ U.SeqEx $ instrToOps sq-  DocGroup _ sq -> instrToOpsImpl opts sq-  Fn t sfn i -> [U.PrimEx . U.EXT . U.FN t sfn $ instrToOps i]-  Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext-  FrameInstr _ i -> instrToOpsImpl opts i-  -- TODO [#283] After representation of locations is polished,-  -- this place should be updated to pass it from typed to untyped ASTs.-  WithLoc _ i -> instrToOpsImpl opts i-  InstrWithVarAnns _ i -> instrToOpsImpl opts i-  InstrWithNotes proxy n i -> case i of-    Nop -> instrToOpsImpl opts i-    Seq _ _ -> instrToOpsImpl opts i-    Nested _ -> instrToOpsImpl opts i-    DocGroup _ _ -> instrToOpsImpl opts i-    Ext _ -> instrToOpsImpl opts i-    WithLoc _ i0 -> instrToOpsImpl opts (InstrWithNotes proxy n i0)-    InstrWithNotes {} -> instrToOpsImpl opts i-    -- For inner instruction, filter out values that we don't want to apply-    -- annotations to and delegate it's conversion to this function itself.-    -- If none of the above, convert a single instruction and copy annotations-    -- to it.-    InstrWithVarNotes n0 (InstrWithVarAnns _ i0) ->-      instrToOpsImpl opts $ InstrWithNotes proxy n $ InstrWithVarNotes n0 i0-    InstrWithVarNotes n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n n0]-    InstrWithVarAnns _ _ -> instrToOpsImpl opts i-    _ -> [U.PrimEx $ handleInstrAnnotate i n]-  InstrWithVarNotes n i -> case i of-    Nop -> instrToOpsImpl opts i-    Seq _ _ -> instrToOpsImpl opts i-    Nested _ -> instrToOpsImpl opts i-    DocGroup _ _ -> instrToOpsImpl opts i-    Ext _ -> instrToOpsImpl opts i-    WithLoc _ i0 -> instrToOpsImpl opts (InstrWithVarNotes n i0)-    InstrWithNotes p0 n0 (InstrWithVarAnns _ i0) ->-      instrToOpsImpl opts $ InstrWithNotes p0 n0 $ InstrWithVarNotes n i0-    InstrWithNotes _ n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n0 n]-    InstrWithVarNotes _ _ -> instrToOpsImpl opts i-    InstrWithVarAnns _ i0 -> instrToOpsImpl opts $ InstrWithVarNotes n i0-    _ -> [U.PrimEx $ handleInstrVarNotes i n]-  i -> [U.PrimEx $ handleInstr i]-  where-    handleInstrAnnotateWithVarNotes-      :: forall inp' out' topElems-       . (HasCallStack, Each '[SingI] topElems)-      => Instr inp' out'-      -> Rec Notes topElems-      -> NonEmpty U.VarAnn-      -> U.ExpandedInstr-    handleInstrAnnotateWithVarNotes instr notes varAnns =-      addVarNotes (addInstrNote (handleInstr instr) notes) varAnns--    handleInstrAnnotate-      :: forall inp' out' topElems.-         (HasCallStack, Each '[SingI] topElems)-      => Instr inp' out' -> Rec Notes topElems -> U.ExpandedInstr-    handleInstrAnnotate ins' notes =-      addInstrNote (handleInstr ins') notes--    addInstrNote-      :: forall topElems. (Each '[SingI] topElems, HasCallStack)-      => U.ExpandedInstr -> Rec Notes topElems -> U.ExpandedInstr-    addInstrNote instr notes =-      case (instr, notes) of-        (U.PUSH va _ v, notes' :& _) -> U.PUSH va (mkUType notes') v-        (U.SOME _ va, NTOption ta _ :& _) -> U.SOME ta va-        (U.NONE _ va _, (NTOption ta nt :: Notes t) :& _) ->-          case sing @t of-            STOption t -> U.NONE ta va (withSingI t $ mkUType nt)-        (U.UNIT _ va, NTUnit ta :& _) -> U.UNIT ta va-        (U.PAIRN va n, _) -> U.PAIRN va n-        (U.LEFT ta va fa1 fa2 _, (NTOr _ _ _ _ n2 :: Notes t) :& _) ->-          case sing @t of-            STOr _ rt ->-              U.LEFT ta va fa1 fa2 (withSingI rt $ mkUType n2)-        (U.RIGHT ta va fa1 fa2 _, (NTOr _ _ _ n1 _ :: Notes t) :& _) ->-          case sing @t of-            STOr lt _ ->-              U.RIGHT ta va fa1 fa2 (withSingI lt $ mkUType n1)-        (U.NIL _ va _, (NTList ta n :: Notes t) :& _) ->-          case sing @t of-            STList l -> U.NIL ta va (withSingI l $ mkUType n)-        (U.EMPTY_SET _ va _, (NTSet ta1 n :: Notes t) :& _) ->-          case sing @t of-            STSet s -> U.EMPTY_SET ta1 va (withSingI s $ mkUType n)-        (U.EMPTY_MAP _ va _ _, (NTMap ta1 k n :: Notes t) :& _) ->-          case sing @t of-            STMap kt vt -> U.EMPTY_MAP ta1 va (withSingI kt $ mkUType k) (withSingI vt $ mkUType n)-        (U.EMPTY_BIG_MAP _ va _ _, (NTBigMap ta1 k n :: Notes t) :& _) ->-          case sing @t of-            STBigMap kt vt -> U.EMPTY_BIG_MAP ta1 va (withSingI kt $ mkUType k) (withSingI vt $ mkUType n)-        (U.LAMBDA va _ _ ops, (NTLambda _ n1 n2 :: Notes t) :& _) ->-          case sing @t of-            STLambda v b -> U.LAMBDA va (withSingI v $ mkUType n1) (withSingI b $ mkUType n2) ops-        (U.CAST va _, n :& _) -> U.CAST va (mkUType n)-        (U.UNPACK _ va _, (NTOption ta nt :: Notes t) :& _) ->-          case sing @t of-            STOption op -> U.UNPACK ta va (withSingI op $ mkUType nt)-        (U.CONTRACT va fa _, (NTOption _ (NTContract _ nt :: Notes t) :: Notes t2) :& _) ->-          case sing @t2 of-            STOption (STContract c) -> U.CONTRACT va fa (withSingI c $ mkUType nt)-        (U.CONTRACT va fa t, NTOption _ _ :& _) -> U.CONTRACT va fa t-        (U.CAR {}, _) -> instr-        (U.CDR {}, _) -> instr-        (U.PAIR {}, _) -> instr-        (U.UNPAIR {}, _) -> instr-        (U.APPLY {}, _) -> instr-        (U.CHAIN_ID {}, _) -> instr-        (U.EXT _, _) -> instr-        (U.DROP, _) -> instr-        (U.DROPN _, _) -> instr-        (U.DUP _, _) -> instr-        (U.DUPN _ _, _) -> instr-        (U.SWAP, _) -> instr-        (U.DIG {}, _) -> instr-        (U.DUG {}, _) -> instr-        (U.IF_NONE _ _, _) -> instr-        (U.CONS _, _) -> instr-        (U.IF_LEFT _ _, _) -> instr-        (U.IF_CONS _ _, _) -> instr-        (U.SIZE _, _) -> instr-        (U.MAP _ _, _) -> instr-        (U.ITER _, _) -> instr-        (U.MEM _, _) -> instr-        (U.GET _, _) -> instr-        (U.GETN _ _, _) -> instr-        (U.UPDATE _, _) -> instr-        (U.UPDATEN _ _, _) -> instr-        (U.GET_AND_UPDATE _, _) -> instr-        (U.IF _ _, _) -> instr-        (U.LOOP _, _) -> instr-        (U.LOOP_LEFT _, _) -> instr-        (U.EXEC _, _) -> instr-        (U.DIP _, _) -> instr-        (U.DIPN {}, _) -> instr-        (U.FAILWITH, _) -> instr-        (U.RENAME _, _) -> instr-        (U.PACK _, _) -> instr-        (U.CONCAT _, _) -> instr-        (U.SLICE _, _) -> instr-        (U.ISNAT _, _) -> instr-        (U.ADD _, _) -> instr-        (U.SUB _, _) -> instr-        (U.MUL _, _) -> instr-        (U.EDIV _, _) -> instr-        (U.ABS _, _) -> instr-        (U.NEG _, _) -> instr-        (U.LSL _, _) -> instr-        (U.LSR _, _) -> instr-        (U.OR _, _) -> instr-        (U.AND _, _) -> instr-        (U.XOR _, _) -> instr-        (U.NOT _, _) -> instr-        (U.COMPARE _, _) -> instr-        (U.EQ _, _) -> instr-        (U.NEQ _, _) -> instr-        (U.LT _, _) -> instr-        (U.GT _, _) -> instr-        (U.LE _, _) -> instr-        (U.GE _, _) -> instr-        (U.INT _, _) -> instr-        (U.SELF _ _, _) -> instr-        (U.TRANSFER_TOKENS _, _) -> instr-        (U.SET_DELEGATE _, _) -> instr-        (U.CREATE_CONTRACT {}, _) -> instr-        (U.IMPLICIT_ACCOUNT _, _) -> instr-        (U.NOW _, _) -> instr-        (U.LEVEL _, _) -> instr-        (U.AMOUNT _, _) -> instr-        (U.BALANCE _, _) -> instr-        (U.VOTING_POWER _, _) -> instr-        (U.TOTAL_VOTING_POWER _, _) -> instr-        (U.CHECK_SIGNATURE _, _) -> instr-        (U.SHA256 _, _) -> instr-        (U.SHA512 _, _) -> instr-        (U.BLAKE2B _, _) -> instr-        (U.SHA3 _, _) -> instr-        (U.KECCAK _, _) -> instr-        (U.HASH_KEY _, _) -> instr-        (U.SOURCE _, _) -> instr-        (U.SENDER _, _) -> instr-        (U.ADDRESS _, _) -> instr-        (U.SELF_ADDRESS _, _) -> instr-        (U.NEVER, _) -> instr-        (U.TICKET _, _) -> instr-        (U.READ_TICKET _, _) -> instr-        (U.SPLIT_TICKET _, _) -> instr-        (U.JOIN_TICKETS _, _) -> instr-        _ -> error $ pretty $ unlinesF-          [ "addInstrNote: Unexpected instruction/annotation combination"-          , "Instruction:"-          , indentF 2 $ build instr-          , "Annotations:"-          , indentF 2 $ blockListF $ buildNotes notes-          ]-          where-            buildNotes :: Rec Notes ts -> [Builder]-            buildNotes = \case-              RNil -> []-              n :& ns -> build n : buildNotes ns--    handleInstrVarNotes :: forall inp' out' . HasCallStack-      => Instr inp' out' -> NonEmpty U.VarAnn -> U.ExpandedInstr-    handleInstrVarNotes ins' varAnns =-      let x = handleInstr ins' in addVarNotes x varAnns--    addVarNotes-      :: HasCallStack-      => U.ExpandedInstr -> NonEmpty U.VarAnn -> U.ExpandedInstr-    addVarNotes ins varNotes = case varNotes of-      va1 :| [va2] -> case ins of-        U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va1 va2 c-        _ -> error $-          "addVarNotes: Cannot add two var annotations to instr: " <> show ins-      va :| [] -> case ins of-        U.DUP _ -> U.DUP va-        U.DUPN _ s -> U.DUPN va s-        U.PUSH _ t v -> U.PUSH va t v-        U.SOME ta _ -> U.SOME ta va-        U.NONE ta _ t -> U.NONE ta va t-        U.UNIT ta _ -> U.UNIT ta va-        U.PAIR ta _ fa1 fa2 -> U.PAIR ta va fa1 fa2-        U.PAIRN _ n -> U.PAIRN va n-        U.LEFT ta _ fa1 fa2 t -> U.LEFT ta va fa1 fa2 t-        U.RIGHT ta _ fa1 fa2 t -> U.RIGHT ta va fa1 fa2 t-        U.NIL ta _ t -> U.NIL ta va t-        U.CONS _ -> U.CONS va-        U.SIZE _ -> U.SIZE va-        U.EMPTY_SET ta _ c -> U.EMPTY_SET ta va c-        U.EMPTY_MAP ta _ c t -> U.EMPTY_MAP ta va c t-        U.EMPTY_BIG_MAP ta _ c t -> U.EMPTY_BIG_MAP ta va c t-        U.MAP _ ops -> U.MAP va ops-        U.MEM _ -> U.MEM va-        U.GET _ -> U.GET va-        U.GETN _ n -> U.GETN va n-        U.UPDATE _ -> U.UPDATE va-        U.UPDATEN _ n -> U.UPDATEN va n-        U.GET_AND_UPDATE _ -> U.GET_AND_UPDATE va-        U.LAMBDA _ t1 t2 ops -> U.LAMBDA va t1 t2 ops-        U.EXEC _ -> U.EXEC va-        U.APPLY _ -> U.APPLY va-        U.CAST _ t -> U.CAST va t-        U.RENAME _ -> U.RENAME va-        U.PACK _ -> U.PACK va-        U.UNPACK ta _ t -> U.UNPACK ta va t-        U.CONCAT _ -> U.CONCAT va-        U.SLICE _ -> U.SLICE va-        U.ISNAT _ -> U.ISNAT va-        U.ADD _ -> U.ADD va-        U.SUB _ -> U.SUB va-        U.MUL _ -> U.MUL va-        U.EDIV _ -> U.EDIV va-        U.ABS _ -> U.ABS va-        U.NEG _ -> U.NEG va-        U.LSL _ -> U.LSL va-        U.LSR _ -> U.LSR va-        U.OR _ -> U.OR va-        U.AND _ -> U.AND va-        U.XOR _ -> U.XOR va-        U.NOT _ -> U.NOT va-        U.COMPARE _ -> U.COMPARE va-        U.EQ _ -> U.EQ va-        U.NEQ _ -> U.NEQ va-        U.LT _ -> U.LT va-        U.GT _ -> U.GT va-        U.LE _ -> U.LE va-        U.GE _ -> U.GE va-        U.INT _ -> U.INT va-        U.SELF _ fa -> U.SELF va fa-        U.CONTRACT _ fa t -> U.CONTRACT va fa t-        U.TRANSFER_TOKENS _ -> U.TRANSFER_TOKENS va-        U.SET_DELEGATE _ -> U.SET_DELEGATE va-        U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va U.noAnn c-        U.IMPLICIT_ACCOUNT _ -> U.IMPLICIT_ACCOUNT va-        U.NOW _ -> U.NOW va-        U.AMOUNT _ -> U.AMOUNT va-        U.BALANCE _ -> U.BALANCE va-        U.VOTING_POWER _ -> U.VOTING_POWER va-        U.TOTAL_VOTING_POWER _ -> U.TOTAL_VOTING_POWER va-        U.CHECK_SIGNATURE _ -> U.CHECK_SIGNATURE va-        U.SHA256 _ -> U.SHA256 va-        U.SHA512 _ -> U.SHA512 va-        U.BLAKE2B _ -> U.BLAKE2B va-        U.SHA3 _ -> U.SHA3 va-        U.KECCAK _ -> U.KECCAK va-        U.HASH_KEY _ -> U.HASH_KEY va-        U.SOURCE _ -> U.SOURCE va-        U.SENDER _ -> U.SENDER va-        U.ADDRESS _ -> U.ADDRESS va-        U.CHAIN_ID _ -> U.CHAIN_ID va-        U.LEVEL _ -> U.LEVEL va-        U.SELF_ADDRESS _ -> U.SELF_ADDRESS va-        U.TICKET _ -> U.TICKET va-        U.READ_TICKET _ -> U.READ_TICKET va-        U.SPLIT_TICKET _ -> U.SPLIT_TICKET va-        U.JOIN_TICKETS _ -> U.JOIN_TICKETS va-        _ -> error $-          "addVarNotes: Cannot add single var annotation to instr: " <> (show ins) <> " with " <> show va-      _ -> error $-        "addVarNotes: Trying to add more than two var annotations to instr: " <> (show ins)--    handleInstr :: Instr inp out -> U.ExpandedInstr-    handleInstr = \case-      (WithLoc _ _) -> error "impossible"-      InstrWithNotes {} -> error "impossible"-      (InstrWithVarNotes _ _) -> error "impossible"-      (InstrWithVarAnns _ _) -> error "impossible"-      (FrameInstr _ _) -> error "impossible"-      (Seq _ _) -> error "impossible"-      Nop -> error "impossible"-      (Ext _) -> error "impossible"-      (Nested _) -> error "impossible"-      DocGroup{} -> error "impossible"-      Fn t sfn i -> U.EXT . U.FN t sfn $ instrToOpsImpl opts i-      DROP -> U.DROP-      (DROPN s) -> U.DROPN (fromIntegral $ fromPeanoNatural s)-      DUP -> U.DUP U.noAnn-      (DUPN s) -> U.DUPN U.noAnn (fromIntegral $ fromPeanoNatural s)-      SWAP -> U.SWAP-      (DIG s) -> U.DIG (fromIntegral $ fromPeanoNatural s)-      (DUG s) -> U.DUG (fromIntegral $ fromPeanoNatural s)-      i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i ->-        let value = untypeValueImpl opts val-        in U.PUSH U.noAnn (untypeDemoteT @t) value-      i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i ->-        U.NONE U.noAnn U.noAnn (untypeDemoteT @a)-      SOME -> U.SOME U.noAnn U.noAnn-      UNIT -> U.UNIT U.noAnn U.noAnn-      (IF_NONE i1 i2) -> U.IF_NONE (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)--      -- `AnnUNPAIR` accepts special var anns, so it carries them inside its constructor,-      -- so we can use them here to re-construct an untyped `U.UNPAIR`.-      -- `AnnPAIR`, on the other hand, doesn't accept special var anns, so the var anns-      -- are carried in the `InstrWithVarNotes` meta-instruction instead.-      ---      -- See: Note [Annotations - Exceptional scenarios] in `Michelson.Typed.Instr`-      ---      -- TODO [#580]-      AnnPAIR tn fn1 fn2 -> U.PAIR tn U.noAnn fn1 fn2-      AnnUNPAIR vn1 vn2 fn1 fn2 -> U.UNPAIR vn1 vn2 fn1 fn2--      PAIRN n -> U.PAIRN U.noAnn (fromIntegral $ fromPeanoNatural n)-      UNPAIRN n -> U.UNPAIRN (fromIntegral $ fromPeanoNatural n)-      (AnnCAR vn fn) -> U.CAR vn fn-      (AnnCDR vn fn) -> U.CDR vn fn-      i@(AnnLEFT tn fn1 fn2) | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->-        U.LEFT tn U.noAnn fn1 fn2 (untypeDemoteT @b)-      i@(AnnRIGHT tn fn1 fn2) | _ :: Instr (b ': s) ('TOr a b ': s) <- i ->-        U.RIGHT tn U.noAnn fn1 fn2 (untypeDemoteT @a)-      (IF_LEFT i1 i2) -> U.IF_LEFT (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)-      i@NIL | _ :: Instr s ('TList p ': s) <- i ->-        U.NIL U.noAnn U.noAnn (untypeDemoteT @p)-      CONS -> U.CONS U.noAnn-      (IF_CONS i1 i2) -> U.IF_CONS (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)-      SIZE -> U.SIZE U.noAnn-      i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i ->-        U.EMPTY_SET U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @e) U.noAnn)-      i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i ->-        U.EMPTY_MAP U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @a) U.noAnn)-          (untypeDemoteT @b)-      i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i ->-        U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @a) U.noAnn)-          (untypeDemoteT @b)-      (MAP op) -> U.MAP U.noAnn $ instrToOpsImpl opts op-      (ITER op) -> U.ITER $ instrToOpsImpl opts op-      MEM -> U.MEM U.noAnn-      GET -> U.GET U.noAnn-      GETN n -> U.GETN U.noAnn (fromIntegral $ fromPeanoNatural n)-      UPDATE -> U.UPDATE U.noAnn-      UPDATEN n -> U.UPDATEN U.noAnn (fromIntegral $ fromPeanoNatural n)-      GET_AND_UPDATE -> U.GET_AND_UPDATE U.noAnn-      (IF op1 op2) -> U.IF (instrToOpsImpl opts op1) (instrToOpsImpl opts op2)-      (LOOP op) -> U.LOOP (instrToOpsImpl opts op)-      (LOOP_LEFT op) -> U.LOOP_LEFT (instrToOpsImpl opts op)-      i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i ->-        U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOpsImpl opts $ rfAnyInstr l)-      EXEC -> U.EXEC U.noAnn-      APPLY -> U.APPLY U.noAnn-      (DIP op) -> U.DIP (instrToOpsImpl opts op)-      (DIPN s op) ->-        U.DIPN (fromIntegral $ fromPeanoNatural s) (instrToOpsImpl opts op)-      FAILWITH -> U.FAILWITH-      i@CAST | _ :: Instr (a ': s) (a ': s) <- i ->-        U.CAST U.noAnn (untypeDemoteT @a)-      RENAME -> U.RENAME U.noAnn-      PACK -> U.PACK U.noAnn-      i@UNPACK-        | _ :: Instr ('TBytes ': s) ('TOption a ': s) <- i ->-            U.UNPACK U.noAnn U.noAnn (untypeDemoteT @a)-      CONCAT -> U.CONCAT U.noAnn-      CONCAT' -> U.CONCAT U.noAnn-      SLICE -> U.SLICE U.noAnn-      ISNAT -> U.ISNAT U.noAnn-      ADD -> U.ADD U.noAnn-      SUB -> U.SUB U.noAnn-      MUL -> U.MUL U.noAnn-      EDIV -> U.EDIV U.noAnn-      ABS -> U.ABS U.noAnn-      NEG -> U.NEG U.noAnn-      LSL -> U.LSL U.noAnn-      LSR -> U.LSR U.noAnn-      OR -> U.OR U.noAnn-      AND -> U.AND U.noAnn-      XOR -> U.XOR U.noAnn-      NOT -> U.NOT U.noAnn-      COMPARE -> U.COMPARE U.noAnn-      Instr.EQ -> U.EQ U.noAnn-      NEQ -> U.NEQ U.noAnn-      Instr.LT -> U.LT U.noAnn-      Instr.GT -> U.GT U.noAnn-      LE -> U.LE U.noAnn-      GE -> U.GE U.noAnn-      INT -> U.INT U.noAnn-      SELF sepc ->-        U.SELF U.noAnn (epNameToRefAnn $ sepcName sepc)-      i@(CONTRACT nt epName)-        | _ :: Instr ('TAddress ': s) ('TOption ('TContract p) ': s) <- i ->-            let fa = epNameToRefAnn epName-            in U.CONTRACT U.noAnn fa (mkUType nt)-      TRANSFER_TOKENS -> U.TRANSFER_TOKENS U.noAnn-      SET_DELEGATE -> U.SET_DELEGATE U.noAnn-      i@(CREATE_CONTRACT contract)-        | _ :: Instr-            (  'TOption ('TKeyHash)-            ': 'TMutez-            ': g-            ': s)-            ('TOperation ': 'TAddress ': s) <- i ->-          U.CREATE_CONTRACT U.noAnn U.noAnn (convertContract contract)-      IMPLICIT_ACCOUNT -> U.IMPLICIT_ACCOUNT U.noAnn-      NOW -> U.NOW U.noAnn-      AMOUNT -> U.AMOUNT U.noAnn-      BALANCE -> U.BALANCE U.noAnn-      VOTING_POWER -> U.VOTING_POWER U.noAnn-      TOTAL_VOTING_POWER -> U.TOTAL_VOTING_POWER U.noAnn-      CHECK_SIGNATURE -> U.CHECK_SIGNATURE U.noAnn-      SHA256 -> U.SHA256 U.noAnn-      SHA512 -> U.SHA512 U.noAnn-      BLAKE2B -> U.BLAKE2B U.noAnn-      SHA3 -> U.SHA3 U.noAnn-      KECCAK -> U.KECCAK U.noAnn-      HASH_KEY -> U.HASH_KEY U.noAnn-      PAIRING_CHECK -> U.PAIRING_CHECK U.noAnn-      SOURCE -> U.SOURCE U.noAnn-      SENDER -> U.SENDER U.noAnn-      ADDRESS -> U.ADDRESS U.noAnn-      CHAIN_ID -> U.CHAIN_ID U.noAnn-      LEVEL -> U.LEVEL U.noAnn-      SELF_ADDRESS -> U.SELF_ADDRESS U.noAnn-      NEVER -> U.NEVER-      TICKET -> U.TICKET U.noAnn-      READ_TICKET -> U.READ_TICKET U.noAnn-      SPLIT_TICKET -> U.SPLIT_TICKET U.noAnn-      JOIN_TICKETS -> U.JOIN_TICKETS U.noAnn--untypeStackRef :: StackRef s -> U.StackRef-untypeStackRef (StackRef n) = U.StackRef (fromPeanoNatural n)--untypePrintComment :: PrintComment s -> U.PrintComment-untypePrintComment (PrintComment pc) = U.PrintComment $ map (second untypeStackRef) pc--extInstrToOps :: ExtInstr s -> [U.ExtInstrAbstract U.ExpandedOp]-extInstrToOps = \case-  PRINT pc -> one $ U.UPRINT (untypePrintComment pc)-  TEST_ASSERT (TestAssert nm pc i) ->-    one $ U.UTEST_ASSERT $-    U.TestAssert nm (untypePrintComment pc) (instrToOps i)-  DOC_ITEM{} -> []-  COMMENT_ITEM tp ->-    case tp of-      FunctionStarts name -> one $ U.UCOMMENT $ name <> " [user func starts]"-      FunctionEnds name -> one $ U.UCOMMENT $ name <> " [user func ends]"-      StatementStarts name -> one $ U.UCOMMENT $ name <> " [user stmt starts]"-      StatementEnds name -> one $ U.UCOMMENT $ name <> " [user stmt ends]"-      JustComment com -> one $ U.UCOMMENT com-      StackTypeComment (Just stack) -> one $ U.UCOMMENT $ pretty (listF stack)-      StackTypeComment Nothing -> one $ U.UCOMMENT $ fmt "any stack type"-  STACKTYPE s -> one $ U.STACKTYPE s---- It's an orphan instance, but it's better than checking all cases manually.--- We can also move this convertion to the place where `Instr` is defined,--- but then there will be a very large module (as we'll have to move a lot of--- stuff as well).-instance Eq (Instr inp out) where-  i1 == i2 = instrToOps i1 == instrToOps i2--instance SingI s => Eq (TestAssert s) where-  TestAssert   name1 pattern1 instr1-    ==-    TestAssert name2 pattern2 instr2-    = and-    [ name1 == name2-    , pattern1 `eqParamSing` pattern2-    , instr1 `eqParamSing2` instr2-    ]--instance (SingI t, HasNoOp t) => Buildable (Value' Instr t) where-  build = build . untypeValue--instance Buildable (Instr inp out) where-  build = buildRenderDocExtended--instance RenderDoc (Instr inp out) where-  renderDoc context = renderDocList context . instrToOps---- | Generate a value used for generating examples in documentation.------ Since not for all types it is possible to produce a sensible example,--- the result is optional. E.g. for operations, @never@, not proper--- types like @contract operation@ we return 'Nothing'.-sampleTypedValue :: Sing t -> Maybe (Value t)-sampleTypedValue = \case-    STInt              -> Just $ VInt -1-    STNat              -> Just $ VNat 0-    STString           -> Just $ VString [mt|hello|]-    STMutez            -> Just $ VMutez (unsafeMkMutez 100)-    STBool             -> Just $ VBool True-    STKey              -> Just $ VKey samplePublicKey-    STKeyHash          -> Just $ VKeyHash $ hashKey samplePublicKey-    STBls12381Fr       -> Just $ VBls12381Fr 1-    STBls12381G1       -> Just $ VBls12381G1 BLS.g1One-    STBls12381G2       -> Just $ VBls12381G2 BLS.g2One-    STTimestamp        -> Just $ VTimestamp $ timestampFromSeconds 1564142952-    STBytes            -> Just $ VBytes "\10"-    STAddress          -> Just $ VAddress $ sampleAddress-    STUnit             -> Just $ VUnit-    STSignature        -> Just $ VSignature $ sampleSignature-    STChainId          -> Just $ VChainId sampleChainId-    STOperation        -> Nothing-    STNever            -> Nothing-    STOption t ->-      withSingI t $ VOption . Just <$> sampleTypedValue t-    STList t ->-      withSingI t $ VList . one <$> sampleTypedValue t-    STSet t -> withSingI t $ do-      Dict <- comparabilityPresence t-      VSet . one <$> sampleTypedValue t-    STContract t -> withSingI t $ do-      Dict <- opAbsense t-      Dict <- nestedBigMapsAbsense t-      pure . VContract (eaAddress sampleAddress) $ SomeEpc unsafeEpcCallRoot-    STTicket t -> withSingI t $ do-      cmpProof <- comparabilityPresence t-      dat <- sampleTypedValue t-      VNat amount <- sampleTypedValue STNat-      case cmpProof of-        Dict -> return $ VTicket (eaAddress sampleAddress) dat amount-    STPair t1 t2 -> withSingI t1 $ withSingI t2 $ do-      val1 <- sampleTypedValue t1-      val2 <- sampleTypedValue t2-      pure $ VPair (val1, val2)-    STOr tl tr -> withSingI tl $ withSingI tr $ asum-      [ VOr . Left <$> sampleTypedValue tl-      , VOr . Right <$> sampleTypedValue tr-      ]-    STMap t1 t2 -> withSingI t1 $ withSingI t2 $ do-      val1 <- sampleTypedValue t1-      val2 <- sampleTypedValue t2-      case checkComparability t1 of-        CanBeCompared -> pure $ VMap $ Map.fromList [(val1, val2)]-        CannotBeCompared -> Nothing-    STBigMap t1 t2 -> withSingI t1 $ withSingI t2 $ do-      val1 <- sampleTypedValue t1-      val2 <- sampleTypedValue t2-      case (checkComparability t1, bigMapAbsense t2) of-        (CanBeCompared, Just Dict) -> pure $ VBigMap Nothing $ Map.fromList [(val1, val2)]-        _                          -> Nothing-    STLambda v (t2 :: Sing t2) -> withSingI v $ withSingI t2 $-      case checkScope @(ConstantScope t2) of-        Right Dict -> do-          val <- sampleTypedValue t2-          pure $ VLam $ RfNormal (DROP `Seq` PUSH val)-        _ -> pure $ VLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH)-    where-      sampleAddress = unsafeParseEpAddress "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"-      samplePublicKey = fromRight (error "impossible") $ parsePublicKey-        "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"-      sampleSignature = fromRight (error "impossible") $ parseSignature-        "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"-      sampleChainId = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t"---- Misc--------------------------------------------------------------------------------- | Flatten a provided list of notes to a map of its entrypoints and its--- corresponding utype. Please refer to 'mkEntrypointsMap' in regards to how--- duplicate entrypoints are handled.-flattenEntrypoints :: SingI t => ParamNotes t -> Map EpName U.Ty-flattenEntrypoints = U.mkEntrypointsMap . convertParamNotes

− src/Michelson/Typed/Doc.hs

@@ -1,157 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}---- | Extracting documentation from instructions set.-module Michelson.Typed.Doc-  ( buildInstrDoc-  , buildInstrDocWithGitRev-  , modifyInstrDoc-  , modifyInstrAllDoc-  , cutInstrNonDoc-  , docInstr-  ) where--import Control.Lens (at)-import Data.Default (def)-import Data.Typeable (cast)-import Prelude hiding (Ordering(..))--import Michelson.Doc-import Michelson.Typed.Instr-import Michelson.Typed.Util--someDefinitionDocItemToContractDoc :: SomeDocDefinitionItem -> State ContractDoc ()-someDefinitionDocItemToContractDoc sdi@(SomeDocDefinitionItem di) =-  modify $ flip mappend-    mempty-    { cdContents = mempty-    , cdDefinitions = docItemToBlock di-    , cdDefinitionsSet = one sdi-    , cdDefinitionIds = one $ case docItemRef di of-        DocItemRef docItemId -> docItemId-    }--someDocItemToContractDoc :: SomeDocItem -> State ContractDoc ()-someDocItemToContractDoc (SomeDocItem di) = do-  () <- case docItemRef di of-    DocItemNoRef ->-      modify (<> mempty{ cdContents = docItemToBlock di })-    DocItemRefInlined{} ->-      modify (<> mempty{ cdContents = docItemToBlock di })-    DocItemRef{} ->-      someDefinitionDocItemToContractDoc (SomeDocDefinitionItem di)-  forM_ @_ @_ @() (docItemDependencies di) $ \(SomeDocDefinitionItem dep) ->-    case docItemRef dep of-      DocItemRef{} -> do-        -- Taking special treatment for possible cyclic dependencies.-        isPresent <- use $ cdDefinitionsSetL . at (SomeDocDefinitionItem dep)-        case isPresent of-          Just () -> pass-          Nothing -> someDocItemToContractDoc (SomeDocItem dep)---- | Put a document item.-docInstr :: DocItem di => di -> Instr s s-docInstr = Ext . DOC_ITEM . SomeDocItem---- | Assemble contract documentation with the revision of the contract.-{-# DEPRECATED buildInstrDocWithGitRev-    "Use `buildDoc . attachDocCommons gitRev` instead."-#-}-buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc-buildInstrDocWithGitRev gitRev contract =-  let toc = DToc $ contractDocToToc $ buildInstrDoc contract-      c = pure contract-            >>= attachGitInfo gitRev-            >>= attachToc toc-  in buildDoc c---- | Assemble contract documentation.-{-# DEPRECATED buildInstrDoc "Use 'buildDoc' instead." #-}-buildInstrDoc :: Instr inp out -> ContractDoc-buildInstrDoc = dfsFoldInstr dfsSettings $ \case-  Ext ext -> case ext of-    DOC_ITEM sdi ->-      execState (someDocItemToContractDoc sdi) mempty-    _ -> mempty-  _ -> mempty-  where-  dfsSettings :: DfsSettings ContractDoc-  dfsSettings = def-    { dsCtorEffectsApp = CtorEffectsApp-        { ceaName = "Building DocGroup"-        , ceaApplyEffects = \resChildren _ -> \case-            i@(DocGroup grouping _) ->-              (i, docGroupContent grouping resChildren)-            i -> (i, resChildren)-        }-    }---- | Modify all documentation items recursively.-{-# DEPRECATED modifyInstrAllDoc "Use 'modifyDocEntirely' instead." #-}-modifyInstrAllDoc-  :: (SomeDocItem -> SomeDocItem)-  -> Instr inp out-  -> Instr inp out-modifyInstrAllDoc mapper = dfsModifyInstr def $ \case-  Ext ext -> Ext $-    case ext of-      DOC_ITEM sdi -> DOC_ITEM (mapper sdi)-      i -> i-  i -> i---- | Recursevly traverse an instruction and modify documentation items--- matching given type.------ If mapper returns 'Nothing', doc item will remain unmodified.-{-# DEPRECATED modifyInstrDoc "Use 'modifyDoc' instead." #-}-modifyInstrDoc-  :: (DocItem i1, DocItem i2)-  => (i1 -> Maybe i2)-  -> Instr inp out-  -> Instr inp out-modifyInstrDoc mapper = modifyInstrAllDoc untypedMapper-  where-  untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do-    di' <- cast di-    newDi <- mapper di'-    return (SomeDocItem newDi)--instance ContainsDoc (Instr inp out) where-  buildDocUnfinalized = buildInstrDoc--instance ContainsUpdateableDoc (Instr inp out) where-  modifyDocEntirely = modifyInstrAllDoc--instance ContainsDoc (Contract cp st) where-  buildDocUnfinalized = buildDocUnfinalized . cCode--instance ContainsUpdateableDoc (Contract cp st) where-  modifyDocEntirely how contract =-    contract{ cCode = modifyInstrAllDoc how (cCode contract) }---- | Leave only instructions related to documentation.------ Generated documentation for resulting instruction remains the same, but--- semantics of instruction itself gets lost.--- We have to pass optimizer here as an argument to avoid cyclic dependencies.-cutInstrNonDoc :: (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr s s-cutInstrNonDoc optimize = optimize . dfsFoldInstr dfsSettings step-  where-  dfsSettings :: DfsSettings (Instr s s)-  dfsSettings = def-    { dsCtorEffectsApp = CtorEffectsApp-        { ceaName = "Wrap into DocGroup"-        , ceaApplyEffects = \resChildren _ -> \case-            i@(DocGroup g _) -> (i, DocGroup g resChildren)-            i -> (i, resChildren)-        }-    }-  step :: Instr inp out -> Instr s s-  step = \case-    Ext ext -> case ext of-      DOC_ITEM di -> Ext $ DOC_ITEM di-      _ -> Nop-    _ -> Nop

− src/Michelson/Typed/Entrypoints.hs

@@ -1,500 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities for lightweight entrypoints support.-module Michelson.Typed.Entrypoints-  ( EpAddress (..)-  , ParseEpAddressError (..)-  , formatEpAddress-  , mformatEpAddress-  , parseEpAddress-  , unsafeParseEpAddress-  , parseEpAddressRaw-  , unsafeParseEpAddressRaw-  , ParamNotes (..)-  , pattern ParamNotes-  , starParamNotes-  , ArmCoord (..)-  , ArmCoords-  , ParamEpError (..)-  , mkParamNotes--  , EpLiftSequence (..)-  , EntrypointCallT (..)-  , epcPrimitive-  , unsafeEpcCallRoot-  , SomeEntrypointCallT (..)-  , unsafeSepcCallRoot-  , sepcPrimitive-  , sepcName-  , ForbidOr-  , MkEntrypointCallRes (..)-  , mkEntrypointCall--  , tyImplicitAccountParam--    -- * Re-exports-  , EpName (..)-  , pattern DefEpName-  , epNameFromParamAnn-  , epNameToParamAnn-  , epNameFromRefAnn-  , epNameToRefAnn-  , EpNameFromRefAnnError (..)-  ) where--import Control.Monad.Except (throwError)-import qualified Data.ByteString as BS-import Data.Constraint (Dict(..))-import Data.Singletons (withSingI)-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import Fmt (Buildable(..), hexF, pretty, (+|), (|+))-import Text.PrettyPrint.Leijen.Text ((<+>), int, squotes, punctuate, textStrict)--import Michelson.Text-import Michelson.Typed.Annotation-import Michelson.Typed.Scope-import Michelson.Typed.Sing-import Michelson.Typed.T-import Michelson.Printer.Util (RenderDoc(..), renderAnyBuildable, buildRenderDoc)-import Michelson.Untyped.Annotation-import Michelson.Untyped.Entrypoints-import Tezos.Address-import Tezos.Crypto (keyHashLengthBytes)-import Util.TH-import Util.Typeable-import Util.TypeLits--------------------------------------------------------------------------------- Primitives----------------------------------------------------------------------------------- EpAddress--------------------------------------------------------------------------------- | Address with optional entrypoint name attached to it.--- TODO: come up with better name?-data EpAddress = EpAddress-  { eaAddress :: Address-    -- ^ Address itself-  , eaEntrypoint :: EpName-    -- ^ Entrypoint name (might be empty)-  } deriving stock (Show, Eq, Ord, Generic)--instance Buildable EpAddress where-  build = build . formatEpAddress--instance NFData EpAddress--formatEpAddress :: EpAddress -> Text-formatEpAddress (EpAddress addr ep)-  | isDefEpName ep = formatAddress addr-  | otherwise = formatAddress addr <> "%" <> pretty ep--mformatEpAddress :: EpAddress -> MText-mformatEpAddress ea =-  let t = formatEpAddress ea-     -- Should be safe because set of characters allowed in annotations-     -- (and thus in 'EpName') is subset of characters allowed in Michelson strings.-  in unsafeMkMText t--data ParseEpAddressError-  = ParseEpAddressBadAddress ParseAddressError-  | ParseEpAddressRawBadAddress ParseAddressRawError-  | ParseEpAddressBadEntryopint ByteString UnicodeException-  | ParseEpAddressBadRefAnn Text-  | ParseEpAddressRefAnnError EpNameFromRefAnnError-  | ParseEpAddressInvalidLength Int-  deriving stock (Show, Eq, Generic)--instance NFData ParseEpAddressError--instance Buildable ParseEpAddressError where-  build = buildRenderDoc--instance RenderDoc ParseEpAddressError where-  renderDoc context = \case-    ParseEpAddressBadAddress err -> renderDoc context err-    ParseEpAddressRawBadAddress err -> renderDoc context err-    ParseEpAddressBadEntryopint addr exception ->-      "Invalid entrypoint given for raw adddress" <+> (renderAnyBuildable $ hexF addr)<>-      " and failed with" <+> (textStrict (show @Text exception))-    ParseEpAddressBadRefAnn txt -> "Invalid reference annotation:" <+> (textStrict txt)-    ParseEpAddressRefAnnError err -> renderDoc context err-    ParseEpAddressInvalidLength len ->-      "Given raw entrypoint address has invalid length:" <+> int len---- | Parse an address which can be suffixed with entrypoint name--- (e.g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU%entrypoint").-parseEpAddress :: Text -> Either ParseEpAddressError EpAddress-parseEpAddress txt =-  let (addrTxt, mannotTxt) = T.breakOn "%" txt-  in case mannotTxt of-    "" -> do-      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt-      return $ EpAddress addr DefEpName-    annotTxt' -> do-      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt-      annot <- first ParseEpAddressBadRefAnn $ case T.stripPrefix "%" annotTxt' of-        Nothing -> error "impossible"-        Just a -> mkAnnotation a-      epName <- first ParseEpAddressRefAnnError $ epNameFromRefAnn annot-      return $ EpAddress addr epName--unsafeParseEpAddress :: HasCallStack => Text -> EpAddress-unsafeParseEpAddress = either (error . pretty) id . parseEpAddress---- | Parses byte representation of entrypoint address.------ For every address------ @--- KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo%bar--- @------ we get the following byte representation------ @--- 01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f25626172--- \________________________________________/\/\____/\/\____/---               address                     %   ep1  % ep2--- @----parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress-parseEpAddressRaw raw = do-  let (bytes, eps) = BS.splitAt (keyHashLengthBytes + 2) raw-  eaAddress <- first ParseEpAddressRawBadAddress $ parseAddressRaw bytes-  decodedEntrypoint <- first (ParseEpAddressBadEntryopint raw) $ decodeUtf8' eps-  decodedAnnotation <- first ParseEpAddressBadRefAnn $ mkAnnotation decodedEntrypoint-  eaEntrypoint <- first ParseEpAddressRefAnnError $ epNameFromRefAnn decodedAnnotation-  pure $ EpAddress {..}--unsafeParseEpAddressRaw :: ByteString -> EpAddress-unsafeParseEpAddressRaw = either (error . pretty) id . parseEpAddressRaw---- ParamNotes--------------------------------------------------------------------------------- | Annotations for contract parameter declaration.------ Following the Michelson specification, this type has the following invariants:--- 1. No entrypoint name is duplicated.--- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable.-data ParamNotes (t :: T) = UnsafeParamNotes-  { pnNotes   :: Notes t-  , pnRootAnn :: RootAnn-  } deriving stock (Show, Eq, Generic)-    deriving anyclass (NFData)--pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t-pattern ParamNotes t f <- UnsafeParamNotes t f-{-# COMPLETE ParamNotes #-}---- | Parameter without annotations.-starParamNotes :: SingI t => ParamNotes t-starParamNotes = UnsafeParamNotes starNotes noAnn---- | Coordinates of "arm" in Or tree, used solely in error messages.-type ArmCoords = [ArmCoord]-data ArmCoord = AcLeft | AcRight-  deriving stock (Show, Eq, Generic)--instance NFData ArmCoord--instance Buildable ArmCoord where-  build = buildRenderDoc--instance RenderDoc ArmCoord where-  renderDoc _ = \case-    AcLeft -> "left"-    AcRight -> "right"----- | Errors specific to parameter type declaration (entrypoints).-data ParamEpError-  = ParamEpDuplicatedNames (NonEmpty EpName)-  | ParamEpUncallableArm ArmCoords-  deriving stock (Show, Eq, Generic)--instance NFData ParamEpError--instance Buildable ParamEpError where-  build = buildRenderDoc--instance RenderDoc ParamEpError where-  renderDoc context = \case-    ParamEpDuplicatedNames names -> mconcat-      [ "Duplicated entrypoint names: "-      , mconcat $ punctuate ", " . map (squotes . renderAnyBuildable) $ toList names-      ]-    ParamEpUncallableArm arm -> mconcat-      [ "Due to presence of 'default' entrypoint, one of contract \"arms\" \-        \cannot be called: \""-      , mconcat . intersperse " - " $ map (renderDoc context) arm-      , "\""-      , if length arm > 1 then " (in top-to-bottom order)" else ""-      ]---- | Check whether given notes are valid parameter notes.-verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()-verifyParamNotes notes ra = do-  let allEps = appEndo (gatherEntrypoints notes) []-      duplicatedEps-        = mapMaybe (safeHead . tail)-        . NE.group-        . sort-        $ maybe allEps (: allEps) (epNameFromParamAnn ra)--  whenJust (nonEmpty duplicatedEps) $ \dups ->-    throwError $ ParamEpDuplicatedNames dups--  -- In case contract have explicit root entrypoint, we assume that everything is-  -- callable.-  when (ra == noAnn) $ void-    $ first ParamEpUncallableArm-    $ ensureAllCallable notes-  where-    gatherEntrypoints :: Notes t -> Endo [EpName]-    gatherEntrypoints = \case-      NTOr _ fn1 fn2 l r -> mconcat-        [ Endo $ maybe id (:) (epNameFromParamAnn fn1)-        , Endo $ maybe id (:) (epNameFromParamAnn fn2)-        , gatherEntrypoints l-        , gatherEntrypoints r-        ]-      _ -> mempty--    -- Here we can assume that there is no more than one @default@ entrypoint,-    -- because duplications check occurs earlier.-    ---    -- In case when multiple entrypoints are uncallable, the reference-    -- implementation prefers displaying (in error message) arms which are-    -- closer to the root, but here we don't do this because that would be-    -- some more complex to implement and not sure how much does it worth that.-    ensureAllCallable :: Notes t -> Either ArmCoords Bool-    ensureAllCallable = \case-      NTOr _ fnL fnR l r -> do-        let epNameL = epNameFromParamAnn fnL-        let epNameR = epNameFromParamAnn fnR-        haveDefLL <- first (AcLeft  :) $ ensureAllCallable l-        haveDefRR <- first (AcRight :) $ ensureAllCallable r--        let haveDefL = or [haveDefLL, maybe False isDefEpName epNameL]-        let haveDefR = or [haveDefRR, maybe False isDefEpName epNameR]--        when haveDefL $ first (AcRight :) $ checkAllEpsNamed epNameR r-        when haveDefR $ first (AcLeft  :) $ checkAllEpsNamed epNameL l--        return $ or [haveDefL, haveDefR]--      _ -> return False--    checkAllEpsNamed :: Maybe EpName -> Notes t -> Either ArmCoords ()-    checkAllEpsNamed epNameRoot-      | isJust epNameRoot = \_ -> pass-      | otherwise = \case-          NTOr _ fnL fnR l r -> do-            let epNameL = epNameFromParamAnn fnL-                epNameR = epNameFromParamAnn fnR--            first (AcLeft  :) $ checkAllEpsNamed epNameL l-            first (AcRight :) $ checkAllEpsNamed epNameR r--          _ -> throwError []---- | Construct 'ParamNotes' performing all necessary checks.-mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)-mkParamNotes nt fa = verifyParamNotes nt fa $> UnsafeParamNotes nt fa--------------------------------------------------------------------------------- Entrypoint logic--------------------------------------------------------------------------------- | Describes how to construct full contract parameter from given entrypoint--- argument.------ This could be just wrapper over @Value arg -> Value param@, but we cannot--- use @Value@ type in this module easily.-data EpLiftSequence (arg :: T) (param :: T) where-  EplArgHere :: EpLiftSequence arg arg-  EplWrapLeft-    :: (SingI subparam, SingI r)-    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)-  EplWrapRight-    :: (SingI l, SingI subparam)-    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)--deriving stock instance Eq (EpLiftSequence arg param)-deriving stock instance Show (EpLiftSequence arg param)--$(deriveGADTNFData ''EpLiftSequence)--instance Buildable (EpLiftSequence arg param) where-  build = \case-    EplArgHere -> "×"-    EplWrapLeft es -> "Left (" <> build es <> ")"-    EplWrapRight es -> "Right (" <> build es <> ")"---- | Reference for calling a specific entrypoint of type @arg@.-data EntrypointCallT (param :: T) (arg :: T) =-  ParameterScope arg => EntrypointCall-  { epcName :: EpName-    -- ^ Name of entrypoint.-  , epcParamProxy :: Proxy param-    -- ^ Proxy of parameter, to make parameter type more easily fetchable.-  , epcLiftSequence :: EpLiftSequence arg param-    -- ^ How to call this entrypoint in the corresponding contract.-  }--deriving stock instance Eq (EntrypointCallT param arg)-deriving stock instance Show (EntrypointCallT param arg)-instance NFData (EntrypointCallT param arg) where-  rnf (EntrypointCall name Proxy s) = rnf (name, s)--instance Buildable (EntrypointCallT param arg) where-  build EntrypointCall{..} =-    "Call " +| epcName |+ ": " +| epcLiftSequence |+ ""---- | Construct 'EntrypointCallT' which calls no entrypoint and assumes that--- there is no explicit "default" one.------ Validity of such operation is not ensured.-unsafeEpcCallRoot :: ParameterScope param => EntrypointCallT param param-unsafeEpcCallRoot = EntrypointCall-  { epcName = DefEpName-  , epcParamProxy = Proxy-  , epcLiftSequence = EplArgHere-  }---- | Call parameter which has no entrypoints, always safe.-epcPrimitive-  :: forall p.-     (ParameterScope p, ForbidOr p)-  => EntrypointCallT p p-epcPrimitive = unsafeEpcCallRoot-  where-  _requireNoOr = Dict @(ForbidOr p)--type family ForbidOr (t :: T) :: Constraint where-  ForbidOr ('TOr l r) =-    TypeError-    ('Text "Cannot apply to sum type parameter " ':<>: 'ShowType ('TOr l r))-  ForbidOr _ = ()---- | 'EntrypointCallT' with hidden parameter type.------ This requires argument to satisfy 'ParameterScope' constraint.--- Strictly speaking, entrypoint argument may one day start having different--- set of constraints comparing to ones applied to parameter, but this seems--- unlikely.-data SomeEntrypointCallT (arg :: T) =-  forall param. (ParameterScope param) =>-  SomeEpc (EntrypointCallT param arg)--instance Eq (SomeEntrypointCallT arg) where-  SomeEpc epc1 == SomeEpc epc2 = isJust @() $ do-    Refl <- eqP (epcParamProxy epc1) (epcParamProxy epc2)-    guard (epc1 == epc2)--deriving stock instance Show (SomeEntrypointCallT arg)-instance NFData (SomeEntrypointCallT arg) where-  rnf (SomeEpc epc) = rnf epc--instance Buildable (SomeEntrypointCallT arg) where-  build (SomeEpc epc) = build epc---- | Construct 'SomeEntrypointCallT' which calls no entrypoint and assumes that--- there is no explicit "default" one.------ Validity of such operation is not ensured.-unsafeSepcCallRoot :: ParameterScope param => SomeEntrypointCallT param-unsafeSepcCallRoot = SomeEpc unsafeEpcCallRoot---- | Call parameter which has no entrypoints, always safe.-sepcPrimitive-  :: forall t.-     (ParameterScope t, ForbidOr t)-  => SomeEntrypointCallT t-sepcPrimitive = SomeEpc epcPrimitive--sepcName :: SomeEntrypointCallT arg -> EpName-sepcName (SomeEpc epc) = epcName epc---- | Build 'EpLiftSequence'.------ Here we accept entrypoint name and type information for the parameter--- of target contract.------ Returns 'Nothing' if entrypoint is not found.--- Does not treat default entrypoints specially.-withEpLiftSequence-  :: forall param r.-     (ParameterScope param)-  => EpName-  -> Notes param-  -> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r)-  -> Maybe r-withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont =-  case (sing @param, param) of-    (STOr lSing rSing, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->-      withSingI lSing $-      withSingI rSing $-      case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of-        (OpAbsent, NestedBigMapsAbsent) -> asum-          [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)-          , guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere)-          , withEpLiftSequence epName lNotes (cont . fmap @((,) _) EplWrapLeft)-          , withEpLiftSequence epName rNotes (cont . fmap @((,) _) EplWrapRight)-          ]-    _ -> Nothing---- Helper datatype for 'mkEntrypointCall'.-data MkEntrypointCallRes param where-  MkEntrypointCallRes-    :: ParameterScope arg-    => Notes arg-    -> EntrypointCallT param arg-    -> MkEntrypointCallRes param---- | Build 'EntrypointCallT'.------ Here we accept entrypoint name and type information for the parameter--- of target contract.------ Returns 'Nothing' if entrypoint is not found.-mkEntrypointCall-  :: (ParameterScope param)-  => EpName-  -> ParamNotes param-  -> Maybe (MkEntrypointCallRes param)-mkEntrypointCall epName (ParamNotes paramNotes root) =-  asum-  [ do-      epName' <- epNameFromParamAnn root-      guard (epName == epName')-      return $ MkEntrypointCallRes-        paramNotes-        EntrypointCall-          { epcName = epName-          , epcParamProxy = Proxy-          , epcLiftSequence = EplArgHere-          }-  , withEpLiftSequence epName paramNotes $ \(argInfo, liftSeq) ->-      MkEntrypointCallRes argInfo $ EntrypointCall-        { epcName = epName-        , epcParamProxy = Proxy-        , epcLiftSequence = liftSeq-        }-  , guard (isDefEpName epName) $>-      MkEntrypointCallRes paramNotes EntrypointCall-        { epcName = epName-        , epcParamProxy = Proxy-        , epcLiftSequence = EplArgHere-        }-  ]---- | "Parameter" type of implicit account.-tyImplicitAccountParam :: ParamNotes 'TUnit-tyImplicitAccountParam = UnsafeParamNotes starNotes noAnn

− src/Michelson/Typed/Existential.hs

@@ -1,79 +0,0 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Typed.Existential-  ( SomeConstant (..)-  , SomeConstrainedValue (..)-  , SomeContract (..)-  , SomeContractAndStorage (..)-  , SomeIsoValue (..)-  , SomeValue (..)-  , SomeStorage(..)-  ) where--import Fmt (Buildable(..))--import Michelson.Typed.Aliases-import Michelson.Typed.Convert ()-import Michelson.Typed.Haskell.Value (KnownIsoT)-import Michelson.Typed.Instr (Contract(..))-import Michelson.Typed.Scope-import Michelson.Typed.T (T(..))-import Util.Sing (eqParamSing)--data SomeConstrainedValue (c :: T -> Constraint) where-  SomeConstrainedValue-    :: forall (t :: T) (c :: T -> Constraint)-    . (c t)-    => Value t-    -> SomeConstrainedValue c--deriving stock instance Show (SomeConstrainedValue c)---- TODO--- @gromak: perhaps we should implement `SomeValue` in terms of--- `SomeConstrainedValue`, but it will require changing quite a lot of code,--- so it is postponed.--data SomeValue where-  SomeValue :: SingI t => Value t -> SomeValue--deriving stock instance Show SomeValue--instance Eq SomeValue where-  SomeValue v1 == SomeValue v2 = v1 `eqParamSing` v2--data SomeConstant where-  SomeConstant :: (ConstantScope t, SingI t) => Value t -> SomeConstant--instance Buildable SomeConstant where-  build (SomeConstant v) = build v---- | Hides some Haskell value put in line with Michelson 'Value'.-data SomeIsoValue where-  SomeIsoValue :: (KnownIsoT a) => a -> SomeIsoValue--data SomeContract where-  SomeContract :: Contract cp st -> SomeContract--instance NFData SomeContract where-  rnf (SomeContract c) = rnf c--deriving stock instance Show SomeContract---- | Represents a typed contract & a storage value of the type expected by the contract.-data SomeContractAndStorage where-  SomeContractAndStorage-    :: forall cp st.-       (StorageScope st, ParameterScope cp)-       => Contract cp st-       -> Value st-       -> SomeContractAndStorage--deriving stock instance Show SomeContractAndStorage--data SomeStorage where-  SomeStorage :: forall st. StorageScope st => Value st -> SomeStorage--deriving stock instance Show SomeStorage

− src/Michelson/Typed/Extract.hs

@@ -1,219 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, containing functions to convert @Michelson.Untyped.Ty@ to--- @Michelson.Typed.T.T@ Michelson type representation (type stripped off all--- annotations) and to @Michelson.Typed.Annotation.Notes@ value (which contains--- field and type annotations for a given Michelson type).------ I.e. @Michelson.Untyped.Ty@ is split to value @t :: T@ and value of type--- @Notes t@ for which @t@ is a type representation of value @t@.-module Michelson.Typed.Extract-  ( fromUType-  , mkUType-  , toUType-  , withUType--  , pattern AsUType-  , pattern AsUTypeExt-  ) where--import Data.Singletons (Sing, SingI, fromSing, withSingI)--import Michelson.Typed.Annotation (Notes(..), notesSing)-import Michelson.Typed.Sing (SingT(..))-import Michelson.Typed.T (T(..), toUType)-import qualified Michelson.Untyped as Un--{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}--fromUType :: Un.Ty -> T-fromUType ut = withUType ut (fromSing . notesSing)--mkUType :: SingI x => Notes x -> Un.Ty-mkUType notes = case (notesSing notes, notes) of-  (STInt, NTInt tn)               -> Un.Ty Un.TInt tn-  (STNat, NTNat tn)               -> Un.Ty Un.TNat tn-  (STString, NTString tn)         -> Un.Ty Un.TString tn-  (STBytes, NTBytes tn)           -> Un.Ty Un.TBytes tn-  (STMutez, NTMutez tn)           -> Un.Ty Un.TMutez tn-  (STBool, NTBool tn)             -> Un.Ty Un.TBool tn-  (STKeyHash, NTKeyHash tn)       -> Un.Ty Un.TKeyHash tn-  (STBls12381Fr, NTBls12381Fr tn) -> Un.Ty Un.TBls12381Fr tn-  (STBls12381G1, NTBls12381G1 tn) -> Un.Ty Un.TBls12381G1 tn-  (STBls12381G2, NTBls12381G2 tn) -> Un.Ty Un.TBls12381G2 tn-  (STTimestamp, NTTimestamp tn)   -> Un.Ty Un.TTimestamp tn-  (STAddress, NTAddress tn)       -> Un.Ty Un.TAddress tn-  (STKey, NTKey tn)               -> Un.Ty Un.TKey tn-  (STUnit, NTUnit tn)             -> Un.Ty Un.TUnit tn-  (STSignature, NTSignature tn)   -> Un.Ty Un.TSignature tn-  (STChainId, NTChainId tn)       -> Un.Ty Un.TChainId tn-  (STOption t, NTOption tn n)     -> Un.Ty (Un.TOption $ withSingI t $ mkUType n) tn-  (STList t, NTList tn n)         -> Un.Ty (Un.TList $ withSingI t $ mkUType n) tn-  (STSet t, NTSet tn n)           -> Un.Ty (Un.TSet $ withSingI t $ mkUType n) tn-  (STOperation, NTOperation tn)   -> Un.Ty Un.TOperation tn-  (STNever, NTNever tn)           -> Un.Ty Un.TNever tn-  (STContract t, NTContract tn n) ->-    Un.Ty (Un.TContract $ withSingI t (mkUType n)) tn-  (STTicket t, NTTicket tn n) ->-      Un.Ty (Un.TTicket $ withSingI t (mkUType n)) tn-  (STPair t t', NTPair tn fl fr vl vr nl nr) ->-    Un.Ty-    (Un.TPair fl fr vl vr-    (withSingI t $ mkUType nl)-    (withSingI t' $ mkUType nr))-    tn-  (STOr t t', NTOr tn fl fr nl nr) ->-    Un.Ty-    (Un.TOr fl fr-    (withSingI t $ mkUType nl)-    (withSingI t' $ mkUType nr))-    tn-  (STLambda t t', NTLambda tn np nq) ->-    Un.Ty-    (Un.TLambda-    (withSingI t $ mkUType np)-    (withSingI t' $ mkUType nq))-    tn-  (STMap t t', NTMap tn nk nv) ->-    Un.Ty-    (Un.TMap-    (withSingI t $ mkUType nk)-    (withSingI t' $ mkUType nv))-    tn-  (STBigMap t t', NTBigMap tn nk nv) ->-    Un.Ty-    (Un.TBigMap-    (withSingI t $ mkUType nk)-    (withSingI t' $ mkUType nv))-    tn---- | Convert 'Un.Ty' to the isomorphic set of information from typed world.-withUType-  :: Un.Ty-  -> (forall t. SingI t => Notes t -> r)-  -> r-withUType (Un.Ty ut tn) cont = case ut of--  Un.TInt ->-    cont (NTInt tn)--  Un.TNat ->-    cont (NTNat tn)--  Un.TString ->-    cont (NTString tn)--  Un.TBytes ->-    cont (NTBytes tn)--  Un.TMutez ->-    cont (NTMutez tn)--  Un.TBool ->-    cont (NTBool tn)--  Un.TKeyHash ->-    cont (NTKeyHash tn)--  Un.TBls12381Fr ->-    cont (NTBls12381Fr tn)--  Un.TBls12381G1 ->-    cont (NTBls12381G1 tn)--  Un.TBls12381G2 ->-    cont (NTBls12381G2 tn)--  Un.TTimestamp ->-    cont (NTTimestamp tn)--  Un.TAddress ->-    cont (NTAddress tn)--  Un.TKey ->-    cont (NTKey tn)--  Un.TUnit ->-    cont (NTUnit tn)--  Un.TSignature ->-    cont (NTSignature tn)--  Un.TChainId ->-    cont (NTChainId tn)--  Un.TNever ->-    cont (NTNever tn)--  Un.TOption internalT -> withUType internalT $-    \(notesInternalT :: Notes internalT) ->-      cont (NTOption tn notesInternalT)--  Un.TList listT -> withUType listT $-    \(notesListT :: Notes listT) ->-      cont (NTList tn notesListT)--  Un.TSet setT -> withUType setT $-    \(notesSetT :: Notes setT) ->-      cont (NTSet tn notesSetT)--  Un.TOperation ->-    cont (NTOperation tn)--  Un.TContract contractT -> withUType contractT $-    \(notesContractT :: Notes contractT) ->-      cont (NTContract tn notesContractT)--  Un.TTicket ticketT -> withUType ticketT $-    \(notesTicketT :: Notes ticketT) ->-      cont (NTTicket tn notesTicketT)--  Un.TPair la ra lv rv lt rt ->-    withUType lt $ \ln ->-      withUType rt $ \rn ->-        cont (NTPair tn la ra lv rv ln rn)--  Un.TOr la ra lt rt ->-    withUType lt $ \ln ->-      withUType rt $ \rn ->-        cont (NTOr tn la ra ln rn)--  Un.TLambda lt rt ->-    withUType lt $ \ln ->-      withUType rt $ \rn ->-        cont (NTLambda tn ln rn)--  Un.TMap keyT valT ->-    withUType keyT $ \keyN ->-      withUType valT $ \valN ->-        cont @('TMap _ _) (NTMap tn keyN valN)--  Un.TBigMap keyT valT ->-    withUType keyT $ \keyN ->-      withUType valT $ \valN ->-        cont @('TBigMap _ _) (NTBigMap tn keyN valN)---- Helper datatype for 'AsUType'.-data SomeTypedInfo = forall t. SingI t => SomeTypedInfo (Notes t)---- | Transparently represent untyped 'Ty' as wrapper over @Notes t@--- from typed world with @SingI t@ constraint.------ As expression this carries logic of 'mkUType', and as pattern it performs--- 'withUType' but may make code a bit cleaner.------ Note about constraints: pattern signatures usually require two constraints ---- one they require and another one which they provide. In our case we require--- nothing (thus first constraint is @()@) and provide some knowledge about @t@.-pattern AsUType :: () => (SingI t) => Notes t -> Un.Ty-pattern AsUType notes <- ((\ut -> withUType ut SomeTypedInfo) -> SomeTypedInfo notes)-  where AsUType notes = mkUType notes-{-# COMPLETE AsUType #-}---- | Similar to 'AsUType', but also gives 'Sing' for given type.-pattern AsUTypeExt :: () => (SingI t) => Sing t -> Notes t -> Un.Ty-pattern AsUTypeExt sng notes <- AsUType notes@(notesSing -> sng)-  where AsUTypeExt _ notes = AsUType notes-{-# COMPLETE AsUTypeExt #-}

− src/Michelson/Typed/Haskell.hs

@@ -1,14 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Haskell-Michelson conversions.-module Michelson.Typed.Haskell-  ( module Exports-  ) where--import Michelson.Typed.Haskell.Compatibility as Exports-import Michelson.Typed.Haskell.Doc as Exports-import Michelson.Typed.Haskell.Instr as Exports-import Michelson.Typed.Haskell.LooseSum as Exports-import Michelson.Typed.Haskell.Value as Exports hiding (GIsoValue(..))

− src/Michelson/Typed/Haskell/Compatibility.hs

@@ -1,53 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Compatibility of Haskell values representation in Michelson.-module Michelson.Typed.Haskell.Compatibility-  ( ligoLayout-  , ligoCombLayout-  ) where--import Util.CustomGeneric---- | Default layout in LIGO.------ To be used with 'customGeneric', see this method for more info.------ This is similar to 'leftBalanced', but------ * fields are sorted alphabetically;--- * always puts as large complete binary subtrees as possible at left.-ligoLayout :: GenericStrategy-ligoLayout =-  reorderingData forbidUnnamedFields alphabetically $-    fromDepthsStrategy ligoDepths-  where-    ligoDepths n =-      case fmap last . nonEmpty $ takeWhile (\(_, p) -> p <= n) powersOfTwo of-        Nothing -> []-        Just (depth, power) ->-          let leftSub = replicate power depth-              rightSub = ligoDepths (n - power)-          in if null rightSub then leftSub else map succ $ leftSub ++ rightSub--    powersOfTwo = [0..] <&> \i -> (i, 2 ^ i)---- | Comb layout in LIGO (@ [\@layout:comb] @).------ To be used with 'customGeneric'.------ Note: to make comb layout work for sum types, make sure that in LIGO--- all the constructors are preceded by the bar symbol in your type declaration:------ @--- type my_type =---   [@layout:comb]---   | Ctor1 of nat  ← bar symbol _must_ be here---   | Ctor2 of int---   ...--- @------ Though the situation may change: https://gitlab.com/ligolang/ligo/-/issues/1104.-ligoCombLayout :: GenericStrategy-ligoCombLayout = rightComb

− src/Michelson/Typed/Haskell/Doc.hs

@@ -1,942 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- Dunno why it triggers-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Documentation of types appearing in contracts.-module Michelson.Typed.Haskell.Doc-  ( ADTRep-  , ConstructorRep (..)-  , crNameL, crDescriptionL, crFieldsL-  , FieldRep (..)-  , frNameL, frDescriptionL, frTypeRepL-  , WithinParens (..)-  , TypeHasDoc (..)-  , TypeDocHaskellRep-  , TypeDocMichelsonRep-  , FieldDescriptions-  , PolyTypeHasDocC-  , SomeTypeWithDoc (..)--  , HaveCommonTypeCtor-  , IsHomomorphic-  , genericTypeDocDependencies-  , customTypeDocMdReference-  , homomorphicTypeDocMdReference-  , poly1TypeDocMdReference-  , poly2TypeDocMdReference-  , homomorphicTypeDocHaskellRep-  , concreteTypeDocHaskellRep-  , unsafeConcreteTypeDocHaskellRep-  , haskellAddNewtypeField-  , haskellRepNoFields-  , haskellRepStripFieldPrefix-  , homomorphicTypeDocMichelsonRep-  , concreteTypeDocMichelsonRep-  , unsafeConcreteTypeDocMichelsonRep--  , DType (..)-  , DStorageType (..)-  , dStorage-  , GTypeHasDoc-  , GProductHasDoc-  , dTypeDep-  , dTypeDepP-  , buildADTRep-  , applyWithinParens-  ) where--import Control.Lens (_Just, each, to)-import Data.Char (isLower, isUpper, toLower)-import Data.List (lookup)-import Data.Singletons (SingI, demote)-import qualified Data.Text as T-import Data.Typeable (typeRep)-import Fmt (Buildable, build, (+|), (|+))-import GHC.Generics ((:*:)(..), (:+:)(..))-import qualified GHC.Generics as G-import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal)-import Named (NamedF)-import qualified Text.Show-import Type.Showtype (Showtype(..))--import Michelson.Doc-import Michelson.Text-import Michelson.Typed.Aliases-import Michelson.Typed.Entrypoints-import Michelson.Typed.Haskell.ValidateDescription-import Michelson.Typed.Haskell.Value-import Michelson.Typed.T-import Tezos.Address-import Tezos.Core-import Tezos.Crypto-import Util.Generic-import Util.Lens-import Util.Markdown-import Util.Named-import Util.Typeable---- | Stands for representation of some Haskell ADT corresponding to--- Michelson value. Type parameter @a@ is what you put in place of--- each field of the datatype, e.g. information about field type.------ This representation also includes descriptions of constructors and fields.-type ADTRep a = [ConstructorRep a]---- | Representation of a constructor with an optional description.-data ConstructorRep a = ConstructorRep-  { crName :: Text-  , crDescription :: Maybe Text-  , crFields :: [FieldRep a]-  }---- | Representation of a field with an optional description.-data FieldRep a = FieldRep-  { frName :: Maybe Text-  , frDescription :: Maybe Text-  , frTypeRep :: a-  }--makeLensesWith postfixLFields ''ConstructorRep-makeLensesWith postfixLFields ''FieldRep---- | Show given 'ADTRep' in a neat way.-buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown-buildADTRep buildField = \case-  [] -> mdItalic "no values"-  [ctor@ConstructorRep{..}] -> renderProduct (WithinParens False) ctor crFields-  ps -> (mappend (mdItalic "one of" <> " \n")) $-        foldMap-        (toListItem . renderNamedProduct (WithinParens True)) (toList ps)-  where-    toListItem item = "+ " <> item <> "\n"--    renderNamedProduct :: WithinParens -> ConstructorRep a -> Markdown-    renderNamedProduct wp ctor@ConstructorRep{..} =-      mdBold (build crName) <>-      if hasFieldNames-         then maybe "" (\d -> ": " <> build d <> " ") crDescription <>-              renderProduct wp ctor crFields-         else renderProduct wp ctor crFields <>-              maybe "" (\d -> ": " <> build d) crDescription-      where-        hasFieldNames = any (isJust . frName) crFields--    renderProduct :: WithinParens -> ConstructorRep a -> [FieldRep a] -> Markdown-    renderProduct wp ctor = \case-      [] -> "()"-      [t@FieldRep{ frDescription = Nothing }]-        | Nothing <- crDescription ctor -> renderNamedField wp t-      ts -> mconcat $ map (("\n  * " <>) . renderNamedField wp) ts--    renderNamedField :: WithinParens -> FieldRep a -> Markdown-    renderNamedField wp FieldRep{..} = mconcat-      [ maybe "" buildFieldName frName-      , buildField wp frTypeRep-      , maybe "" (mappend "    " . mappend "\n" . build) frDescription-      ]---- | Map field names in a 'ADTRep', with the possibility to remove some names by--- mapping them to 'Nothing'.-mapADTRepFields :: (Maybe Text -> Maybe Text) -> ADTRep a -> ADTRep a-mapADTRepFields = over $ each . crFieldsL . each . frNameL---- | How field names should be displayed.------ Result of this function call should appear right before rendered type--- of that field.-buildFieldName :: Text -> Markdown-buildFieldName name = mdItalic (mdBold (build name)) |+ " :"---- | Whether given text should be rendered grouped in parentheses--- (if they make sense).-newtype WithinParens = WithinParens Bool--applyWithinParens :: WithinParens -> Markdown -> Markdown-applyWithinParens (WithinParens wp) txt-  | wp = "(" <> txt <> ")"-  | otherwise = txt---- | Description for a Haskell type appearing in documentation.-class ( Typeable a-      , SingI (TypeDocFieldDescriptions a)-      , FieldDescriptionsValid (TypeDocFieldDescriptions a) a-      ) => TypeHasDoc a where-  -- | Name of type as it appears in definitions section.-  ---  -- Each type must have its own unique name because it will be used-  -- in identifier for references.-  ---  -- Default definition derives name from Generics.-  -- If it does not fit, consider defining this function manually.-  -- (We tried using 'Data.Data' for this, but it produces names including-  -- module names which is not do we want).-  typeDocName :: Proxy a -> Text-  default typeDocName-    :: (Generic a, KnownSymbol (GenericTypeName a))-    => Proxy a -> Text-  typeDocName _ = toText $ symbolVal (Proxy @(GenericTypeName a))--  -- | Explanation of a type. Markdown formatting is allowed.-  typeDocMdDescription :: Markdown--  -- | How reference to this type is rendered, in Markdown.-  ---  -- Examples:-  ---  -- * @\[Integer](\#type-integer)@,-  -- * @\[Maybe](\#type-Maybe) \[()](\#type-unit)@.-  ---  -- Consider using one of the following functions as default implementation;-  -- which one to use depends on number of type arguments in your type:-  ---  -- * 'homomorphicTypeDocMdReference'-  -- * 'poly1TypeDocMdReference'-  -- * 'poly2TypeDocMdReference'-  ---  -- If none of them fits your purposes precisely, consider using-  -- 'customTypeDocMdReference'.-  typeDocMdReference :: Proxy a -> WithinParens -> Markdown-  default typeDocMdReference-    :: (Typeable a, IsHomomorphic a)-    => Proxy a -> WithinParens -> Markdown-  typeDocMdReference = homomorphicTypeDocMdReference--  -- | All types which this type directly contains.-  ---  -- Used in automatic types discovery.-  typeDocDependencies :: Proxy a -> [SomeDocDefinitionItem]-  default typeDocDependencies-    :: (Generic a, GTypeHasDoc (G.Rep a))-    => Proxy a -> [SomeDocDefinitionItem]-  typeDocDependencies = genericTypeDocDependencies--  -- | For complex types - their immediate Haskell representation.-  ---  -- For primitive types set this to 'Nothing'.-  ---  -- For homomorphic types use 'homomorphicTypeDocHaskellRep' implementation.-  ---  -- For polymorhpic types consider using 'concreteTypeDocHaskellRep' as implementation.-  ---  -- Modifier 'haskellRepNoFields' can be used to hide names of fields,-  -- beneficial for newtypes.-  ---  -- Another modifier called 'haskellRepStripFieldPrefix' can be used for datatypes-  -- to leave only meaningful part of name in every field.-  typeDocHaskellRep :: TypeDocHaskellRep a-  default typeDocHaskellRep-    :: (Generic a, GTypeHasDoc (G.Rep a), IsHomomorphic a)-    => TypeDocHaskellRep a-  typeDocHaskellRep = haskellRepStripFieldPrefix homomorphicTypeDocHaskellRep--  -- | Description of constructors and fields of @a@.-  ---  -- See 'FieldDescriptions' documentation for an example of usage.-  ---  -- Descriptions will be checked at compile time to make sure that only existing constructors-  -- and fields are referenced.-  ---  -- For that check to work @instance Generic a@ is required whenever @TypeDocFieldDescriptions@-  -- is not empty.-  ---  -- For implementation of the check see 'FieldDescriptionsValid' type family.-  type TypeDocFieldDescriptions a :: FieldDescriptions-  type TypeDocFieldDescriptions _ = '[]--  -- | Final michelson representation of a type.-  ---  -- For homomorphic types use 'homomorphicTypeDocMichelsonRep' implementation.-  ---  -- For polymorhpic types consider using 'concreteTypeDocMichelsonRep' as implementation.-  typeDocMichelsonRep :: TypeDocMichelsonRep a-  default typeDocMichelsonRep-    :: (KnownIsoT a, IsHomomorphic a)-    => TypeDocMichelsonRep a-  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep---- | Signature of 'typeDocHaskellRep' function.------ A value of 'FieldDescriptionsV' is provided by the library to make sure that--- instances won't replace it with an unchecked value.------ When value is 'Just', it contains types which this type is built from.------ First element of provided pair may contain name a concrete type which has--- the same type constructor as @a@ (or just @a@ for homomorphic types), and--- the second element of the pair - its unfolding in Haskell.------ For example, for some @newtype MyNewtype = MyNewtype (Integer, Natural)@--- we would not specify the first element in the pair because @MyNewtype@ is--- already a concrete type, and second element would contain @(Integer, Natural)@.--- For polymorhpic types like @newtype MyPolyNewtype a = MyPolyNewtype (Text, a)@,--- we want to describe its representation on some example of @a@, because--- working with type variables is too non-trivial; so the first element of--- the pair may be e.g. @"MyPolyNewType Integer"@, and the second one shows--- that it unfolds to @(Text, Integer)@.------ When rendered, values of this type look like:------ * @(Integer, Natural)@ - for homomorphic type.--- * @MyError Integer = (Text, Integer)@ - concrete sample for polymorhpic type.-type TypeDocHaskellRep a =-  Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)---- | Signature of 'typeDocMichelsonRep' function.------ As in 'TypeDocHaskellRep', set the first element of the pair to 'Nothing'--- for primitive types, otherwise it stands as some instantiation of a type,--- and its Michelson representation is given in the second element of the pair.------ Examples of rendered representation:------ * @pair int nat@ - for homomorphic type.--- * @MyError Integer = pair string int@ - concrete sample for polymorhpic type.-type TypeDocMichelsonRep a =-  Proxy a -> (Maybe DocTypeRepLHS, T)---- | Data hides some type implementing 'TypeHasDoc'.-data SomeTypeWithDoc where-  SomeTypeWithDoc :: TypeHasDoc td => Proxy td -> SomeTypeWithDoc---- | When rendering type's inner representation, this stands for name of------ Having this makes sense for polymorhpic types, when you want to render--- representation of some concrete instantiation of that type.-newtype DocTypeRepLHS = DocTypeRepLHS Text-  deriving newtype (IsString, Buildable)---- | Doc element with description of a type.-data DType where-  DType :: TypeHasDoc a => Proxy a -> DType--instance Show DType where-  show (DType a) = show $ typeRep a--instance Eq DType where-  DType a1 == DType a2 = a1 `eqExt` a2-instance Ord DType where-  DType a1 `compare` DType a2 = a1 `compareExt` a2--instance DocItem DType where-  type DocItemPlacement DType = 'DocItemInDefinitions-  type DocItemReferenced DType = 'True-  docItemPos = 5000--  docItemSectionName = Just "Types"--  docItemRef (DType a) = DocItemRef $-    DocItemId ("types-" <> typeDocName a)--  docItemDependencies (DType (ap' :: Proxy a)) =-    typeDocDependencies ap'--  docItemToMarkdown lvl (DType (ap' :: Proxy a)) =-    mconcat . catMaybes $-    [ Just mdSeparator-    , Just $ mdHeader lvl (mdTicked . build $ typeDocName ap')-    , Just $ typeDocMdDescription @a |+ "\n\n"-    , typeDocHaskellRep ap' (demote @(TypeDocFieldDescriptions a)) <&> \(mlhs, rep) ->-        let-          -- Without this signature type inference trips.-          buildField :: WithinParens -> SomeTypeWithDoc -> Markdown-          buildField wp (SomeTypeWithDoc di) =-            typeDocMdReference di wp-          renderedRep =-             buildADTRep buildField rep-          rendered = case mlhs of-            Nothing ->-              mdSubsection "Structure" renderedRep-            Just lhs ->-              mdSubsection "Structure (example)" $-                mdTicked (build lhs) <> " = " <> renderedRep-        in rendered <> "\n\n"-    , Just $-        let (mlhs, rep) = typeDocMichelsonRep ap'-            renderedRep = mdTicked (build rep)-            rendered = case mlhs of-              Nothing -> mdSubsection "Final Michelson representation"-                         renderedRep-              Just lhs -> mdSubsection "Final Michelson representation (example)" $-                          mdTicked (build lhs) <> " = " <> renderedRep-        in rendered <> "\n\n"-    ]--  docItemToToc lvl d@(DType ap') =-    mdTocFromRef lvl (build $ typeDocName ap') d---- | Create a 'DType' in form suitable for putting to 'typeDocDependencies'.-dTypeDep :: forall (t :: Type). TypeHasDoc t => SomeDocDefinitionItem-dTypeDep = SomeDocDefinitionItem (DType (Proxy @t))---- | Proxy version of 'dTypeDep'.-dTypeDepP-  :: forall (t :: Type).-      TypeHasDoc t-  => Proxy t -> SomeDocDefinitionItem-dTypeDepP _ = dTypeDep @t---- | Doc element with description of contract storage type.-newtype DStorageType = DStorageType DType-  deriving stock (Generic, Eq, Ord)---- | Shortcut for 'DStorageType'.-dStorage :: forall store. TypeHasDoc store => DStorageType-dStorage = DStorageType $ DType (Proxy @store)--instance DocItem DStorageType where-  type DocItemPlacement DStorageType = 'DocItemInlined-  type DocItemReferenced DStorageType = 'True--  docItemRef (DStorageType (DType a)) = DocItemRefInlined $-    DocItemId ("storage-" <> typeDocName a)-  docItemPos = 835-  docItemSectionName = Just "Storage"-  docItemToMarkdown lvl (DStorageType t) = docItemToMarkdown lvl t-  docItemToToc lvl d@(DStorageType (DType a)) =-    mdTocFromRef lvl (build $ typeDocName a) d-  docItemDependencies (DStorageType t) = docItemDependencies t---- Default implementations--------------------------------------------------------------------------------- | Require two types to be built from the same type constructor.------ E.g. @HaveCommonTypeCtor (Maybe Integer) (Maybe Natural)@ is defined,--- while @HaveCmmonTypeCtor (Maybe Integer) [Integer]@ is not.-class HaveCommonTypeCtor a b-instance HaveCommonTypeCtor ac bc => HaveCommonTypeCtor (ac a) (bc b)-instance HaveCommonTypeCtor a a---- | Require this type to be homomorphic.-class IsHomomorphic a where-instance TypeError ('Text "Type is not homomorphic: " ':<>: 'ShowType (a b)) =>-         IsHomomorphic (a b)-instance {-# OVERLAPPABLE #-} IsHomomorphic a---- | Render a reference to a type which consists of type constructor--- (you have to provide name of this type constructor and documentation--- for the whole type) and zero or more type arguments.-customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown-customTypeDocMdReference (typeCtorName, tyDoc) typeArgsDoc wp =-  let DocItemRef ctorDocItemId = docItemRef tyDoc-  in applyWithinParens wpSmart $-     mconcat . intersperse " " $-      ( mdLocalRef (mdTicked $ build typeCtorName) ctorDocItemId-      : (typeArgsDoc <&> \(DType di) -> typeDocMdReference di (WithinParens True))-      )-    where-      -- If we are rendering an atomic thing, there is no need in parentheses-      -- around it-      wpSmart =-        let WithinParens wp' = wp-        in WithinParens (wp' && not (null typeArgsDoc))---- | Derive 'typeDocMdReference', for homomorphic types only.-homomorphicTypeDocMdReference-  :: forall (t :: Type).-     (Typeable t, TypeHasDoc t, IsHomomorphic t)-  => Proxy t -> WithinParens -> Markdown-homomorphicTypeDocMdReference tp _ =-  customTypeDocMdReference-    (typeDocName tp, DType tp)-    []-    (WithinParens False)---- | Derive 'typeDocMdReference', for polymorphic type with one--- type argument, like @Maybe Integer@.-poly1TypeDocMdReference-  :: forall t (r :: Type) (a :: Type).-      (r ~ t a, Typeable t, Each '[TypeHasDoc] [r, a], IsHomomorphic t)-  => Proxy r -> WithinParens -> Markdown-poly1TypeDocMdReference tp =-  customTypeDocMdReference-    (toText $ showtype (Proxy @t), DType tp)-    [DType (Proxy @a)]---- | Derive 'typeDocMdReference', for polymorphic type with two--- type arguments, like @Lambda Integer Natural@.-poly2TypeDocMdReference-  :: forall t (r :: Type) (a :: Type) (b :: Type).-      (r ~ t a b, Typeable t, Each '[TypeHasDoc] [r, a, b], IsHomomorphic t)-  => Proxy r -> WithinParens -> Markdown-poly2TypeDocMdReference tp =-  customTypeDocMdReference-    (toText $ showtype (Proxy @t), DType tp)-    [ DType (Proxy @a)-    , DType (Proxy @b)-    ]---- | Implement 'typeDocDependencies' via getting all immediate fields--- of a datatype.------ Note: this will not include phantom types, I'm not sure yet how this--- scenario should be handled (@martoon).-genericTypeDocDependencies-  :: forall a.-      (Generic a, GTypeHasDoc (G.Rep a))-  => Proxy a -> [SomeDocDefinitionItem]-genericTypeDocDependencies _ = do-  ConstructorRep{..} <- toList $ gTypeDocHaskellRep @(G.Rep a) []-  FieldRep{..} <- crFields-  SomeTypeWithDoc ty <- pure frTypeRep-  return (dTypeDepP ty)---- | Implement 'typeDocHaskellRep' for a homomorphic type.------ Note that it does not require your type to be of 'IsHomomorphic' instance,--- which can be useful for some polymorhpic types which, for documentation--- purposes, we want to consider homomorphic.------ Example: 'Operation' is in fact polymorhpic, but we don't want this fact to--- be reflected in the documentation.-homomorphicTypeDocHaskellRep-  :: forall a.-     (Generic a, GTypeHasDoc (G.Rep a))-  => TypeDocHaskellRep a-homomorphicTypeDocHaskellRep _ descr = Just-  ( Nothing-  , gTypeDocHaskellRep @(G.Rep a) descr-  )---- | Implement 'typeDocHaskellRep' on example of given concrete type.------ This is a best effort attempt to implement 'typeDocHaskellRep' for polymorhpic--- types, as soon as there is no simple way to preserve type variables when--- automatically deriving Haskell representation of a type.-concreteTypeDocHaskellRep-  :: forall a b.-     ( Typeable a, GenericIsoValue a, GTypeHasDoc (G.Rep a)-     , HaveCommonTypeCtor b a-     )-  => TypeDocHaskellRep b-concreteTypeDocHaskellRep = unsafeConcreteTypeDocHaskellRep @a---- | Version of 'concreteTypeDocHaskellRep' which does not ensure--- whether the type for which representation is built is any similar to--- the original type which you implement a 'TypeHasDoc' instance for.-unsafeConcreteTypeDocHaskellRep-  :: forall a b.-     ( Typeable a, GenericIsoValue a, GTypeHasDoc (G.Rep a)-     )-  => TypeDocHaskellRep b-unsafeConcreteTypeDocHaskellRep _ descr = Just-  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)-  , gTypeDocHaskellRep @(G.Rep a) descr-  )---- | Erase fields from Haskell datatype representation.------ Use this when rendering fields names is undesired.-haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a-haskellRepNoFields mkRep =-  \p descr -> second (mapADTRepFields (const Nothing)) <$> mkRep p descr---- | Add field name for @newtype@.------ Since @newtype@ field is automatically erased. Use this function--- to add the desired field name.-haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a-haskellAddNewtypeField fieldName mkRep =-  \p descr -> second (mapADTRepFields (const (Just fieldName))) <$> mkRep p descr---- | Cut fields prefixes which we use according to the style guide.------ E.g. @cmMyField@ field will be transformed to @myField@.-haskellRepStripFieldPrefix-  :: HasCallStack-  => TypeDocHaskellRep a -> TypeDocHaskellRep a-haskellRepStripFieldPrefix mkRep =-  \p descr -> second (mapADTRepFields (fmap stripPrefix)) <$> mkRep p descr-  where-    stripPrefix fieldName =-      case T.uncons $ T.dropWhile isLower fieldName of-        Nothing -> error $ "Field '" <> fieldName <> "' has no prefix"-        Just (c, cs) ->-          -- For fields like @ciUSPosition@ we should not lead the first letter-          -- to lower case like @uSPosition@.-          let isAbbreviation = case T.uncons cs of-                Just (c2, _)-                  | isUpper c2 -> True-                  | otherwise -> False-                Nothing -> False-          in T.cons (if isAbbreviation then c else toLower c) cs---- | Implement 'typeDocMichelsonRep' for homomorphic type.-homomorphicTypeDocMichelsonRep-  :: forall a.-     KnownIsoT a-  => TypeDocMichelsonRep a-homomorphicTypeDocMichelsonRep _ =-  ( Nothing-  , demote @(ToT a)-  )---- | Implement 'typeDocMichelsonRep' on example of given concrete type.------ This function exists for the same reason as 'concreteTypeDocHaskellRep'.-concreteTypeDocMichelsonRep-  :: forall a b.-     (Typeable a, KnownIsoT a, HaveCommonTypeCtor b a)-  => TypeDocMichelsonRep b-concreteTypeDocMichelsonRep _ =-  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)-  , demote @(ToT a)-  )---- | Version of 'unsafeConcreteTypeDocHaskellRep' which does not ensure--- whether the type for which representation is built is any similar to--- the original type which you implement a 'TypeHasDoc' instance for.-unsafeConcreteTypeDocMichelsonRep-  :: forall a b.-     (Typeable a, KnownIsoT a)-  => TypeDocMichelsonRep b-unsafeConcreteTypeDocMichelsonRep _ =-  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)-  , demote @(ToT a)-  )---- | Generic traversal for automatic deriving of some methods in 'TypeHasDoc'.-class GTypeHasDoc (x :: Type -> Type) where-  gTypeDocHaskellRep :: FieldDescriptionsV -> ADTRep SomeTypeWithDoc--instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'False) x) where-  gTypeDocHaskellRep = gTypeDocHaskellRep @x--instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'True) x) where-  gTypeDocHaskellRep descr =-    mapADTRepFields (const Nothing) $ gTypeDocHaskellRep @x descr--instance (GTypeHasDoc x, GTypeHasDoc y) => GTypeHasDoc (x :+: y) where-  gTypeDocHaskellRep descr = gTypeDocHaskellRep @x descr <> gTypeDocHaskellRep @y descr--instance (GProductHasDoc x, KnownSymbol ctor) =>-         GTypeHasDoc (G.C1 ('G.MetaCons ctor _1 _2) x) where-  gTypeDocHaskellRep descr = one $ ConstructorRep-    { crName = conName-    , crDescription = descr ^? to (lookup conName) . _Just . _1 . _Just-    , crFields = gProductDocHaskellRep @x $ descr ^. to (lookup conName) . _Just . _2-    }-    where-      conName = toText $ symbolVal (Proxy @ctor)--instance GTypeHasDoc G.V1 where-  gTypeDocHaskellRep _ = []---- | Product type traversal for 'TypeHasDoc'.-class GProductHasDoc (x :: Type -> Type) where-  gProductDocHaskellRep :: [(Text, Text)] -> [FieldRep SomeTypeWithDoc]--instance (GProductHasDoc x, GProductHasDoc y) => GProductHasDoc (x :*: y) where-  gProductDocHaskellRep descr = gProductDocHaskellRep @x descr <> gProductDocHaskellRep @y descr--instance TypeHasDoc a =>-         GProductHasDoc (G.S1 ('G.MetaSel 'Nothing _1 _2 _3) (G.Rec0 a)) where-  gProductDocHaskellRep _ = one $ FieldRep-    { frName = Nothing-    , frDescription = Nothing-    , frTypeRep = SomeTypeWithDoc (Proxy @a)-    }--instance (TypeHasDoc a, KnownSymbol field) =>-         GProductHasDoc (G.S1 ('G.MetaSel ('Just field) _1 _2 _3) (G.Rec0 a)) where-  gProductDocHaskellRep descr = one $ FieldRep-    { frName = Just fieldName-    , frDescription = descr ^? to (lookup fieldName) . _Just-    , frTypeRep = SomeTypeWithDoc (Proxy @a)-    }-    where-      fieldName = toText (symbolVal $ Proxy @field)--instance GProductHasDoc G.U1 where-  gProductDocHaskellRep = mempty---- Instances--------------------------------------------------------------------------------- | Constraint, required when deriving 'TypeHasDoc' for polymorphic type--- with the least possible number of methods defined manually.-type PolyTypeHasDocC ts = Each '[TypeHasDoc] ts---- | Version of 'PolyTypeHasDocC' for comparable types.-type PolyCTypeHasDocC ts = Each '[TypeHasDoc] ts--instance TypeHasDoc Integer where-  typeDocName _ = "Integer"-  typeDocMdDescription = "Signed number."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc Natural where-  typeDocName _ = "Natural"-  typeDocMdDescription = "Unsigned number."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc MText where-  typeDocName _ = "Text"-  typeDocMdReference p = customTypeDocMdReference ("Text", DType p) []-  typeDocMdDescription =-    "Michelson string.\n\n\-    \This has to contain only ASCII characters with codes from [32; 126] range; \-    \additionally, newline feed character is allowed."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc Bool where-  typeDocName _ = "Bool"-  typeDocMdDescription = "Bool primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc ByteString where-  typeDocName _ = "ByteString"-  typeDocMdDescription = "Bytes primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc Mutez where-  typeDocName _ = "Mutez"-  typeDocMdDescription = "Mutez primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc KeyHash where-  typeDocName _ = "KeyHash"-  typeDocMdDescription = "KeyHash primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc Timestamp where-  typeDocName _ = "Timestamp"-  typeDocMdDescription = "Timestamp primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc Address where-  typeDocName _ = "Address"-  typeDocMdDescription = [md|-    Address primitive.--    Unlike Michelson's `address`, it is assumed not to contain an entrypoint name,-    even if it refers to a contract; this won't be checked, so passing an entrypoint-    name may result in unexpected errors.-    |]-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc EpAddress where-  typeDocName _ = "EntrypointAddress"-  typeDocMdDescription = [md|-    Address primitive.--    This exactly matches the Michelson's `address`, and can refer to a specific entrypoint.-    |]-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc PublicKey where-  typeDocName _ = "PublicKey"-  typeDocMdDescription = "PublicKey primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc Signature where-  typeDocName _ = "Signature"-  typeDocMdDescription = "Signature primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc ChainId where-  typeDocName _ = "ChainId"-  typeDocMdDescription = "Identifier of the current chain."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing--instance TypeHasDoc () where-  typeDocName _ = "()"-  typeDocMdDescription = "Unit primitive."-  typeDocDependencies _ = []--instance PolyTypeHasDocC '[a] => TypeHasDoc [a] where-  typeDocName _ = "List"-  typeDocMdDescription = "List primitive."-  typeDocMdReference _ =-    -- poly1TypeDocMdReference would produce text like @[] Integer@, we want-    -- to replace this @[]@ with @List@.-    customTypeDocMdReference ("List", DType (Proxy @[a])) [DType (Proxy @a)]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @[Integer]--instance PolyTypeHasDocC '[a] => TypeHasDoc (Maybe a) where-  typeDocMdDescription = "Option primitive."-  typeDocMdReference = poly1TypeDocMdReference-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Maybe Integer)--instance PolyTypeHasDocC [l, r] => TypeHasDoc (Either l r) where-  typeDocMdDescription = "Or primitive."-  typeDocMdReference = poly2TypeDocMdReference-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Either Integer Natural)--instance PolyTypeHasDocC [a, b] => TypeHasDoc (a, b) where-  typeDocName _ = "(a, b)"-  typeDocMdReference _ = tupleTypeDocReference-    [ typeDocMdReference (Proxy @a) (WithinParens False)-    , typeDocMdReference (Proxy @b) (WithinParens False)-    ]-  typeDocMdDescription = "Pair primitive."-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Integer, Natural)--instance PolyCTypeHasDocC '[a] => TypeHasDoc (Set a) where-  typeDocName _ = "Set"-  typeDocMdReference = poly1TypeDocMdReference-  typeDocMdDescription = "Set primitive."-  typeDocDependencies _ = [dTypeDep @a]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Set Integer)--instance TypeHasDoc Operation where-  typeDocName _ = "Operation"-  typeDocMdReference tp = customTypeDocMdReference ("Operation", DType tp) []-  typeDocMdDescription = "Operation primitive."-  typeDocDependencies _ = []-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep--instance PolyTypeHasDocC '[cp] => TypeHasDoc (ContractRef cp) where-  typeDocName _ = "Contract"-  typeDocMdReference = poly1TypeDocMdReference-  typeDocMdDescription = "Contract primitive with given type of parameter."-  typeDocDependencies _ = [dTypeDep @cp, dTypeDep @Integer]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(ContractRef Integer)--instance PolyTypeHasDocC '[a] => TypeHasDoc (Ticket a) where-  typeDocName _ = "Ticket"-  typeDocMdReference = poly1TypeDocMdReference-  typeDocMdDescription = "Ticket primitive."-  typeDocDependencies _ = [dTypeDep @a, dTypeDep @MText]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Ticket MText)--instance (PolyCTypeHasDocC '[k], PolyTypeHasDocC '[v], Ord k) =>-         TypeHasDoc (Map k v) where-  typeDocName _ = "Map"-  typeDocMdReference = poly2TypeDocMdReference-  typeDocMdDescription = "Map primitive."-  typeDocDependencies _ =-    [dTypeDep @k, dTypeDep @v]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Map Integer Natural)--instance (PolyCTypeHasDocC '[k], PolyTypeHasDocC '[v], Ord k) =>-         TypeHasDoc (BigMap k v) where-  typeDocName _ = "BigMap"-  typeDocMdReference = poly2TypeDocMdReference-  typeDocMdDescription = "BigMap primitive."-  typeDocDependencies _ =-    [dTypeDep @k, dTypeDep @v]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(BigMap Integer Natural)---tupleTypeDocReference :: [Markdown] -> WithinParens -> Markdown-tupleTypeDocReference vs _ = "(" +| mconcat (intersperse ", " $ map build vs) |+ ")"--instance PolyTypeHasDocC [a, b, c] => TypeHasDoc (a, b, c) where-  typeDocName _ = "(a, b, c)"-  typeDocMdReference _ = tupleTypeDocReference-    [ typeDocMdReference (Proxy @a) (WithinParens False)-    , typeDocMdReference (Proxy @b) (WithinParens False)-    , typeDocMdReference (Proxy @c) (WithinParens False)-    ]-  typeDocMdDescription = "Tuple of size 3."-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Integer, Natural, MText)--instance PolyTypeHasDocC [a, b, c, d] => TypeHasDoc (a, b, c, d) where-  typeDocName _ = "(a, b, c, d)"-  typeDocMdReference _ = tupleTypeDocReference-    [ typeDocMdReference (Proxy @a) (WithinParens False)-    , typeDocMdReference (Proxy @b) (WithinParens False)-    , typeDocMdReference (Proxy @c) (WithinParens False)-    , typeDocMdReference (Proxy @d) (WithinParens False)-    ]-  typeDocMdDescription = "Tuple of size 4."-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep =-    -- Starting from tuple of size 4 the exact types should not matter to a reader,-    -- rather the resulting pairs tree.-    concreteTypeDocMichelsonRep @((), (), (), ())--instance PolyTypeHasDocC [a, b, c, d, e] => TypeHasDoc (a, b, c, d, e) where-  typeDocName _ = "(a, b, c, d, e)"-  typeDocMdDescription = "Tuple of size 5."-  typeDocMdReference _ = tupleTypeDocReference-    [ typeDocMdReference (Proxy @a) (WithinParens False)-    , typeDocMdReference (Proxy @b) (WithinParens False)-    , typeDocMdReference (Proxy @c) (WithinParens False)-    , typeDocMdReference (Proxy @d) (WithinParens False)-    , typeDocMdReference (Proxy @e) (WithinParens False)-    ]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep =-    concreteTypeDocMichelsonRep @((), (), (), (), ())--instance PolyTypeHasDocC [a, b, c, d, e, f] => TypeHasDoc (a, b, c, d, e, f) where-  typeDocName _ = "(a, b, c, d, e, f)"-  typeDocMdReference _ = tupleTypeDocReference-    [ typeDocMdReference (Proxy @a) (WithinParens False)-    , typeDocMdReference (Proxy @b) (WithinParens False)-    , typeDocMdReference (Proxy @c) (WithinParens False)-    , typeDocMdReference (Proxy @d) (WithinParens False)-    , typeDocMdReference (Proxy @e) (WithinParens False)-    , typeDocMdReference (Proxy @f) (WithinParens False)-    ]-  typeDocMdDescription = "Tuple of size 6."-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep =-    concreteTypeDocMichelsonRep @((), (), (), (), (), ())--instance PolyTypeHasDocC [a, b, c, d, e, f, g] => TypeHasDoc (a, b, c, d, e, f, g) where-  typeDocName _ = "(a, b, c, d, e, f, g)"-  typeDocMdReference _ = tupleTypeDocReference-    [ typeDocMdReference (Proxy @a) (WithinParens False)-    , typeDocMdReference (Proxy @b) (WithinParens False)-    , typeDocMdReference (Proxy @c) (WithinParens False)-    , typeDocMdReference (Proxy @d) (WithinParens False)-    , typeDocMdReference (Proxy @e) (WithinParens False)-    , typeDocMdReference (Proxy @f) (WithinParens False)-    , typeDocMdReference (Proxy @g) (WithinParens False)-    ]-  typeDocMdDescription = "Tuple of size 7."-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep =-    concreteTypeDocMichelsonRep @((), (), (), (), (), (), ())---instance ( TypeHasDoc (ApplyNamedFunctor f a)-         , KnownSymbol n-         , KnownIsoT (ApplyNamedFunctor f Integer)-         , Typeable f, Typeable a-         ) =>-         TypeHasDoc (NamedF f a n) where-  typeDocName _ = "Named entry"-  typeDocMdReference _ wp =-    applyWithinParens wp $-    buildFieldName (toText (symbolVal $ Proxy @n)) +| " " +|-    typeDocMdReference (Proxy @(ApplyNamedFunctor f a)) (WithinParens False) |+ ""-  typeDocDependencies _ =-    [ dTypeDep @(ApplyNamedFunctor f a)-    , dTypeDep @Integer-    ]-  typeDocHaskellRep _ _ = Nothing-  typeDocMichelsonRep _ = (Just "number: Integer", demote @(ToT (ApplyNamedFunctor f Integer)))-  typeDocMdDescription =-    "Some entries have names for clarity.\n\n\-    \In resulting Michelson names may be mapped to annotations."

− src/Michelson/Typed/Haskell/Instr.hs

@@ -1,10 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Typed.Haskell.Instr-  ( module Exports-  ) where--import Michelson.Typed.Haskell.Instr.Product as Exports-import Michelson.Typed.Haskell.Instr.Sum as Exports

− src/Michelson/Typed/Haskell/Instr/Helpers.hs

@@ -1,22 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Typed.Haskell.Instr.Helpers-  ( Branch (..)-  , Path-  ) where---- | Which branch to choose in generic tree representation: left,--- straight or right. 'S' is used when there is one constructor with--- one field (something newtype-like).------ The reason why we need 'S' can be explained by this example:--- data A = A1 B | A2 Integer--- data B = B Bool--- Now we may search for A1 constructor or B constructor. Without 'S' in--- both cases path will be the same ([L]).-data Branch = L | S | R---- | Path to a leaf (some field or constructor) in generic tree representation.-type Path = [Branch]

− src/Michelson/Typed/Haskell/Instr/Product.hs

@@ -1,424 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE InstanceSigs #-}---- | Instructions working on product types derived from Haskell ones.-module Michelson.Typed.Haskell.Instr.Product-  ( InstrGetFieldC-  , InstrSetFieldC-  , InstrConstructC-  , instrToField-  , instrSetField-  , instrConstruct-  , instrConstructStack-  , instrDeconstruct-  , InstrDeconstructC--  , GetFieldType-  , ConstructorFieldTypes-  , ConstructorFieldNames-  , FieldConstructor (..)-  , CastFieldConstructors (..)-  ) where--import Data.Vinyl.Core (Rec(..))-import GHC.Generics ((:*:)(..), (:+:)(..))-import qualified GHC.Generics as G-import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)-import Named (NamedF(..), (:!), (:?))--import Michelson.Text-import Michelson.Typed.Haskell.Instr.Helpers-import Michelson.Typed.Haskell.Value-import Michelson.Typed.Instr-import Util.Label (Label)-import Util.Named (NamedInner)-import Util.Type---- Fields lookup (helper)--------------------------------------------------------------------------------- | Result of field lookup - its type and path to it in--- the tree.-data LookupNamedResult = LNR Type Path--type family LnrFieldType (lnr :: LookupNamedResult) where-  LnrFieldType ('LNR f _) = f-type family LnrBranch (lnr :: LookupNamedResult) :: Path where-  LnrBranch ('LNR _ p) = p---- | Find field of some product type by its name.------ Name might be either field record name, or one in 'NamedF' if--- field is wrapped using '(:!)' or '(:?)'.-type GetNamed name a = LNRequireFound name a (GLookupNamed name (G.Rep a))---- | Force result of 'GLookupNamed' to be 'Just'-type family LNRequireFound-  (name :: Symbol)-  (a :: Type)-  (mf :: Maybe LookupNamedResult)-    :: LookupNamedResult where-  LNRequireFound _ _ ('Just lnr) = lnr-  LNRequireFound name a 'Nothing = TypeError-    ('Text "Datatype " ':<>: 'ShowType a ':<>:-     'Text " has no field " ':<>: 'ShowType name)--type family GLookupNamed (name :: Symbol) (x :: Type -> Type)-          :: Maybe LookupNamedResult where-  GLookupNamed name (G.D1 _ x) = GLookupNamed name x-  GLookupNamed name (G.C1 _ x) = GLookupNamed name x--  GLookupNamed name (G.S1 ('G.MetaSel ('Just recName) _ _ _) (G.Rec0 a)) =-    If (name == recName)-      ('Just $ 'LNR a '[])-      'Nothing-  GLookupNamed name (G.S1 _ (G.Rec0 (NamedF f a fieldName))) =-    If (name == fieldName)-      ('Just $ 'LNR (NamedInner (NamedF f a fieldName)) '[])-      'Nothing-  GLookupNamed _ (G.S1 _ _) = 'Nothing--  GLookupNamed name (x :*: y) =-    LNMergeFound name (GLookupNamed name x) (GLookupNamed name y)-  GLookupNamed name (_ :+: _) = TypeError-    ('Text "Cannot seek for a field " ':<>: 'ShowType name ':<>:-     'Text " in sum type")-  GLookupNamed _ G.U1 = 'Nothing-  GLookupNamed _ G.V1 = TypeError-    ('Text "Cannot access fields of void-like type")--type family LNMergeFound-  (name :: Symbol)-  (f1 :: Maybe LookupNamedResult)-  (f2 :: Maybe LookupNamedResult)-    :: Maybe LookupNamedResult where-  LNMergeFound _ 'Nothing 'Nothing = 'Nothing-  LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p)-  LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p)-  LNMergeFound name ('Just _) ('Just _) = TypeError-    ('Text "Ambigous reference to datatype field: " ':<>: 'ShowType name)---- | Get type of field by datatype it is contained in and field name.-type GetFieldType dt name = LnrFieldType (GetNamed name dt)--------------------------------------------------------------------------------- Value accessing instruction--------------------------------------------------------------------------------- | Make an instruction which accesses given field of the given datatype.-instrToField-  :: forall dt name st.-     InstrGetFieldC dt name-  => Label name -> Instr (ToT dt ': st) (ToT (GetFieldType dt name) ': st)-instrToField _ =-  gInstrToField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))-    @(GetFieldType dt name)---- | Constraint for 'instrGetField'.-type InstrGetFieldC dt name =-  ( GenericIsoValue dt-  , GInstrGet name (G.Rep dt)-      (LnrBranch (GetNamed name dt))-      (LnrFieldType (GetNamed name dt))-  )--{- Note about bulkiness of `instrToField` type signature:--Read this only if you are going to modify the signature qualitatively.--It may seem that you can replace 'LnrBranch' and 'LnrFieldType' getters since-their result is already assigned to a type variable, but if you do so,-on attempt to access non-existing field GHC will prompt you a couple of huge-"cannot deduce type" errors along with desired "field is not present".-To make error messages clearer we prevent GHC from deducing 'GInstrAccess' when-no field is found via using those getters.--}---- | Generic traversal for 'instrAccess'.-class GIsoValue x =>-  GInstrGet-    (name :: Symbol)-    (x :: Type -> Type)-    (path :: Path)-    (fieldTy :: Type) where-  gInstrToField-    :: GIsoValue x-    => Instr (GValueType x ': s) (ToT fieldTy ': s)--instance GInstrGet name x path f => GInstrGet name (G.M1 t i x) path f where-  gInstrToField = gInstrToField @name @x @path @f--instance (IsoValue f, ToT f ~ ToT f') =>-         GInstrGet name (G.Rec0 f) '[] f' where-  gInstrToField = Nop--instance (GInstrGet name x path f, GIsoValue y) => GInstrGet name (x :*: y) ('L ': path) f where-  gInstrToField = CAR `Seq` gInstrToField @name @x @path @f--instance (GInstrGet name y path f, GIsoValue x) => GInstrGet name (x :*: y) ('R ': path) f where-  gInstrToField = CDR `Seq` gInstrToField @name @y @path @f---- Examples-------------------------------------------------------------------------------type MyType1 = ("int" :! Integer, "bytes" :! ByteString, "bytes2" :? ByteString)--_getIntInstr1 :: Instr (ToT MyType1 ': s) (ToT Integer ': s)-_getIntInstr1 = instrToField @MyType1 #int--_getTextInstr1 :: Instr (ToT MyType1 ': s) (ToT (Maybe ByteString) ': s)-_getTextInstr1 = instrToField @MyType1 #bytes2--data MyType2 = MyType2-  { getInt :: Integer-  , getText :: MText-  , getUnit :: ()-  , getMyType1 :: MyType1-  } deriving stock (Generic)-    deriving anyclass (IsoValue)--_getIntInstr2 :: Instr (ToT MyType2 ': s) (ToT () ': s)-_getIntInstr2 = instrToField @MyType2 #getUnit--_getIntInstr2' :: Instr (ToT MyType2 ': s) (ToT Integer ': s)-_getIntInstr2' =-  instrToField @MyType2 #getMyType1 `Seq` instrToField @MyType1 #int--------------------------------------------------------------------------------- Value modification instruction--------------------------------------------------------------------------------- | For given complex type @dt@ and its field @fieldTy@ update the field value.-instrSetField-  :: forall dt name st.-     InstrSetFieldC dt name-  => Label name -> Instr (ToT (GetFieldType dt name) ': ToT dt ': st) (ToT dt ': st)-instrSetField _ =-  gInstrSetField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))-    @(GetFieldType dt name)---- | Constraint for 'instrSetField'.-type InstrSetFieldC dt name =-  ( GenericIsoValue dt-  , GInstrSetField name (G.Rep dt)-      (LnrBranch (GetNamed name dt))-      (LnrFieldType (GetNamed name dt))-  )---- | Generic traversal for 'instrSetField'.-class GIsoValue x =>-  GInstrSetField-    (name :: Symbol)-    (x :: Type -> Type)-    (path :: Path)-    (fieldTy :: Type) where-  gInstrSetField-    :: Instr (ToT fieldTy ': GValueType x ': s) (GValueType x ': s)--instance GInstrSetField name x path f => GInstrSetField name (G.M1 t i x) path f where-  gInstrSetField = gInstrSetField @name @x @path @f--instance (IsoValue f, ToT f ~ ToT f') =>-         GInstrSetField name (G.Rec0 f) '[] f' where-  gInstrSetField = DIP DROP--instance (GInstrSetField name x path f, GIsoValue y) => GInstrSetField name (x :*: y) ('L ': path) f where-  gInstrSetField =-    DIP UNPAIR `Seq`-    gInstrSetField @name @x @path @f `Seq`-    PAIR--instance (GInstrSetField name y path f, GIsoValue x) => GInstrSetField name (x :*: y) ('R ': path) f where-  gInstrSetField =-    DIP (UNPAIR `Seq` SWAP) `Seq`-    gInstrSetField @name @y @path @f `Seq`-    SWAP `Seq` PAIR---- Examples-------------------------------------------------------------------------------_setIntInstr1 :: Instr (ToT Integer ': ToT MyType2 ': s) (ToT MyType2 ': s)-_setIntInstr1 = instrSetField @MyType2 #getInt--------------------------------------------------------------------------------- Value construction instruction--------------------------------------------------------------------------------- | Way to construct one of the fields in a complex datatype.-newtype FieldConstructor (st :: [k]) (field :: Type) =-  FieldConstructor (Instr (ToTs' st) (ToT field ': ToTs' st))---- | Ability to pass list of fields with the same ToTs.--- It may be useful if you don't want to work with NamedF in ConstructorFieldTypes.-class ToTs xs ~ ToTs ys => CastFieldConstructors xs ys where-  castFieldConstructorsImpl :: Rec (FieldConstructor st) xs -> Rec (FieldConstructor st) ys--instance CastFieldConstructors '[] '[] where-  castFieldConstructorsImpl RNil = RNil--instance (CastFieldConstructors xs ys, ToTs xs ~ ToTs ys, ToT x ~ ToT y)-    => CastFieldConstructors (x ': xs) (y ': ys) where-  castFieldConstructorsImpl (FieldConstructor fctr :& xs) =-    FieldConstructor fctr :& (castFieldConstructorsImpl @xs @ys xs)---- | For given complex type @dt@ and its field @fieldTy@ update the field value.-instrConstruct-  :: forall dt st. InstrConstructC dt-  => Rec (FieldConstructor st) (ConstructorFieldTypes dt)-  -> Instr st (ToT dt ': st)-instrConstruct = gInstrConstruct @(G.Rep dt)--instrConstructStack-  :: forall dt stack st .-  ( InstrConstructC dt-  , stack ~ ToTs (ConstructorFieldTypes dt)-  , KnownList stack-  )-  => Instr (stack ++ st) (ToT dt ': st)-instrConstructStack =-  FrameInstr (Proxy @st) (gInstrConstructStack @(G.Rep dt))---- | Types of all fields in a datatype.-type ConstructorFieldTypes dt = GFieldTypes (G.Rep dt)---- | Names of all fields in a datatype.-type ConstructorFieldNames dt = GFieldNames (G.Rep dt)---- | Constraint for 'instrConstruct' and 'gInstrConstructStack'.-type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (G.Rep dt))---- | Retrieve field names of a constructor.-type family GFieldNames x :: [Symbol] where-  GFieldNames (G.D1 _ x) = GFieldNames x-  GFieldNames (G.C1 _ x) = GFieldNames x-  GFieldNames (x :*: y) = GFieldNames x ++ GFieldNames y-  GFieldNames (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) _) = '[fieldName]-  GFieldNames (G.S1 _ (G.Rec0 (NamedF _ _ fieldName))) = '[fieldName]--  GFieldNames (G.S1 ('G.MetaSel _ _ _ _) _) = TypeError ('Text "All fields have to be named")-  GFieldNames (_ :+: _) = TypeError ('Text "Cannot get field names of sum type")-  GFieldNames G.V1 = TypeError ('Text "Must be at least one constructor")---- | Generic traversal for 'instrConstruct'.-class GIsoValue x => GInstrConstruct (x :: Type -> Type) where-  type GFieldTypes x :: [Type]-  gInstrConstruct :: Rec (FieldConstructor st) (GFieldTypes x) -> Instr st (GValueType x ': st)-  gInstrConstructStack :: Instr (ToTs (GFieldTypes x)) '[GValueType x]--instance GInstrConstruct x => GInstrConstruct (G.M1 t i x) where-  type GFieldTypes (G.M1 t i x) = GFieldTypes x-  gInstrConstruct = gInstrConstruct @x-  gInstrConstructStack = gInstrConstructStack @x--instance ( GInstrConstruct x, GInstrConstruct y-         , RSplit (GFieldTypes x) (GFieldTypes y)-         , KnownList (ToTs (GFieldTypes x)), KnownList (ToTs (GFieldTypes y))-         , ToTs (GFieldTypes x) ++ ToTs (GFieldTypes y) ~ ToTs (GFieldTypes x ++ GFieldTypes y)-         ) => GInstrConstruct (x :*: y) where-  type GFieldTypes (x :*: y) = GFieldTypes x ++ GFieldTypes y-  gInstrConstruct fs =-    let (lfs, rfs) = rsplit fs-        linstr = gInstrConstruct @x lfs-        rinstr = gInstrConstruct @y rfs-    in linstr `Seq` DIP rinstr `Seq` PAIR--  gInstrConstructStack =-    let linstr = gInstrConstructStack @x-        rinstr = gInstrConstructStack @y-    in FrameInstr (Proxy @(ToTs (GFieldTypes y))) linstr `Seq` DIP rinstr `Seq` PAIR--instance GInstrConstruct G.U1 where-  type GFieldTypes G.U1 = '[]-  gInstrConstruct RNil = UNIT-  gInstrConstructStack = UNIT--instance ( TypeError ('Text "Cannot construct sum type")-         , GIsoValue x, GIsoValue y-         ) => GInstrConstruct (x :+: y) where-  type GFieldTypes (x :+: y) = '[]-  gInstrConstruct = error "impossible"-  gInstrConstructStack = error "impossible"--instance ( TypeError ('Text "Cannot construct void-like type")-         ) => GInstrConstruct G.V1 where-  type GFieldTypes G.V1 = '[]-  gInstrConstruct = error "impossible"-  gInstrConstructStack = error "impossible"--instance IsoValue a => GInstrConstruct (G.Rec0 a) where-  type GFieldTypes (G.Rec0 a) = '[a]-  gInstrConstruct (FieldConstructor i :& RNil) = i-  gInstrConstructStack = Nop---- Examples-------------------------------------------------------------------------------_constructInstr1 :: Instr (ToT MyType1 ': s) (ToT MyType2 ': ToT MyType1 ': s)-_constructInstr1 =-  instrConstruct @MyType2 $-    FieldConstructor (PUSH (toVal @Integer 5)) :&-    FieldConstructor (PUSH (toVal @MText [mt||])) :&-    FieldConstructor UNIT :&-    FieldConstructor DUP :&-    RNil--_constructInstr2 :: Instr s (ToT MyType1 ': s)-_constructInstr2 =-  instrConstruct @MyType1 $-    FieldConstructor (PUSH (toVal @Integer 5)) :&-    FieldConstructor (PUSH (toVal @ByteString "bytestring1")) :&-    FieldConstructor (PUSH (toVal @(Maybe ByteString) (Just "bytestring2"))) :&-    RNil--------------------------------------------------------------------------------- Value deconstruction--------------------------------------------------------------------------------- | Constraint for 'instrConstruct'.-type InstrDeconstructC dt = (GenericIsoValue dt, GInstrDeconstruct (G.Rep dt))---- | For given complex type @dt@ deconstruct it to its field types.-instrDeconstruct-  :: forall dt stack st .-  (InstrDeconstructC dt-  , stack ~ ToTs (ConstructorFieldTypes dt)-  , KnownList stack-  )-  => Instr (ToT dt ': st) (stack ++ st)-instrDeconstruct = FrameInstr (Proxy @st) $ gInstrDeconstruct @(G.Rep dt)---- | Generic traversal for 'instrDeconstruct'.-class GIsoValue x => GInstrDeconstruct (x :: Type -> Type) where-  gInstrDeconstruct :: Instr '[GValueType x] (ToTs (GFieldTypes x))--instance GInstrDeconstruct x => GInstrDeconstruct (G.M1 t i x) where-  gInstrDeconstruct = gInstrDeconstruct @x--instance ( GInstrDeconstruct x, GInstrDeconstruct y-         , t ~ (x :*: y)-         , KnownList (ToTs (GFieldTypes x)), KnownList (ToTs (GFieldTypes y))-         , ToTs (GFieldTypes x) ++ ToTs (GFieldTypes y) ~ ToTs (GFieldTypes x ++ GFieldTypes y)-         ) => GInstrDeconstruct (x :*: y) where-  gInstrDeconstruct =-    let linstr = gInstrDeconstruct @x-        rinstr = gInstrDeconstruct @y-    in UNPAIR `Seq` DIP rinstr `Seq` FrameInstr (Proxy @(ToTs (GFieldTypes y))) linstr--instance GInstrDeconstruct G.U1 where-  gInstrDeconstruct = DROP--instance ( TypeError ('Text "Cannot deconstruct sum type")-         , GIsoValue x, GIsoValue y-         ) => GInstrDeconstruct (x :+: y) where-  gInstrDeconstruct = error "impossible"--instance ( TypeError ('Text "Cannot deconstruct void-like type")-         ) => GInstrDeconstruct G.V1 where-  gInstrDeconstruct = error "impossible"--instance IsoValue a => GInstrDeconstruct (G.Rec0 a) where-  gInstrDeconstruct = Nop

− src/Michelson/Typed/Haskell/Instr/Sum.hs

@@ -1,719 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Instructions working on sum types derived from Haskell ones.-module Michelson.Typed.Haskell.Instr.Sum-  ( InstrWrapC-  , InstrWrapOneC-  , InstrCaseC-  , InstrUnwrapC-  , instrWrap-  , instrWrapOne-  , hsWrap-  , instrCase-  , (//->)-  , unsafeInstrUnwrap-  , hsUnwrap--  , CaseClauseParam (..)-  , CaseClause (..)-  , CaseClauses-  , GCaseClauses-  , GCaseBranchInput--  , Branch (..)-  , Path-  , CtorField (..)-  , ExtractCtorField-  , AppendCtorField-  , AppendCtorFieldAxiom-  , appendCtorFieldAxiom-  , GetCtorField-  , CtorHasOnlyField-  , CtorOnlyField-  , MyCompoundType--    -- * Helpers-  , IsPrimitiveValue-  ) where--import Data.Singletons (SingI(..))-import Data.Type.Bool (type (||))-import Data.Vinyl.Core (Rec(..))-import GHC.Generics ((:*:)(..), (:+:)(..))-import qualified GHC.Generics as G-import GHC.TypeLits (AppendSymbol, ErrorMessage(..), Symbol, TypeError)-import Named (NamedF, (:!))-import Type.Reflection ((:~:)(Refl))-import Unsafe.Coerce (unsafeCoerce)--import Michelson.Text (MText, mt)-import Michelson.Typed.Entrypoints-import Michelson.Typed.Haskell.Instr.Helpers-import Michelson.Typed.Haskell.Value-import Michelson.Typed.Instr-import Michelson.Typed.T-import Michelson.Typed.Value-import Tezos.Address (Address)-import Tezos.Core (ChainId, Mutez, Timestamp)-import Tezos.Crypto (KeyHash, PublicKey, Signature)-import Util.Label (Label)-import Util.Type-import Util.TypeTuple---- Constructors lookup (helper)--------------------------------------------------------------------------------- | We support only two scenarious - constructor with one field and--- without fields. Nonetheless, it's not that sad since for sum types--- we can't even assign names to fields if there are many (the style--- guide prohibits partial records).-data CtorField-  = OneField Type-  | NoFields---- | Get /something/ as field of the given constructor.-type family ExtractCtorField (cf :: CtorField) where-  ExtractCtorField ('OneField t) = t-  ExtractCtorField 'NoFields = ()---- | Push field to stack, if any.-type family AppendCtorField (cf :: CtorField) (l :: [k]) :: [k] where-  AppendCtorField ('OneField t) (l :: [T]) = ToT t ': l-  AppendCtorField ('OneField t) (l :: [Type]) = t ': l-  AppendCtorField 'NoFields (l :: [T]) = l-  AppendCtorField 'NoFields (l :: [Type]) = l---- | To use 'AppendCtorField' not only here for 'T'-based stacks, but also--- later in Lorentz with 'Type'-based stacks we need the following property.-type AppendCtorFieldAxiom (cf :: CtorField) (st :: [Type]) =-  ToTs (AppendCtorField cf st) ~ AppendCtorField cf (ToTs st)---- | Proof of 'AppendCtorFieldAxiom'.-appendCtorFieldAxiom-  :: ( AppendCtorFieldAxiom ('OneField Word) '[Int]-     , AppendCtorFieldAxiom 'NoFields '[Int]-     )-  => Dict (AppendCtorFieldAxiom cf st)-appendCtorFieldAxiom =-  -- In order to avoid a lot of boilerplate and burdening GHC type checker we-  -- write an unsafe code. Its correctness is tested in dummy constraints of-  -- this function.-  -- Alternative approach I compare this unsafe one with-  -- would be to implement @instance SingI@ for 'CtorField' and consider cases-  -- of 'CtorField' one by one, but this would require propagading-  -- @SingI (cf :: CtorField)@ constraint to all users of 'appendCtorFieldAxiom'.-  unsafeCoerce $ Dict @(AppendCtorFieldAxiom 'NoFields '[])---- | Result of constructor lookup - entry type and path to it in the tree.-data LookupNamedResult = LNR CtorField Path--type family LnrFieldType (lnr :: LookupNamedResult) where-  LnrFieldType ('LNR f _) = f-type family LnrBranch (lnr :: LookupNamedResult) :: Path where-  LnrBranch ('LNR _ p) = p---- | Transitively find constructor of some sum type by its name.------ Transitivity means that if sum type consists of other sum types,--- they will be searched recursively.-type GetNamed name a = LNRequireFound name a (GLookupNamed name (G.Rep a))---- | Force result of 'GLookupNamed' to be 'Just'-type family LNRequireFound-  (name :: Symbol)-  (a :: Type)-  (mf :: Maybe LookupNamedResult)-    :: LookupNamedResult where-  LNRequireFound _ _ ('Just lnr) = lnr-  LNRequireFound name a 'Nothing = TypeError-    ('Text "Datatype " ':<>: 'ShowType a ':<>:-     'Text " has no (sub)constructor " ':<>: 'ShowType name)--type family GLookupNamed (name :: Symbol) (x :: Type -> Type)-          :: Maybe LookupNamedResult where-  GLookupNamed name (G.D1 _ x) = GLookupNamed name x-  GLookupNamed name (G.C1 ('G.MetaCons ctorName _ _) x) =-    -- This case corresponds to going straight into a data type (as-    -- opposed to going left or right when we encounter a sum type),-    -- so we need to prepend 'S' here if we successfully find a-    -- constructor.-    PrependS-    -- If we encounter a constructor with requested name, we consider-    -- search successful.-    (If (name == ctorName || name == ("c" `AppendSymbol` ctorName))-       ('Just $ 'LNR (GExtractFields x) '[])-        -- If we do not, we check whether we can go deeper (see-        -- description below).-        (If (GCanGoDeeper x)-        -- And here we essentially just recursively call this search.-        (GLookupNamedDeeper name x)-        -- Or return 'Nothing' if we can not go deeper.-         'Nothing-      )-    )-  GLookupNamed name (x :+: y) =-    LNMergeFound name (GLookupNamed name x) (GLookupNamed name y)-  GLookupNamed _ G.V1 = 'Nothing---- Prepend 'S' to the path inside 'LookupNamedResult' (if 'Just' is passed).--- Should be done in the case when we go straight into a data type.-type family PrependS (x :: Maybe LookupNamedResult) :: Maybe LookupNamedResult where-  PrependS 'Nothing = 'Nothing-  PrependS ('Just ('LNR cf path)) = 'Just ('LNR cf ('S ': path))---- Helper type family to check whether we should search for a--- constructor inside given data type which is supposed to be part of--- another constructor. Basically we can go deeper only if we--- encounter another ADT with a constructor storing at least something--- and which is not a primitive type. We do not go deeper when we--- encounter a product type here, because it means that there are multiple--- fields inside one constructor (it is not supported).-type family GCanGoDeeper (x :: Type -> Type) :: Bool where-  GCanGoDeeper (_ :+: _) = 'True-  GCanGoDeeper (G.D1 _ x) = GCanGoDeeper x-  GCanGoDeeper (G.S1 _ (G.Rec0 x)) = CanGoDeeper x-  GCanGoDeeper (G.C1 _ _) = 'True-  GCanGoDeeper G.V1 = 'False-  GCanGoDeeper G.U1 = 'False-  GCanGoDeeper (_ :*: _) = 'False-  GCanGoDeeper x = TypeError-    ('Text "GCanGoDeeper encountered unexpected pattern: " ':<>: 'ShowType x)---- | Whether given type represents an atomic Michelson value.-type family IsPrimitiveValue (x :: Type) :: Bool where-  IsPrimitiveValue (Maybe _) = 'True-  IsPrimitiveValue (NamedF _ _ _) = 'True-  IsPrimitiveValue Integer = 'True-  IsPrimitiveValue Natural = 'True-  IsPrimitiveValue Text = 'True-  IsPrimitiveValue MText = 'True-  IsPrimitiveValue Bool = 'True-  IsPrimitiveValue ByteString = 'True-  IsPrimitiveValue Mutez = 'True-  IsPrimitiveValue Address = 'True-  IsPrimitiveValue EpAddress = 'True-  IsPrimitiveValue KeyHash = 'True-  IsPrimitiveValue Timestamp = 'True-  IsPrimitiveValue PublicKey = 'True-  IsPrimitiveValue Signature = 'True-  IsPrimitiveValue (ContractRef _) = 'True-  IsPrimitiveValue (BigMap _ _) = 'True-  IsPrimitiveValue (Map _ _) = 'True-  IsPrimitiveValue (Set _) = 'True-  IsPrimitiveValue ([_]) = 'True-  IsPrimitiveValue (Operation' _) = 'True-  IsPrimitiveValue ChainId = 'True-  IsPrimitiveValue _ = 'False---- Some types don't have Generic instances (e. g. primitives like Integer), so--- we need another type family to handle them.-type CanGoDeeper (x :: Type) =-  If (IsPrimitiveValue x)-     'False-     (GCanGoDeeper (G.Rep x))--type family GLookupNamedDeeper (name :: Symbol) (x :: Type -> Type)-          :: Maybe LookupNamedResult where-  GLookupNamedDeeper name (G.S1 _ (G.Rec0 y))  = GLookupNamed name (G.Rep y)-  GLookupNamedDeeper name _ = TypeError-    ('Text "Attempt to go deeper failed while looking for sum type constructor"-     ':<>: 'ShowType name-     ':$$:-     'Text "Make sure that all constructors have exactly one field inside."-    )--type family LNMergeFound-  (name :: Symbol)-  (f1 :: Maybe LookupNamedResult)-  (f2 :: Maybe LookupNamedResult)-    :: Maybe LookupNamedResult where-  LNMergeFound _ 'Nothing 'Nothing = 'Nothing-  LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p)-  LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p)-  LNMergeFound name ('Just _) ('Just _) = TypeError-    ('Text "Ambiguous reference to datatype constructor: " ':<>: 'ShowType name)--type family GExtractFields (x :: Type -> Type)-          :: CtorField where-  GExtractFields (G.S1 _ x) = GExtractFields x-  GExtractFields (G.Rec0 a) = 'OneField a-  GExtractFields G.U1 = 'NoFields-  GExtractFields (_ :*: _) = TypeError-    ('Text "Cannot automatically lookup constructors having multiple fields"-     ':$$:-     'Text "Consider using tuple instead")-    --- ^ @martoon: Probably we will have no use cases for such scenario-    --- anyway, tuples seem to be not worse than separate fields in most cases.---- | Get type of constructor fields (one or zero) referred by given datatype--- and name.-type GetCtorField dt ctor =-  LnrFieldType (GetNamed ctor dt)---- | Expect referred constructor to have only one field (in form of constraint)--- and extract its type.-type CtorHasOnlyField ctor dt f =-  GetCtorField dt ctor ~ 'OneField f--type family RequireOneField (ctor :: Symbol) (cf :: CtorField) :: Type where-  RequireOneField _ ('OneField f) = f-  RequireOneField ctor 'NoFields = TypeError-    ('Text "Expected exactly one field" ':$$:-     'Text "In constructor " ':<>: 'ShowType ctor)---- | Expect referred constructor to have only one field--- (otherwise compile error is raised) and extract its type.-type CtorOnlyField name dt =-  RequireOneField name (GetCtorField dt name)--------------------------------------------------------------------------------- Constructor wrapping instruction--------------------------------------------------------------------------------- | Wrap given element into a constructor with the given name.------ Mentioned constructor must have only one field.------ Since labels interpretable by "OverloadedLabels" extension cannot--- start with capital latter, prepend constructor name with letter--- "c" (see examples below).-instrWrap-  :: forall dt name st.-     InstrWrapC dt name-  => Label name-  -> Instr (AppendCtorField (GetCtorField dt name) st)-           (ToT dt ': st)-instrWrap _ =-  gInstrWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))-                         @(LnrFieldType (GetNamed name dt))---- | Like 'instrWrap' but only works for contructors with a single field.--- Results in a type error if a constructor with no field is used instead.-instrWrapOne-  :: forall dt name st.-     InstrWrapOneC dt name-  => Label name-  -> Instr (ToT (CtorOnlyField name dt) ': st) (ToT dt ': st)-instrWrapOne _ =-  gInstrWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))-                         @(LnrFieldType (GetNamed name dt))--type InstrWrapC dt name =-  ( GenericIsoValue dt-  , GInstrWrap (G.Rep dt)-      (LnrBranch (GetNamed name dt))-      (LnrFieldType (GetNamed name dt))-  )--type InstrWrapOneC dt name =-  ( InstrWrapC dt name-  , GetCtorField dt name ~ 'OneField (CtorOnlyField name dt)-  )---- | Wrap a haskell value into a constructor with the given name.------ This is symmetric to 'instrWrap'.-hsWrap-  :: forall dt name.-     InstrWrapC dt name-  => Label name-  -> ExtractCtorField (GetCtorField dt name)-  -> dt-hsWrap _ =-  G.to . gHsWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))-                             @(LnrFieldType (GetNamed name dt))---- | Generic traversal for 'instrWrap'.-class GIsoValue x =>-  GInstrWrap-    (x :: Type -> Type)-    (path :: Path)-    (entryTy :: CtorField) where-  gInstrWrap-    :: GIsoValue x-    => Instr (AppendCtorField entryTy s) (GValueType x ': s)-  gHsWrap-    :: GIsoValue x-    => ExtractCtorField entryTy -> x p--instance GInstrWrap x path e => GInstrWrap (G.D1 i x) path e where-  gInstrWrap = gInstrWrap @x @path @e-  gHsWrap = G.M1 . gHsWrap @x @path @e--instance (GInstrWrap x path e, GIsoValue y, SingI (GValueType y)) =>-         GInstrWrap (x :+: y) ('L ': path) e where-  gInstrWrap = gInstrWrap @x @path @e `Seq` LEFT-  gHsWrap = G.L1 . gHsWrap @x @path @e--instance (GInstrWrap y path e, GIsoValue x, SingI (GValueType x)) =>-         GInstrWrap (x :+: y) ('R ': path) e where-  gInstrWrap = gInstrWrap @y @path @e `Seq` RIGHT-  gHsWrap = G.R1 . gHsWrap @y @path @e--instance (IsoValue e) =>-         GInstrWrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] ('OneField e) where-  gInstrWrap = Nop-  gHsWrap = G.M1 . G.M1 . G.K1---- This is the case when a sum type is part of another sum type.--- Here 'sub' is intermediate sum type.-instance ( path ~ (x ': xs)-         , GInstrWrap (G.Rep sub) path e-         , GenericIsoValue sub-         , GIsoValue (G.Rep sub)-         ) =>-         GInstrWrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where-  gInstrWrap = gInstrWrap @(G.Rep sub) @path @e-  gHsWrap = G.M1 . G.M1 . G.K1 . G.to . gHsWrap @(G.Rep sub) @path @e--instance GInstrWrap (G.C1 c G.U1) '[ 'S] 'NoFields where-  gInstrWrap = PUSH VUnit-  gHsWrap () = G.M1 G.U1---- Examples--------------------------------------------------------------------------------- TODO [TM-186] Consider moving this stuff to test-suite using--- doctest. Or at least add tests for correctness.--data MyType-  = MyCtor Integer-  | ComplexThing ()-  | UselessThing ("field1" :! ByteString, "field2" :! ())-  deriving stock Generic-  deriving anyclass IsoValue--_MyTypeMyCtor ::-  GetNamed "cMyCtor" MyType :~: 'LNR ('OneField Integer) '[ 'L, 'S]-_MyTypeMyCtor = Refl--_MyTypeComplexThing ::-  GetNamed "cComplexThing" MyType :~: 'LNR ('OneField ()) '[ 'R, 'L, 'S]-_MyTypeComplexThing = Refl--_wrapMyType1 :: Instr (ToT Integer ': s) (ToT MyType ': s)-_wrapMyType1 = instrWrap @MyType #cMyCtor---- If "c" prefix is too annoying, one can construct labels without--- OverloadedLabels extension.-_wrapMyType1' :: Instr (ToT Integer ': s) (ToT MyType ': s)-_wrapMyType1' = instrWrap @MyType @"MyCtor" fromLabel--_wrapMyType2 :: Instr (ToT () ': s) (ToT MyType ': s)-_wrapMyType2 = instrWrap @MyType #cComplexThing--_wrapMyType3 :: Instr (ToT (ByteString, ()) ': s) (ToT MyType ': s)-_wrapMyType3 = instrWrap @MyType #cUselessThing--data MyType' = WrapBool Bool-  deriving stock Generic-  deriving anyclass IsoValue--_MyType'WrapBool ::-  GetNamed "cWrapBool" MyType' :~: 'LNR ('OneField Bool) '[ 'S]-_MyType'WrapBool = Refl--_wrapMyType' :: Instr (ToT Bool ': s) (ToT MyType' ': s)-_wrapMyType' = instrWrap @MyType' #cWrapBool--data MyCompoundType-  = CompoundPart1 MyType-  | CompoundPart2 Integer-  | CompoundPart3 Address-  | CompoundPart4 MyType'-  deriving stock Generic-  deriving anyclass IsoValue--_MyCompoundTypeCompoundPart1 ::-  GetNamed "cCompoundPart1" MyCompoundType :~: 'LNR ('OneField MyType) '[ 'L, 'L, 'S]-_MyCompoundTypeCompoundPart1 = Refl--_MyCompoundTypeMyCtor ::-  GetNamed "cMyCtor" MyCompoundType :~: 'LNR ('OneField Integer) '[ 'L, 'L, 'S, 'L, 'S]-_MyCompoundTypeMyCtor = Refl--_MyCompoundTypeCompoundPart2 ::-  GetNamed "cCompoundPart2" MyCompoundType :~: 'LNR ('OneField Integer) '[ 'L, 'R, 'S]-_MyCompoundTypeCompoundPart2 = Refl--_MyCompoundTypeCompoundPart4 ::-  GetNamed "cCompoundPart4" MyCompoundType :~: 'LNR ('OneField MyType') '[ 'R, 'R, 'S]-_MyCompoundTypeCompoundPart4 = Refl--_MyCompoundTypeWrapBool ::-  GetNamed "cWrapBool" MyCompoundType :~: 'LNR ('OneField Bool) '[ 'R, 'R, 'S, 'S]-_MyCompoundTypeWrapBool = Refl--_wrapMyCompoundType1 :: Instr (ToT Integer ': s) (ToT MyCompoundType ': s)-_wrapMyCompoundType1 = instrWrap @MyCompoundType #cMyCtor--_wrapMyCompoundType2 :: Instr (ToT Integer ': s) (ToT MyCompoundType ': s)-_wrapMyCompoundType2 = instrWrap @MyCompoundType #cCompoundPart2--_wrapMyCompoundType3 :: Instr (ToT Bool ': s) (ToT MyCompoundType ': s)-_wrapMyCompoundType3 = instrWrap @MyCompoundType #cWrapBool--_wrapMyCompoundType4 :: Instr (ToT MyType' ': s) (ToT MyCompoundType ': s)-_wrapMyCompoundType4 = instrWrap @MyCompoundType #cCompoundPart4--data MyEnum = Case1 | Case2 | CaseN Integer | CaseDef-  deriving stock Generic-  deriving anyclass IsoValue--_wrapMyEnum1 :: Instr s (ToT MyEnum ': s)-_wrapMyEnum1 = instrWrap @MyEnum #cCase1--_wrapMyEnum2 :: Instr (ToT Integer ': s) (ToT MyEnum ': s)-_wrapMyEnum2 = instrWrap @MyEnum #cCaseN--data MyTypeWithNamedField-  = MeaninglessCtor-  | CtorWithNamedField ("name" :! Natural)-  deriving stock Generic-  deriving anyclass IsoValue--_accessMyTypeWithNamedField :: Instr (ToT Natural ': s) (ToT MyTypeWithNamedField ': s)-_accessMyTypeWithNamedField = instrWrap @MyTypeWithNamedField #cCtorWithNamedField--------------------------------------------------------------------------------- "case" instruction--------------------------------------------------------------------------------- | Pattern-match on the given datatype.-instrCase-  :: forall dt out inp.-     InstrCaseC dt-  => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt ': inp) out-instrCase = gInstrCase @(G.Rep dt)--type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (G.Rep dt))---- | In what different case branches differ - related constructor name and--- input stack type which the branch starts with.-data CaseClauseParam = CaseClauseParam Symbol CtorField---- | Type information about single case clause.-data CaseClause (inp :: [T]) (out :: [T]) (param :: CaseClauseParam) where-  CaseClause-    :: RemFail Instr (AppendCtorField x inp) out-    -> CaseClause inp out ('CaseClauseParam ctor x)---- | Lift an instruction to case clause.------ You should write out constructor name corresponding to the clause--- explicitly. Prefix constructor name with "c" letter, otherwise--- your label will not be recognized by Haskell parser.--- Passing constructor name can be circumvented but doing so is not recomended--- as mentioning contructor name improves readability and allows avoiding--- some mistakes.-(//->)-  :: Label ("c" `AppendSymbol` ctor)-  -> RemFail Instr (AppendCtorField x inp) out-  -> CaseClause inp out ('CaseClauseParam ctor x)-(//->) _ = CaseClause-infixr 8 //->---- | List of 'CaseClauseParam's required to pattern match on the given type.-type CaseClauses a = GCaseClauses (G.Rep a)---- | Generic traversal for 'instrWrap'.-class GIsoValue x => GInstrCase (x :: Type -> Type) where--  type GCaseClauses x :: [CaseClauseParam]--  gInstrCase-    :: GIsoValue x-    => Rec (CaseClause inp out) (GCaseClauses x) -> RemFail Instr (GValueType x ': inp) out--instance GInstrCase x => GInstrCase (G.D1 i x) where-  type GCaseClauses (G.D1 i x) = GCaseClauses x-  gInstrCase = gInstrCase @x--instance (GInstrCase x, GInstrCase y, RSplit (GCaseClauses x) (GCaseClauses y)) =>-         GInstrCase (x :+: y) where-  type GCaseClauses (x :+: y) = GCaseClauses x ++ GCaseClauses y-  gInstrCase clauses =-    let (leftClauses, rightClauses) = rsplit clauses-    in rfMerge IF_LEFT (gInstrCase @x leftClauses) (gInstrCase @y rightClauses)--instance GInstrCase G.V1 where-  type GCaseClauses G.V1 = '[]-  gInstrCase RNil = RfAlwaysFails NEVER--instance GInstrCaseBranch ctor x => GInstrCase (G.C1 ('G.MetaCons ctor _1 _2) x) where-  type GCaseClauses (G.C1 ('G.MetaCons ctor _1 _2) x) = '[GCaseBranchInput ctor x]-  gInstrCase (clause :& RNil) = gInstrCaseBranch @ctor @x clause---- | Traverse a single contructor and supply its field to instruction in case clause.-class GIsoValue x =>-      GInstrCaseBranch (ctor :: Symbol) (x :: Type -> Type) where--  type GCaseBranchInput ctor x :: CaseClauseParam--  gInstrCaseBranch-    :: CaseClause inp out (GCaseBranchInput ctor x)-    -> RemFail Instr (GValueType x ': inp) out--instance-  ( GIsoValue x, GIsoValue y-  , TypeError ('Text "Cannot pattern match on constructors with more than 1 field"-               ':$$: 'Text "Consider using tuples instead")-  ) => GInstrCaseBranch ctor (x :*: y) where--  type GCaseBranchInput ctor (x :*: y) = 'CaseClauseParam ctor 'NoFields-  gInstrCaseBranch = error "impossible"--instance GInstrCaseBranch ctor x => GInstrCaseBranch ctor (G.S1 i x) where-  type GCaseBranchInput ctor (G.S1 i x) = GCaseBranchInput ctor x-  gInstrCaseBranch = gInstrCaseBranch @ctor @x--instance IsoValue a => GInstrCaseBranch ctor (G.Rec0 a) where-  type GCaseBranchInput ctor (G.Rec0 a) = 'CaseClauseParam ctor ('OneField a)-  gInstrCaseBranch (CaseClause i) = i--instance GInstrCaseBranch ctor G.U1 where-  type GCaseBranchInput ctor G.U1 = 'CaseClauseParam ctor 'NoFields-  gInstrCaseBranch (CaseClause i) = rfMapAnyInstr (DROP `Seq`) i---- Examples-------------------------------------------------------------------------------_caseMyType :: RemFail Instr (ToT MyType ': s) (ToT Integer ': s)-_caseMyType = instrCase @MyType $-     #cMyCtor //-> RfNormal Nop-  :& #cComplexThing //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 5))-  :& #cUselessThing //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 0))-  :& RNil---- Another version, written via tuple.-_caseMyType2 :: RemFail Instr (ToT MyType ': s) (ToT Integer ': s)-_caseMyType2 = instrCase @MyType $ recFromTuple-  ( #cMyCtor //->-      RfNormal Nop-  , #cComplexThing //->-      RfNormal (DROP `Seq` PUSH (toVal @Integer 5))-  , #cUselessThing //->-      RfNormal (DROP `Seq` PUSH (toVal @Integer 0))-  )--_caseMyEnum :: RemFail Instr (ToT MyEnum ': ToT Integer ': s) (ToT Integer ': s)-_caseMyEnum = instrCase @MyEnum $ recFromTuple-  ( #cCase1 //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 1))-  , #cCase2 //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 2))-  , #cCaseN //-> RfNormal (DIP DROP `Seq` Nop)-  , #cCaseDef //-> RfNormal Nop-  )--------------------------------------------------------------------------------- Constructor unwrapping instruction--------------------------------------------------------------------------------- | Unwrap a constructor with the given name.------ Rules which apply to 'instrWrap' function work here as well.--- Although, unlike @instrWrap@, this function does not work for nullary--- constructors.-unsafeInstrUnwrap-  :: forall dt name st.-     InstrUnwrapC dt name-  => Label name-  -> Instr (ToT dt ': st)-           (ToT (CtorOnlyField name dt) ': st)-unsafeInstrUnwrap _ =-  unsafeGInstrUnwrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))-                                 @(CtorOnlyField name dt)--type InstrUnwrapC dt name =-  ( GenericIsoValue dt-  , GInstrUnwrap (G.Rep dt)-      (LnrBranch (GetNamed name dt))-      (CtorOnlyField name dt)-  )---- | Try to unwrap a constructor with the given name.-hsUnwrap-  :: forall dt name.-     InstrUnwrapC dt name-  => Label name-  -> dt-  -> Maybe (CtorOnlyField name dt)-hsUnwrap _ =-  gHsUnwrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))-            @(CtorOnlyField name dt) .-  G.from--class GIsoValue x =>-  GInstrUnwrap-    (x :: Type -> Type)-    (path :: Path)-    (entryTy :: Type) where-  unsafeGInstrUnwrap-    :: GIsoValue x-    => Instr (GValueType x ': s) (ToT entryTy ': s)-  gHsUnwrap-    :: x p -> Maybe entryTy--instance GInstrUnwrap x path e => GInstrUnwrap (G.D1 i x) path e where-  unsafeGInstrUnwrap = unsafeGInstrUnwrap @x @path @e-  gHsUnwrap = gHsUnwrap @x @path @e . G.unM1--instance (GInstrUnwrap x path e, GIsoValue y, SingI (GValueType y)) =>-         GInstrUnwrap (x :+: y) ('L ': path) e where-  unsafeGInstrUnwrap = IF_LEFT (unsafeGInstrUnwrap @x @path @e) failWithWrongCtor-  gHsUnwrap = \case-    G.L1 x -> gHsUnwrap @x @path @e x-    G.R1 _ -> Nothing--instance (GInstrUnwrap y path e, GIsoValue x, SingI (GValueType x)) =>-         GInstrUnwrap (x :+: y) ('R ': path) e where-  unsafeGInstrUnwrap = IF_LEFT failWithWrongCtor (unsafeGInstrUnwrap @y @path @e)-  gHsUnwrap = \case-    G.R1 y -> gHsUnwrap @y @path @e y-    G.L1 _ -> Nothing--instance (IsoValue e) =>-         GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] e where-  unsafeGInstrUnwrap = Nop-  gHsUnwrap = Just . G.unK1 . G.unM1 . G.unM1---- This is the case when a sum type is part of another sum type.--- Here 'sub' is intermediate sum type.-instance ( path ~ (x ': xs)-         , GInstrUnwrap (G.Rep sub) path e-         , GenericIsoValue sub-         , GIsoValue (G.Rep sub)-         ) =>-         GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where-  unsafeGInstrUnwrap = unsafeGInstrUnwrap @(G.Rep sub) @path @e-  gHsUnwrap = gHsUnwrap @(G.Rep sub) @path @e . G.from . G.unK1 . G.unM1 . G.unM1---- | Failure indicating that we expected value created with one constructor,--- but got value with different one.--- The error message is intentionally ugly to keep it relatively short and--- save on gas.-failWithWrongCtor :: Instr i o-failWithWrongCtor =-  PUSH (toVal [mt|BadCtor|]) `Seq`-  FAILWITH---- Examples-------------------------------------------------------------------------------_unwrapMyType :: Instr (ToT MyType ': s) (ToT Integer ': s)-_unwrapMyType = unsafeInstrUnwrap @MyType #cMyCtor--_unwrapMyCompoundType :: Instr (ToT MyCompoundType ': s) (ToT Integer ': s)-_unwrapMyCompoundType = unsafeInstrUnwrap @MyCompoundType #cMyCtor--_unwrapMyCompoundType2 :: Instr (ToT MyCompoundType ': s) (ToT Address ': s)-_unwrapMyCompoundType2 = unsafeInstrUnwrap @MyCompoundType #cCompoundPart3--_unwrapMyCompoundType3 :: Instr (ToT MyCompoundType ': s) (ToT Bool ': s)-_unwrapMyCompoundType3 = unsafeInstrUnwrap @MyCompoundType #cWrapBool--_unwrapMyCompoundType4 :: Instr (ToT MyCompoundType ': s) (ToT MyType' ': s)-_unwrapMyCompoundType4 = unsafeInstrUnwrap @MyCompoundType #cCompoundPart4

− src/Michelson/Typed/Haskell/LooseSum.hs

@@ -1,129 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Representation of Haskell sum types via loosy typed Michelson values,--- useful for e.g. errors and enums.------ In particular, ADT sum can be represented as constructor name + data--- it carries. Such expression does not have particular type because--- different constructors may carry different data, and we avoid lifting--- this data to a union in order to keep only the significant parts--- (and thus not to confuse the client).-module Michelson.Typed.Haskell.LooseSum-  ( ComposeResult (..)-  , fromTaggedVal-  , toTaggedVal-  , LooseSumC-  ) where--import Data.Singletons-import GHC.Generics ((:*:), (:+:))-import qualified GHC.Generics as G--import Michelson.Typed.Aliases-import Michelson.Typed.Existential-import Michelson.Typed.Haskell.Value-import Michelson.Typed.T-import Util.Sing (castSing)-import Util.TypeLits---- | Possible outcomes of an attempt to construct a Haskell ADT value--- from constructor name and relevant data.-data ComposeResult a-  = ComposeOk a-    -- ^ Composed fine.-  | ComposeCtorNotFound-    -- ^ No constructor with such name.-  | ComposeFieldTypeMismatch T T-    -- ^ Found required constructor, but type of data does not correspond-    -- to provided one.-  deriving stock (Functor)--instance Semigroup (ComposeResult a) where-  r@(ComposeOk _) <> _ = r-  _ <> r@(ComposeOk _) = r-  r@(ComposeFieldTypeMismatch _ _) <> _ = r-  _ <> r@(ComposeFieldTypeMismatch _ _) = r-  r@ComposeCtorNotFound <> ComposeCtorNotFound = r--instance Monoid (ComposeResult a) where-  mempty = ComposeCtorNotFound-  mappend = (<>)---- | Constraint for 'hsDecompose' and 'hsCompose'.-type LooseSumC dt =-  ( Generic dt, GLooseSum (G.Rep dt)-  )---- | Decompose Haskell type into constructor name and--- data it carries, converting the latter into Michelson 'Value'.-toTaggedVal :: LooseSumC dt => dt -> (Text, SomeValue)-toTaggedVal = gToTaggedVal . G.from---- | Inverse to 'toTaggedVal'.-fromTaggedVal :: LooseSumC dt => (Text, SomeValue) -> ComposeResult dt-fromTaggedVal = fmap G.to . gFromTaggedVal---- | Generic traversal for 'toTaggedVal' and 'fromTaggedVal'.-class GLooseSum (x :: Type -> Type) where-  gToTaggedVal :: x p -> (Text, SomeValue)-  gFromTaggedVal :: (Text, SomeValue) -> ComposeResult (x p)--instance GLooseSum x => GLooseSum (G.D1 i x) where-  gToTaggedVal = gToTaggedVal . G.unM1-  gFromTaggedVal = fmap G.M1 . gFromTaggedVal--instance (GLooseSum x, GLooseSum y) => GLooseSum (x :+: y) where-  gToTaggedVal = \case-    G.L1 x -> gToTaggedVal x-    G.R1 y -> gToTaggedVal y-  gFromTaggedVal v = mconcat-    [ G.L1 <$> gFromTaggedVal v-    , G.R1 <$> gFromTaggedVal v-    ]--instance (GAccessField x, KnownSymbol ctor) =>-         GLooseSum (G.C1 ('G.MetaCons ctor f o) x) where-  gToTaggedVal = (symbolValT' @ctor, ) . gExtractField @x . G.unM1-  gFromTaggedVal (ctor, val)-    | symbolValT' @ctor == ctor = G.M1 <$> gMakeField @x val-    | otherwise = ComposeCtorNotFound--instance GLooseSum G.V1 where-  gToTaggedVal = \case{}-  gFromTaggedVal _ = mempty---- | Pick a field from constructor with zero or one fields.-class GAccessField (x :: Type -> Type) where-  gExtractField :: x p -> SomeValue-  gMakeField :: SomeValue -> ComposeResult (x p)--instance GAccessField x => GAccessField (G.S1 i x) where-  gExtractField = gExtractField . G.unM1-  gMakeField v = G.M1 <$> gMakeField @x v--instance IsoValue a =>-         GAccessField (G.Rec0 a) where-  gExtractField = SomeValue . toVal . G.unK1-  gMakeField (SomeValue v) = G.K1 . fromVal <$> composeCast v--instance GAccessField G.U1 where-  gExtractField G.U1 = SomeValue $ toVal ()-  gMakeField (SomeValue v) = G.U1 <$ composeCast @_ @'TUnit v--composeCast :: forall a b. (SingI a, SingI b) => Value a -> ComposeResult (Value b)-composeCast a =-  case castSing a of-    Nothing -> ComposeFieldTypeMismatch (demote @a) (demote @b)-    Just b -> ComposeOk b--instance-  TypeError ('Text "Cannot compose/decompose constructors with more \-             \than one field" ':$$:-             'Text "Consider using tuple instead") =>-  GAccessField (x :*: y) where-  gExtractField = error "impossible"-  gMakeField = error "impossible"

− src/Michelson/Typed/Haskell/ValidateDescription.hs

@@ -1,134 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Typed.Haskell.ValidateDescription-  ( FieldDescriptions-  , FieldDescriptionsV--  , FieldDescriptionsValid-  ) where--import Data.Singletons (Demote)-import Data.Type.Bool-import qualified GHC.Generics as G-import GHC.TypeLits---- | Description of constructors and fields of some datatype.------ This type is just two nested maps represented as associative lists. It is supposed to--- be interpreted like this:------ > [(Constructor name, (Maybe constructor description, [(Field name, Field description)]))]------ Example with a concrete data type:------ > data Foo--- >   = Foo--- >       { fFoo :: Int--- >       }--- >   | Bar--- >       { fBar :: Text--- >       }--- >   deriving (Generic)--- >--- > type FooDescriptions =--- >   '[ '( "Foo", '( 'Just "foo constructor",--- >       , '[ '("fFoo", "some number")--- >          ])--- >       )--- >    , '( "Bar", '( 'Nothing,--- >       , '[ '("fBar", "some string")--- >          ])--- >       )--- >    ]-type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]---- | Value-level counterpart to 'FieldDescriptions'.-type FieldDescriptionsV = Demote FieldDescriptions---- | This type family checks that field descriptions mention only existing constructors and fields.------ When @descr@ is empty this family does nothing, to avoid breaking for built-in, non-ADT types.------ When @descr@ is not empty, this family will demand 'G.Generic' instance for @typ@ and fail with a--- 'TypeError' if there none.-type family FieldDescriptionsValid (descr :: FieldDescriptions) (typ :: Type) :: Constraint where-  FieldDescriptionsValid '[] _ = ()-  FieldDescriptionsValid descr typ =-    Assert-      (TypeError-        ('Text "No Generic instance for " ':<>: 'ShowType typ ':<>: 'Text "." ':$$:-         'Text "Generic is needed to validate TypeDocFieldDescriptions.")-      )-      (G.Rep typ)-      (FieldDescriptionsValidImpl descr typ)---- | Actual recursive implementation for 'FieldDescriptionsValid'.-type family FieldDescriptionsValidImpl (descr :: FieldDescriptions) (typ :: Type) :: Constraint where-  FieldDescriptionsValidImpl '[] _ = ()-  FieldDescriptionsValidImpl ( '(conName, '(_, fields)) ': rest ) typ =-    ( HasAllFields conName fields typ-    , FieldDescriptionsValidImpl rest typ-    )---- | Check whether given constructor name @conName@ is present in 'G.Rep' of a datatype.-type family HasConstructor (conName :: Symbol) (g :: Type -> Type) :: Bool where-  HasConstructor conName (G.D1 _ cs) = HasConstructor conName cs-  HasConstructor conName (G.C1 ('G.MetaCons conName _ _) _) = 'True-  HasConstructor conName (l G.:+: r) = HasConstructor conName l || HasConstructor conName r-  HasConstructor _ _ = 'False---- | Check whether all fields described for given constructor @conName@ are present in the datatype.------ This family also checks whether the constructor is present and fails with a 'TypeError'--- otherwise.-type family HasAllFields (conName :: Symbol) (fields :: [(Symbol, Symbol)]) (typ :: Type) :: Constraint where-  HasAllFields conName fields typ =-    If-      (HasConstructor conName (G.Rep typ))-      (HasAllFieldsImpl conName fields typ)-      (TypeError-        ('Text "No constructor " ':<>: 'ShowType conName ':<>: 'Text " in type " ':<>: 'ShowType typ ':<>: 'Text "." )-      )---- | Actual recursive implementation of 'HasAllFields'.-type family HasAllFieldsImpl (conName :: Symbol) (fields :: [(Symbol, Symbol)]) (typ :: Type) :: Constraint where-  HasAllFieldsImpl _ '[] _ = ()-  HasAllFieldsImpl conName ( '(fieldName, _) ': rest ) typ =-    ( If-        (HasField conName fieldName (G.Rep typ))-        (() :: Constraint)-        (TypeError-          ('Text "No field " ':<>: 'ShowType fieldName ':<>: 'Text " in constructor " ':<>:-           'ShowType conName ':<>: 'Text " of type " ':<>: 'ShowType typ ':<>: 'Text "."-          )-        )-    , HasAllFieldsImpl conName rest typ-    )---- | Check that Generic 'G.Rep' has given field @fieldName@ in a given constructor @conName@.-type family HasField (conName :: Symbol) (fieldName :: Symbol) (g :: Type -> Type) :: Bool where-  HasField conName fieldName (G.D1 _ cs) = HasField conName fieldName cs-  HasField conName fieldName (G.C1 ('G.MetaCons conName _ _) c) = ConHasField fieldName c-  HasField conName fieldName (l G.:+: r) = HasField conName fieldName l || HasField conName fieldName r-  HasField _ _ _ = 'False---- | Check that Generic representation for a constructor has given field @fieldName@.-type family ConHasField (fieldName :: Symbol) (g :: Type -> Type) :: Bool where-  ConHasField fieldName (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) _) = 'True-  ConHasField fieldName (l G.:*: r) = ConHasField fieldName l || ConHasField fieldName r-  ConHasField _ _ = 'False---- A trick by Csongor Kiss: https://kcsongor.github.io/report-stuck-families/------ 'T1' is a dummy type and 'Assert' will get stuck whenever its argument @break@ is stuck.------ This happens because for stuck argument GHC can't check whether it is equal to 'T1' and therefore--- can't select one of 'Assert's equations.--data T1 a--type family Assert (err :: Constraint) (break :: Type -> Type) (v :: k) :: k where-  Assert _ T1 _ = Any-  Assert _ _ k = k

− src/Michelson/Typed/Haskell/Value.hs

@@ -1,498 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Conversions between haskell types/values and Michelson ones.-module Michelson.Typed.Haskell.Value-  ( -- * Value conversions-    IsoValue (..)-  , KnownIsoT-  , GIsoValue (GValueType)-  , ToT'-  , GenericIsoValue-  , WellTyped-  , WellTypedIsoValue-  , WellTypedToT-  , HasNoOpToT--  , Dict(..) -- * Re-exporting to use in tests.--    -- * Missing Haskell analogies to Michelson values-  , EntrypointCall-  , SomeEntrypointCall-  , ContractRef (..)-  , coerceContractRef-  , contractRefToAddr-  , Ticket (..)-  , BigMapId(..)-  , BigMap(..)-  , mkBigMap--    -- * Stack conversion-  , ToTs-  , ToTs'-  , IsoValuesStack (..)-  , totsKnownLemma-  , totsAppendLemma-  ) where--import Data.Constraint (Dict(..))-import Data.Data (Data)-import Data.Default (Default(..))-import Data.Foldable (Foldable(foldr))-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import Data.Vinyl.Core (Rec(..))-import Fmt (Buildable(..), mapF)-import GHC.Exts as Exts (IsList(..))-import GHC.Generics ((:*:)(..), (:+:)(..))-import qualified GHC.Generics as G-import Named (NamedF(..))--import Michelson.Text-import Michelson.Typed.Aliases-import Michelson.Typed.Entrypoints-import Michelson.Typed.Scope-import Michelson.Typed.T-import Michelson.Typed.Value-import Tezos.Address (Address)-import Tezos.Core (ChainId, Mutez, Timestamp)-import Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature)-import Util.Type--------------------------------------------------------------------------------- Complex values isomorphism-------------------------------------------------------------------------------type KnownIsoT a = SingI (ToT a)---- | Isomorphism between Michelson values and plain Haskell types.------ Default implementation of this typeclass converts ADTs to Michelson--- "pair"s and "or"s.-class (WellTypedToT a) => IsoValue a where-  -- | Type function that converts a regular Haskell type into a @T@ type.-  type ToT a :: T-  type ToT a = GValueType (G.Rep a)--  -- | Converts a Haskell structure into @Value@ representation.-  toVal :: a -> Value (ToT a)-  default toVal-    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GValueType (G.Rep a))-    => a -> Value (ToT a)-  toVal = gToValue . G.from--  -- | Converts a @Value@ into Haskell type.-  fromVal :: Value (ToT a) -> a-  default fromVal-    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GValueType (G.Rep a))-    => Value (ToT a) -> a-  fromVal = G.to . gFromValue---- | Overloaded version of 'ToT' to work on Haskell and @T@ types.-type family ToT' (t :: k) :: T where-  ToT' (t :: T) = t-  ToT' (t :: Type) = ToT t---- Instances-------------------------------------------------------------------------------instance WellTyped t => IsoValue (Value t) where-  type ToT (Value t) = t-  toVal = id-  fromVal = id--instance IsoValue Integer where-  type ToT Integer = 'TInt-  toVal = VInt-  fromVal (VInt x) = x--instance IsoValue Natural where-  type ToT Natural = 'TNat-  toVal = VNat-  fromVal (VNat x) = x--instance IsoValue MText where-  type ToT MText = 'TString-  toVal = VString-  fromVal (VString x) = x--instance DoNotUseTextError => IsoValue Text where-  type ToT Text = ToT MText-  toVal = error "impossible"-  fromVal = error "impossible"--instance IsoValue Bool where-  type ToT Bool = 'TBool-  toVal = VBool-  fromVal (VBool x) = x--instance IsoValue ByteString where-  type ToT ByteString = 'TBytes-  toVal = VBytes-  fromVal (VBytes x) = x--instance IsoValue Mutez where-  type ToT Mutez = 'TMutez-  toVal = VMutez-  fromVal (VMutez x) = x--instance IsoValue KeyHash where-  type ToT KeyHash = 'TKeyHash-  toVal = VKeyHash-  fromVal (VKeyHash x) = x--instance IsoValue Bls12381Fr where-  type ToT Bls12381Fr = 'TBls12381Fr-  toVal = VBls12381Fr-  fromVal (VBls12381Fr x) = x--instance IsoValue Bls12381G1 where-  type ToT Bls12381G1 = 'TBls12381G1-  toVal = VBls12381G1-  fromVal (VBls12381G1 x) = x--instance IsoValue Bls12381G2 where-  type ToT Bls12381G2 = 'TBls12381G2-  toVal = VBls12381G2-  fromVal (VBls12381G2 x) = x--instance IsoValue Timestamp where-  type ToT Timestamp = 'TTimestamp-  toVal = VTimestamp-  fromVal (VTimestamp x) = x--instance IsoValue Address where-  type ToT Address = 'TAddress-  toVal addr = VAddress $ EpAddress addr DefEpName-  fromVal (VAddress x) = eaAddress x--instance IsoValue EpAddress where-  type ToT EpAddress = 'TAddress-  toVal = VAddress-  fromVal (VAddress x) = x--instance IsoValue PublicKey where-  type ToT PublicKey = 'TKey-  toVal = VKey-  fromVal (VKey x) = x--instance IsoValue Signature where-  type ToT Signature = 'TSignature-  toVal = VSignature-  fromVal (VSignature x) = x--instance IsoValue ChainId where-  type ToT ChainId = 'TChainId-  toVal = VChainId-  fromVal (VChainId x) = x--instance IsoValue ()--instance IsoValue a => IsoValue [a] where-  type ToT [a] = 'TList (ToT a)-  toVal = VList . map toVal-  fromVal (VList x) = map fromVal x--instance IsoValue a => IsoValue (Maybe a) where-  type ToT (Maybe a) = 'TOption (ToT a)-  toVal = VOption . fmap toVal-  fromVal (VOption x) = fmap fromVal x--instance IsoValue Void--instance (IsoValue l, IsoValue r) => IsoValue (Either l r)--instance (IsoValue a, IsoValue b) => IsoValue (a, b)--instance (Comparable (ToT c), Ord c, IsoValue c) => IsoValue (Set c) where-  type ToT (Set c) = 'TSet (ToT c)-  toVal = VSet . Set.map toVal-  fromVal (VSet x) = Set.map fromVal x--instance (Comparable (ToT k), Ord k, IsoValue k, IsoValue v) => IsoValue (Map k v) where-  type ToT (Map k v) = 'TMap (ToT k) (ToT v)-  toVal = VMap . Map.mapKeys toVal . Map.map toVal-  fromVal (VMap x) = Map.map fromVal $ Map.mapKeys fromVal x--instance IsoValue Operation where-  type ToT Operation = 'TOperation-  toVal = VOp-  fromVal (VOp x) = x--deriving newtype instance IsoValue a => IsoValue (Identity a)-deriving newtype instance IsoValue a => IsoValue (NamedF Identity a name)-deriving newtype instance IsoValue a => IsoValue (NamedF Maybe a name)--instance (IsoValue a, IsoValue b, IsoValue c) => IsoValue (a, b, c)-instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d)-       => IsoValue (a, b, c, d)-instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e)-       => IsoValue (a, b, c, d, e)-instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e,-          IsoValue f)-       => IsoValue (a, b, c, d, e, f)-instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e,-          IsoValue f, IsoValue g)-       => IsoValue (a, b, c, d, e, f, g)---- Types used specifically for conversion-------------------------------------------------------------------------------type EntrypointCall param arg = EntrypointCallT (ToT param) (ToT arg)--type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)--type WellTypedToT a = WellTyped (ToT a)-type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)--type HasNoOpToT a = HasNoOp (ToT a)-type HasNoBigMapToT a = HasNoBigMap (ToT a)---- | Since @Contract@ name is used to designate contract code, lets call--- analogy of 'TContract' type as follows.------ Note that type argument always designates an argument of entrypoint.--- If a contract has explicit default entrypoint (and no root entrypoint),--- @ContractRef@ referring to it can never have the entire parameter as its--- type argument.-data ContractRef (arg :: Type) = ContractRef-  { crAddress :: Address-  , crEntrypoint :: SomeEntrypointCall arg-  } deriving stock (Eq, Show)--instance (IsoValue (ContractRef arg)) => Buildable (ContractRef arg) where-  build = buildVContract . toVal--instance (HasNoOpToT arg, WellTypedToT arg) => IsoValue (ContractRef arg) where-  type ToT (ContractRef arg) = 'TContract (ToT arg)-  toVal ContractRef{..} = VContract crAddress crEntrypoint-  fromVal (VContract addr epc) = ContractRef addr epc---- | Replace type argument of 'ContractAddr' with isomorphic one.-coerceContractRef :: (ToT a ~ ToT b) => ContractRef a -> ContractRef b-coerceContractRef ContractRef{..} = ContractRef{..}--contractRefToAddr :: ContractRef cp -> EpAddress-contractRefToAddr ContractRef{..} = EpAddress crAddress (sepcName crEntrypoint)---- | Ticket type.-data Ticket (arg :: Type) = Ticket-  { tTicketer :: Address-  , tData :: arg-  , tAmount :: Natural-  } deriving stock (Eq, Show)--instance (Comparable (ToT a), IsoValue a) => IsoValue (Ticket a) where-  type ToT (Ticket a) = 'TTicket (ToT a)-  toVal Ticket{..} = VTicket tTicketer (toVal tData) tAmount-  fromVal (VTicket tTicketer dat tAmount) = Ticket{ tData = fromVal dat, .. }---- | Phantom type that represents the ID of a big_map with--- keys of type @k@ and values of type @v@.-newtype BigMapId k v = BigMapId { unBigMapId :: Natural }-  -- Note: we purposefully do not derive an `Eq` instance.-  -- If we did, it would be possible for a @cleveland@ user to mistakenly-  -- compare two big_map IDs, whilst being under the impression that they were-  -- actually comparing the big_map's contents.-  -- To avoid this confusion, we simply do not create an `Eq` instance.-  -- For context, see: https://gitlab.com/morley-framework/morley/-/merge_requests/833#note_598577341-  deriving stock (Show, Data)-  deriving newtype (IsoValue, Buildable, Num)--data BigMap k v = BigMap-  { bmId :: Maybe (BigMapId k v)-  , bmMap :: Map k v-  }-  deriving stock (Show, Generic, Data)-  deriving anyclass (Default, Container)--mkBigMap :: Ord k => [(k, v)] -> BigMap k v-mkBigMap = Exts.fromList--instance Ord k => Semigroup (BigMap k v) where-  BigMap _ m1 <> BigMap _ m2 = BigMap Nothing (m1 <> m2)--instance Foldable (BigMap k) where-  foldr f z (BigMap _ bmMap) = Map.foldr f z bmMap--instance One (BigMap k v) where-  type OneItem (BigMap k v) = OneItem (Map k v)-  one x = BigMap Nothing (one x)--instance Ord k => IsList (BigMap k v) where-  type Item (BigMap k v) = Item (Map k v)-  fromList xs = BigMap Nothing (Exts.fromList xs)-  toList (BigMap _ xs) = Exts.toList xs--instance (Ord k, Buildable k, Buildable v) => Buildable (BigMap k v) where-  build = mapF--instance-  ( Comparable (ToT k) , Ord k, IsoValue k-  , IsoValue v, HasNoBigMapToT v, HasNoOpToT v-  ) => IsoValue (BigMap k v) where-  type ToT (BigMap k v) = 'TBigMap (ToT k) (ToT v)-  toVal (BigMap bmId bmMap) =-    VBigMap-      (unBigMapId <$> bmId)-      (Map.mapKeys toVal $ Map.map toVal bmMap)-  fromVal (VBigMap bmId x) =-    BigMap-      (BigMapId <$> bmId)-      (Map.map fromVal $ Map.mapKeys fromVal x)---- Generic magic--------------------------------------------------------------------------------- | Implements ADT conversion to Michelson value.------ Thanks to Generic, Michelson representation will--- be a balanced tree; this reduces average access time in general case.------ A drawback of such approach is that, in theory, in new GHC version--- generified representation may change; however, chances are small and--- I (martoon) believe that contract versions will change much faster anyway.------ In case an unbalanced tree is needed, the Generic instance can be derived by--- using the utilities in the 'Util.Generics' module.-class SingI (GValueType x) =>-      GIsoValue (x :: Type -> Type) where-  type GValueType x :: T-  gToValue :: x p -> Value (GValueType x)-  gFromValue :: Value (GValueType x) -> x p--instance GIsoValue x => GIsoValue (G.M1 t i x) where-  type GValueType (G.M1 t i x) = GValueType x-  gToValue = gToValue . G.unM1-  gFromValue = G.M1 . gFromValue--instance (GIsoValue x, GIsoValue y) => GIsoValue (x :+: y) where-  type GValueType (x :+: y) = 'TOr (GValueType x) (GValueType y)-  gToValue = VOr . \case-    L1 x -> Left (gToValue x)-    R1 y -> Right (gToValue y)-  gFromValue (VOr e) = case e of-    Left vx -> L1 (gFromValue vx)-    Right vy -> R1 (gFromValue vy)--instance (GIsoValue x, GIsoValue y) => GIsoValue (x :*: y) where-  type GValueType (x :*: y) = 'TPair (GValueType x) (GValueType y)-  gToValue (x :*: y) = VPair (gToValue x, gToValue y)-  gFromValue (VPair (vx, vy)) = gFromValue vx :*: gFromValue vy--instance GIsoValue G.U1 where-  type GValueType G.U1 = 'TUnit-  gToValue G.U1 = VUnit-  gFromValue VUnit = G.U1--instance GIsoValue G.V1 where-  type GValueType G.V1 = 'TNever-  gToValue = \case-  gFromValue = \case--instance IsoValue a => GIsoValue (G.Rec0 a) where-  type GValueType (G.Rec0 a) = ToT a-  gToValue = toVal . G.unK1-  gFromValue = G.K1 . fromVal---- | Whether Michelson representation of the type is derived via Generics.-type GenericIsoValue t =-  (IsoValue t, Generic t, ToT t ~ GValueType (G.Rep t))--------------------------------------------------------------------------------- Stacks conversion--------------------------------------------------------------------------------- | Type function to convert a Haskell stack type to @T@-based one.-type family ToTs (ts :: [Type]) :: [T] where-  ToTs '[] = '[]-  ToTs (x ': xs) = ToT x ': ToTs xs---- | Overloaded version of 'ToTs' to work on Haskell and @T@ stacks.-type family ToTs' (t :: [k]) :: [T] where-  ToTs' (t :: [T]) = t-  ToTs' (a :: [Type]) = ToTs a---- | Isomorphism between Michelson stack and its Haskell reflection.-class IsoValuesStack (ts :: [Type]) where-  toValStack :: Rec Identity ts -> Rec Value (ToTs ts)-  fromValStack :: Rec Value (ToTs ts) -> Rec Identity ts--instance IsoValuesStack '[] where-  toValStack RNil = RNil-  fromValStack RNil = RNil--instance (IsoValue t, IsoValuesStack st) => IsoValuesStack (t ': st) where-  toValStack (v :& vs) = toVal v :& toValStack vs-  fromValStack (v :& vs) = fromVal v :& fromValStack vs--totsKnownLemma :: forall s. KnownList s :- KnownList (ToTs s)-totsKnownLemma = Sub $ case klist @s of-  KNil -> Dict-  KCons _ (_ :: Proxy a') ->-    case totsKnownLemma @a' of Sub Dict -> Dict--totsAppendLemma-  :: forall a b.-      (KnownList a)-  => Dict (ToTs (a ++ b) ~ (ToTs a ++ ToTs b))-totsAppendLemma = case klist @a of-  KNil -> Dict-  KCons _ (_ :: Proxy a') ->-    case totsAppendLemma @a' @b of Dict -> Dict---- | This class encodes Michelson rules w.r.t where it requires comparable--- types. Earlier we had a dedicated type for representing comparable types @CT@.--- But then we integreated those types into @T@. This meant that some of the--- types that could be formed with various combinations of @T@ would be--- illegal as per Michelson typing rule. Using this class, we inductively--- enforce that a type and all types it contains are well typed as per--- Michelson's rules.-class (SingI t, WellTypedSuperC t) => WellTyped (t :: T) where-  -- | Constraints required for instance of a given type.-  type WellTypedSuperC t :: Constraint-  type WellTypedSuperC _ = ()--instance WellTyped 'TKey where-instance WellTyped 'TUnit where-instance WellTyped 'TNever where-instance WellTyped 'TSignature where-instance WellTyped 'TChainId where-instance WellTyped t => WellTyped ('TOption t) where-  type WellTypedSuperC ('TOption t) = WellTyped t-instance WellTyped t => WellTyped ('TList t) where-  type WellTypedSuperC ('TList t) = WellTyped t-instance (Comparable t, WellTyped t) => WellTyped ('TSet t) where-  type WellTypedSuperC ('TSet t) = (Comparable t, WellTyped t)-instance WellTyped 'TOperation where-instance (WellTyped t, HasNoOp t) => WellTyped ('TContract t) where-  type WellTypedSuperC ('TContract t) = (WellTyped t, HasNoOp t)-instance (WellTyped t, Comparable t) => WellTyped ('TTicket t) where-  type WellTypedSuperC ('TTicket t) = (WellTyped t, Comparable t)-instance (WellTyped t1, WellTyped t2) => WellTyped ('TPair t1 t2) where-  type WellTypedSuperC ('TPair t1 t2) = (WellTyped t1, WellTyped t2)-instance (WellTyped t1, WellTyped t2) => WellTyped ('TOr t1 t2) where-  type WellTypedSuperC ('TOr t1 t2) = (WellTyped t1, WellTyped t2)-instance (WellTyped t1, WellTyped t2) => WellTyped ('TLambda t1 t2) where-  type WellTypedSuperC ('TLambda t1 t2) = (WellTyped t1, WellTyped t2)-instance (Comparable k, WellTyped k, WellTyped v) => WellTyped ('TMap k v) where-  type WellTypedSuperC ('TMap k v) = (Comparable k, WellTyped k, WellTyped v)-instance (Comparable k, WellTyped k, WellTyped v, HasNoBigMap v, HasNoOp v)-         => WellTyped ('TBigMap k v) where-  type WellTypedSuperC ('TBigMap k v) = ( Comparable k, WellTyped k, WellTyped v-                                        , HasNoBigMap v, HasNoOp v)-instance WellTyped 'TInt-instance WellTyped 'TNat-instance WellTyped 'TString-instance WellTyped 'TBytes-instance WellTyped 'TMutez-instance WellTyped 'TBool-instance WellTyped 'TKeyHash-instance WellTyped 'TBls12381Fr-instance WellTyped 'TBls12381G1-instance WellTyped 'TBls12381G2-instance WellTyped 'TTimestamp-instance WellTyped 'TAddress

− src/Michelson/Typed/Instr.hs

@@ -1,955 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}---- | Module, containing data types for Michelson value.-module Michelson.Typed.Instr-  ( Instr (..)-  , castInstr-  , pattern (:#)-  , ExtInstr (..)-  , CommentType (..)-  , StackRef (..)-  , mkStackRef-  , PrintComment (..)-  , TestAssert (..)-  , ContractCode-  , Contract (..)-  , defaultContract-  , mapContractCode-  , mapEntriesOrdered-  , pattern CAR-  , pattern CDR-  , pattern LEFT-  , pattern PAIR-  , pattern RIGHT-  , pattern UNPAIR-  , ConstraintDUPN-  , ConstraintDUPN'-  , ConstraintDIPN-  , ConstraintDIPN'-  , ConstraintDIG-  , ConstraintDIG'-  , ConstraintDUG-  , ConstraintDUG'-  , ConstraintPairN-  , PairN-  , RightComb-  , ConstraintUnpairN-  , UnpairN-  , ConstraintGetN-  , GetN-  , ConstraintUpdateN-  , UpdateN-  ) where--import Data.Default-import Data.Singletons (Sing)-import Data.Type.Equality ((:~:)(..))-import Data.Vinyl (RMap, Rec(..), RecordToList, ReifyConstraint(..))-import Fmt ((+||), (||+))-import GHC.TypeNats (type (+))-import qualified GHC.TypeNats as GHC (Nat)-import qualified Text.Show--import Michelson.Doc-import Michelson.ErrorPos-import Michelson.Typed.Annotation (Notes(..), starNotes)-import Michelson.Typed.Arith-import Michelson.Typed.Entrypoints-import Michelson.Typed.Polymorphic-import Michelson.Typed.Scope-import Michelson.Typed.T (T(..))-import Michelson.Typed.TypeLevel-  (CombedPairLeafCount, CombedPairLeafCountIsAtLeast, CombedPairNodeCount,-  CombedPairNodeIndexIsValid, IsPair)-import Michelson.Typed.Value (Comparable, ContractInp, ContractOut, Value'(..))-import Michelson.Untyped-  (Annotation(..), EntriesOrder(..), FieldAnn, StackFn, StackTypePattern, TypeAnn, VarAnn, VarAnns,-  entriesOrderToInt)-import Util.Peano-import Util.PeanoNatural-import Util.Sing (eqI)-import Util.TH-import Util.Type (If, KnownList, type (++))-import Util.TypeLits (ErrorMessage(ShowType, Text, (:$$:), (:<>:)), TypeErrorUnless)--{--Note [Annotations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When typechecking a sequence of instructions:--1. We'll typecheck an "untyped instruction" like `EMPTY_SET :ta @va unit`, producing:-    * a "typed instruction" `EMPTY_SET :: Instr s (TSet TUnit : s)`, and-    * an output stack with a `@va set :ta int` at the top.-2. In `Michelson.TypeCheck.Helpers.wrapWithNotes`:-    * if the original instruction had a var annotation (e.g. `SOME_INSTR @some_ann`),-      then we wrap the "typed instruction" in `InstrWithVarNotes`.-    * if the element at the top of the output stack has a var annotation,-      we wrap it in `InstrWithVarAnns`.-    * if the element at the top of the output stack has field/type anns,-      we wrap it in `InstrWithNotes`-        ```-        InstrWithNotes Proxy (NTSet "ta" (NTUnit "")) $-          InstrWithVarNotes (one "va") $-            InstrWithVarAnns (OneVarAnn "va") $-              EMPTY_SET-        ```--These "meta-instruction" wrappers are later used in the interpreter/serializer.--The interpreter ('Michelson.Interpret'):-  * Looks at the typed instruction (e.g. `EMPTY_SET`), and simply adds/removes/moves elements-    in the stack, without caring about annotations.-  * Looks at the `InstrWithNotes` and `InstrWithVarAnns` meta-instructions, and blindly-    applies a series of annotations to the output stack, without caring about the underlying-    instruction.--The serializer ('Michelson.Interpret.Pack'):-  * Looks at the `InstrWithNotes` and `InstrWithVarNotes` meta-instructions, and infers-    that the original `EMPTY_SET` instruction must have had two explicit `:ta` and `@va` annotations.--Notice that the interpreter does not care about the `InstrWithVarNotes` meta-instruction, and-the serializer does not care about the `InstrWithVarAnns` meta-instruction.----Note [Annotations - Exceptional scenarios]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--For the most part, this works without a hitch.-However, `wrapWithNotes` makes the assumption that we can infer an instruction's-original annotations by simply looking at the output stack, e.g.:--> If after running an `EMPTY_SET` instruction we end up with a `@va set :ta int`-> at the top of output stack, then we can infer that the `EMPTY_SET` instruction-> had two `@va` and `:ta` annotations.--Unfortunately, that assumption doesn't always hold.-Here are some counter examples:--* Special annotations.-    These 3 `CAR` instructions will all put a `@p.a nat` at the top of the stack:--    > PUSH @p (pair (nat %a) nat) (Pair 1 2);-    > CAR @%%;--    > PUSH (pair (nat %p.a) nat) (Pair 1 2);-    > CAR @%;--    > PUSH (pair (nat %p.a) nat) (Pair 1 2);-    > CAR @p.a;--    Therefore, it's impossible for `wrapWithNotes` to figure out what-    CAR's original var annotation was.--    This scenario affects all instructions that can take special annotations:-    - PAIR, LEFT, RIGHT: accept special field anns-    - UNPAIR, CAR, CDR: accept special var anns--* Annotations that do not affect the output stack whatsoever.-    For example, CAR may take a field annotation, but it's only used by the typechecker-    to verify that the pair in the input stack has a matching field ann.--    The following instructions will generate the exact same output stack,-    with an un-annotated `nat` at the top.--    > PUSH (pair (nat %a) nat) (Pair 1 2);-    > CAR %a;--    > PUSH (pair (nat %a) nat) (Pair 1 2);-    > CAR;--    Therefore, it's impossible for `wrapWithNotes` to figure out whether-    CAR had a field annotation.--    This scenario affects: UNPAIR, CAR, CDR.---In situations like the above, where the instruction's annotations cannot be inferred from-looking at the output stack, we have to save and store the instruction's annotations inside-the typed instruction's constructor, instead of using meta-instructions.-E.g.:--> AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s)--TODO [#580]: address the assumptions mentioned above.---}---- This next comment is needed to run the doctest examples throughout this module.---- $setup--- >>> :m +Michelson.Typed.T Util.Peano--- >>> :set -XPartialTypeSignatures---- | Constraint that is used in DUPN, we want to share it with--- typechecking code and eDSL code.-type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) =-  ( RequireLongerOrSameLength inp n, n > 'Z ~ 'True-  , inp ~ (Take (Decrement n) inp ++ (a ': Drop n inp))-  , out ~ (a ': inp)-  )--type ConstraintDUPN n inp out a = ConstraintDUPN' T n inp out a---- | Constraint that is used in DIPN, we want to share it with--- typechecking code and eDSL code.-type ConstraintDIPN' kind (n :: Peano) (inp :: [kind])-  (out :: [kind]) (s :: [kind]) (s' :: [kind]) =-  ( RequireLongerOrSameLength inp n-  , ((Take n inp) ++ s) ~ inp-  , ((Take n inp) ++ s') ~ out-  )--type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s'---- | Constraint that is used in DIG, we want to share it with--- typechecking code and eDSL code.-type ConstraintDIG' kind (n :: Peano) (inp :: [kind])-  (out :: [kind]) (a :: kind) =-  ( RequireLongerThan inp n-  , inp ~ (Take n inp ++ (a ': Drop ('S n) inp))-  , out ~ (a ': Take n inp ++ Drop ('S n) inp)-  )--type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a---- | Constraint that is used in DUG, we want to share it with--- typechecking code and eDSL code.-type ConstraintDUG' kind (n :: Peano) (inp :: [kind])-  (out :: [kind]) (a :: kind) =-  ( RequireLongerThan out n-  , inp ~ (a ': Drop ('S 'Z) inp)-  , out ~ (Take n (Drop ('S 'Z) inp) ++ (a ': Drop ('S n) inp))-  )--type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a--type ConstraintPairN (n :: Peano) (inp :: [T]) =-  ( RequireLongerOrSameLength inp n-  , TypeErrorUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n ≥ 2")-  )--type PairN (n :: Peano) (s :: [T]) = (RightComb (Take n s) ': Drop n s)---- | Folds a stack into a right-combed pair.------ > RightComb '[ 'TInt,  'TString, 'TUnit ]--- > ~--- > 'TPair 'TInt ('TPair 'TString 'TUnit)-type family RightComb (s :: [T]) :: T where-  RightComb '[ x, y ] = 'TPair x y-  RightComb (x ': xs) = 'TPair x (RightComb xs)--type ConstraintUnpairN (n :: Peano) (pair :: T) =-  ( TypeErrorUnless (n >= ToPeano 2)-      ('Text "'UNPAIR n' expects n ≥ 2")--  , TypeErrorUnless (CombedPairLeafCountIsAtLeast n pair)-      (If (IsPair pair)-        ('Text "'UNPAIR "-          ':<>: 'ShowType (FromPeano n)-          ':<>: 'Text "' expects a right-combed pair with at least "-          ':<>: 'ShowType (FromPeano n)-          ':<>: 'Text " elements at the top of the stack,"-          ':$$: 'Text "but the pair only contains "-          ':<>: 'ShowType (FromPeano (CombedPairLeafCount pair))-          ':<>: 'Text " elements.")-        ('Text "Expected a pair at the top of the stack, but found: "-          ':<>: 'ShowType pair-        )-      )-  )---- | Splits a right-combed pair into @n@ elements.------ > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString 'TUnit))--- > ~--- > '[ 'TInt, 'TString, 'TUnit]------ > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString ('TPair 'TUnit 'TInt)))--- > ~--- > '[ 'TInt, 'TString, 'TPair 'TUnit 'TInt]-type family UnpairN (n :: Peano) (s :: T) :: [T] where-  UnpairN ('S ('S 'Z)) ('TPair x y) = [x, y]-  UnpairN ('S n)       ('TPair x y) = x : UnpairN n y--type ConstraintGetN (ix :: Peano) (pair :: T) =-  ( TypeErrorUnless (CombedPairNodeIndexIsValid ix pair)-      (If (IsPair pair)-        ('Text "'GET "-          ':<>: 'ShowType (FromPeano ix)-          ':<>: 'Text "' expects a right-combed pair with at least "-          ':<>: 'ShowType (FromPeano ix + 1)-          ':<>: 'Text " nodes at the top of the stack,"-          ':$$: 'Text "but the pair only contains "-          ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))-          ':<>: 'Text " nodes.")-        ('Text "Expected a pair at the top of the stack, but found: "-          ':<>: 'ShowType pair-        )-      )-  )---- | Get the node at index @ix@ of a right-combed pair.-type family GetN (ix :: Peano) (pair :: T) :: T where-  GetN 'Z val                       = val-  GetN ('S 'Z) ('TPair left _)      = left-  GetN ('S ('S n)) ('TPair _ right) = GetN n right--type ConstraintUpdateN (ix :: Peano) (pair :: T) =-  ( TypeErrorUnless (CombedPairNodeIndexIsValid ix pair)-      (If (IsPair pair)-        ('Text "'UPDATE "-          ':<>: 'ShowType (FromPeano ix)-          ':<>: 'Text "' expects the 2nd element of the stack to be a right-combed pair with at least "-          ':<>: 'ShowType (FromPeano ix + 1)-          ':<>: 'Text " nodes,"-          ':$$: 'Text "but the pair only contains "-          ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))-          ':<>: 'Text " nodes.")-        ('Text "Expected the 2nd element of the stack to be a pair, but found: "-          ':<>: 'ShowType pair-        )-      )-  )---- | Update the node at index @ix@ of a right-combed pair.-type family UpdateN (ix :: Peano) (val :: T) (pair :: T) :: T where-  UpdateN 'Z          val _                   = val-  UpdateN ('S 'Z)     val ('TPair _  right)   = 'TPair val right-  UpdateN ('S ('S n)) val ('TPair left right) = 'TPair left (UpdateN n val right)---- | Representation of Michelson instruction or sequence--- of instructions.------ Each Michelson instruction is represented by exactly one--- constructor of this data type. Sequence of instructions--- is represented with use of @Seq@ constructor in following--- way: @SWAP; DROP ; DUP;@ -> @SWAP `Seq` DROP `Seq` DUP@.--- Special case where there are no instructions is represented--- by constructor @Nop@, e.g. @IF_NONE {} { SWAP; DROP; }@ ->--- @IF_NONE Nop (SWAP `Seq` DROP)@.------ Type parameter @inp@ states for input stack type. That is,--- type of the stack that is required for operation to execute.------ Type parameter @out@ states for output stack type or type--- of stack that will be left after instruction's execution.-data Instr (inp :: [T]) (out :: [T]) where-  -- | A wrapper carrying original source location of the instruction.-  ---  -- TODO [#283]: replace this wrapper with something more clever and abstract.-  WithLoc :: InstrCallStack -> Instr a b -> Instr a b--  -- | A wrapper for instructions that, when interpreted, will-  -- place field/type annotations on one or more of the elements at-  -- the top of the stack.-  ---  -- This can wrap only instructions with at least one non-failing execution-  -- branch.-  ---  -- See: Note [Annotations]-  InstrWithNotes-    :: forall a (topElems :: [T]) (s :: [T]).-      ( RMap topElems-      , RecordToList topElems-      , ReifyConstraint Show Notes topElems-      , ReifyConstraint NFData Notes topElems-      , Each '[ SingI ] topElems-      )-    => Proxy s -> Rec Notes topElems-    -> Instr a (topElems ++ s) -> Instr a (topElems ++ s)--  -- | A wrapper for instructions that have var annotations, e.g. `SOME_INSTR @ann1`.-  ---  -- This information is necessary for serializing the instruction back to json/binary.-  ---  -- See: Note [Annotations]-  InstrWithVarNotes :: NonEmpty VarAnn -> Instr a b -> Instr a b--  -- | A wrapper for instructions that, when interpreted, will-  -- place var annotations on one or more of the elements at-  -- the top of the stack.-  ---  -- See: Note [Annotations]-  InstrWithVarAnns :: VarAnns -> Instr a b -> Instr a b--  -- | Execute given instruction on truncated stack.-  ---  -- This can wrap only instructions with at least one non-failing execution-  -- branch.-  ---  -- Morley has no such instruction, it is used solely in eDSLs.-  -- This instruction is sound because for all Michelson instructions-  -- the following property holds: if some code accepts stack @i@ and-  -- produces stack @o@, when it can also be run on stack @i + s@-  -- producing stack @o + s@; and also because Michelson never makes-  -- implicit assumptions on types, rather you have to express all-  -- "yet ambiguous" type information in code.-  -- We could make this not an instruction but rather a function-  -- which modifies an instruction (this would also automatically prove-  -- soundness of used transformation), but it occurred to be tricky-  -- (in particular for TestAssert and DipN and family), so let's leave-  -- this for future work.-  FrameInstr-    :: forall a b s.-       (KnownList a, KnownList b)-    => Proxy s -> Instr a b -> Instr (a ++ s) (b ++ s)--  Seq :: Instr a b -> Instr b c -> Instr a c-  -- | Nop operation. Missing in Michelson spec, added to parse construction-  -- like  `IF {} { SWAP; DROP; }`.-  Nop :: Instr s s-  Ext :: ExtInstr s -> Instr s s-  -- | Nested wrapper is going to wrap a sequence of instructions with { }.-  -- It is crucial because serialisation of a contract-  -- depends on precise structure of its code.-  Nested :: Instr inp out -> Instr inp out-  -- | Places documentation generated for given instruction under some group.-  -- This is not part of 'ExtInstr' because it does not behave like 'Nop';-  -- instead, it inherits the behaviour of the instruction put within it.-  DocGroup :: DocGrouping -> Instr inp out -> Instr inp out-  -- | Represents a typed stack function.-  -- This is not part of 'ExtInstr' because it does not behave like 'Nop';-  -- instead, it inherits the behaviour of the instruction put within it.-  Fn :: Text -> StackFn -> Instr inp out -> Instr inp out--  -- | CAR and CDR's original annotations must be retained inside-  -- the instruction's constructor.-  -- See: Note [Annotations - Exceptional scenarios].-  AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s)-  AnnCDR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (b ': s)--  -- Note that we can not merge DROP and DROPN into one instruction-  -- because they are packed differently.-  DROP :: Instr (a ': s) s-  DROPN-    :: forall (n :: Peano) s.-    (RequireLongerOrSameLength s n, NFData (Sing n))-    => PeanoNatural n -> Instr s (Drop n s)-  DUP :: DupableScope a => Instr (a ': s) (a ': a ': s)-  DUPN-    :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, DupableScope a, NFData (Sing n))-    => PeanoNatural n -> Instr inp out-  SWAP :: Instr (a ': b ': s) (b ': a ': s)-  DIG-    :: forall (n :: Peano) inp out a. (ConstraintDIG n inp out a, NFData (Sing n))-    => PeanoNatural n -> Instr inp out-  DUG-    :: forall (n :: Peano) inp out a. (ConstraintDUG n inp out a, NFData (Sing n))-    => PeanoNatural n -> Instr inp out-  PUSH-    :: forall t s . ConstantScope t-    => Value' Instr t -> Instr s (t ': s)-  SOME :: Instr (a ': s) ('TOption a ': s)-  NONE :: forall a s . SingI a => Instr s ('TOption a ': s)-  UNIT :: Instr s ('TUnit ': s)-  IF_NONE-    :: Instr s s'-    -> Instr (a ': s) s'-    -> Instr ('TOption a ': s) s'-  -- | PAIR's original annotations must be retained inside-  -- the instruction's constructor.-  -- See: Note [Annotations - Exceptional scenarios].-  AnnPAIR :: TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': b ': s) ('TPair a b ': s)-  -- | UNPAIR's original annotations must be retained inside-  -- the instruction's constructor.-  -- See: Note [Annotations - Exceptional scenarios].-  AnnUNPAIR :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': b ': s)-  -- |-  -- >>> :t PAIRN (toPeanoNatural' @3) :: Instr '[ 'TInt, 'TUnit, 'TString ] _-  -- ...-  -- ...:: Instr-  -- ...    '[ 'TInt, 'TUnit, 'TString]-  -- ...    '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]-  ---  ---  -- >>> PAIRN (toPeanoNatural' @1) :: Instr '[ 'TInt, 'TInt ] _-  -- ...-  -- ... 'PAIR n' expects n ≥ 2-  -- ...-  ---  -- >>> PAIRN (toPeanoNatural' @3) :: Instr '[ 'TInt, 'TInt ] _-  -- ...-  -- ... Expected stack with length >= 3-  -- ... Current stack has size of only 2:-  -- ...-  PAIRN-    :: forall n inp. ConstraintPairN n inp-    => PeanoNatural n -> Instr inp (PairN n inp)-  -- |-  -- >>> :t UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit 'TString) ] _-  -- ...-  -- ...:: Instr-  -- ...   '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]-  -- ...   '[ 'TInt, 'TUnit, 'TString]-  ---  -- >>> :t UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat)) ] _-  -- ...-  -- ...:: Instr-  -- ...   '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat))]-  -- ...   '[ 'TInt, 'TUnit, 'TPair 'TString 'TNat]-  ---  -- >>> UNPAIRN (toPeanoNatural' @1) :: Instr '[ 'TPair 'TInt 'TUnit ] _-  -- ...-  -- ...'UNPAIR n' expects n ≥ 2-  -- ...-  ---  -- >>> UNPAIRN (toPeanoNatural' @2) :: Instr '[ 'TInt, 'TUnit, 'TString ] _-  -- ...-  -- ...Expected a pair at the top of the stack, but found: 'TInt-  -- ...-  ---  -- >>> UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _-  -- ...-  -- ...'UNPAIR 3' expects a right-combed pair with at least 3 elements at the top of the stack,-  -- ...but the pair only contains 2 elements.-  -- ...-  UNPAIRN-    :: forall (n :: Peano) (pair :: T) (s :: [T]).-       ConstraintUnpairN n pair-    => PeanoNatural n-    -> Instr (pair : s) (UnpairN n pair ++ s)--  -- | LEFT and RIGHT's original annotations must be retained inside-  -- the instruction's constructor.-  -- See: Note [Annotations - Exceptional scenarios].-  AnnLEFT :: SingI b => TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': s) ('TOr a b ': s)-  AnnRIGHT :: SingI a => TypeAnn -> FieldAnn -> FieldAnn -> Instr (b ': s) ('TOr a b ': s)-  IF_LEFT-    :: Instr (a ': s) s'-    -> Instr (b ': s) s'-    -> Instr ('TOr a b ': s) s'-  NIL :: SingI p => Instr s ('TList p ': s)-  CONS :: Instr (a ': 'TList a ': s) ('TList a ': s)-  IF_CONS-    :: Instr (a ': 'TList a ': s) s'-    -> Instr s s'-    -> Instr ('TList a ': s) s'-  SIZE :: SizeOp c => Instr (c ': s) ('TNat ': s)-  EMPTY_SET :: (SingI e, Comparable e) => Instr s ('TSet e ': s)-  EMPTY_MAP :: (SingI a, SingI b, Comparable a) => Instr s ('TMap a b ': s)-  EMPTY_BIG_MAP :: (SingI a, SingI b, Comparable a, HasNoBigMap b) => Instr s ('TBigMap a b ': s)-  MAP :: (MapOp c, SingI b)-      => Instr (MapOpInp c ': s) (b ': s)-      -> Instr (c ': s) (MapOpRes c b ': s)-  ITER :: IterOp c => Instr (IterOpEl c ': s) s -> Instr (c ': s) s-  MEM :: MemOp c => Instr (MemOpKey c ': c ': s) ('TBool ': s)-  GET-    :: (GetOp c, SingI (GetOpVal c))-    => Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s)-  -- | Get the node at index @ix@ of a right-combed pair.-  -- Nodes are 0-indexed, and are numbered in a breadth-first,-  -- left-to-right fashion.-  ---  -- For example, a pair with 3 elements @pair a b c@ will be-  -- represented as a tree with 5 nodes:-  ---  -- >    pair-  -- >    /   \-  -- >  a     pair-  -- >        /   \-  -- >      b       c-  ---  -- Where the nodes are numbered as follows:-  ---  -- >      0-  -- >    /   \-  -- >  1       2-  -- >        /   \-  -- >      3       4-  ---  -- >>> :t GETN (toPeanoNatural' @1) :: Instr '[ 'TPair 'TInt 'TUnit] _-  -- ...-  -- ...:: Instr '[ 'TPair 'TInt 'TUnit] '[ 'TInt]-  ---  -- >>> GETN (toPeanoNatural' @1) :: Instr '[ 'TUnit ] _-  -- ...-  -- ...Expected a pair at the top of the stack, but found: 'TUnit-  -- ...-  ---  -- >>> GETN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _-  -- ...-  -- ...'GET 3' expects a right-combed pair with at least 4 nodes at the top of the stack,-  -- ...but the pair only contains 3 nodes.-  -- ...-  ---  -- Note that @GET 0@ is just the identity function and works for all types (not just pairs).-  ---  -- >>> :t GETN (toPeanoNatural' @0) :: Instr '[ 'TInt ] _-  -- ...-  -- ...:: Instr '[ 'TInt] '[ 'TInt]-  GETN-    :: forall (ix :: Peano) (pair :: T) (s :: [T]).-       ConstraintGetN ix pair-    => PeanoNatural ix-    -> Instr (pair : s) (GetN ix pair ': s)-  UPDATE-    :: UpdOp c-    => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) (c ': s)-  -- | Update the node at index @ix@ of a right-combed pair.-  ---  -- >>> :t UPDATEN (toPeanoNatural' @1) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit] _-  -- ...-  -- ...:: Instr-  -- ...     '[ 'TString, 'TPair 'TInt 'TUnit] '[ 'TPair 'TString 'TUnit]-  ---  -- >>> UPDATEN (toPeanoNatural' @1) :: Instr '[ 'TUnit, 'TInt ] _-  -- ...-  -- ...Expected the 2nd element of the stack to be a pair, but found: 'TInt-  -- ...-  ---  -- >>> UPDATEN (toPeanoNatural' @3) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit ] _-  -- ...-  -- ...'UPDATE 3' expects the 2nd element of the stack to be a right-combed pair with at least 4 nodes,-  -- ...but the pair only contains 3 nodes.-  -- ...-  ---  -- Note that @UPDATE 0@ is equivalent to @DIP { DROP }@.-  ---  -- >>> :t UPDATEN (toPeanoNatural' @0) :: Instr '[ 'TInt, 'TString ] _-  -- ...-  -- ...:: Instr '[ 'TInt, 'TString] '[ 'TInt]-  UPDATEN-    :: forall (ix :: Peano) (val :: T) (pair :: T) (s :: [T]).-       ConstraintUpdateN ix pair-    => PeanoNatural ix-    -> Instr (val : pair : s) (UpdateN ix val pair ': s)-  GET_AND_UPDATE-    :: ( GetOp c, UpdOp c, SingI (GetOpVal c)-       , UpdOpKey c ~ GetOpKey c-       )-    => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) ('TOption (GetOpVal c) : c ': s)-  IF :: Instr s s'-     -> Instr s s'-     -> Instr ('TBool ': s) s'-  LOOP :: Instr s ('TBool ': s)-       -> Instr ('TBool ': s) s-  LOOP_LEFT-    :: Instr (a ': s) ('TOr a b ': s)-    -> Instr ('TOr a b ': s) (b ': s)-  LAMBDA :: forall i o s . (SingI i, SingI o)-         => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s)-  EXEC :: Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s)-  APPLY-    :: forall a b c s . (ConstantScope a, SingI b)-    => Instr (a ': 'TLambda ('TPair a b) c ': s) ('TLambda b c ': s)-  DIP :: Instr a c -> Instr (b ': a) (b ': c)-  DIPN-    :: forall (n :: Peano) inp out s s'. (ConstraintDIPN n inp out s s', (NFData (Sing n)))-    => PeanoNatural n -> Instr s s' -> Instr inp out-  -- Since 008 it's prohibited to fail with non-packable values and with the-  -- 'Contract t' type values, which is equivalent to our @ConstantScope@ constraint.-  -- See https://gitlab.com/tezos/tezos/-/issues/1093#note_496066354 for more information.-  FAILWITH :: (SingI a, ConstantScope a) => Instr (a ': s) t-  CAST :: forall a s . SingI a => Instr (a ': s) (a ': s)-  RENAME :: Instr (a ': s) (a ': s)-  PACK :: PackedValScope a => Instr (a ': s) ('TBytes ': s)-  UNPACK :: (UnpackedValScope a, SingI a) => Instr ('TBytes ': s) ('TOption a ': s)-  CONCAT :: ConcatOp c => Instr (c ': c ': s) (c ': s)-  CONCAT' :: ConcatOp c => Instr ('TList c ': s) (c ': s)-  SLICE-    :: (SliceOp c, SingI c)-    => Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s)-  ISNAT :: Instr ('TInt ': s) ('TOption ('TNat) ': s)-  ADD-    :: ArithOp Add n m-    => Instr (n ': m ': s) (ArithRes Add n m ': s)-  SUB-    :: ArithOp Sub n m-    => Instr (n ': m ': s) (ArithRes Sub n m ': s)-  MUL-    :: ArithOp Mul n m-    => Instr (n ':  m ': s) (ArithRes Mul n m ': s)-  EDIV-    :: EDivOp n m-    => Instr (n ':  m ': s)-                 (('TOption ('TPair (EDivOpRes n m)-                                      (EModOpRes n m))) ': s)-  ABS-    :: UnaryArithOp Abs n-    => Instr (n ': s) (UnaryArithRes Abs n ': s)-  NEG-    :: UnaryArithOp Neg n-    => Instr (n ': s) (UnaryArithRes Neg n ': s)-  LSL-    :: ArithOp Lsl n m-    => Instr (n ': m ': s) (ArithRes Lsl n m ': s)-  LSR-    :: ArithOp Lsr n m-    => Instr (n ':  m ': s) (ArithRes Lsr n m ': s)-  OR-    :: ArithOp Or n m-    => Instr (n ': m ': s) (ArithRes Or n m ': s)-  AND-    :: ArithOp And n m-    => Instr (n ': m ': s) (ArithRes And n m ': s)-  XOR-    :: ArithOp Xor n m-    => Instr (n ': m ': s) (ArithRes Xor n m ': s)-  NOT-    :: UnaryArithOp Not n-    => Instr (n ': s) (UnaryArithRes Not n ': s)-  COMPARE-    :: (Comparable n, SingI n)-    => Instr (n ': n ': s) ('TInt ': s)-  EQ-    :: UnaryArithOp Eq' n-    => Instr (n ': s) (UnaryArithRes Eq' n ': s)-  NEQ-    :: UnaryArithOp Neq n-    => Instr (n ': s) (UnaryArithRes Neq n ': s)-  LT-    :: UnaryArithOp Lt n-    => Instr (n ': s) (UnaryArithRes Lt n ': s)-  GT-    :: UnaryArithOp Gt n-    => Instr (n ': s) (UnaryArithRes Gt n ': s)-  LE-    :: UnaryArithOp Le n-    => Instr (n ': s) (UnaryArithRes Le n ': s)-  GE-    :: UnaryArithOp Ge n-    => Instr (n ': s) (UnaryArithRes Ge n ': s)-  INT-    :: ToIntArithOp n-    => Instr (n ': s) ('TInt ': s)-  SELF-    :: forall (arg :: T) s .-       (ParameterScope arg)-    => SomeEntrypointCallT arg-    -> Instr s ('TContract arg ': s)-  CONTRACT-    :: (ParameterScope p)-    => Notes p   -- Store Notes to be able to verify CONTRACT in typechecker-    -> EpName-    -> Instr ('TAddress ': s) ('TOption ('TContract p) ': s)-  TRANSFER_TOKENS-    :: (ParameterScope p) =>-       Instr (p ': 'TMutez ': 'TContract p ': s)-                   ('TOperation ': s)-  SET_DELEGATE-    :: Instr ('TOption 'TKeyHash ': s) ('TOperation ': s)--  CREATE_CONTRACT-    :: (ParameterScope p, StorageScope g)-    => Contract p g-    -> Instr ('TOption 'TKeyHash ':-              'TMutez ':-               g ': s)-             ('TOperation ': 'TAddress ': s)-  IMPLICIT_ACCOUNT-    :: Instr ('TKeyHash ': s) ('TContract 'TUnit ': s)-  NOW :: Instr s ('TTimestamp ': s)-  AMOUNT :: Instr s ('TMutez ': s)-  BALANCE :: Instr s ('TMutez ': s)-  VOTING_POWER :: Instr ('TKeyHash ': s) ('TNat ': s)-  TOTAL_VOTING_POWER :: Instr s ('TNat ': s)-  CHECK_SIGNATURE-    :: Instr ('TKey ': 'TSignature ': 'TBytes ': s)-                   ('TBool ': s)-  SHA256 :: Instr ('TBytes ': s) ('TBytes ': s)-  SHA512 :: Instr ('TBytes ': s) ('TBytes ': s)-  BLAKE2B :: Instr ('TBytes ': s) ('TBytes ': s)-  SHA3 :: Instr ('TBytes ': s) ('TBytes ': s)-  KECCAK :: Instr ('TBytes ': s) ('TBytes ': s)-  HASH_KEY :: Instr ('TKey ': s) ('TKeyHash ': s)-  PAIRING_CHECK-    :: Instr ('TList ('TPair 'TBls12381G1 'TBls12381G2) ': s) ('TBool ': s)-  SOURCE :: Instr s ('TAddress ': s)-  SENDER :: Instr s ('TAddress ': s)-  ADDRESS :: Instr ('TContract a ': s) ('TAddress ': s)-  CHAIN_ID :: Instr s ('TChainId ': s)-  LEVEL :: Instr s ('TNat ': s)-  SELF_ADDRESS :: Instr s ('TAddress ': s)-  NEVER :: Instr ('TNever ': s) t-  TICKET-    :: (Comparable a)-    => Instr (a ': 'TNat ': s) ('TTicket a ': s)-  READ_TICKET-    :: Instr ('TTicket a ': s)-             (RightComb ['TAddress, a, 'TNat] ': 'TTicket a ': s)-  SPLIT_TICKET-    :: Instr ('TTicket a ': 'TPair 'TNat 'TNat ': s)-             ('TOption ('TPair ('TTicket a) ('TTicket a)) ': s)-  JOIN_TICKETS-    :: Instr ('TPair ('TTicket a) ('TTicket a) ': s)-             ('TOption ('TTicket a) ': s)--castInstr-  :: forall inp1 out1 inp2 out2.-  ( SingI inp1-  , SingI out1-  , SingI inp2-  , SingI out2-  )-  => Instr inp1 out1 -> Maybe (Instr inp2 out2)-castInstr instr =-  case (eqI @inp1 @inp2, eqI @out1 @out2) of-    (Just Refl, Just Refl) -> Just instr-    (_,_) -> Nothing---- | Right-associative operator for 'Seq'.------ >>> show (DROP :# UNIT :# Nop) == show (DROP :# (UNIT :# Nop))--- True-pattern (:#) :: Instr a b -> Instr b c -> Instr a c-pattern a :# b = Seq a b-infixr 8 :#--deriving stock instance Show (Instr inp out)--instance Semigroup (Instr s s) where-  (<>) = Seq-instance Monoid (Instr s s) where-  mempty = Nop---- We have to write down pattern like this because simple--- @Instr (TPair a b : s) (a : s)@ signature would assume that we /expect/--- the input stack to have pair on top, but we want to /provide/ this info--- in scope of a pattern-match.--- In pattern declaration we have to write down the two mentioned constraints--- explicitly.------ Note that internally GADT constructors are rewritten in the very same way.-pattern CAR :: () => (i ~ ('TPair a b : s), o ~ (a : s)) => Instr i o-pattern CAR = AnnCAR (UnsafeAnnotation "") (UnsafeAnnotation "")--pattern CDR :: () => (i ~ ('TPair a b : s), o ~ (b : s)) => Instr i o-pattern CDR = AnnCDR (UnsafeAnnotation "") (UnsafeAnnotation "")--pattern UNPAIR :: () => (i ~ ('TPair a b : s), o ~ (a : b : s)) => Instr i o-pattern UNPAIR = AnnUNPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")--pattern PAIR :: () => (i ~ (a ': b ': s), o ~ ('TPair a b ': s)) => Instr i o-pattern PAIR = AnnPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")--pattern LEFT :: () => (SingI b, i ~ (a ': s), o ~ ('TOr a b ': s)) => Instr i o-pattern LEFT = AnnLEFT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")--pattern RIGHT :: () => (SingI a, i ~ (b ': s), o ~ ('TOr a b ': s)) => Instr i o-pattern RIGHT = AnnRIGHT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")--data TestAssert (s :: [T]) where-  TestAssert-    :: (SingI out)-    => Text-    -> PrintComment inp-    -> Instr inp ('TBool ': out)-    -> TestAssert inp--deriving stock instance Show (TestAssert s)-instance NFData (TestAssert s) where-  rnf (TestAssert a b c) = rnf (a, b, c)---- | A reference into the stack of a given type.-data StackRef (st :: [T]) where-  -- | Keeps 0-based index to a stack element counting from the top.-  StackRef-    :: (RequireLongerThan st idx)-    => PeanoNatural idx -> StackRef st--instance NFData (StackRef st) where-  rnf (StackRef s) = rnf s--instance Eq (StackRef st) where-  StackRef snat1 == StackRef snat2 = fromPeanoNatural snat1 == fromPeanoNatural snat2--instance Show (StackRef st) where-  show (StackRef snat) = "StackRef {" +|| fromPeanoNatural snat ||+ "}"---- | Create a stack reference, performing checks at compile time.-mkStackRef-  :: forall (gn :: GHC.Nat) st n.-      (n ~ ToPeano gn, SingI (ToPeano gn), RequireLongerThan st n)-  => StackRef st-mkStackRef = StackRef $ toPeanoNatural' @gn---- | A print format with references into the stack-newtype PrintComment (st :: [T]) = PrintComment-  { unPrintComment :: [Either Text (StackRef st)]-  } deriving stock (Eq, Show, Generic)-    deriving newtype (Semigroup, Monoid)--instance NFData (PrintComment st)--instance IsString (PrintComment st) where-  fromString = PrintComment . one . Left . fromString--data CommentType- = FunctionStarts Text- | FunctionEnds Text- | StatementStarts Text- | StatementEnds Text- | JustComment Text- | StackTypeComment (Maybe [T]) -- ^ 'Nothing' for any stack type- deriving stock (Show, Generic)--instance NFData CommentType--data ExtInstr s-  = TEST_ASSERT (TestAssert s)-  | PRINT (PrintComment s)-  | DOC_ITEM SomeDocItem-  | COMMENT_ITEM CommentType-  | STACKTYPE StackTypePattern-  deriving stock (Show, Generic)--instance NFData (ExtInstr s)-------------------------------------------------------type ContractCode cp st = Instr (ContractInp cp st) (ContractOut st)---- | Typed contract and information about annotations--- which is not present in the contract code.-data Contract cp st = (ParameterScope cp, StorageScope st) => Contract-  { cCode       :: ContractCode cp st-  , cParamNotes :: ParamNotes cp-  , cStoreNotes :: Notes st-  , cEntriesOrder :: EntriesOrder-  }--deriving stock instance Show (Contract cp st)-deriving stock instance Eq (ContractCode cp st) => Eq (Contract cp st)-instance NFData (Contract cp st) where-  rnf (Contract a b c d) = rnf (a, b, c, d)--defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode cp st -> Contract cp st-defaultContract code = Contract-  { cCode = code-  , cParamNotes = starParamNotes-  , cStoreNotes = starNotes-  , cEntriesOrder = def-  }--mapContractCode-  :: (ContractCode cp st -> ContractCode cp st)-  -> Contract cp st-  -> Contract cp st-mapContractCode f contract = contract { cCode = f $ cCode contract }---- | Map each typed contract fields by the given function and sort the output--- based on the 'EntriesOrder'.-mapEntriesOrdered-  :: Contract cp st-  -> (ParamNotes cp -> a)-  -> (Notes st -> a)-  -> (ContractCode cp st -> a)-  -> [a]-mapEntriesOrdered Contract{..} fParam fStorage fCode =-  fmap snd-    $ sortWith fst-        [ (paramPos, fParam cParamNotes)-        , (storagePos, fStorage cStoreNotes)-        , (codePos, fCode cCode)-        ]-  where-    (paramPos, storagePos, codePos) = entriesOrderToInt cEntriesOrder--$(deriveGADTNFData ''Instr)

− src/Michelson/Typed/OpSize.hs

@@ -1,34 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Measuring operation size of typed stuff.-module Michelson.Typed.OpSize-  ( OpSize (..)-  , U.opSizeHardLimit-  , U.smallTransferOpSize--  , instrOpSize-  , contractOpSize-  , valueOpSize-  ) where--import Michelson.Typed.Aliases-import Michelson.Typed.Convert-import Michelson.Typed.Instr-import Michelson.Typed.Scope-import Michelson.Untyped (OpSize)-import qualified Michelson.Untyped as U---- | Estimate instruction operation size.-instrOpSize :: Instr inp out -> OpSize-instrOpSize = U.expandedInstrsOpSize . instrToOps---- | Estimate contract code operation size.-contractOpSize :: Contract cp st -> OpSize-contractOpSize = instrOpSize . cCode---- | Estimate value operation size.--- TODO: [#428]: do not use 'PrintedValScope' here.-valueOpSize :: (PrintedValScope t) => Value t -> OpSize-valueOpSize = U.valueOpSize . untypeValue

− src/Michelson/Typed/Origination.hs

@@ -1,110 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Typed.Origination-  ( OriginationOperation(..)-  , mkOriginationOperationHash--  -- * Operation hashing-  , OperationHash (..)-  , mkContractAddress--  ) where--import Data.Binary.Put (putInt32be, putWord64be, runPut)-import qualified Data.ByteString.Lazy as BSL--import Michelson.Interpret.Pack (toBinary')-import Michelson.Typed.Aliases (Value)-import Michelson.Typed.Haskell.Value (IsoValue(..))-import Michelson.Typed.Instr (Contract(..), cCode)-import Michelson.Typed.Scope (ParameterScope, StorageScope)-import Tezos.Address-  (Address(ContractAddress), ContractHash(..), GlobalCounter(..), OriginationIndex(..))-import Tezos.Core (Mutez(..))-import Tezos.Crypto (KeyHash, blake2b, blake2b160)---- | Data necessary to originate a contract.-data OriginationOperation =-  forall cp st.-  (StorageScope st, ParameterScope cp) =>-  OriginationOperation-  { ooOriginator :: Address-  -- ^ Originator of the contract.-  , ooDelegate :: Maybe KeyHash-  -- ^ Optional delegate.-  , ooBalance :: Mutez-  -- ^ Initial balance of the contract.-  , ooStorage :: Value st-  -- ^ Initial storage value of the contract.-  , ooContract :: Contract cp st-  -- ^ The contract itself.-  }--deriving stock instance Show OriginationOperation---- | Construct 'OperationHash' for an 'OriginationOperation'.-mkOriginationOperationHash :: OriginationOperation -> OperationHash-mkOriginationOperationHash OriginationOperation{..} =-  OperationHash $ blake2b packedOperation-  where-    -- In Tezos OriginationOperation is encoded as 4-tuple of-    -- (balance, optional delegate, code, storage)-    ---    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L314-    -- and https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/script_repr.ml#L68-    packedOperation =-      BSL.toStrict (runPut $ putWord64be $ unMutez ooBalance)-      <> packMaybe (toBinary' . toVal) ooDelegate-      <> toBinary' (cCode ooContract)-      <> toBinary' ooStorage--    -- "optional" encoding in Tezos.-    ---    -- See https://gitlab.com/nomadic-labs/data-encoding/-/blob/2c2b795a37e7d76e3eaa861da9855f2098edc9b9/src/binary_writer.ml#L278-283-    packMaybe :: (a -> ByteString) -> Maybe a -> ByteString-    packMaybe _ Nothing = "\255"-    packMaybe f (Just a) = "\0" <> f a--------------------------------------------------------------------------------- Operation hash-------------------------------------------------------------------------------newtype OperationHash = OperationHash-  { unOperationHash :: ByteString-  }-  deriving stock (Show, Eq, Ord, Generic)-  deriving anyclass (NFData)---- | Compute address of a contract from its origination operation, origination index and global counter.------ However, in real Tezos encoding of the operation is more than just 'OriginationOperation'.--- There an Operation has several more meta-fields plus a big sum-type of all possible operations.------ See here: https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78------ What is important is that one (big) Operation may lead to origination of multiple contracts. That--- is why contract address is constructed from hash of the operation that originated and of index--- of the contract's origination in the execution of that operation.------ In other words, contract hash is calculated as the blake2b160 (20-byte) hash of--- origination operation hash + int32 origination index + word64 global counter.------ In Morley we do not yet support full encoding of Tezos Operations, therefore we choose--- to generate contract addresses in a simplified manner.------ Namely, we encode 'OriginationOperation' as we can and concat it with the origination index--- and the global counter.--- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's--- address.-mkContractAddress-  :: OperationHash-  -> OriginationIndex-  -> GlobalCounter-  -> Address-mkContractAddress (OperationHash opHash) (OriginationIndex idx) (GlobalCounter counter) =-  ContractAddress-  $ ContractHash-  $ blake2b160-  $ opHash <> BSL.toStrict (runPut $ putInt32be idx >> putWord64be counter)

− src/Michelson/Typed/Polymorphic.hs

@@ -1,282 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, containing type classes for operating with Michelson values--- in the context of polymorphic stack type operations.--module Michelson.Typed.Polymorphic-  ( EDivOp (..)-  , MemOp (..)-  , MapOp (..)-  , IterOp (..)-  , SizeOp (..)-  , GetOp (..)-  , UpdOp (..)-  , SliceOp (..)-  , ConcatOp (..)-  , divMich-  , modMich-  ) where--import qualified Data.ByteString as B-import qualified Data.Map as M-import qualified Data.Set as S-import Data.Singletons (SingI)--import Michelson.Text-import Michelson.Typed.Annotation-import Michelson.Typed.T (T(..))-import Michelson.Typed.Value (Value'(..))-import Michelson.Untyped.Annotation (noAnn)--import Tezos.Core (divModMutez, divModMutezInt)--class MemOp (c :: T) where-  type MemOpKey c :: T-  evalMem :: Value' instr (MemOpKey c) -> Value' instr c -> Bool-instance MemOp ('TSet e) where-  type MemOpKey ('TSet e) = e-  evalMem e (VSet s) = e `S.member` s-instance MemOp ('TMap k v) where-  type MemOpKey ('TMap k v) = k-  evalMem k (VMap m) = k `M.member` m-instance MemOp ('TBigMap k v) where-  type MemOpKey ('TBigMap k v) = k-  evalMem k (VBigMap _ m) = k `M.member` m--class MapOp (c :: T) where-  type MapOpInp c :: T-  type MapOpRes c :: T -> T-  mapOpToList :: Value' instr c -> [Value' instr (MapOpInp c)]-  mapOpFromList-    :: (SingI b)-    => Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b)-  mapOpNotes :: Notes c -> Notes (MapOpInp c)-instance MapOp ('TMap k v) where-  type MapOpInp ('TMap k v) = 'TPair k v-  type MapOpRes ('TMap k v) = 'TMap k-  mapOpToList (VMap m) = map (\(k, v) -> VPair (k, v)) $ M.toAscList m-  mapOpFromList (VMap m) l =-    VMap $ M.fromList $ zip (map fst $ M.toAscList m) l-  mapOpNotes (NTMap _ nk nv) = NTPair noAnn noAnn noAnn noAnn noAnn nk nv-instance MapOp ('TList e) where-  type MapOpInp ('TList e) = e-  type MapOpRes ('TList e) = 'TList-  mapOpToList (VList l) = l-  mapOpFromList (VList _) l' = VList l'-  mapOpNotes (NTList _ n) = n--- If you find it difficult to implement 'MapOp' for your datatype--- because of order of type arguments in it, consider wrapping it--- into a newtype.--class IterOp (c :: T) where-  type IterOpEl c :: T-  iterOpDetachOne ::-    Value' instr c -> (Maybe (Value' instr (IterOpEl c)), Value' instr c)-  iterOpNotes :: Notes c -> Notes (IterOpEl c)-instance IterOp ('TMap k v) where-  type IterOpEl ('TMap k v) = 'TPair k v-  iterOpDetachOne (VMap m) =-    (VPair <$> M.lookupMin m, VMap $ M.deleteMin m)-  iterOpNotes (NTMap _ nk nv) = NTPair noAnn noAnn noAnn noAnn noAnn nk nv-instance IterOp ('TList e) where-  type IterOpEl ('TList e) = e-  iterOpDetachOne (VList l) =-    case l of-      x : xs -> (Just x, VList xs)-      [] -> (Nothing, VList [])-  iterOpNotes (NTList _ n) = n-instance IterOp ('TSet e) where-  type IterOpEl ('TSet e) = e-  iterOpDetachOne (VSet s) = (S.lookupMin s, VSet $ S.deleteMin s)-  iterOpNotes (NTSet _ n) = n--class SizeOp (c :: T) where-  evalSize :: Value' instr c -> Int-instance SizeOp 'TString where-  evalSize (VString s) = length s-instance SizeOp ('TBytes) where-  evalSize (VBytes b) = length b-instance SizeOp ('TSet a) where-  evalSize (VSet s) = S.size s-instance SizeOp ('TList a) where-  evalSize (VList l) = length l-instance SizeOp ('TMap k v) where-  evalSize (VMap m) = M.size m--class UpdOp (c :: T) where-  type UpdOpKey c :: T-  type UpdOpParams c :: T-  evalUpd-    :: Value' instr (UpdOpKey c)-    -> Value' instr (UpdOpParams c) -> Value' instr c -> Value' instr c-instance UpdOp ('TMap k v) where-  type UpdOpKey ('TMap k v) = k-  type UpdOpParams ('TMap k v) = 'TOption v-  evalUpd k (VOption o) (VMap m) =-    case o of-      Just newV -> VMap $ M.insert k newV m-      Nothing -> VMap $ M.delete k m-instance UpdOp ('TBigMap k v) where-  type UpdOpKey ('TBigMap k v) = k-  type UpdOpParams ('TBigMap k v) = 'TOption v-  evalUpd k (VOption o) (VBigMap bmId m) =-    case o of-      Just newV -> VBigMap bmId $ M.insert k newV m-      Nothing -> VBigMap bmId $ M.delete k m-instance UpdOp ('TSet a) where-  type UpdOpKey ('TSet a) = a-  type UpdOpParams ('TSet a) = 'TBool-  evalUpd k (VBool b) (VSet s) =-    case b of-      True -> VSet $ S.insert k s-      False -> VSet $ S.delete k s--class GetOp (c :: T) where-  type GetOpKey c :: T-  type GetOpVal c :: T-  evalGet :: Value' instr (GetOpKey c) -> Value' instr c -> Maybe (Value' instr (GetOpVal c))-instance GetOp ('TBigMap k v) where-  type GetOpKey ('TBigMap k v) = k-  type GetOpVal ('TBigMap k v) = v-  evalGet k (VBigMap _ m) = k `M.lookup` m-instance GetOp ('TMap k v) where-  type GetOpKey ('TMap k v) = k-  type GetOpVal ('TMap k v) = v-  evalGet k (VMap m) = k `M.lookup` m--class ConcatOp (c :: T) where-  evalConcat :: Value' instr c -> Value' instr c -> Value' instr c-  evalConcat' :: [Value' instr c] -> Value' instr c-instance ConcatOp ('TString) where-  evalConcat (VString s1) (VString s2) = (VString) (s1 <> s2)-  evalConcat' l =-    (VString) $ mconcat $ map (\(VString s) -> s) l-instance ConcatOp ('TBytes) where-  evalConcat (VBytes b1) (VBytes b2) = VBytes (b1 <> b2)-  evalConcat' l =-    (VBytes) $ foldr ((<>) . (\(VBytes b) -> b)) mempty l--class SliceOp (c :: T) where-  evalSlice :: Natural -> Natural -> Value' instr c -> Maybe (Value' instr c)-instance SliceOp 'TString where-  evalSlice o l (VString s) =-    VString <$> sliceImpl dropMText takeMText o l s-instance SliceOp 'TBytes where-  evalSlice o l (VBytes b) =-    VBytes <$> sliceImpl B.drop B.take o l b--sliceImpl ::-  Container str-  => (Int -> str -> str)-  -> (Int -> str -> str)-  -> Natural-  -> Natural-  -> str-  -> Maybe str-sliceImpl dropF takeF offset l s-  | offset >= fromIntegral (length s) || offset + l > fromIntegral (length s) =-    Nothing-  | otherwise-  -- Drop offset and then take requested number of items.-   = Just . takeF (fromIntegral l) . dropF (fromIntegral offset) $ s--class EDivOp (n :: T) (m :: T) where-  type EDivOpRes n m :: T-  type EModOpRes n m :: T--  -- | Converge the notes of given operands.-  convergeEDiv-    :: Notes n-    -> Notes m-    -> Either AnnConvergeError-        (Notes ('TOption ('TPair (EDivOpRes n m)-                                  (EModOpRes n m))))--  evalEDivOp-    :: Value' instr n-    -> Value' instr m-    -> Value' instr ('TOption ('TPair (EDivOpRes n m)-                                     (EModOpRes n m)))--instance EDivOp 'TInt 'TInt where-  type EDivOpRes 'TInt 'TInt = 'TInt-  type EModOpRes 'TInt 'TInt = 'TNat-  convergeEDiv n1 n2 =-    (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a $ NTNat noAnn)-      <$> converge n1 n2-  evalEDivOp (VInt i) (VInt j) =-    if j == 0-      then VOption $ Nothing-      else VOption $ Just $-        VPair (VInt (divMich i j), VNat $ fromInteger $ modMich i j)-instance EDivOp 'TInt 'TNat where-  type EDivOpRes 'TInt 'TNat = 'TInt-  type EModOpRes 'TInt 'TNat = 'TNat-  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1-    $ NTNat noAnn-  evalEDivOp (VInt i) (VNat j) =-    if j == 0-      then VOption $ Nothing-      else VOption $ Just $-        VPair (VInt (divMich i (toInteger j)), VNat $ fromInteger $ modMich i (toInteger j))-instance EDivOp 'TNat 'TInt where-  type EDivOpRes 'TNat 'TInt = 'TInt-  type EModOpRes 'TNat 'TInt = 'TNat-  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn-    (NTInt noAnn) n1-  evalEDivOp (VNat i) (VInt j) =-    if j == 0-      then VOption $ Nothing-      else VOption $ Just $-        VPair (VInt (divMich (toInteger i) j), VNat $ fromInteger $ modMich (toInteger i) j)-instance EDivOp 'TNat 'TNat where-  type EDivOpRes 'TNat 'TNat = 'TNat-  type EModOpRes 'TNat 'TNat = 'TNat-  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a a)-    <$> converge n1 n2-  evalEDivOp (VNat i) (VNat j) =-    if j == 0-      then VOption $ Nothing-      else VOption $ Just $-        VPair (VNat (divMich i j), VNat $ (modMich i j))-instance EDivOp 'TMutez 'TMutez where-  type EDivOpRes 'TMutez 'TMutez = 'TNat-  type EModOpRes 'TMutez 'TMutez = 'TMutez-  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn (NTNat noAnn) a)-    <$> converge n1 n2-  evalEDivOp (VMutez i) (VMutez j) =-    VOption $-    i `divModMutez` j <&> \case-      (quotient, remainder) ->-        VPair (VNat (fromIntegral quotient), VMutez remainder)--instance EDivOp 'TMutez 'TNat where-  type EDivOpRes 'TMutez 'TNat = 'TMutez-  type EModOpRes 'TMutez 'TNat = 'TMutez-  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1 n1-  evalEDivOp (VMutez i) (VNat j) =-    VOption $-    i `divModMutezInt` j <&> \case-      (quotient, remainder) ->-        VPair (VMutez quotient, VMutez remainder)---- | Computing 'div' function in Michelson style.--- When divisor is negative, Haskell gives x as integer part,--- while Michelson gives x+1.-divMich :: Integral a => a -> a -> a-divMich divisible divisor = divisible `div` divisor + extra-  where-    extra =-      if divisor > 0 ||-         divisible `mod` divisor == 0-      then 0-      else 1---- | Computing 'mod' function in Michelson style.--- When divisor is negative, Haskell gives a negative modulo,--- while there is a positive modulo in Michelson.-modMich :: Integral a => a -> a -> a-modMich divisible divisor = divisible - divisor * intPart-  where intPart = divMich divisible divisor

− src/Michelson/Typed/Scope.hs

@@ -1,981 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# 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-    ConstantScope-  , DupableScope-  , StorageScope-  , PackedValScope-  , ParameterScope-  , PrintedValScope-  , UnpackedValScope--  , ProperParameterBetterErrors-  , ProperStorageBetterErrors-  , ProperConstantBetterErrors-  , ProperDupableBetterErrors-  , ProperPackedValBetterErrors-  , ProperUnpackedValBetterErrors-  , ProperPrintedValBetterErrors--  , properParameterEvi-  , properStorageEvi-  , properConstantEvi-  , properDupableEvi-  , properPackedValEvi-  , properUnpackedValEvi-  , properPrintedValEvi-  , (:-)(..)--  , BadTypeForScope (..)-  , CheckScope (..)-  , WithDeMorganScope (..)--    -- * Implementation internals-  , HasNoBigMap-  , HasNoNestedBigMaps-  , HasNoOp-  , HasNoContract-  , HasNoTicket-  , ContainsBigMap-  , ContainsNestedBigMaps--  , ForbidOp-  , ForbidContract-  , ForbidTicket-  , ForbidBigMap-  , ForbidNestedBigMaps-  , FailOnBigMapFound-  , FailOnNestedBigMapsFound-  , FailOnOperationFound--  , OpPresence (..)-  , ContractPresence (..)-  , TicketPresence (..)-  , BigMapPresence (..)-  , NestedBigMapsPresence (..)-  , checkOpPresence-  , checkContractTypePresence-  , checkTicketPresence-  , checkBigMapPresence-  , checkNestedBigMapsPresence-  , opAbsense-  , contractTypeAbsense-  , bigMapAbsense-  , nestedBigMapsAbsense-  , forbiddenOp-  , forbiddenContractType-  , forbiddenBigMap-  , forbiddenNestedBigMaps--    -- * Re-exports-  , withDict-  , SingI (..)-  ) where--import Data.Constraint (Dict(..), withDict, (:-)(..), (\\))-import Data.Singletons (Sing, SingI(..))-import Data.Type.Bool (type (||))-import Fmt (Buildable(..))-import GHC.TypeLits (ErrorMessage(..), TypeError)--import Michelson.Typed.Sing (SingT(..))-import Michelson.Typed.T (T(..))-import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)--------------------------------------------------------------------------------- Constraints-------------------------------------------------------------------------------- | Whether a value of this type _may_ contain an operation.------ 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 'TKey = 'False-  ContainsOp 'TUnit = 'False-  ContainsOp 'TSignature = 'False-  ContainsOp 'TChainId = 'False-  ContainsOp ('TOption t) = ContainsOp t-  ContainsOp ('TList t) = ContainsOp t-  ContainsOp ('TSet t) = ContainsOp t-  ContainsOp 'TOperation = 'True-  ContainsOp ('TContract _) = 'False-  ContainsOp ('TTicket t) = ContainsOp t-  ContainsOp ('TPair a b) = ContainsOp a || ContainsOp b-  ContainsOp ('TOr a b) = ContainsOp a || ContainsOp b-  ContainsOp ('TLambda _ _) = 'False-  ContainsOp ('TMap k v) = ContainsOp k || ContainsOp v-  ContainsOp ('TBigMap k v) = ContainsOp k || ContainsOp v-  ContainsOp _ = 'False---- | Whether a value of this type _may_ contain a @contract@ value.------ 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 '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-  ContainsContract _ = 'False---- | Whether a value of this type _may_ contain a @ticket@ value.-type family ContainsTicket (t :: T) :: Bool where-  ContainsTicket ('TOption t) = ContainsTicket t-  ContainsTicket ('TList t) = ContainsTicket t-  ContainsTicket ('TSet _) = 'False-  ContainsTicket ('TTicket _) = 'True-  ContainsTicket ('TPair a b) = ContainsTicket a || ContainsTicket b-  ContainsTicket ('TOr a b) = ContainsTicket a || ContainsTicket b-  ContainsTicket ('TLambda _ _) = 'False-  ContainsTicket ('TMap _ v) = ContainsTicket v-  ContainsTicket ('TBigMap _ v) = ContainsTicket v-  ContainsTicket _ = 'False---- | Whether a value of this type _may_ contain a @big_map@ value.-type family ContainsBigMap (t :: T) :: Bool where-  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 _) = 'False-  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-  ContainsBigMap _ = 'False---- | Whether a value of this type _may_ contain nested @big_map@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 don't work with big_map at all.-type family ContainsNestedBigMaps (t :: T) :: Bool where-  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 _) = 'False-  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-  ContainsNestedBigMaps _ = 'False---- | Constraint which ensures that a value of type @t@ does not contain operations.------ 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 a value of type @t@ does not contain @contract@ values.-class (ContainsContract t ~ 'False) => HasNoContract t-instance (ContainsContract t ~ 'False) => HasNoContract t---- | Constraint which ensures that a value of type @t@ does not contain @ticket@ values.-class (ContainsTicket t ~ 'False) => HasNoTicket t-instance (ContainsTicket t ~ 'False) => HasNoTicket t---- | Constraint which ensures that a value of type @t@ does not contain @big_map@ values.-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 "Type `contract` is not allowed in this scope")-  FailOnContractFound 'False = ()---- | Report a human-readable error about 'TTicket' at a wrong place.-type family FailOnTicketFound (enabled :: Bool) :: Constraint where-  FailOnTicketFound 'True =-    TypeError ('Text "Type `ticket` is not allowed in this scope")-  FailOnTicketFound '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'.--- Though, hopefully, it will someday:--- <https://gitlab.haskell.org/ghc/ghc/issues/11503 #11503>.------ Use this constraint in our eDSL.-type ForbidOp t = FailOnOperationFound (ContainsOp t)--type ForbidContract t = FailOnContractFound (ContainsContract t)--type ForbidTicket t = FailOnTicketFound (ContainsTicket 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---- | Reify 'HasNoTicket' contraint from 'ForbidTicket'.-forbiddenTicketTypeEvi-  :: forall t. (SingI t, ForbidTicket t) :- HasNoTicket t-forbiddenTicketTypeEvi = Sub $-  case checkTicketPresence (sing @t) of-    TicketAbsent -> Dict-    TicketPresent -> error "impossible"---- | Whether a value of this type _may_ contain an operation.-data OpPresence (t :: T)-  = ContainsOp t ~ 'True => OpPresent-    -- ^ A value of type @t@ may or may not contain an operation.-  | ContainsOp t ~ 'False => OpAbsent-    -- ^ A value of type @t@ cannot contain @big_map@ values.---- | Whether a value of this type _may_ contain a @contract@ value.-data ContractPresence (t :: T)-  = ContainsContract t ~ 'True => ContractPresent-    -- ^ A value of type @t@ may or may not contain a @contract@ value.-  | ContainsContract t ~ 'False => ContractAbsent-    -- ^ A value of type @t@ cannot contain @contract@ values.---- | Whether a value of this type _may_ contain a @ticket@ value.-data TicketPresence (t :: T)-  = ContainsTicket t ~ 'True => TicketPresent-    -- ^ A value of type @t@ may or may not contain a @ticket@ value.-  | ContainsTicket t ~ 'False => TicketAbsent-    -- ^ A value of type @t@ cannot contain @ticket@ values.---- | Whether a value of this type _may_ contain a @big_map@ value.-data BigMapPresence (t :: T)-  = ContainsBigMap t ~ 'True => BigMapPresent-    -- ^ A value of type @t@ may or may not contain a @big_map@ value.-  | ContainsBigMap t ~ 'False => BigMapAbsent-    -- ^ A value of type @t@ cannot contain @big_map@ values.---- | Whether a value of this type _may_ contain nested @big_map@s.-data NestedBigMapsPresence (t :: T)-  = ContainsNestedBigMaps t ~ 'True => NestedBigMapsPresent-    -- ^ A value of type @t@ may or may not contain nested @big_map@s.-  | ContainsNestedBigMaps t ~ 'False => NestedBigMapsAbsent-    -- ^ A value of type @t@ cannot contain nested @big_map@s.---- @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 a value of the given type _may_ contain an operation.-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.-  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 a -> case checkOpPresence a of-    OpPresent -> OpPresent-    OpAbsent -> OpAbsent-  STOperation -> OpPresent-  STContract _ -> OpAbsent-  STTicket 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 k v -> case (checkOpPresence k, checkOpPresence v) of-    (OpAbsent, OpAbsent) -> OpAbsent-    (OpPresent, _) -> OpPresent-    (_, OpPresent) -> OpPresent-  STBigMap k v -> case (checkOpPresence k, checkOpPresence v) of-    (OpAbsent, OpAbsent) -> OpAbsent-    (OpPresent, _) -> OpPresent-    (_, OpPresent) -> OpPresent-  STInt -> OpAbsent-  STNat -> OpAbsent-  STString -> OpAbsent-  STBytes -> OpAbsent-  STMutez -> OpAbsent-  STBool -> OpAbsent-  STKeyHash -> OpAbsent-  STBls12381Fr -> OpAbsent-  STBls12381G1 -> OpAbsent-  STBls12381G2 -> OpAbsent-  STTimestamp -> OpAbsent-  STAddress -> OpAbsent-  STNever -> OpAbsent---- | Check at runtime whether a value of the given type _may_ contain a @contract@ value.-checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty-checkContractTypePresence = \case-  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-  STTicket _ -> ContractAbsent  -- contract type is not allowed in tickets at all-  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-  STInt -> ContractAbsent-  STNat -> ContractAbsent-  STString -> ContractAbsent-  STBytes -> ContractAbsent-  STMutez -> ContractAbsent-  STBool -> ContractAbsent-  STKeyHash -> ContractAbsent-  STBls12381Fr -> ContractAbsent-  STBls12381G1 -> ContractAbsent-  STBls12381G2 -> ContractAbsent-  STTimestamp -> ContractAbsent-  STAddress -> ContractAbsent-  STNever -> ContractAbsent---- | Check at runtime whether a value of the given type _may_ contain a @ticket@ value.-checkTicketPresence :: Sing (ty :: T) -> TicketPresence ty-checkTicketPresence = \case-  STKey -> TicketAbsent-  STSignature -> TicketAbsent-  STChainId -> TicketAbsent-  STUnit -> TicketAbsent-  STOption t -> case checkTicketPresence t of-    TicketPresent -> TicketPresent-    TicketAbsent -> TicketAbsent-  STList t -> case checkTicketPresence t of-    TicketPresent -> TicketPresent-    TicketAbsent -> TicketAbsent-  STSet _ -> TicketAbsent-  STOperation -> TicketAbsent-  STContract _ -> TicketAbsent-  STTicket _ -> TicketPresent-  STPair a b -> case (checkTicketPresence a, checkTicketPresence b) of-    (TicketPresent, _) -> TicketPresent-    (_, TicketPresent) -> TicketPresent-    (TicketAbsent, TicketAbsent) -> TicketAbsent-  STOr a b -> case (checkTicketPresence a, checkTicketPresence b) of-    (TicketPresent, _) -> TicketPresent-    (_, TicketPresent) -> TicketPresent-    (TicketAbsent, TicketAbsent) -> TicketAbsent-  STLambda _ _ -> TicketAbsent-  STMap _ v -> case checkTicketPresence v of-    TicketPresent -> TicketPresent-    TicketAbsent -> TicketAbsent-  STBigMap _ v -> case checkTicketPresence v of-    TicketPresent -> TicketPresent-    TicketAbsent -> TicketAbsent-  STInt -> TicketAbsent-  STNat -> TicketAbsent-  STString -> TicketAbsent-  STBytes -> TicketAbsent-  STMutez -> TicketAbsent-  STBool -> TicketAbsent-  STKeyHash -> TicketAbsent-  STBls12381Fr -> TicketAbsent-  STBls12381G1 -> TicketAbsent-  STBls12381G2 -> TicketAbsent-  STTimestamp -> TicketAbsent-  STAddress -> TicketAbsent-  STNever -> TicketAbsent---- | Check at runtime whether a value of the given type _may_ contain a @big_map@ value.-checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty-checkBigMapPresence = \case-  -- More boilerplate to boilerplate god.-  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 _ -> BigMapAbsent-  STTicket _ -> BigMapAbsent  -- big_maps are not allowed in tickets at all-  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-  STInt -> BigMapAbsent-  STNat -> BigMapAbsent-  STString -> BigMapAbsent-  STBytes -> BigMapAbsent-  STMutez -> BigMapAbsent-  STBool -> BigMapAbsent-  STKeyHash -> BigMapAbsent-  STBls12381Fr -> BigMapAbsent-  STBls12381G1 -> BigMapAbsent-  STBls12381G2 -> BigMapAbsent-  STTimestamp -> BigMapAbsent-  STAddress -> BigMapAbsent-  STNever -> BigMapAbsent---- | Check at runtime whether a value of the given type _may_ contain nested @big_map@s.-checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty-checkNestedBigMapsPresence = \case-  -- More boilerplate to boilerplate god.-  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 _ -> NestedBigMapsAbsent-  STTicket _ -> 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-  STInt -> NestedBigMapsAbsent-  STNat -> NestedBigMapsAbsent-  STString -> NestedBigMapsAbsent-  STBytes -> NestedBigMapsAbsent-  STMutez -> NestedBigMapsAbsent-  STBool -> NestedBigMapsAbsent-  STKeyHash -> NestedBigMapsAbsent-  STBls12381Fr -> NestedBigMapsAbsent-  STBls12381G1 -> NestedBigMapsAbsent-  STBls12381G2 -> NestedBigMapsAbsent-  STTimestamp -> NestedBigMapsAbsent-  STAddress -> NestedBigMapsAbsent-  STNever -> NestedBigMapsAbsent---- | Check at runtime that a value of the given type cannot contain operations.-opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)-opAbsense s = case checkOpPresence s of-  OpPresent -> Nothing-  OpAbsent -> Just Dict---- | Check at runtime that a value of the given type cannot contain @contract@ values.-contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoContract t)-contractTypeAbsense s = case checkContractTypePresence s of-  ContractPresent -> Nothing-  ContractAbsent -> Just Dict---- | Check at runtime that a value of the given type cannot contain @ticket@ values.-ticketAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoTicket t)-ticketAbsense s = case checkTicketPresence s of-  TicketPresent -> Nothing-  TicketAbsent -> Just Dict---- | Check at runtime that a value of the given type cannot containt @big_map@ values-bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t)-bigMapAbsense s = case checkBigMapPresence s of-  BigMapPresent -> Nothing-  BigMapAbsent -> Just Dict---- | Check at runtime that a value of the given type cannot contain nested @big_map@s.-nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoNestedBigMaps t)-nestedBigMapsAbsense s = case checkNestedBigMapsPresence s of-  NestedBigMapsPresent -> Nothing-  NestedBigMapsAbsent -> Just Dict--------------------------------------------------------------------------------- Scopes-------------------------------------------------------------------------------data BadTypeForScope-  = BtNotComparable-  | BtIsOperation-  | BtHasBigMap-  | BtHasNestedBigMap-  | BtHasContract-  | BtHasTicket-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)--instance Buildable BadTypeForScope where-  build = buildRenderDoc--instance RenderDoc BadTypeForScope where-  renderDoc _ = \case-    BtNotComparable -> "is not comparable"-    BtIsOperation -> "has 'operation' type"-    BtHasBigMap -> "has 'big_map'"-    BtHasNestedBigMap -> "has nested 'big_map'"-    BtHasContract -> "has 'contract' type"-    BtHasTicket -> "has 'ticket' type"---- | Set of constraints that Michelson applies to parameters.------ Not just a type alias in order to be able to partially apply it-class (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t-instance (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t---- | Set of constraints that Michelson applies to contract storage.------ Not just a type alias in order to be able to partially apply it-class (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t-instance (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t---- | Set of constraints that Michelson applies to pushed constants.------ Not just a type alias in order to be able to partially apply it-class (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t-instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t---- | Alias for constraints which Michelson requires in @DUP@ instruction.-class (SingI t, HasNoTicket t) => DupableScope t-instance (SingI t, HasNoTicket t) => DupableScope t---- | Set of constraints that Michelson applies to packed values.------ Not just a type alias in order to be able to partially apply it-class (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t-instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t---- | Set of constraints that Michelson applies to unpacked values.------ It is different from 'PackedValScope', e.g. @contract@ type cannot appear--- in a value we unpack to.------ Not just a type alias in order to be able to partially apply it-class (PackedValScope t, ConstantScope t) => UnpackedValScope t-instance (PackedValScope t, ConstantScope t) => UnpackedValScope t---- | Alias for constraints which are required for printing.-type PrintedValScope t = (SingI t, HasNoOp t)--------------------------------------------------------------------------------- Conveniences--------------------------------------------------------------------------------- | Should be present for common scopes.-class CheckScope (c :: Constraint) where-  -- | Check that constraint hold for a given type.-  checkScope :: Either BadTypeForScope (Dict c)--instance SingI t => CheckScope (HasNoOp t) where-  checkScope = maybeToRight BtIsOperation $ opAbsense sing-instance SingI t => CheckScope (HasNoBigMap t) where-  checkScope = maybeToRight BtHasBigMap $ bigMapAbsense sing-instance SingI t => CheckScope (HasNoNestedBigMaps t) where-  checkScope = maybeToRight BtHasNestedBigMap $ nestedBigMapsAbsense sing-instance SingI t => CheckScope (HasNoContract t) where-  checkScope = maybeToRight BtHasContract $ contractTypeAbsense sing-instance SingI t => CheckScope (HasNoTicket t) where-  checkScope = maybeToRight BtHasTicket $ ticketAbsense sing--instance SingI t => CheckScope (ParameterScope t) where-  checkScope =-    (\Dict Dict -> Dict)-      <$> checkScope @(HasNoOp t)-      <*> checkScope @(HasNoNestedBigMaps t)--instance SingI t => CheckScope (StorageScope t) where-  checkScope =-    (\Dict Dict Dict -> Dict)-      <$> checkScope @(HasNoOp t)-      <*> checkScope @(HasNoNestedBigMaps t)-      <*> checkScope @(HasNoContract t)--instance SingI t => CheckScope (ConstantScope t) where-  checkScope =-    (\Dict Dict Dict Dict -> Dict)-      <$> checkScope @(HasNoOp t)-      <*> checkScope @(HasNoBigMap t)-      <*> checkScope @(HasNoContract t)-      <*> checkScope @(HasNoTicket t)--instance SingI t => CheckScope (DupableScope t) where-  checkScope =-    (\Dict -> Dict)-      <$> checkScope @(HasNoTicket t)--instance SingI t => CheckScope (PackedValScope t) where-  checkScope =-    (\Dict Dict Dict -> Dict)-      <$> checkScope @(HasNoOp t)-      <*> checkScope @(HasNoBigMap t)-      <*> checkScope @(HasNoTicket t)--instance SingI t => CheckScope (UnpackedValScope t) where-  checkScope =-    (\Dict Dict -> Dict)-      <$> checkScope @(PackedValScope t)-      <*> checkScope @(ConstantScope t)---- | Allows using a scope that can be proven true with a De Morgan law.------ Many scopes are defined as @not a@ (or rather @a ~ 'False@) where @a@ is a--- negative property we want to avoid as a 'Constraint'.--- The negative constraints are implemented with a type family that for some--- combination types resolves to itself applied to the type arguments in an @or@,--- e.g. A @pair l r@ has @x@ if @l@ or @r@ contain @x@.------ Because of the De Morgan laws @not (a or b)@ implies @(not a) and (not b)@--- or in our case: @pair@ does not contain @x@ -> @a@ and @b@ don't contain @x@.------ GHC is however not able to prove this, so we need to use another (impossible)--- 'error' to forcefully "prove" one of the two scopes.--- Funnily enough however GHC is able to prove that if one holds then the other--- does too, so we don't actually have to prove both, see 'mkWithDeMorgan'.-class WithDeMorganScope (c :: T -> Constraint) t a b where-  withDeMorganScope :: c (t a b) => ((c a, c b) => ret) -> ret---- | Helper to builds a 'WithDeMorganScope' by using a 'CheckScope' that we know--- cannot fail.------ This can be used to make instances that also prove the other side of a--- negative @or-like@ scope constraint, see 'WithDeMorganScope'.-mkWithDeMorgan-  :: forall scope a ret. CheckScope (scope a)-  => (scope a => ret) -> ret-mkWithDeMorgan f = fromRight (error "impossible") $ do-  Dict <- checkScope @(scope a)-  pure f--instance SingI a => WithDeMorganScope HasNoOp 'TPair a b where-  withDeMorganScope = mkWithDeMorgan @HasNoOp @a--instance SingI a => WithDeMorganScope HasNoContract 'TPair a b where-  withDeMorganScope = mkWithDeMorgan @HasNoContract @a--instance SingI a => WithDeMorganScope HasNoTicket 'TPair a b where-  withDeMorganScope = mkWithDeMorgan @HasNoTicket @a--instance SingI a => WithDeMorganScope HasNoBigMap 'TPair a b where-  withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a--instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TPair a b where-  withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a--instance SingI a => WithDeMorganScope HasNoOp 'TOr a b where-  withDeMorganScope = mkWithDeMorgan @HasNoOp @a--instance SingI a => WithDeMorganScope HasNoContract 'TOr a b where-  withDeMorganScope = mkWithDeMorgan @HasNoContract @a--instance SingI a => WithDeMorganScope HasNoTicket 'TOr a b where-  withDeMorganScope = mkWithDeMorgan @HasNoTicket @a--instance SingI a => WithDeMorganScope HasNoBigMap 'TOr a b where-  withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a--instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TOr a b where-  withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a--instance SingI k => WithDeMorganScope HasNoOp 'TMap k v where-  withDeMorganScope = mkWithDeMorgan @HasNoOp @k--instance SingI k => WithDeMorganScope HasNoOp 'TBigMap k v where-  withDeMorganScope = mkWithDeMorgan @HasNoOp @k--instance-  ( WithDeMorganScope HasNoOp t a b-  , WithDeMorganScope HasNoNestedBigMaps t a b-  , SingI a, SingI b-  ) => WithDeMorganScope ParameterScope t a b where-  withDeMorganScope f =-    withDeMorganScope @HasNoOp @t @a @b $-    withDeMorganScope @HasNoNestedBigMaps @t @a @b f--instance-  ( WithDeMorganScope HasNoOp t a b-  , WithDeMorganScope HasNoNestedBigMaps t a b-  , WithDeMorganScope HasNoContract t a b-  , SingI a, SingI b-  ) => WithDeMorganScope StorageScope t a b where-  withDeMorganScope f =-    withDeMorganScope @HasNoOp @t @a @b $-    withDeMorganScope @HasNoNestedBigMaps @t @a @b $-    withDeMorganScope @HasNoContract @t @a @b f--instance-  ( WithDeMorganScope HasNoOp t a b-  , WithDeMorganScope HasNoBigMap t a b-  , WithDeMorganScope HasNoContract t a b-  , WithDeMorganScope HasNoTicket t a b-  , SingI a, SingI b-  ) => WithDeMorganScope ConstantScope t a b where-  withDeMorganScope f =-    withDeMorganScope @HasNoOp @t @a @b $-    withDeMorganScope @HasNoBigMap @t @a @b $-    withDeMorganScope @HasNoContract @t @a @b $-    withDeMorganScope @HasNoTicket @t @a @b f--instance-  ( WithDeMorganScope HasNoOp t a b-  , WithDeMorganScope HasNoBigMap t a b-  , WithDeMorganScope HasNoTicket t a b-  , SingI a, SingI b-  ) => WithDeMorganScope PackedValScope t a b where-  withDeMorganScope f =-    withDeMorganScope @HasNoOp @t @a @b $-    withDeMorganScope @HasNoBigMap @t @a @b $-    withDeMorganScope @HasNoTicket @t @a @b f--instance-  ( WithDeMorganScope PackedValScope t a b-  , WithDeMorganScope ConstantScope t a b-  , SingI a, SingI b-  ) => WithDeMorganScope UnpackedValScope t a b where-  withDeMorganScope f =-    withDeMorganScope @PackedValScope @t @a @b $-    withDeMorganScope @ConstantScope @t @a @b f---- 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 =-  (SingI t, ForbidOp t, ForbidNestedBigMaps t)--type ProperStorageBetterErrors t =-  (SingI t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)--type ProperConstantBetterErrors t =-  (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t, ForbidTicket t)--type ProperDupableBetterErrors t =-  (SingI t, ForbidTicket t)--type ProperPackedValBetterErrors t =-  (SingI t, ForbidOp t, ForbidBigMap t, ForbidTicket 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-       \\ forbiddenTicketTypeEvi @t--properDupableEvi :: forall t. ProperDupableBetterErrors t :- DupableScope t-properDupableEvi = Sub $-  Dict \\ forbiddenTicketTypeEvi @t--properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t-properPackedValEvi = Sub $-  Dict \\ forbiddenOpEvi @t-       \\ forbiddenBigMapEvi @t-       \\ forbiddenTicketTypeEvi @t--properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t-properUnpackedValEvi = Sub $-  Dict \\ properPackedValEvi @t-       \\ properConstantEvi @t--properPrintedValEvi :: forall t. ProperPrintedValBetterErrors t :- PrintedValScope t-properPrintedValEvi = Sub $-  Dict \\ forbiddenOpEvi @t

− src/Michelson/Typed/Sing.hs

@@ -1,96 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE StandaloneKindSignatures #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Module, providing singleton boilerplate for--- 'T' data types.------ Some functions from Data.Singletons are provided alternative version here.--- Some instances which are usually generated with TH are manually implemented--- as they require some specific constraints, namely 'Typeable' and/or--- 'Converge', not provided in instances generated by TH.--module Michelson.Typed.Sing-  ( SingT (..)-  , castSingE-  , castM-  , eqP-  , requireEq-  ) where--import Data.Type.Equality ((:~:)(..))-import Data.Singletons (Demote, KindOf, SingI(..), demote)-import Data.Singletons.TH (genSingletons, singDecideInstance)-import Data.Singletons.TH.Options (Options(..), defaultOptions, withOptions)-import Language.Haskell.TH (Name, mkName, nameBase)--import Fmt ((+||), (||+))-import Michelson.Typed.T (T(..))-import Util.Sing (SingI1(..), castSing, eqI)---- | 'SingI' and 'SDecide' instances for the 'T' kind.-$(let singPrefix, sPrefix :: Name -> Name-      singPrefix nm = mkName ("Sing" ++ nameBase nm)-      sPrefix nm = mkName ("S" ++ nameBase nm) in--  withOptions defaultOptions{singledDataConName = sPrefix, singledDataTypeName = singPrefix} $-  concat <$> sequence [genSingletons [''T], singDecideInstance ''T]-  )-------------------------------------------------- 'withSingI' usage------------------------------------------------- | Previously, we were using 'SingI' constraints in 'SingT'--- constructors. That was not so optimal because we have been--- spending too much space at runtime. Instead of that, we process--- values of 'SingT' using the function 'withSingI' in those places--- where the 'SingI' constraint is required. 'withSingI' allows one--- to create the 'SingI' context for a given 'Sing'.-------------------------------------------------- Singleton-related helpers for T------------------------------------------------instance SingI1 'TList where-  withSingI1 x = x--instance SingI k => SingI1 ('TMap k) where-  withSingI1 x = x--castSingE-  :: forall (a :: T) (b :: T) t. (SingI a, SingI b)-  => t a -> Either Text (t b)-castSingE = maybeToRight errMsg . castSing-  where-    errMsg = "Type mismatch: expected " +|| demote @a ||+-                               ", got " +|| demote @b ||+ ""---- | Monadic version of 'castSing'.--- Throws an error using the given function if the cast fails.-castM-  :: forall (a :: T) (b :: T) t m. (SingI a, SingI b, Monad m)-  => t a-  -> (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x)-  -> m (t b)-castM a throwErr =-  requireEq @a @b throwErr <&> \Refl -> a---- | Monadic version of 'eqI'.--- Throws an error using the given function if the two types are not equal.-requireEq-  :: forall (a :: T) (b :: T) m. (SingI a, SingI b, Monad m)-  => (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x)-  -> m (a :~: b)-requireEq throwErr =-  case eqI @a @b of-    Just p -> pure p-    Nothing -> throwErr (demote @a) (demote @b)---- | Version of 'eqI' that uses 'Proxy'-eqP :: forall (a :: T) (b :: T). (SingI a, SingI b) => Proxy a -> Proxy b -> Maybe (a :~: b)-eqP _ _ = eqI @a @b

− src/Michelson/Typed/T.hs

@@ -1,99 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module, providing 'T' data type, representing Michelson--- language types without annotations.-module Michelson.Typed.T-  ( T (..)-  , toUType-  , buildStack-  ) where--import Fmt (Buildable(..), Builder, listF)-import qualified Michelson.Untyped.Annotation as Un-import qualified Michelson.Untyped.Type as Un-import Michelson.Printer.Util (RenderDoc (..))---- | Michelson language type with annotations stripped off.-data T =-    TKey-  | TUnit-  | TSignature-  | TChainId-  | TOption T-  | TList T-  | TSet T-  | TOperation-  | TContract T-  | TTicket T-  | TPair T T-  | TOr T T-  | TLambda T T-  | TMap T T-  | TBigMap T T-  | TInt-  | TNat-  | TString-  | TBytes-  | TMutez-  | TBool-  | TKeyHash-  | TBls12381Fr-  | TBls12381G1-  | TBls12381G2-  | TTimestamp-  | TAddress-  | TNever-  deriving stock (Eq, Show, Generic)--instance NFData T---- | Converts from 'T' to 'Michelson.Type.Type'.-toUType :: T -> Un.Ty-toUType t = Un.Ty (convert t) Un.noAnn-  where-    convert :: T -> Un.T-    convert TInt = Un.TInt-    convert TNat = Un.TNat-    convert TString = Un.TString-    convert TBytes = Un.TBytes-    convert TMutez = Un.TMutez-    convert TBool = Un.TBool-    convert TKeyHash = Un.TKeyHash-    convert TTimestamp = Un.TTimestamp-    convert TAddress = Un.TAddress-    convert TKey = Un.TKey-    convert TBls12381Fr = Un.TBls12381Fr-    convert TBls12381G1 = Un.TBls12381G1-    convert TBls12381G2 = Un.TBls12381G2-    convert TUnit = Un.TUnit-    convert TSignature = Un.TSignature-    convert TChainId = Un.TChainId-    convert TNever = Un.TNever-    convert (TOption a) = Un.TOption (toUType a)-    convert (TList a) = Un.TList (toUType a)-    convert (TSet a) = Un.TSet $ Un.Ty (Un.unwrapT $ toUType a) Un.noAnn-    convert (TOperation) = Un.TOperation-    convert (TContract a) = Un.TContract (toUType a)-    convert (TTicket a) = Un.TTicket (toUType a)-    convert (TPair a b) =-      Un.TPair Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType a) (toUType b)-    convert (TOr a b) =-      Un.TOr Un.noAnn Un.noAnn (toUType a) (toUType b)-    convert (TLambda a b) =-      Un.TLambda (toUType a) (toUType b)-    convert (TMap a b) =-      Un.TMap (Un.Ty (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)-    convert (TBigMap a b) =-      Un.TBigMap (Un.Ty (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)--instance Buildable T where-  build = build . toUType--instance RenderDoc T where-  renderDoc context = renderDoc context . toUType---- | Format type stack in a pretty way.-buildStack :: [T] -> Builder-buildStack = listF

− src/Michelson/Typed/TypeLevel.hs

@@ -1,59 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | A collection of type families and other type-level machinery--- for working with Michelson types.-module Michelson.Typed.TypeLevel-  ( -- * Right-combed pairs-    IsPair-  , CombedPairLeafCount-  , CombedPairNodeCount-  , CombedPairLeafCountIsAtLeast-  , CombedPairNodeIndexIsValid-  )-  where--import Michelson.Typed.T (T(TPair))-import Util.Peano (Nat(S, Z), Peano, ToPeano)--------------------------------------------------------------------------------- Right-combed pairs-------------------------------------------------------------------------------type family IsPair (pair :: T) :: Bool where-  IsPair ('TPair _ _) = 'True-  IsPair _ = 'False---- | Returns the number of leaves in a right-combed pair.------ > CombedPairLeafCount ('TPair 'TInt ('TPair 'TString 'TUnit))--- > ~--- > ToPeano 3------ If the pair contains sub-trees to the left, they will not be accounted for.--- E.g. the length of @pair w (pair x y) z@ is 3.-type family CombedPairLeafCount (t :: T) :: Peano where-  CombedPairLeafCount ('TPair _ ('TPair y z)) = 'S (CombedPairLeafCount ('TPair y z))-  CombedPairLeafCount ('TPair _ _) = ToPeano 2---- | Returns the number of nodes in a right-combed pair.-type family CombedPairNodeCount (t :: T) :: Peano where-  CombedPairNodeCount ('TPair _ ('TPair y z)) = 'S ('S (CombedPairNodeCount ('TPair y z)))-  CombedPairNodeCount ('TPair _ _) = ToPeano 3---- | Checks whether a pair contains at least @n@ elements.-type family CombedPairLeafCountIsAtLeast (n :: Peano) (t :: T) :: Bool where-  CombedPairLeafCountIsAtLeast ('S ('S 'Z)) ('TPair _ _) = 'True-  CombedPairLeafCountIsAtLeast ('S n) ('TPair _ y) = CombedPairLeafCountIsAtLeast n y-  CombedPairLeafCountIsAtLeast ('S _) _ = 'False---- | For a given node index @i@, this type family checks whether--- a pair has at least @i+1@ nodes.------ Note that the index 0 is always valid, even if the input type is not a pair.-type family CombedPairNodeIndexIsValid (nodeIndex :: Peano) (pair :: T) :: Bool where-  CombedPairNodeIndexIsValid 'Z                   _                = 'True-  CombedPairNodeIndexIsValid ('S 'Z)              ('TPair _ _)     = 'True-  CombedPairNodeIndexIsValid ('S ('S nodeIndex')) ('TPair _ right) = CombedPairNodeIndexIsValid nodeIndex' right-  CombedPairNodeIndexIsValid _ _                                   = 'False

− src/Michelson/Typed/Util.hs

@@ -1,787 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | General-purpose utility functions for typed types.--module Michelson.Typed.Util-  ( DfsSettings (..)-  , CtorEffectsApp (..)-  , ceaBottomToTop-  , dfsInstr-  , dfsFoldInstr-  , dfsModifyInstr--  -- * Changing instruction tree structure-  , linearizeLeft-  , linearizeLeftDeep--  -- * Value analysis-  , dfsFoldMapValue-  , dfsFoldMapValueM-  , dfsMapValue-  , dfsTraverseValue-  , isStringValue-  , isBytesValue-  , allAtomicValues--  -- * Instruction generation-  , PushableStorageSplit (..)-  , splitPushableStorage-  ) where--import Prelude hiding (Ordering(..))--import Control.Monad.Writer.Strict (execWriterT, runWriter, tell, writer)-import Data.Constraint (Dict(..))-import Data.Default (Default(..))-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Text.Show--import Michelson.Text (MText)-import Michelson.Typed.Aliases-import Michelson.Typed.Instr-import Michelson.Typed.Scope-import qualified Michelson.Typed.T as T-import Michelson.Typed.Value---- | Options for 'dfsInstr'.-data DfsSettings x = DfsSettings-  { dsGoToValues :: Bool-    -- ^ Whether 'dfsInstr' function should go into values which contain other-    -- instructions: lambdas and constant contracts-    -- (which can be passed to @CREATE_CONTRACT@).-  , dsCtorEffectsApp :: CtorEffectsApp x-    -- ^ How do we handle intermediate nodes in instruction tree.-  } deriving stock (Show)---- | Describes how intermediate nodes in instruction tree are accounted.-data CtorEffectsApp x = CtorEffectsApp-  { ceaName :: Text-    -- ^ Name of this way.-  , ceaApplyEffects-      :: forall i o. Semigroup x => x -> x -> Instr i o -> (Instr i o, x)-    -- ^ This function accepts:-    -- 1. Effects gathered after applying @step@ to node's children, but-    -- before applying it to the node itself.-    -- 2. Effects gathered after applying @step@ to the given intermediate node.-    -- 3. Instruction resulting after all modifications produced by @step@.-  }--instance Show (CtorEffectsApp x) where-  show CtorEffectsApp{..} = show ceaName---- | Gather effects first for children nodes, then for their parents.-ceaBottomToTop :: CtorEffectsApp x-ceaBottomToTop = CtorEffectsApp-  { ceaName = "Apply after"-  , ceaApplyEffects =-      \effBefore effAfter instr -> (instr, effBefore <> effAfter)-  }--instance Default (DfsSettings x) where-  def = DfsSettings-    { dsGoToValues = False-    , dsCtorEffectsApp = ceaBottomToTop-    }---- | Traverse a typed instruction in depth-first order.--- '<>' is used to concatenate intermediate results.--- Each instructions can be changed using the supplied @step@ function.--- It does not consider extra instructions (not present in Michelson).-dfsInstr ::-     forall x inp out. Semigroup x-  => DfsSettings x-  -> (forall i o. Instr i o -> (Instr i o, x))-  -> Instr inp out-  -> (Instr inp out, x)-dfsInstr settings@DfsSettings{..} step i =-  case i of-    Seq i1 i2 -> recursion2 Seq i1 i2-    WithLoc loc i1 -> recursion1 (WithLoc loc) i1-    InstrWithNotes p notes i1 -> recursion1 (InstrWithNotes p notes) i1-    InstrWithVarNotes varNotes i1 -> recursion1 (InstrWithVarNotes varNotes) i1-    InstrWithVarAnns varAnns i1 -> recursion1 (InstrWithVarAnns varAnns) i1-    FrameInstr p i1 -> recursion1 (FrameInstr p) i1-    Nested i1 -> recursion1 Nested i1-    DocGroup dg i1 -> recursion1 (DocGroup dg) i1-    Fn t sfn i1 -> recursion1 (Fn t sfn) i1-    IF_NONE i1 i2 -> recursion2 IF_NONE i1 i2-    IF_LEFT i1 i2 -> recursion2 IF_LEFT i1 i2-    IF_CONS i1 i2 -> recursion2 IF_CONS i1 i2-    IF i1 i2 -> recursion2 IF i1 i2-    MAP i1 -> recursion1 MAP i1-    ITER i1 -> recursion1 ITER i1-    LOOP i1 -> recursion1 LOOP i1-    LOOP_LEFT i1 -> recursion1 LOOP_LEFT i1-    DIP i1 -> recursion1 DIP i1-    DIPN s i1 -> recursion1 (DIPN s) i1--    -- This case is more complex so we duplicate @recursion1@ a bit.-    -- We have to traverse the pushed value because a lambda can be-    -- somewhere inside of it (e. g. one item of a pair).-    PUSH v -> fromMaybe (step i) do-        guard dsGoToValues-        let-          valueStep :: forall t . Value t -> (Value t, Maybe x)-          valueStep = \case-            -- Using 'analyzeInstrFailure' here (and in case below) is cheap-            -- (O(n) in total) because we never make it run over the same code twice-            VLam lambda -> bimap (VLam . analyzeInstrFailure) Just $-              dfsInstr settings step (rfAnyInstr lambda)-            otherV -> (otherV, Nothing)-        -- Note that @dfsTraverseValue@ does not respect 'CtorEffectsApp',-        -- so if we encounter a value that contains more than one lambda-        -- this function may misbehave.-        -- That's very unlikely in practice.-        -- In #264 we will support this feature in @dfsTraverseValue@.-        let-          (innerV, innerXMaybe) = runWriter $ dfsTraverseValue (writer . valueStep) v--        innerX <- innerXMaybe-        let (outerI, outerX) = step $ PUSH innerV-        pure $ ceaApplyEffects dsCtorEffectsApp innerX outerX outerI--    LAMBDA (VLam i1)-      | dsGoToValues ->-          recursion1 (LAMBDA . VLam . analyzeInstrFailure) (rfAnyInstr i1)-      | otherwise -> step i-    CREATE_CONTRACT contract-      | dsGoToValues ->-        let updateContractCode code = CREATE_CONTRACT $ contract{ cCode = code }-        in recursion1 updateContractCode $ cCode contract-      | otherwise -> step i--    Nop{} -> step i-    Ext (TEST_ASSERT (TestAssert nm pc i1)) ->-      recursion1 (Ext . TEST_ASSERT . TestAssert nm pc) i1-    Ext{} -> step i-    AnnCAR{} -> step i-    AnnCDR{} -> step i-    DROP{} -> step i-    DROPN{} -> step i-    DUP{} -> step i-    DUPN{} -> step i-    SWAP{} -> step i-    DIG{} -> step i-    DUG{} -> step i-    SOME{} -> step i-    NONE{} -> step i-    UNIT{} -> step i-    AnnPAIR{} -> step i-    AnnUNPAIR{} -> step i-    PAIRN{} -> step i-    UNPAIRN{} -> step i-    AnnLEFT{} -> step i-    AnnRIGHT{} -> step i-    NIL{} -> step i-    CONS{} -> step i-    SIZE{} -> step i-    EMPTY_SET{} -> step i-    EMPTY_MAP{} -> step i-    EMPTY_BIG_MAP{} -> step i-    MEM{} -> step i-    GET{} -> step i-    GETN{} -> step i-    UPDATE{} -> step i-    UPDATEN{} -> step i-    GET_AND_UPDATE{} -> step i-    EXEC{} -> step i-    APPLY{} -> step i-    FAILWITH{} -> step i-    CAST{} -> step i-    RENAME{} -> step i-    PACK{} -> step i-    UNPACK{} -> step i-    CONCAT{} -> step i-    CONCAT'{} -> step i-    SLICE{} -> step i-    ISNAT{} -> step i-    ADD{} -> step i-    SUB{} -> step i-    MUL{} -> step i-    EDIV{} -> step i-    ABS{} -> step i-    NEG{} -> step i-    LSL{} -> step i-    LSR{} -> step i-    OR{} -> step i-    AND{} -> step i-    XOR{} -> step i-    NOT{} -> step i-    COMPARE{} -> step i-    EQ{} -> step i-    NEQ{} -> step i-    LT{} -> step i-    GT{} -> step i-    LE{} -> step i-    GE{} -> step i-    INT{} -> step i-    SELF{} -> step i-    CONTRACT{} -> step i-    TRANSFER_TOKENS{} -> step i-    SET_DELEGATE{} -> step i-    IMPLICIT_ACCOUNT{} -> step i-    NOW{} -> step i-    AMOUNT{} -> step i-    BALANCE{} -> step i-    VOTING_POWER{} -> step i-    TOTAL_VOTING_POWER{} -> step i-    CHECK_SIGNATURE{} -> step i-    SHA256{} -> step i-    SHA512{} -> step i-    BLAKE2B{} -> step i-    SHA3{} -> step i-    KECCAK{} -> step i-    HASH_KEY{} -> step i-    PAIRING_CHECK{} -> step i-    SOURCE{} -> step i-    SENDER{} -> step i-    ADDRESS{} -> step i-    CHAIN_ID{} -> step i-    LEVEL{} -> step i-    SELF_ADDRESS{} -> step i-    NEVER{} -> step i-    TICKET{} -> step i-    READ_TICKET{} -> step i-    SPLIT_TICKET{} -> step i-    JOIN_TICKETS{} -> step i-  where-    recursion1 ::-      forall a b c d. (Instr a b -> Instr c d) -> Instr a b -> (Instr c d, x)-    recursion1 constructor i0 =-      let-        (innerI, innerX) = dfsInstr settings step i0-        (outerI, outerX) = step $ constructor innerI-      in ceaApplyEffects dsCtorEffectsApp innerX outerX outerI--    recursion2 ::-      forall i o i1 o1 i2 o2.-      (Instr i1 o1 -> Instr i2 o2 -> Instr i o) ->-      Instr i1 o1 -> Instr i2 o2 -> (Instr i o, x)-    recursion2 constructor i1 i2 =-      let-        (i1', x1) = dfsInstr settings step i1-        (i2', x2) = dfsInstr settings step i2-        (i', x) = step $ constructor i1' i2'-      in ceaApplyEffects dsCtorEffectsApp (x1 <> x2) x i'---- | Specialization of 'dfsInstr' for case when changing the instruction is--- not required.-dfsFoldInstr-  :: forall x inp out.-      (Semigroup x)-  => DfsSettings x-  -> (forall i o. Instr i o -> x)-  -> Instr inp out-  -> x-dfsFoldInstr settings step instr =-  snd $ dfsInstr settings (\i -> (i, step i)) instr---- | Specialization of 'dfsInstr' which only modifies given instruction.-dfsModifyInstr-  :: DfsSettings ()-  -> (forall i o. Instr i o -> Instr i o)-  -> Instr inp out-  -> Instr inp out-dfsModifyInstr settings step instr =-  fst $ dfsInstr settings (\i -> (step i, ())) instr---- | Check whether instruction fails at each execution path or have at least one--- non-failing path.------ This function assumes that given instruction contains no dead code--- (contract with dead code cannot be valid Michelson contract) and may behave--- in unexpected way if such is present. Term "dead code" includes instructions--- which render into empty Michelson, like Morley extensions.--- On the other hand, this function does not traverse the whole instruction tree;--- performs fastest on left-growing combs.------ Often we already have information about instruction failure, use this--- function only in cases when this info is actually unavailable or hard--- to use.-analyzeInstrFailure :: HasCallStack => Instr i o -> RemFail Instr i o-analyzeInstrFailure = go-  where-  go :: Instr i o -> RemFail Instr i o-  go = \case-    WithLoc loc i -> case go i of-      RfNormal i0 ->-        RfNormal (WithLoc loc i0)-      r -> r-    InstrWithNotes p pn i -> case go i of-      RfNormal i0 ->-        RfNormal (InstrWithNotes p pn i0)-      RfAlwaysFails i0 ->-        error $ "InstrWithNotes wraps always-failing instruction: " <> show i0-    InstrWithVarNotes vn i -> case go i of-      RfNormal i0 ->-        RfNormal (InstrWithVarNotes vn i0)-      RfAlwaysFails i0 ->-        error $ "InstrWithVarNotes wraps always-failing instruction: " <> show i0-    InstrWithVarAnns vn i -> case go i of-      RfNormal i0 ->-        RfNormal (InstrWithVarAnns vn i0)-      RfAlwaysFails i0 ->-        error $ "InstrWithVarAnns wraps always-failing instruction: " <> show i0-    FrameInstr s i -> case go i of-      RfNormal i0 ->-        RfNormal (FrameInstr s i0)-      RfAlwaysFails i0 ->-        error $ "FrameInstr wraps always-failing instruction: " <> show i0-    Seq a b -> Seq a `rfMapAnyInstr` go b-    Nop -> RfNormal Nop-    Ext e -> RfNormal (Ext e)-    Nested i -> Nested `rfMapAnyInstr` go i-    DocGroup g i -> DocGroup g `rfMapAnyInstr` go i-    Fn t sfn i -> Fn t sfn `rfMapAnyInstr` go i--    IF_NONE l r -> rfMerge IF_NONE (go l) (go r)-    IF_LEFT l r -> rfMerge IF_LEFT (go l) (go r)-    IF_CONS l r -> rfMerge IF_CONS (go l) (go r)-    IF l r -> rfMerge IF (go l) (go r)--    i@MAP{} -> RfNormal i-    i@ITER{} -> RfNormal i-    i@LOOP{} -> RfNormal i-    i@LOOP_LEFT{} -> RfNormal i-    i@LAMBDA{} -> RfNormal i-    i@DIP{} -> RfNormal i-    i@DIPN{} -> RfNormal i--    i@AnnCAR{} -> RfNormal i-    i@AnnCDR{} -> RfNormal i-    i@DROP{} -> RfNormal i-    i@DROPN{} -> RfNormal i-    i@DUP{} -> RfNormal i-    i@DUPN{} -> RfNormal i-    i@SWAP{} -> RfNormal i-    i@DIG{} -> RfNormal i-    i@DUG{} -> RfNormal i-    i@PUSH{} -> RfNormal i-    i@SOME{} -> RfNormal i-    i@NONE{} -> RfNormal i-    i@UNIT{} -> RfNormal i-    i@AnnPAIR{} -> RfNormal i-    i@AnnUNPAIR{} -> RfNormal i-    i@PAIRN{} -> RfNormal i-    i@UNPAIRN{} -> RfNormal i-    i@AnnLEFT{} -> RfNormal i-    i@AnnRIGHT{} -> RfNormal i-    i@NIL{} -> RfNormal i-    i@CONS{} -> RfNormal i-    i@SIZE{} -> RfNormal i-    i@EMPTY_SET{} -> RfNormal i-    i@EMPTY_MAP{} -> RfNormal i-    i@EMPTY_BIG_MAP{} -> RfNormal i-    i@MEM{} -> RfNormal i-    i@GET{} -> RfNormal i-    i@GETN{} -> RfNormal i-    i@UPDATE{} -> RfNormal i-    i@UPDATEN{} -> RfNormal i-    i@GET_AND_UPDATE{} -> RfNormal i-    i@EXEC{} -> RfNormal i-    i@APPLY{} -> RfNormal i-    FAILWITH -> RfAlwaysFails FAILWITH-    i@CAST -> RfNormal i-    i@RENAME -> RfNormal i-    i@PACK -> RfNormal i-    i@UNPACK -> RfNormal i-    i@CONCAT -> RfNormal i-    i@CONCAT' -> RfNormal i-    i@SLICE -> RfNormal i-    i@ISNAT -> RfNormal i-    i@ADD -> RfNormal i-    i@SUB -> RfNormal i-    i@MUL -> RfNormal i-    i@EDIV -> RfNormal i-    i@ABS -> RfNormal i-    i@NEG -> RfNormal i-    i@LSL -> RfNormal i-    i@LSR -> RfNormal i-    i@OR -> RfNormal i-    i@AND -> RfNormal i-    i@XOR -> RfNormal i-    i@NOT -> RfNormal i-    i@COMPARE -> RfNormal i-    i@EQ -> RfNormal i-    i@NEQ -> RfNormal i-    i@LT -> RfNormal i-    i@GT -> RfNormal i-    i@LE -> RfNormal i-    i@GE -> RfNormal i-    i@INT -> RfNormal i-    i@SELF{} -> RfNormal i-    i@CONTRACT{} -> RfNormal i-    i@TRANSFER_TOKENS -> RfNormal i-    i@SET_DELEGATE -> RfNormal i-    i@CREATE_CONTRACT{} -> RfNormal i-    i@IMPLICIT_ACCOUNT -> RfNormal i-    i@NOW -> RfNormal i-    i@AMOUNT -> RfNormal i-    i@BALANCE -> RfNormal i-    i@VOTING_POWER -> RfNormal i-    i@TOTAL_VOTING_POWER -> RfNormal i-    i@CHECK_SIGNATURE -> RfNormal i-    i@SHA256 -> RfNormal i-    i@SHA512 -> RfNormal i-    i@BLAKE2B -> RfNormal i-    i@SHA3 -> RfNormal i-    i@KECCAK -> RfNormal i-    i@HASH_KEY -> RfNormal i-    i@PAIRING_CHECK -> RfNormal i-    i@SOURCE -> RfNormal i-    i@SENDER -> RfNormal i-    i@ADDRESS -> RfNormal i-    i@CHAIN_ID -> RfNormal i-    i@LEVEL -> RfNormal i-    i@SELF_ADDRESS -> RfNormal i-    NEVER -> RfAlwaysFails NEVER-    i@TICKET -> RfNormal i-    i@READ_TICKET -> RfNormal i-    i@SPLIT_TICKET -> RfNormal i-    i@JOIN_TICKETS -> RfNormal i---- | There are many ways to represent a sequence of more than 2 instructions.--- E. g. for @i1; i2; i3@ it can be @Seq i1 $ Seq i2 i3@ or @Seq (Seq i1 i2) i3@.--- This function enforces a particular structure. Specifically, it makes each--- 'Seq' have a single instruction (i. e. not 'Seq') in its second argument.--- This function also erases redundant 'Nop's.------ Please note that this function is not recursive, it does not--- linearize contents of @IF@ and similar instructions.-linearizeLeft :: Instr inp out -> Instr inp out-linearizeLeft = linearizeLeftHelper False-  where-    -- In order to avoid quadratic performance we make a simple optimization.-    -- We track whether left argument of `Seq` is already linearized.-    -- If it is, we do not need to ever linearize it again.-    linearizeLeftHelper :: Bool -> Instr inp out -> Instr inp out-    linearizeLeftHelper isLeftInstrAlreadyLinear =-      \case-        Seq i1 (Seq i2 i3) ->-          linearizeLeftHelper True $-          Seq (linearizeLeftHelper isLeftInstrAlreadyLinear (Seq i1 i2)) i3-        -- `i2` is not a `Seq`, so we only need to linearize `i1`-        -- and connect it with `i2`.-        Seq i1 i2-          | isLeftInstrAlreadyLinear-          , Nop <- i2 -> i1-          | isLeftInstrAlreadyLinear -> Seq i1 i2-          | Nop <- i2 -> linearizeLeft i1-          | otherwise -> Seq (linearizeLeft i1) i2-        i -> i---- | "Deep" version of 'linearizeLeft'. It recursively linearizes--- instructions stored in other instructions.-linearizeLeftDeep :: Instr inp out -> Instr inp out-linearizeLeftDeep = dfsModifyInstr def linearizeLeft--------------------------------------------------------------------------------- Value analysis--------------------------------------------------------------------------------- | Traverse a value in depth-first order.-dfsMapValue ::-     forall t.-     (forall t'. Value t' -> Value t')-  -> Value t-  -> Value t-dfsMapValue step v = runIdentity $ dfsTraverseValue (pure . step) v---- | Traverse a value in depth-first order.-dfsTraverseValue ::-     forall t m.-     (Monad m)-  => (forall t'. Value t' -> m (Value t'))-  -> Value t-  -> m (Value t)-dfsTraverseValue step i = case i of-  -- Atomic-  VKey{} -> step i-  VUnit -> step i-  VSignature{} -> step i-  VChainId{} -> step i-  VOp{} -> step i-  VContract{} -> step i-  VTicket{} -> step i  -- cannot appear as constant in a contract-  VLam{} -> step i-  VInt{} -> step i-  VNat{} -> step i-  VString{} -> step i-  VBytes{} -> step i-  VMutez{} -> step i-  VBool{} -> step i-  VKeyHash{} -> step i-  VBls12381Fr{} -> step i-  VBls12381G1{} -> step i-  VBls12381G2{} -> step i-  VTimestamp{} -> step i-  VAddress{} -> step i--  -- Non-atomic-  VOption mVal -> case mVal of-    Nothing -> step i-    Just val -> recursion1 (VOption . Just) val-  VList vals -> do-    vs <- traverse (dfsTraverseValue step) vals-    step $ VList vs-  VSet vals -> do-    cs <- S.fromList <$> traverse (dfsTraverseValue step) (S.toList vals)-    step (VSet cs)-  VPair (v1, v2) -> do-    v1' <- dfsTraverseValue step v1-    v2' <- dfsTraverseValue step v2-    step $ VPair (v1', v2')-  VOr vEither -> case vEither of-    Left v -> recursion1 (VOr . Left) v-    Right v -> recursion1 (VOr . Right) v-  VMap vmap -> mapRecursion VMap vmap-  VBigMap bmId vmap -> mapRecursion (VBigMap bmId) vmap-  where-    recursion1 ::-         forall t'.-         (Value t' -> Value t)-      -> Value t'-      -> m (Value t)-    recursion1 constructor v = do-      v' <- dfsTraverseValue step v-      step $ constructor v'--    mapRecursion-      :: forall k v. Comparable k-      => (M.Map (Value k) (Value v) -> Value t)-      -> M.Map (Value k) (Value v)-      -> m (Value t)-    mapRecursion constructor vmap = do-      vmap' <--        M.fromList <$> forM (M.toList vmap) \(k, v) -> do-          k' <- dfsTraverseValue step k-          v' <- dfsTraverseValue step v-          pure (k', v')-      step $ constructor vmap'---- | Specialization of 'dfsMapValue' for case when changing the value is--- not required.-dfsFoldMapValue ::-  Monoid x =>-  (forall t'. Value t' -> x)-  -> Value t-  -> x-dfsFoldMapValue step v =-  runIdentity $ dfsFoldMapValueM (pure . step) v---- | Specialization of 'dfsMapValue' for case when changing the value is--- not required.-dfsFoldMapValueM-  :: (Monoid x, Monad m)-  => (forall t'. Value t' -> m x)-  -> Value t-  -> m x-dfsFoldMapValueM step v = do-  execWriterT $-    dfsTraverseValue-      (\val -> do-          x <- lift $ step val-          tell x-          pure val-      )-      v---- | If value is a string, return the stored string.-isStringValue :: Value t -> Maybe MText-isStringValue =-  \case-    VString str -> Just str-    _ -> Nothing---- | If value is a bytestring, return the stored bytestring.-isBytesValue :: Value t -> Maybe ByteString-isBytesValue =-  \case-    VBytes bytes -> Just bytes-    _ -> Nothing---- | Takes a selector which checks whether a value can be converted--- to something. Recursively applies it to all values. Collects extracted--- values in a list.-allAtomicValues ::-  forall t a. (forall t'. Value t' -> Maybe a) -> Value t -> [a]-allAtomicValues selector = dfsFoldMapValue (maybeToList . selector)-------------------------------------------------------------------------------------- Instruction generation------------------------------------------------------------------------------------- | Result of splitting a storage 'Value' of @st@ on the stack @s@.------ The idea behind this is to either: prove that the whole 'Value' can be put on--- the stack without containing a single @big_map@ or to split it into:--- a 'Value' containing its @big_map@s and an instruction to reconstruct the--- storage.------ The main idea behind this is to create a large storage in Michelson code to--- then create a contract using 'CREATE_CONTRACT'.--- Note: a simpler solution would have been to replace @big_map@ 'Value's with--- an 'EMPTY_BIG_MAP' followed by many 'UPDATE' to push its content, but sadly--- a bug (tezos/tezos/1154) prevents this from being done.-data PushableStorageSplit s st where-  -- | The type of the storage is fully constant.-  ConstantStorage-    :: ConstantScope st-    => Value st-    -> PushableStorageSplit s st--  -- | The type of the storage is not a constant, but its value does not contain-  -- @big_map@s. E.g. A 'Right ()' value of type 'Either (BigMap k v) ()'.-  PushableValueStorage-    :: StorageScope st-    => Instr s (st ': s)-    -> PushableStorageSplit s st--  -- | The type of the storage and part of its value (here @heavy@) contain one or-  -- more @big_map@s or @ticket@s. The instruction can take the non-pushable-  -- 'Value heavy' and reconstruct the original 'Value st' without using any-  -- 'EMPTY_BIG_MAP'.-  PartlyPushableStorage-    :: (StorageScope heavy, StorageScope st)-    => Value heavy -> Instr (heavy ': s) (st ': s)-    -> PushableStorageSplit s st---- | Splits the given storage 'Value' into a 'PushableStorageSplit'.------ This is based off the fact that the only storages that cannot be directly--- 'PUSH'ed are the ones that contain 'BigMap's and tickets.--- See difference between 'StorageScope' and 'ConstantScope'.------ So what we do here is to create a 'Value' as small as possible with all the--- @big_map@s in it (if any) and an 'Instr' that can use it to rebuild the original--- storage 'Value'.------ Note: This is done this way to avoid using 'EMPTY_BIG_MAP' instructions, see--- 'PushableStorageSplit' for motivation.-splitPushableStorage :: StorageScope t => Value t -> PushableStorageSplit s t-splitPushableStorage v = case v of-  -- Atomic (except op and contract)-  VKey{}        -> ConstantStorage v-  VUnit         -> ConstantStorage v-  VSignature{}  -> ConstantStorage v-  VChainId{}    -> ConstantStorage v-  VLam{}        -> ConstantStorage v-  VInt{}        -> ConstantStorage v-  VNat{}        -> ConstantStorage v-  VString{}     -> ConstantStorage v-  VBytes{}      -> ConstantStorage v-  VMutez{}      -> ConstantStorage v-  VBool{}       -> ConstantStorage v-  VKeyHash{}    -> ConstantStorage v-  VBls12381Fr{} -> ConstantStorage v-  VBls12381G1{} -> ConstantStorage v-  VBls12381G2{} -> ConstantStorage v-  VTimestamp{}  -> ConstantStorage v-  VAddress{}    -> ConstantStorage v-  VTicket{}     -> PartlyPushableStorage v Nop--  -- Non-atomic-  VOption (Nothing :: Maybe (Value tm)) -> case checkScope @(ConstantScope tm) of-    Right Dict -> ConstantStorage $ VOption Nothing-    Left _     -> PushableValueStorage $ NONE-  VOption (Just jVal :: Maybe (Value tm)) -> case splitPushableStorage jVal of-    ConstantStorage _ -> ConstantStorage . VOption $ Just jVal-    PushableValueStorage instr -> PushableValueStorage $ instr `Seq` SOME-    PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` SOME--  VList (vals :: [Value tl]) -> case checkScope @(ConstantScope tl) of-    Right Dict -> ConstantStorage v-    Left _     ->-      -- Here we check that even tho the type contains big_maps, we actually-      -- have big_maps in (one or more of) the values too.-      let handleList-            :: Instr s ('T.TList tl ': s) -> Value tl-            -> Maybe (Instr s ('T.TList tl ': s))-          handleList instr ele = case splitPushableStorage ele of-            ConstantStorage val ->-              Just $ instr `Seq` PUSH val `Seq` CONS-            PushableValueStorage eleInstr ->-              Just $ instr `Seq` eleInstr `Seq` CONS-            PartlyPushableStorage _ _ -> Nothing-      in  maybe (PartlyPushableStorage v Nop) PushableValueStorage $-            foldM handleList NIL vals--  VSet{} -> ConstantStorage v--  VPair (v1 :: Value t1, v2 :: Value t2) ->-    withValueTypeSanity v1 $ withValueTypeSanity v2 $-      withDeMorganScope @StorageScope @'T.TPair @t1 @t2 $-        let handlePair-              :: PushableStorageSplit s t2-              -> PushableStorageSplit (t2 ': s) t1-              -> PushableStorageSplit s ('T.TPair t1 t2)-            handlePair psp2 psp1 = case (psp2, psp1) of-              -- at least one side is a constant-              (ConstantStorage _, ConstantStorage _) ->-                ConstantStorage v-              (ConstantStorage val2, _) ->-                handlePair (PushableValueStorage $ PUSH val2) psp1-              (_, ConstantStorage val1) ->-                handlePair psp2 (PushableValueStorage $ PUSH val1)-              -- at least one side is a constant or has no big_map values-              (PushableValueStorage instr2, PushableValueStorage instr1) ->-                PushableValueStorage $ instr2 `Seq` instr1 `Seq` PAIR-              (PushableValueStorage instr2, PartlyPushableStorage val1 instr1) ->-                PartlyPushableStorage val1 $ DIP instr2 `Seq` instr1 `Seq` PAIR-              (PartlyPushableStorage val2 instr2, PushableValueStorage instr1) ->-                PartlyPushableStorage val2 $ instr2 `Seq` instr1 `Seq` PAIR-              -- both sides contain a big_map-              (PartlyPushableStorage val2 instr2, PartlyPushableStorage val1 instr1) ->-                PartlyPushableStorage (VPair (val1, val2)) $-                  UNPAIR `Seq` DIP instr2 `Seq` instr1 `Seq` PAIR-        in handlePair (splitPushableStorage v2) (splitPushableStorage v1)--  VOr (Left orVal :: Either (Value t1) (Value t2)) ->-    withValueTypeSanity orVal $ withDeMorganScope @StorageScope @'T.TOr @t1 @t2 $-      case splitPushableStorage orVal of-        ConstantStorage val -> case checkScope @(ConstantScope t2) of-          -- note: here we need to check for the opposite branch too-          Right Dict -> ConstantStorage v-          Left _ -> PushableValueStorage $ PUSH val `Seq` LEFT-        PushableValueStorage instr -> PushableValueStorage $ instr `Seq` LEFT-        PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` LEFT-  VOr (Right orVal :: Either (Value t1) (Value t2)) ->-    withValueTypeSanity orVal $ withDeMorganScope @StorageScope @'T.TOr @t1 @t2 $-      case splitPushableStorage orVal of-        ConstantStorage val -> case checkScope @(ConstantScope t1) of-          -- note: here we need to check for the opposite branch too-          Right Dict -> ConstantStorage v-          Left _ -> PushableValueStorage $ PUSH val `Seq` RIGHT-        PushableValueStorage instr -> PushableValueStorage $ instr `Seq` RIGHT-        PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` RIGHT--  VMap (vMap :: (Map (Value tk) (Value tv))) -> case checkScope @(ConstantScope tk) of-    Left _ ->-      -- NOTE: all keys for a map need to be comparable and (even tho it's-      -- not a superclass) that means they have to be constants.-      -- I (@pasqu4le) found no exception to this rule, perhaps it should be-      -- enforced in the type system as well, but it may have more-      -- downsides than it's worth accepting.-      error "impossible: all map keys should be PUSHable"-    Right Dict -> case checkScope @(ConstantScope tv) of-      Right Dict -> ConstantStorage v-      _ -> withDeMorganScope @HasNoOp @'T.TMap @tk @tv $-        -- Similarly as for lists, here we check that even tho the value type-        -- contains a big_map, we actually have big_maps in (one or more of) them.-        let handleMap-              :: Instr s ('T.TMap tk tv ': s) -> (Value tk, Value tv)-              -> Maybe (Instr s ('T.TMap tk tv ': s))-            handleMap instr (key, ele) = case splitPushableStorage (VOption $ Just ele) of-              ConstantStorage val ->-                Just $ instr `Seq` PUSH val `Seq` PUSH key `Seq` UPDATE-              PushableValueStorage eleInstr ->-                Just $ instr `Seq` eleInstr `Seq` PUSH key `Seq` UPDATE-              PartlyPushableStorage _ _ -> Nothing-        in  maybe (PartlyPushableStorage v Nop) PushableValueStorage $-              foldM handleMap EMPTY_MAP $ M.toList vMap--  VBigMap _ _ -> PartlyPushableStorage v Nop

− src/Michelson/Typed/Value.hs

@@ -1,484 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE QuantifiedConstraints #-}---- | Module, containing data types for Michelson value.--module Michelson.Typed.Value-  ( Comparability (..)-  , Comparable-  , ComparabilityScope-  , ContractInp1-  , ContractInp-  , ContractOut1-  , ContractOut-  , CreateContract (..)-  , Operation' (..)-  , SetDelegate (..)-  , TransferTokens (..)-  , Value' (..)-  , RemFail (..)-  , rfMerge-  , rfAnyInstr-  , rfMapAnyInstr-  , addressToVContract-  , buildVContract-  , checkComparability-  , compileEpLiftSequence-  , comparabilityPresence-  , getComparableProofS-  , liftCallArg-  , valueTypeSanity-  , withValueTypeSanity-  , eqValueExt-  ) where--import Data.Constraint (Dict(..), (\\))-import Data.Singletons (Sing)-import Data.Type.Bool (type (&&))-import Fmt (Buildable(build), Builder, (+|), (|+))-import GHC.TypeLits (ErrorMessage(..), TypeError)--import Michelson.Text (MText)-import Michelson.Typed.Entrypoints-import Michelson.Typed.Scope-import Michelson.Typed.Sing-import Michelson.Typed.T (T(..))-import Tezos.Address (Address)-import Tezos.Core (ChainId, Mutez, Timestamp)-import Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature)-import Util.Sing (eqParamSing, eqParamSing3)-import Util.TH---- | Data type, representing operation, list of which is returned--- by Michelson contract (according to calling convention).------ These operations are to be further executed against system state--- after the contract execution.-data Operation' instr where-  OpTransferTokens-    :: (ParameterScope p)-    => TransferTokens instr p -> Operation' instr-  OpSetDelegate :: SetDelegate -> Operation' instr-  OpCreateContract-    :: ( Show (instr (ContractInp cp st) (ContractOut st))-       , NFData (instr (ContractInp cp st) (ContractOut st))-       , Typeable instr, ParameterScope cp, StorageScope st)-    => CreateContract instr cp st-    -> Operation' instr--instance Buildable (Operation' instr) where-  build =-    \case-      OpTransferTokens tt -> build tt-      OpSetDelegate sd -> build sd-      OpCreateContract cc -> build cc--deriving stock instance Show (Operation' instr)--instance Eq (Operation' instr) where-  op1 == op2 = case (op1, op2) of-    (OpTransferTokens tt1, OpTransferTokens tt2) -> tt1 `eqParamSing` tt2-    (OpTransferTokens _, _) -> False-    (OpSetDelegate sd1, OpSetDelegate sd2) -> sd1 == sd2-    (OpSetDelegate _, _) -> False-    (OpCreateContract cc1, OpCreateContract cc2) -> cc1 `eqParamSing3` cc2-    (OpCreateContract _, _) -> False--data TransferTokens instr p = TransferTokens-  { ttTransferArgument :: Value' instr p-  , ttAmount :: Mutez-  , ttContract :: Value' instr ('TContract p)-  } deriving stock (Show, Eq, Generic)--instance NFData (TransferTokens instr p)--instance Buildable (TransferTokens instr p) where-  build TransferTokens {..} =-    "Transfer " +| ttAmount |+ " tokens to " +| buildVContract ttContract |+ ""--data SetDelegate = SetDelegate-  { sdMbKeyHash :: Maybe KeyHash-  } deriving stock (Show, Eq, Generic)--instance NFData SetDelegate--instance Buildable SetDelegate where-  build (SetDelegate mbDelegate) =-    "Set delegate to " <> maybe "<nobody>" build mbDelegate--data CreateContract instr cp st-  = ( Show (instr (ContractInp cp st) (ContractOut st))-    , Eq (instr (ContractInp cp st) (ContractOut st))-    )-  => CreateContract-  { ccOriginator :: Address-  , ccDelegate :: Maybe KeyHash-  , ccBalance :: Mutez-  , ccStorageVal :: Value' instr st-  , ccContractCode :: instr (ContractInp cp st) (ContractOut st)-  }--instance NFData (instr (ContractInp cp st) (ContractOut st)) => NFData (CreateContract instr cp st) where-  rnf (CreateContract a b c d e) = rnf (a, b, c, d, e)--instance Buildable (CreateContract instr cp st) where-  build CreateContract {..} =-    "Create a new contract with" <>-    " delegate " +| maybe "<nobody>" build ccDelegate |+-    " and balance = " +| ccBalance |+ ""--deriving stock instance Show (CreateContract instr cp st)-deriving stock instance Eq (CreateContract instr cp st)--type ContractInp1 param st = 'TPair param st-type ContractInp param st = '[ ContractInp1 param st ]--type ContractOut1 st = 'TPair ('TList 'TOperation) st-type ContractOut st = '[ ContractOut1 st ]---- | Wrapper over instruction which remembers whether this instruction--- always fails or not.-data RemFail (instr :: k -> k -> Type) (i :: k) (o :: k) where-  RfNormal :: instr i o -> RemFail instr i o-  RfAlwaysFails :: (forall o'. instr i o') -> RemFail instr i o--deriving stock instance (forall o'. Show (instr i o')) => Show (RemFail instr i o)-instance (forall o'. NFData (instr i o')) => NFData (RemFail instr i o) where-  rnf (RfNormal a) = rnf a-  rnf (RfAlwaysFails a) = rnf a---- | Ignoring distinction between constructors here, comparing only semantics.-instance Eq (instr i o) => Eq (RemFail instr i o) where-  RfNormal i1 == RfNormal i2 = i1 == i2-  RfAlwaysFails i1 == RfNormal i2 = i1 == i2-  RfNormal i1 == RfAlwaysFails i2 = i1 == i2-  RfAlwaysFails i1 == RfAlwaysFails i2 = i1 @o == i2---- | Merge two execution branches.-rfMerge-  :: (forall o'. instr i1 o' -> instr i2 o' -> instr i3 o')-  -> RemFail instr i1 o -> RemFail instr i2 o -> RemFail instr i3 o-rfMerge merger instr1 instr2 = case (instr1, instr2) of-  (RfNormal i1, RfNormal i2) -> RfNormal (merger i1 i2)-  (RfAlwaysFails i1, RfNormal i2) -> RfNormal (merger i1 i2)-  (RfNormal i1, RfAlwaysFails i2) -> RfNormal (merger i1 i2)-  (RfAlwaysFails i1, RfAlwaysFails i2) -> RfAlwaysFails (merger i1 i2)---- | Get code disregard whether it always fails or not.-rfAnyInstr :: RemFail instr i o -> instr i o-rfAnyInstr = \case-  RfNormal i -> i-  RfAlwaysFails i -> i---- | Modify inner code.-rfMapAnyInstr-  :: (forall o'. instr i1 o' -> instr i2 o')-  -> RemFail instr i1 o-  -> RemFail instr i2 o-rfMapAnyInstr f = \case-  RfNormal i -> RfNormal $ f i-  RfAlwaysFails i -> RfAlwaysFails $ f i--getComparableProofS :: Sing (a :: T) -> Maybe (Dict (Comparable a))-getComparableProofS s = case checkComparability s of-  CanBeCompared -> Just Dict-  CannotBeCompared -> Nothing---- | Constraint which ensures that type is comparable.-type family IsComparable (t :: T) :: Bool where-  IsComparable ('TPair a b) =  IsComparable a && IsComparable b-  IsComparable ('TOption t) = IsComparable t-  IsComparable 'TBls12381Fr = 'False-  IsComparable 'TBls12381G1 = 'False-  IsComparable 'TBls12381G2 = 'False-  IsComparable ('TList _) = 'False-  IsComparable ('TSet _) = 'False-  IsComparable 'TOperation = 'False-  IsComparable ('TContract _) = 'False-  IsComparable ('TTicket _) = 'False-  IsComparable ('TOr a b) = IsComparable a && IsComparable b-  IsComparable ('TLambda _ _) = 'False-  IsComparable ('TMap _ _) = 'False-  IsComparable ('TBigMap _ _) = 'False-  IsComparable _            = 'True--class (IsComparable t ~ 'True) => Comparable t where-  tcompare :: (Value' instr t) -> (Value' instr t) -> Ordering--instance (Comparable e1, Comparable e2) => Comparable ('TPair e1 e2) where-  tcompare (VPair a) (VPair b) = compare a b-instance (Comparable e1, Comparable e2) => Comparable ('TOr e1 e2) where-  tcompare (VOr a) (VOr b) = compare a b-instance Comparable e => Comparable ('TOption e) where-  tcompare (VOption a) (VOption b) = compare a b-instance Comparable 'TUnit where-  tcompare VUnit VUnit = EQ-instance Comparable 'TInt where-  tcompare (VInt a) (VInt b) = compare a b-instance Comparable 'TNat where-  tcompare (VNat a) (VNat b) = compare a b-instance Comparable 'TString where-  tcompare (VString a) (VString b) = compare a b-instance Comparable 'TBytes where-  tcompare (VBytes a) (VBytes b) = compare a b-instance Comparable 'TMutez where-  tcompare (VMutez a) (VMutez b) = compare a b-instance Comparable 'TBool where-  tcompare (VBool a) (VBool b) = compare a b-instance Comparable 'TKeyHash where-  tcompare (VKeyHash a) (VKeyHash b) = compare a b-instance Comparable 'TTimestamp where-  tcompare (VTimestamp a) (VTimestamp b) = compare a b-instance Comparable 'TAddress where-  tcompare (VAddress a) (VAddress b) = compare a b-instance Comparable 'TNever where-  tcompare = \case-instance Comparable 'TChainId where-  tcompare (VChainId a) (VChainId b) = compare a b-instance Comparable 'TSignature where-  tcompare (VSignature a) (VSignature b) = compare a b-instance Comparable 'TKey where-  tcompare (VKey a) (VKey b) = compare a b--instance (Comparable e) => Ord (Value' instr e) where-  compare = tcompare @e---- | Report a human-readable error that 'TBigMap' contains another 'TBigMap'-type family FailOnNonComparable (isComparable :: Bool) :: Constraint where-  FailOnNonComparable 'False =-    TypeError ('Text "The type is not comparable")-  FailOnNonComparable 'True = ()---- | Alias for comparable types.-type ComparabilityScope t =-  (SingI t, Comparable t)--data Comparability t where-  CanBeCompared :: (Comparable t) => Comparability t-  CannotBeCompared :: (IsComparable t ~ 'False) => Comparability t--checkComparability :: Sing t -> Comparability t-checkComparability = \case-  STPair a b -> case (checkComparability a, checkComparability b) of-    (CanBeCompared, CanBeCompared) -> CanBeCompared-    (CannotBeCompared, _) -> CannotBeCompared-    (_, CannotBeCompared) -> CannotBeCompared-  STOr a b -> case (checkComparability a, checkComparability b) of-    (CanBeCompared, CanBeCompared) -> CanBeCompared-    (CannotBeCompared, _) -> CannotBeCompared-    (_, CannotBeCompared) -> CannotBeCompared-  STOption t -> case checkComparability t of-    CanBeCompared -> CanBeCompared-    CannotBeCompared -> CannotBeCompared-  STList _ -> CannotBeCompared-  STSet _ -> CannotBeCompared-  STOperation -> CannotBeCompared-  STContract _ -> CannotBeCompared-  STTicket _ -> CannotBeCompared-  STLambda _ _ -> CannotBeCompared-  STMap _ _ -> CannotBeCompared-  STBigMap _ _ -> CannotBeCompared-  STNever -> CanBeCompared-  STUnit -> CanBeCompared-  STInt -> CanBeCompared-  STNat -> CanBeCompared-  STString -> CanBeCompared-  STBytes -> CanBeCompared-  STMutez -> CanBeCompared-  STBool -> CanBeCompared-  STKeyHash -> CanBeCompared-  STBls12381Fr -> CannotBeCompared-  STBls12381G1 -> CannotBeCompared-  STBls12381G2 -> CannotBeCompared-  STTimestamp -> CanBeCompared-  STAddress -> CanBeCompared-  STKey -> CanBeCompared-  STSignature -> CanBeCompared-  STChainId -> CanBeCompared--comparabilityPresence :: Sing t -> Maybe (Dict $ (Comparable t))-comparabilityPresence s = case checkComparability s of-  CanBeCompared -> Just Dict-  CannotBeCompared -> Nothing--instance SingI t => CheckScope (Comparable t) where-  checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing--instance (SingI t) => CheckScope (ComparabilityScope t) where-  checkScope =-    (\Dict -> Dict) <$> checkScope @(Comparable t)---- | Representation of Michelson value.------ Type parameter @instr@ stands for Michelson instruction--- type, i.e. data type to represent an instruction of language.--data Value' instr t where-  VKey :: PublicKey -> Value' instr 'TKey-  VUnit :: Value' instr 'TUnit-  VSignature :: Signature -> Value' instr 'TSignature-  VChainId :: ChainId -> Value' instr 'TChainId-  VOption-    :: forall t instr.-       (SingI t)-    => Maybe (Value' instr t) -> Value' instr ('TOption t)-  VList-    :: forall t instr.-       (SingI t)-    => [Value' instr t] -> Value' instr ('TList t)-  VSet-    :: forall t instr.-       (SingI t, Comparable t)-    => Set (Value' instr t) -> Value' instr ('TSet t)-  VOp-    :: Operation' instr -> Value' instr 'TOperation-  VContract-    :: forall arg instr.-       (SingI arg, HasNoOp arg)-    => Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)-  VTicket-    :: forall arg instr.-       (Comparable arg)-    => Address -> Value' instr arg -> Natural -> Value' instr ('TTicket arg)-  VPair-    :: forall l r instr.-       (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)-  VOr-    :: forall l r instr.-       (SingI l, SingI r)-    => Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)-  VLam-    :: forall inp out instr.-       ( SingI inp, SingI out-       , forall i o. Show (instr i o)-       , forall i o. Eq (instr i o)-       , forall i o. NFData (instr i o)-       )-    => RemFail instr (inp ': '[]) (out ': '[]) -> Value' instr ('TLambda inp out)-  VMap-    :: forall k v instr.-       (SingI k, SingI v, Comparable k)-    => Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v)-  VBigMap-    :: forall k v instr.-       (SingI k, SingI v, Comparable k, HasNoBigMap v)-    => Maybe Natural -- ^ The big_map's ID. This is only used in the interpreter.-    -> Map (Value' instr k) (Value' instr v)-    -> Value' instr ('TBigMap k v)-  VInt       :: Integer ->  Value' instr 'TInt-  VNat       :: Natural -> Value' instr 'TNat-  VString    :: MText -> Value' instr 'TString-  VBytes     :: ByteString -> Value' instr 'TBytes-  VMutez     :: Mutez -> Value' instr 'TMutez-  VBool      :: Bool -> Value' instr 'TBool-  VKeyHash   :: KeyHash -> Value' instr 'TKeyHash-  VTimestamp :: Timestamp -> Value' instr 'TTimestamp-  VAddress   :: EpAddress -> Value' instr 'TAddress-  VBls12381Fr :: Bls12381Fr -> Value' instr 'TBls12381Fr-  VBls12381G1 :: Bls12381G1 -> Value' instr 'TBls12381G1-  VBls12381G2 :: Bls12381G2 -> Value' instr 'TBls12381G2--deriving stock instance Show (Value' instr t)-deriving stock instance Eq (Value' instr t)---- | Make value of 'contract' type which refers to the given address and--- does not call any entrypoint.-addressToVContract-  :: forall t instr.-      (ParameterScope t, ForbidOr t)-  => Address -> Value' instr ('TContract t)-addressToVContract addr = VContract addr sepcPrimitive--buildVContract :: Value' instr ('TContract arg) -> Builder-buildVContract = \case-  VContract addr epc -> "Contract " +| addr |+ " call " +| epc |+ ""---- | Turn 'EpLiftSequence' into actual function on 'Value's.-compileEpLiftSequence-  :: EpLiftSequence arg param-  -> Value' instr arg-  -> Value' instr param-compileEpLiftSequence = \case-  EplArgHere -> id-  EplWrapLeft els -> VOr . Left . compileEpLiftSequence els-  EplWrapRight els -> VOr . Right . compileEpLiftSequence els---- | Lift entrypoint argument to full parameter.-liftCallArg-  :: EntrypointCallT param arg-  -> Value' instr arg-  -> Value' instr param-liftCallArg epc = compileEpLiftSequence (epcLiftSequence epc)---- | Get a witness of that value's type is known.------ Note that we cannot pick such witness out of nowhere as not all types--- of kind 'T' have 'Typeable' and 'SingI' instances; example:------ @--- type family Any :: T where---   -- nothing here--- @-valueTypeSanity :: Value' instr t -> Dict (SingI t)-valueTypeSanity = \case-  VKey{} -> Dict-  VUnit{} -> Dict-  VSignature{} -> Dict-  VChainId{} -> Dict-  VOption{} -> Dict-  VList{} -> Dict-  VSet{} -> Dict-  VOp{} -> Dict-  VContract _ (SomeEpc EntrypointCall{}) -> Dict-  VTicket _ v _ -> case valueTypeSanity v of-    Dict -> Dict-  VPair (l, r) -> case (valueTypeSanity l, valueTypeSanity r) of-    (Dict, Dict) -> Dict-  VOr{} -> Dict-  VLam{} -> Dict-  VMap{} -> Dict-  VBigMap{} -> Dict-  VInt{} -> Dict-  VNat{} -> Dict-  VString{} -> Dict-  VBytes{} -> Dict-  VMutez{} -> Dict-  VBool{} -> Dict-  VKeyHash{} -> Dict-  VBls12381Fr{} -> Dict-  VBls12381G1{} -> Dict-  VBls12381G2{} -> Dict-  VTimestamp{} -> Dict-  VAddress{} -> Dict---- | Provide a witness of that value's type is known.-withValueTypeSanity :: Value' instr t -> (SingI t => a) -> a-withValueTypeSanity v a = case valueTypeSanity v of Dict -> a---- | Extended values comparison - it does not require 'Value's to be--- of the same type, only their content to match.-eqValueExt :: Value' instr t1 -> Value' instr t2 -> Bool-eqValueExt v1 v2 =-  v1 `eqParamSing` v2-    \\ valueTypeSanity v1-    \\ valueTypeSanity v2---- TODO: actually we should handle big maps with something close--- to following:------  VBigMap :: BigMap op ref k v -> Value' cp ('TBigMap k v)------ data Value'Op v---     = New v---     | Upd v---     | Rem---     | NotExisted------ data BigMap op ref k v = BigMap---  { bmRef :: ref k v, bmChanges :: Map (CValue k) (Value'Op (Value' cp v)) }--$(deriveGADTNFData ''Operation')-$(deriveGADTNFData ''Value')

− src/Michelson/Untyped.hs

@@ -1,17 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Untyped-  ( module Exports-  ) where--import Michelson.Untyped.Aliases as Exports-import Michelson.Untyped.Annotation as Exports-import Michelson.Untyped.Contract as Exports-import Michelson.Untyped.Entrypoints as Exports-import Michelson.Untyped.Ext as Exports-import Michelson.Untyped.Instr as Exports-import Michelson.Untyped.OpSize as Exports-import Michelson.Untyped.Type as Exports-import Michelson.Untyped.Value as Exports

− src/Michelson/Untyped/Aliases.hs

@@ -1,20 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Some simple aliases for Michelson types.--module Michelson.Untyped.Aliases-  ( Contract-  , Value-  , ExpandedExtInstr-  ) where--import qualified Michelson.Untyped.Contract as Untyped-import qualified Michelson.Untyped.Ext as Untyped-import qualified Michelson.Untyped.Instr as Untyped-import qualified Michelson.Untyped.Value as Untyped--type Value = Untyped.Value' Untyped.ExpandedOp-type Contract = Untyped.Contract' Untyped.ExpandedOp-type ExpandedExtInstr = Untyped.ExtInstrAbstract Untyped.ExpandedOp

− src/Michelson/Untyped/Annotation.hs

@@ -1,428 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Michelson annotations in untyped model.--module Michelson.Untyped.Annotation-  ( Annotation (..)-  , VarAnns (..)-  , pattern Annotation-  , pattern WithAnn--  -- * Annotation Set-  , AnnotationSet(..)-  , annsCount-  , emptyAnnSet-  , firstAnn-  , fullAnnSet-  , isNoAnnSet-  , minAnnSetSize-  , secondAnn-  , singleAnnSet-  , singleGroupAnnSet-  , minimizeAnnSet--  -- * Rendering-  , KnownAnnTag(..)-  , TypeAnn-  , FieldAnn-  , VarAnn-  , SomeAnn-  , RootAnn-  , TypeTag-  , FieldTag-  , VarTag--  -- * Creation and conversions-  , noAnn-  , annQ-  , varAnnQ-  , fieldAnnQ-  , typeAnnQ-  , unsafeMkAnnotation-  , mkAnnotation-  , specialVarAnns-  , specialFieldAnn-  , isValidAnnStart-  , isValidAnnBodyChar-  , orAnn-  , unifyAnn-  , unifyPairFieldAnn-  , convergeVarAnns-  , ifAnnUnified-  , convAnn-  ) where--import Data.Aeson.TH (deriveJSON)-import Data.Char (isAlpha, isAscii, isDigit, isNumber)-import Data.Data (Data(..))-import Data.Default (Default(..))-import qualified Data.Text as T-import Data.Typeable (eqT, (:~:)(..))-import Fmt (Buildable(build))-import Instances.TH.Lift ()-import qualified Language.Haskell.TH as TH-import Language.Haskell.TH.Lift (deriveLift)-import qualified Language.Haskell.TH.Quote as TH-import Text.PrettyPrint.Leijen.Text (Doc, hsep, textStrict, (<+>))-import qualified Text.Show--import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, doesntNeedParens, printDocS)-import Util.Aeson---- | Generic Type/Field/Variable Annotation------ As per Michelson documentation, this type has an invariant:--- (except for the first character, here parametrized in the type `tag`) the--- allowed character set is the one matching the following regexp:--- @%|@%%|%@|[@:%][_0-9a-zA-Z][_0-9a-zA-Z\.%@]*-newtype Annotation tag = UnsafeAnnotation { unAnnotation :: Text }-  deriving stock (Eq, Data, Functor, Generic)--instance NFData (Annotation tag)--pattern Annotation :: Text -> Annotation tag-pattern Annotation ann <- UnsafeAnnotation ann--{-# COMPLETE Annotation :: Annotation #-}--instance Default (Annotation tag) where-  def = noAnn--data VarAnns-  = OneVarAnn VarAnn-  | TwoVarAnns VarAnn VarAnn-  deriving stock (Generic, Show)-  deriving anyclass (NFData)------------------------------------------------------------------------------------- Annotation Set------------------------------------------------------------------------------------- | An 'AnnotationSet' contains all the type/field/variable 'Annotation's--- , with each group in order, associated with an entity.--- Note that in its rendering/show instances the unnecessary annotations will be--- omitted, as well as in some of the functions operating with it.--- Necessary 'Annotation's are the ones strictly required for a consistent--- representation.--- In particular, for each group (t/f/v):---   - if all annotations are 'noAnn' they are all omitted---   - if one or more 'noAnn' follow a non-empty 'ann', they are omitted---   - if one or more 'noAnn' precede a non-empty 'ann', they are kept---   - every non-empty 'ann' is obviously kept--- This is why order for each group is important as well as separation of--- different groups of 'Annotation's.-data AnnotationSet = AnnotationSet-  { asTypes  :: [TypeAnn]-  , asFields :: [FieldAnn]-  , asVars   :: [VarAnn]-  } deriving stock Eq--instance Semigroup AnnotationSet where-  (AnnotationSet ts1 fs1 vs1) <> (AnnotationSet ts2 fs2 vs2) = AnnotationSet {..}-    where-      asTypes  = ts1 <> ts2-      asFields = fs1 <> fs2-      asVars   = vs1 <> vs2--instance Monoid AnnotationSet where-  mempty = emptyAnnSet---- | An 'AnnotationSet' without any 'Annotation'.-emptyAnnSet :: AnnotationSet-emptyAnnSet = AnnotationSet [] [] []---- | An 'AnnotationSet' with only a single 'Annotation' (of any kind).-singleAnnSet :: forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet-singleAnnSet an = singleGroupAnnSet [an]---- | An 'AnnotationSet' with several 'Annotation's of the same kind.-singleGroupAnnSet :: forall tag. KnownAnnTag tag => [Annotation tag] -> AnnotationSet-singleGroupAnnSet ans = AnnotationSet {..}-  where-    asTypes = case eqT @tag @TypeTag of Just Refl -> ans; Nothing -> []-    asFields = case eqT @tag @FieldTag of Just Refl -> ans; Nothing -> []-    asVars = case eqT @tag @VarTag of Just Refl -> ans; Nothing -> []---- | An 'AnnotationSet' built from all 3 kinds of 'Annotation'.-fullAnnSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet-fullAnnSet asTypes asFields asVars = AnnotationSet {..}---- | Returns 'True' if all 'Annotation's in the Set are unnecessary/empty/'noAnn'.--- False otherwise.-isNoAnnSet :: AnnotationSet -> Bool-isNoAnnSet annSet = null asTypes && null asFields && null asVars-  where AnnotationSet {..} = minimizeAnnSet annSet---- | Returns the amount of 'Annotation's that are necessary for a consistent--- representation. See 'AnnotationSet'.-minAnnSetSize :: AnnotationSet -> Int-minAnnSetSize annSet = length asTypes + length asFields + length asVars-  where AnnotationSet {..} = minimizeAnnSet annSet---- | Removes all unnecessary 'Annotation's. See 'AnnotationSet'.-minimizeAnnSet :: AnnotationSet -> AnnotationSet-minimizeAnnSet (AnnotationSet ts fs vs) = AnnotationSet {..}-  where-    asTypes = trimEndNoAnn ts-    asFields = trimEndNoAnn fs-    asVars = trimEndNoAnn vs---- | Removes all unnecessary 'Annotation's from a list of the same type-trimEndNoAnn :: [Annotation tag] -> [Annotation tag]-trimEndNoAnn = foldr (\a lst -> if null lst && a == noAnn then [] else a : lst) []---- | Returns the number of annotations in 'AnnotationSet' for each type.-annsCount :: AnnotationSet -> (Int, Int, Int)-annsCount (AnnotationSet tas fas vas) = (length tas, length fas, length vas)---- | Returns the first annotation in a list of annotations of a specific type--- in 'AnnotationSet', or 'noAnn' if this list is empty.-firstAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag-firstAnn = getAnn (\case [] -> noAnn; a : _ -> a)---- | Returns the second annotation in a list of annotations of a specific type--- in 'AnnotationSet', or 'noAnn' if this list contains less than 2 elements.-secondAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag-secondAnn = getAnn (\case [] -> noAnn; [_] -> noAnn; _ : a : _ -> a)---- | Retrieves an annotation of a specific type from 'AnnotationSet' using--- the passed function.-getAnn :: forall tag. (KnownAnnTag tag)-       => ([Annotation tag] -> Annotation tag)-       -> AnnotationSet-       -> Annotation tag-getAnn getter annSet = case eqT @tag @TypeTag of-  Just Refl -> getter $ asTypes annSet-  Nothing -> case eqT @tag @FieldTag of-    Just Refl -> getter $ asFields annSet-    Nothing -> case eqT @tag @VarTag of-      Just Refl -> getter $ asVars annSet-      Nothing -> error "Impossible"------------------------------------------------------------------------------------- Rendering-----------------------------------------------------------------------------------class Typeable (tag :: Type) => KnownAnnTag tag where-  annPrefix :: Text--instance KnownAnnTag tag => Show (Annotation tag) where-  show = printDocS True . renderDoc doesntNeedParens--data TypeTag-data FieldTag-data VarTag-data SomeTag--type TypeAnn = Annotation TypeTag-type FieldAnn = Annotation FieldTag-type VarAnn = Annotation VarTag-type SomeAnn = Annotation SomeTag---- | Field annotation for the entire parameter.-type RootAnn = Annotation FieldTag--instance KnownAnnTag FieldTag where-  annPrefix = "%"-instance KnownAnnTag VarTag where-  annPrefix = "@"-instance KnownAnnTag TypeTag where-  annPrefix = ":"--instance KnownAnnTag tag => RenderDoc (Annotation tag) where-  renderDoc _ = renderAnn--instance KnownAnnTag tag => Buildable (Annotation tag) where-  build = buildRenderDoc--instance Show AnnotationSet where-  show = printDocS True . renderDoc doesntNeedParens--instance RenderDoc AnnotationSet where-  renderDoc _ (AnnotationSet {..}) =-    renderAnnGroup asTypes <+> renderAnnGroup asFields <+> renderAnnGroup asVars--instance Buildable AnnotationSet where-  build = buildRenderDoc---- | Renders a single 'Annotation', this is used in every rendering instance of it.--- Note that this also renders empty ones/'noAnn's because a single 'Annotation'--- does not have enough context to know if it can be omitted, use 'singleAnnSet'--- if you want to hide it instead.-renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc-renderAnn (Annotation text) = textStrict $ annPrefix @tag <> text---- | Renders a list of 'Annotation's, omitting unnecessary empty ones/'noAnn'.--- This is used (3 times) to render an 'AnnotationSet'.-renderAnnGroup :: KnownAnnTag tag => [Annotation tag] -> Doc-renderAnnGroup = hsep . map renderAnn . trimEndNoAnn------------------------------------------------------------------------------------- Creation and conversions-----------------------------------------------------------------------------------noAnn :: Annotation a-noAnn = UnsafeAnnotation ""---- | Makes an `Annotation` from its textual value, prefix (%/@/:) excluded--- Throws an error if the given `Text` contains invalid characters-unsafeMkAnnotation :: HasCallStack => Text -> Annotation a-unsafeMkAnnotation = either error id . mkAnnotation---- | Makes an `Annotation` from its textual value, prefix (%/@/:) excluded--- Returns a `Text` error message if the given `Text` contains invalid characters-mkAnnotation :: Text -> Either Text (Annotation a)-mkAnnotation text-  -- TODO [#48] these are special annotations and should not be always allowed-  | text `elem` specialVarAnns = Right $ UnsafeAnnotation text-  | text == specialFieldAnn = Right $ UnsafeAnnotation text-  | otherwise = do-    suffix <- case T.uncons text of-      Just (h, tl) | isValidAnnStart h -> Right tl-      Just (h, _) -> Left $ "Invalid first character: '" <> one h <> "'"-      _ -> Right ""-    maybe (Right $ UnsafeAnnotation text) (\c -> Left $ "Invalid character: '" <> one c <> "'") $-      T.find (not . isValidAnnBodyChar) suffix---- |--- >>> :t [annQ|abc|]--- ...--- ... :: forall k (tag :: k). Annotation tag-annQ :: TH.QuasiQuoter-annQ = annQImpl Nothing---- |--- >>> :t [typeAnnQ|abc|]--- ...--- ... :: TypeAnn-typeAnnQ :: TH.QuasiQuoter-typeAnnQ = annQImpl (Just [t|TypeAnn|])---- |--- >>> :t [fieldAnnQ|abc|]--- ...--- ... :: FieldAnn-fieldAnnQ :: TH.QuasiQuoter-fieldAnnQ = annQImpl (Just [t|FieldAnn|])---- |--- >>> :t [varAnnQ|abc|]--- ...--- ... :: VarAnn-varAnnQ :: TH.QuasiQuoter-varAnnQ = annQImpl (Just [t|VarAnn|])--annQImpl :: Maybe TH.TypeQ -> TH.QuasiQuoter-annQImpl annTypeMb = TH.QuasiQuoter-  {-    TH.quoteExp = \s ->-      case (mkAnnotation $ toText @String s) of-        Left err -> fail $ toString err-        Right _ -> case annTypeMb of-          Nothing -> [e| (UnsafeAnnotation s) |]-          Just annType -> [e| (UnsafeAnnotation s :: $(annType)) |]-  , TH.quotePat = \s ->-       case (mkAnnotation $ toText @String s) of-         Left err -> fail $ toString err-         Right _ -> case annTypeMb of-           Nothing -> [p| UnsafeAnnotation $(TH.litP $ TH.StringL s) |]-           Just annType -> [p| (UnsafeAnnotation $(TH.litP $ TH.StringL s) :: $(annType)) |]-  , TH.quoteType = \_ -> fail "Cannot use this QuasiQuoter at type position"-  , TH.quoteDec = \_  -> fail "Cannot use this QuasiQuoter at declaration position"-  }---- | List of all the special Variable Annotations, only allowed in `CAR` and `CDR`--- instructions, prefix (@) excluded.--- These do not respect the rules of `isValidAnnStart` and `isValidAnnBodyChar`.-specialVarAnns :: [Text]-specialVarAnns = ["%%","%"]---- | The only special Field Annotation, only allowed in `PAIR`, `LEFT` and--- `RIGHT` instructions, prefix (%) excluded.--- This does not respect the rules of `isValidAnnStart` and `isValidAnnBodyChar`.-specialFieldAnn :: Text-specialFieldAnn = "@"----- | Checks if a `Char` is valid to be the first of an annotation, prefix--- (%/@/:) excluded, the ones following should be checked with--- `isValidAnnBodyChar` instead.--- Note that this does not check Special Annotations, see `specialVarAnns`--- and `specialFieldAnn`-isValidAnnStart :: Char -> Bool-isValidAnnStart x = (isAscii x && (isAlpha x || isDigit x)) || x == '_'---- | Checks if a `Char` is valid to be part of an annotation, following a valid--- first character (see `isValidAnnStart`) and the prefix (%/@/:).--- Note that this does not check Special Annotations, see `specialVarAnns`--- and `specialFieldAnn`-isValidAnnBodyChar :: Char -> Bool-isValidAnnBodyChar x =-  isValidAnnStart x || (isAscii x && isNumber x) ||  x `elem` (".%@" :: String)--instance Semigroup VarAnn where-  Annotation a <> Annotation b-    | a == "" || b == "" = UnsafeAnnotation $ a <> b-    | otherwise          = UnsafeAnnotation $ a <> "." <> b--instance Monoid VarAnn where-    mempty = noAnn---- | Returns the first annotation if it's not empty, or the second one otherwise.------ > "a" `orAnn` "b" == "a"--- > "a" `orAnn` ""  == "a"--- > ""  `orAnn` "b" == "b"--- > ""  `orAnn` ""  == ""-orAnn :: Annotation t -> Annotation t -> Annotation t-orAnn a b = bool a b (a == def)---- | Given two type or field annotations, attempt to converge them by joining--- these annotations with the following rule:--- 1. If either annotation is empty, an empty annotation is returned;--- 2. If both annotations are equal, return this annotation;--- 3. Otherwise, returns 'Nothing'.------ This function is used primarily for type-checking and attempts to imitate the--- reference implementation's observed behavior with annotations.-unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)-unifyAnn a@(Annotation ann1) (Annotation ann2)-  | ann1 == "" || ann2 == "" = Just noAnn-  | ann1 == ann2 = Just $ a-  | otherwise  = Nothing---- | Given two field annotations where one of them is used in CAR or CDR,--- attempt to converge them by joining these annotations with the following rule:--- 1. If either annotation is empty, return the non-empty one (or empty if both are empty);--- 2. If both annotations are equal, return this annotation;--- 3. Otherwise, returns 'Nothing'.------ This function is used primarily for type-checking and attempts to imitate the--- reference implementation's observed behavior with field annotations when CAR--- and CDR are used with pairs.-unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn-unifyPairFieldAnn a1@(Annotation ann1) a2@(Annotation ann2)-  | ann1 == "" || ann2 == "" = Just $ a1 `orAnn` a2-  | ann1 == ann2 = Just a1-  | otherwise = Nothing---- | Keeps an annotation if and only if the two of them are equal and returns an--- empty annotation otherwise.-convergeVarAnns :: VarAnn -> VarAnn -> VarAnn-convergeVarAnns ann1 ann2-  | ann1 == ann2 = ann1-  | otherwise    = noAnn--ifAnnUnified :: Annotation tag -> Annotation tag -> Bool-ifAnnUnified a1 a2 = isJust $ a1 `unifyAnn` a2--convAnn :: Annotation tag1 -> Annotation tag2-convAnn (Annotation a) = UnsafeAnnotation a--pattern WithAnn :: Annotation tag -> Annotation tag-pattern WithAnn ann <- ann@(Annotation (toString -> _:_))--deriveJSON morleyAesonOptions ''Annotation-deriveLift ''Annotation

− src/Michelson/Untyped/Contract.hs

@@ -1,127 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Michelson contract in untyped model.--module Michelson.Untyped.Contract-  ( EntriesOrder (..)-  , canonicalEntriesOrder-  , entriesOrderToInt-  , mapEntriesOrdered--  , ContractBlock (..)-  , orderContractBlock--  , Contract' (..)-  , Storage-  ) where--import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import Data.Default (Default(..))-import Fmt (Buildable(build))-import Text.PrettyPrint.Leijen.Text (nest, semi, text, (<$$>), (<+>))--import Michelson.Printer.Util-  (Prettier(..), RenderDoc(..), assertParensNotNeeded, buildRenderDoc, needsParens, renderOpsList)-import Michelson.Untyped.Type (ParameterType(..), Ty(..))-import Util.Aeson---- | Top-level entries order of the contract.--- This is preserved due to the fact that it affects--- the output of pretty-printing and serializing contract.---- Each constructors is created by the order of the first letter of--- @parameter@, @storage@, and @code@.------ For example, @PSC@ would be @parameter@, @storage@ and @code@,--- @CPS@ would be @code@, @parameter@,and @storage@, and so on.-data EntriesOrder-  = PSC-  | PCS-  | SPC-  | SCP-  | CSP-  | CPS-  deriving stock (Bounded, Data, Enum, Eq, Generic, Show)--instance Default EntriesOrder where-  def = canonicalEntriesOrder-instance NFData EntriesOrder---- | The canonical entries order which is ordered as follow:--- @parameter@, @storage@, and @code@.-canonicalEntriesOrder :: EntriesOrder-canonicalEntriesOrder = PSC---- | @(Int, Int, Int)@ is the positions of @parameter@, @storage@, and @code@--- respectively.-entriesOrderToInt :: EntriesOrder -> (Int, Int, Int)-entriesOrderToInt = \case-  PSC -> (0, 1, 2)-  PCS -> (0, 2, 1)-  SPC -> (1, 0, 2)-  SCP -> (1, 2, 0)-  CSP -> (2, 1, 0)-  CPS -> (2, 0, 1)---- | Contract block, convenient when parsing-data ContractBlock op-  = CBParam ParameterType-  | CBStorage Ty-  | CBCode [op]-  deriving stock (Eq, Show)--orderContractBlock :: (ContractBlock op, ContractBlock op, ContractBlock op) -> Maybe (Contract' op)-orderContractBlock = \case-  (CBParam   p, CBStorage s, CBCode    c) -> Just $ Contract p s c PSC-  (CBParam   p, CBCode    c, CBStorage s) -> Just $ Contract p s c PCS-  (CBStorage s, CBParam   p, CBCode    c) -> Just $ Contract p s c SPC-  (CBStorage s, CBCode    c, CBParam   p) -> Just $ Contract p s c SCP-  (CBCode    c, CBStorage s, CBParam   p) -> Just $ Contract p s c CSP-  (CBCode    c, CBParam   p, CBStorage s) -> Just $ Contract p s c CPS-  _                                       -> Nothing---- | Map each contract fields by the given function and sort the output--- based on the 'EntriesOrder'.-mapEntriesOrdered-  :: Contract' op-  -> (ParameterType -> a)-  -> (Storage -> a)-  -> ([op] -> a)-  -> [a]-mapEntriesOrdered Contract{..} fParam fStorage fCode =-  fmap snd-    $ sortWith fst-        [ (paramPos, fParam contractParameter)-        , (storagePos, fStorage contractStorage)-        , (codePos, fCode contractCode)-        ]-  where-    (paramPos, storagePos, codePos) = entriesOrderToInt entriesOrder--type Storage = Ty-data Contract' op = Contract-  { contractParameter :: ParameterType-  , contractStorage :: Storage-  , contractCode :: [op]-  , entriesOrder :: EntriesOrder-  } deriving stock (Eq, Show, Functor, Data, Generic)--instance NFData op => NFData (Contract' op)--instance (RenderDoc op) => RenderDoc (Contract' op) where-  renderDoc pn contract =-    assertParensNotNeeded pn-      $ foldr (<$$>) (text "")-      $ mapEntriesOrdered contract-        (\parameter -> "parameter" <+> renderDoc needsParens (Prettier parameter) <> semi)-        (\storage -> "storage" <+> renderDoc needsParens (Prettier storage) <> semi)-        (\code -> "code" <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi))--instance RenderDoc op => Buildable (Contract' op) where-  build = buildRenderDoc--deriveJSON morleyAesonOptions ''EntriesOrder-deriveJSON morleyAesonOptions ''Contract'

− src/Michelson/Untyped/Entrypoints.hs

@@ -1,184 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Untyped.Entrypoints-  ( EpName (..)-  , pattern DefEpName-  , isDefEpName-  , epNameFromParamAnn-  , epNameToParamAnn-  , epNameFromRefAnn-  , epNameFromSelfAnn-  , epNameToRefAnn-  , EpNameFromRefAnnError (..)-  , buildEpName-  , unsafeBuildEpName-  , mkEntrypointsMap-  ) where--import Data.Aeson.TH (deriveJSON)-import qualified Data.Map as Map-import Fmt (Buildable(..), pretty)--import Michelson.Untyped.Annotation-import Michelson.Untyped.Type-import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable, buildRenderDoc)-import Text.PrettyPrint.Leijen.Text ((<+>), enclose)-import Util.Aeson-import Util.CLI---- | Entrypoint name.------ There are two properties we care about:------ 1. Special treatment of the @default@ entrypoint name.--- @default@ is prohibited in the @CONTRACT@ instruction and in--- values of @address@ and @contract@ types.--- However, it is not prohibited in the @SELF@ instruction.--- Hence, the value inside @EpName@ __can__ be @"default"@, so that--- we can distinguish @SELF@ and @SELF %default@. It is important--- to distinguish them because their binary representation that is--- inserted into blockchain is different. For example, typechecking--- @SELF %default@ consumes more gas than @SELF@.--- In this module, we provide several smart constructors with different--- handling of @default@, please use the appropriate one for your use case.--- 2. The set of permitted characters. Intuitively, an entrypoint name should--- be valid only if it is a valid annotation (because entrypoints are defined--- using field annotations). However, it is not enforced in Tezos.--- It is not clear whether this behavior is intended. There is an upstream--- [issue](https://gitlab.com/tezos/tezos/-/issues/851) which received @bug@--- label, so probably it is considered a bug. Currently we treat it as a bug--- and deviate from upstream implementation by probiting entrypoint names that--- are not valid annotations. If Tezos developers fix it soon, we will be happy.--- If they don't, we should (maybe temporarily) remove this limitation from our--- code. There is an--- [issue](https://gitlab.com/morley-framework/morley/-/issues/275) in our--- repo as well.-newtype EpName = UnsafeEpName { unEpName :: Text }-  deriving stock (Show, Eq, Ord, Generic)--instance NFData EpName--deriveJSON morleyAesonOptions ''EpName---- | This is a bidirectional pattern that can be used for two purposes:------ 1. Construct an 'EpName' referring to the default entrypoint.--- 2. Use it in pattern-matching or in equality comparison to check whether--- 'EpName' refers to the default entrypoint. This is trickier because there--- are two possible 'EpName' values referring to the default entrypoints.--- 'DefEpName' will match only the most common one (no entrypoint).--- However, there is a special case: @SELF@ instruction can have explicit--- @%default@ reference. For this reason, it is recommended to use--- 'isDefEpName' instead. Pattern-matching on 'DefEpName' is still permitted--- for backwards compatibility and for the cases when you are sure that--- 'EpName' does not come from the @SELF@ instruction.-pattern DefEpName :: EpName-pattern DefEpName = UnsafeEpName ""---- | Check whether given 'EpName' refers to the default entrypoint.--- Unlike 'DefEpName' pattern, this function correctly handles all cases,--- including the @SELF@ instruction.-isDefEpName :: EpName -> Bool-isDefEpName epName = epName == DefEpName || epName == UnsafeEpName "default"--instance Buildable EpName where-  build = \case-    DefEpName -> "<default>"-    UnsafeEpName name -> build name---- | Make up 'EpName' from annotation in parameter type declaration.------ Returns 'Nothing' if no entrypoint is assigned here.-epNameFromParamAnn :: FieldAnn -> Maybe EpName-epNameFromParamAnn an@(Annotation a)-  | an == noAnn = Nothing-  | a == "default" = Just (UnsafeEpName "")-  | otherwise = Just $ UnsafeEpName a---- | Turn entrypoint name into annotation for contract parameter declaration.-epNameToParamAnn :: EpName -> FieldAnn-epNameToParamAnn (UnsafeEpName name)-  | name == "" = [annQ|default|]-  | otherwise = unsafeMkAnnotation name--data EpNameFromRefAnnError-  = InEpNameBadAnnotation FieldAnn-  deriving stock (Show, Eq, Generic)--instance NFData EpNameFromRefAnnError--instance Buildable EpNameFromRefAnnError where-  build = buildRenderDoc--instance RenderDoc EpNameFromRefAnnError where-  renderDoc _ = \case-    InEpNameBadAnnotation (Annotation an) ->-      "Invalid entrypoint reference" <+> (enclose "`" "`" $ renderAnyBuildable an)---- | Make up 'EpName' from annotation which is reference to an entrypoint.--- Note that it's more common for Michelson to prohibit explicit @default@--- entrypoint reference.------ Specifically, @%default@ annotation is probitited in values of @address@--- and @contract@ types. It's also prohibited in the @CONTRACT@ instruction.--- However, there is an exception: @SELF %default@ is a perfectly valid--- instruction. Hence, when you construct an 'EpName' from an annotation--- that's part of @SELF@, you should use 'epNameFromSelfAnn' instead.-epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName-epNameFromRefAnn an@(Annotation a)-  | a == "default" = Left $ InEpNameBadAnnotation an-  | otherwise = Right $ UnsafeEpName a---- | Make up an 'EpName' from an annotation which is part of the--- @SELF@ instruction.-epNameFromSelfAnn :: FieldAnn -> EpName-epNameFromSelfAnn (Annotation a) = UnsafeEpName a---- | Turn entrypoint name into annotation used as reference to entrypoint.-epNameToRefAnn :: EpName -> FieldAnn-epNameToRefAnn (UnsafeEpName name) = unsafeMkAnnotation name---- | Make a valid entrypoint name from an arbitrary text. This--- function prohibits explicit @default@ entrypoint name which is--- permitted by Michelson inside the @SELF@ instruction. This--- limitation shouldn't be restrictive because @SELF@ is equivalent to--- @SELF %default@.-buildEpName :: Text -> Either String EpName-buildEpName txt = do-  annotation <--    mkAnnotation txt-    & first (mappend "Failed to parse entrypoint: " . pretty)-  epNameFromRefAnn annotation-    & first pretty---- | Partial version of 'buildEpName'.-unsafeBuildEpName :: HasCallStack => Text -> EpName-unsafeBuildEpName = either (error . pretty) id . buildEpName--instance HasCLReader EpName where-  getReader = eitherReader (buildEpName . toText)-  getMetavar = "ENTRYPOINT"---- | Given an untyped parameter type, extract a map that maps entrypoint names--- to the their parameter types. If there are duplicate entrypoints in the--- given Type then the duplicate entrypoints at a deeper nesting level will get--- overwritten with the ones that are on top.-mkEntrypointsMap :: ParameterType -> Map EpName Ty-mkEntrypointsMap (ParameterType ty rootAnn) = mkEntrypointsMapRec rootAnn ty---- | Version of 'mkEntrypointMaps' for plain untyped type.-mkEntrypointsMapRec :: FieldAnn -> Ty -> Map EpName Ty-mkEntrypointsMapRec curRootAnn ty =-  accountRoot curRootAnn <> accountTree ty-  where-    accountRoot rootAnn = Map.fromList $ do-      Just rootEp <- pure $ epNameFromParamAnn rootAnn-      return (rootEp, ty)--    accountTree (Ty t _) = case t of-      -- We are only interested in `Or` branches to extract entrypoint-      -- annotations.-      TOr f1 f2 t1 t2 -> mkEntrypointsMapRec f1 t1 <> mkEntrypointsMapRec f2 t2-      _ -> mempty

− src/Michelson/Untyped/Ext.hs

@@ -1,169 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Michelson.Untyped.Ext-  ( ExtInstrAbstract (..)-  , StackRef (..)-  , PrintComment (..)-  , TestAssert (..)-  , Var (..)-  , TyVar (..)-  , StackTypePattern (..)-  , StackFn (..)-  , varSet-  , stackTypePatternToList-  ) where--import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import qualified Data.Set as Set-import qualified Data.Text as T-import Fmt (Buildable(build), Builder, genericF, listF)-import Text.PrettyPrint.Leijen.Text (textStrict)--import Michelson.Printer.Util (RenderDoc(..), renderOpsList)-import Michelson.Untyped.Type-import Util.Aeson---- | Implementation-specific instructions embedded in a @NOP@ primitive, which--- mark a specific point during a contract's typechecking or execution.------ These instructions are not allowed to modify the contract's stack, but may--- impose additional constraints that can cause a contract to report errors in--- type-checking or testing.------ Additionaly, some implementation-specific language features such as--- type-checking of @LetMacro@s are implemented using this mechanism--- (specifically @FN@ and @FN_END@).-data ExtInstrAbstract op =-    STACKTYPE StackTypePattern -- ^ Matches current stack against a type-pattern-  | FN T.Text StackFn [op]     -- ^ A typed stack function (push and pop a @TcExtFrame@)-  | UTEST_ASSERT (TestAssert op)   -- ^ Copy the current stack and run an inline assertion on it-  | UPRINT PrintComment         -- ^ Print a comment with optional embedded @StackRef@s-  | UCOMMENT Text        -- ^ A comment in Michelson code-  deriving stock (Eq, Show, Data, Generic, Functor)--instance NFData op => NFData (ExtInstrAbstract op)--instance RenderDoc op => RenderDoc (ExtInstrAbstract op) where-  renderDoc _ =-    \case-      FN _ _ ops -> renderOpsList False ops-      UCOMMENT t  -> textStrict ("/* " <> t <> " */")-      _ -> mempty-  isRenderable =-    \case-      FN {} -> True-      UCOMMENT{} -> True-      _ -> False--instance Buildable op => Buildable (ExtInstrAbstract op) where-  build = genericF---- | A reference into the stack.-newtype StackRef = StackRef Natural-  deriving stock (Eq, Show, Data, Generic)--instance NFData StackRef--instance Buildable StackRef where-  build (StackRef i) = "%[" <> show i <> "]"--newtype Var = Var T.Text deriving stock (Eq, Show, Ord, Data, Generic)--instance NFData Var--instance Buildable Var where-  build = genericF---- | A type-variable or a type-constant-data TyVar =-    VarID Var-  | TyCon Ty-  deriving stock (Eq, Show, Data, Generic)--instance NFData TyVar--instance Buildable TyVar where-  build = genericF---- | A stack pattern-match-data StackTypePattern- = StkEmpty- | StkRest- | StkCons TyVar StackTypePattern-  deriving stock (Eq, Show, Data, Generic)--instance NFData StackTypePattern---- | Convert 'StackTypePattern' to a list of types. Also returns--- 'Bool' which is 'True' if the pattern is a fixed list of types and--- 'False' if it's a pattern match on the head of the stack.-stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)-stackTypePatternToList StkEmpty = ([], True)-stackTypePatternToList StkRest = ([], False)-stackTypePatternToList (StkCons t pat) =-  first (t :) $ stackTypePatternToList pat--instance Buildable StackTypePattern where-  build = listF . pairToList . stackTypePatternToList-    where-      pairToList :: ([TyVar], Bool) -> [Builder]-      pairToList (types, fixed)-        | fixed = map build types-        | otherwise = map build types ++ ["..."]---- | A stack function that expresses the type signature of a @LetMacro@-data StackFn = StackFn-  { sfnQuantifiedVars :: Maybe (Set Var)-  , sfnInPattern :: StackTypePattern-  , sfnOutPattern :: StackTypePattern-  } deriving stock (Eq, Show, Data, Generic)--instance NFData StackFn--instance Buildable StackFn where-  build = genericF---- | Get the set of variables in a stack pattern-varSet :: StackTypePattern -> Set Var-varSet = \case-  StkEmpty -> Set.empty-  StkRest -> Set.empty-  (StkCons (VarID v) stk) -> v `Set.insert` (varSet stk)-  (StkCons _ stk) -> varSet stk--newtype PrintComment = PrintComment-  { unUPrintComment :: [Either T.Text StackRef]-  } deriving stock (Eq, Show, Data, Generic)--instance NFData PrintComment--instance Buildable PrintComment where-  build = foldMap (either build build) . unUPrintComment---- An inline test assertion-data TestAssert op = TestAssert-  { tassName :: T.Text-  , tassComment :: PrintComment-  , tassInstrs :: [op]-  } deriving stock (Eq, Show, Functor, Data, Generic)--instance NFData op => NFData (TestAssert op)--instance Buildable code => Buildable (TestAssert code) where-  build = genericF------------------------------------------ Aeson instances----------------------------------------deriveJSON morleyAesonOptions ''ExtInstrAbstract-deriveJSON morleyAesonOptions ''PrintComment-deriveJSON morleyAesonOptions ''StackTypePattern-deriveJSON morleyAesonOptions ''StackRef-deriveJSON morleyAesonOptions ''StackFn-deriveJSON morleyAesonOptions ''Var-deriveJSON morleyAesonOptions ''TyVar-deriveJSON morleyAesonOptions ''TestAssert

− src/Michelson/Untyped/Instr.hs

@@ -1,362 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Michelson instructions in untyped model.--module Michelson.Untyped.Instr-  ( InstrAbstract (..)-  , ExpandedOp (..)-  , ExpandedInstr-  , flattenExpandedOp-  ) where--import Prelude hiding (EQ, GT, LT)--import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import Fmt (Buildable(build), (+|), (|+))-import Generics.SYB (everywhere, mkT)-import Text.PrettyPrint.Leijen.Text-  (Doc, align, braces, enclose, indent, line, nest, space, text, (<$$>), (<+>))-import qualified Text.Show--import Michelson.ErrorPos (InstrCallStack)-import Michelson.Printer.Util-  (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, printDocS, renderOpsList, spaces)-import Michelson.Untyped.Annotation-  (Annotation, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, singleAnnSet)-import Michelson.Untyped.Contract (Contract'(..))-import Michelson.Untyped.Ext (ExtInstrAbstract)-import Michelson.Untyped.Type (Ty)-import Michelson.Untyped.Value (Value'(..))-import Util.Aeson------------------------------------------ Types after macroexpander----------------------------------------type ExpandedInstr = InstrAbstract ExpandedOp--data ExpandedOp-  = PrimEx ExpandedInstr-  | SeqEx [ExpandedOp]-  | WithSrcEx InstrCallStack ExpandedOp-  deriving stock (Show, Eq, Data, Generic)--instance NFData ExpandedOp--instance RenderDoc ExpandedOp where-  renderDoc pn (WithSrcEx _ op) = renderDoc pn op-  renderDoc pn (PrimEx i) = renderDoc pn i-  renderDoc _  (SeqEx i) = renderOpsList False i-  isRenderable =-    \case PrimEx i -> isRenderable i-          WithSrcEx _ op -> isRenderable op-          _ -> True--instance Buildable ExpandedOp where-  build (WithSrcEx _ op) = build op-  build (PrimEx expandedInstr) = "<PrimEx: "+|expandedInstr|+">"-  build (SeqEx expandedOps)    = "<SeqEx: "+|expandedOps|+">"---- | Flatten all 'SeqEx' in 'ExpandedOp'. This function is mostly for--- testing. It returns instructions with the same logic, but they are--- not strictly equivalent, because they are serialized differently--- (grouping instructions into sequences affects the way they are--- PACK'ed).-flattenExpandedOp :: ExpandedOp -> [ExpandedInstr]-flattenExpandedOp =-  \case-    PrimEx i -> [flattenInstr i]-    SeqEx ops -> concatMap flattenExpandedOp ops-    WithSrcEx _ op -> flattenExpandedOp op-  where-    flattenInstr :: ExpandedInstr -> ExpandedInstr-    flattenInstr = everywhere (mkT flattenOps)--    flattenOps :: [ExpandedOp] -> [ExpandedOp]-    flattenOps [] = []-    flattenOps (SeqEx s : xs) = s ++ flattenOps xs-    flattenOps (x@(PrimEx _) : xs) = x : flattenOps xs-    flattenOps (WithSrcEx _ op : xs) = op : flattenOps xs------------------------------------------ Abstract instruction------------------------------------------ | Michelson instruction with abstract parameter `op`.  This--- parameter is necessary, because at different stages of our pipeline--- it will be different. Initially it can contain macros and--- non-flattened instructions, but then it contains only vanilla--- Michelson instructions.-data InstrAbstract op-  = EXT               (ExtInstrAbstract op)-  | DROPN              Word-  -- ^ "DROP n" instruction.-  -- Note: reference implementation permits int16 here.-  -- Negative numbers are parsed successfully there, but rejected later.-  -- Morley is more permissive, so we use 'Word' here,-  -- i. e. permit more positive numbers. We do not permit negative numbers-  -- at type level.-  -- In practice, probably nobody will ever have numbers greater than ≈1000-  -- here, at least due to gas limits.-  -- Same reasoning applies to other instructions which have a numeric-  -- parameter representing number of elements on stack.-  | DROP-  -- ^ 'DROP' is essentially as special case for 'DROPN', but we need-  -- both because they are packed differently.-  | DUP               VarAnn-  | DUPN              VarAnn Word-  | SWAP-  | DIG               Word-  | DUG               Word-  | PUSH              VarAnn Ty (Value' op)-  | SOME              TypeAnn VarAnn-  | NONE              TypeAnn VarAnn Ty-  | UNIT              TypeAnn VarAnn-  | IF_NONE           [op] [op]-  | PAIR              TypeAnn VarAnn FieldAnn FieldAnn-  | UNPAIR            VarAnn VarAnn FieldAnn FieldAnn-  | PAIRN             VarAnn Word-  | UNPAIRN           Word-  | CAR               VarAnn FieldAnn-  | CDR               VarAnn FieldAnn-  | LEFT              TypeAnn VarAnn FieldAnn FieldAnn Ty-  | RIGHT             TypeAnn VarAnn FieldAnn FieldAnn Ty-  | IF_LEFT           [op] [op]-  | NIL               TypeAnn VarAnn Ty-  | CONS              VarAnn-  | IF_CONS           [op] [op]-  | SIZE              VarAnn-  | EMPTY_SET         TypeAnn VarAnn Ty-  | EMPTY_MAP         TypeAnn VarAnn Ty Ty-  | EMPTY_BIG_MAP     TypeAnn VarAnn Ty Ty-  | MAP               VarAnn [op]-  | ITER              [op]-  | MEM               VarAnn-  | GET               VarAnn-  | GETN              VarAnn Word-  | UPDATE            VarAnn-  | UPDATEN           VarAnn Word-  | GET_AND_UPDATE    VarAnn-  | IF                [op] [op]-  | LOOP              [op]-  | LOOP_LEFT         [op]-  | LAMBDA            VarAnn Ty Ty [op]-  | EXEC              VarAnn-  | APPLY             VarAnn-  | DIP               [op]-  | DIPN              Word [op]-  | FAILWITH-  | CAST              VarAnn Ty-  | RENAME            VarAnn-  | PACK              VarAnn-  | UNPACK            TypeAnn VarAnn Ty-  | CONCAT            VarAnn-  | SLICE             VarAnn-  | ISNAT             VarAnn-  | ADD               VarAnn-  | SUB               VarAnn-  | MUL               VarAnn-  | EDIV              VarAnn-  | ABS               VarAnn-  | NEG               VarAnn-  | LSL               VarAnn-  | LSR               VarAnn-  | OR                VarAnn-  | AND               VarAnn-  | XOR               VarAnn-  | NOT               VarAnn-  | COMPARE           VarAnn-  | EQ                VarAnn-  | NEQ               VarAnn-  | LT                VarAnn-  | GT                VarAnn-  | LE                VarAnn-  | GE                VarAnn-  | INT               VarAnn-  | SELF              VarAnn FieldAnn-  | CONTRACT          VarAnn FieldAnn Ty-  | TRANSFER_TOKENS   VarAnn-  | SET_DELEGATE      VarAnn-  | CREATE_CONTRACT   VarAnn VarAnn (Contract' op)-  | IMPLICIT_ACCOUNT  VarAnn-  | NOW               VarAnn-  | AMOUNT            VarAnn-  | BALANCE           VarAnn-  | VOTING_POWER      VarAnn-  | TOTAL_VOTING_POWER VarAnn-  | CHECK_SIGNATURE   VarAnn-  | SHA256            VarAnn-  | SHA512            VarAnn-  | BLAKE2B           VarAnn-  | SHA3              VarAnn-  | KECCAK            VarAnn-  | HASH_KEY          VarAnn-  | PAIRING_CHECK     VarAnn-  | SOURCE            VarAnn-  | SENDER            VarAnn-  | ADDRESS           VarAnn-  | CHAIN_ID          VarAnn-  | LEVEL             VarAnn-  | SELF_ADDRESS      VarAnn-  | NEVER-  | TICKET            VarAnn-  | READ_TICKET       VarAnn-  | SPLIT_TICKET      VarAnn-  | JOIN_TICKETS      VarAnn-  deriving stock (Eq, Functor, Data, Generic)--instance RenderDoc (InstrAbstract op) => Show (InstrAbstract op) where-  show = printDocS True . renderDoc doesntNeedParens--instance NFData op => NFData (InstrAbstract op)--instance (RenderDoc op) => RenderDoc (InstrAbstract op) where-  renderDoc pn = \case-    EXT extInstr            -> renderDoc pn extInstr-    DROP                    -> "DROP"-    DROPN n                 -> "DROP" <+> text (show n)-    DUP va                  -> "DUP" <+> renderAnnot va-    DUPN va n               -> "DUP" <+> renderAnnot va <+> text (show n)-    SWAP                    -> "SWAP"-    DIG n                   -> "DIG" <+> text (show n)-    DUG n                   -> "DUG" <+> text (show n)-    PUSH va t v             ->-      let renderConsecutively =-            "PUSH" <+> renderAnnot va <+> renderTy t <+> renderDoc needsParens v-          renderAligned = "PUSH" <+> renderAnnot va <$$> (spaces 2 <> renderTy t)-                                <$$> spaces 2 <> nest 3 (renderDoc needsParens v)-      in case v of-        ValueNil      -> renderConsecutively-        ValueInt{}    -> renderConsecutively-        ValueString{} -> renderConsecutively-        ValueBytes{}  -> renderConsecutively-        ValueUnit     -> renderConsecutively-        ValueTrue     -> renderConsecutively-        ValueFalse    -> renderConsecutively-        ValueNone     -> renderConsecutively-        _             -> renderAligned-    SOME ta va              -> "SOME" <+> renderAnnots [ta] [] [va]-    NONE ta va t            -> "NONE" <+> renderAnnots [ta] [] [va] <+> renderTy t-    UNIT ta va              -> "UNIT" <+> renderAnnots [ta] [] [va]-    IF_NONE x y             -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)-    PAIR ta va fa1 fa2      -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va]-    UNPAIR va1 va2 fa1 fa2  -> "UNPAIR" <+> renderAnnots [] [fa1, fa2] [va1, va2]-    PAIRN va n              -> "PAIR" <+> renderAnnots [] [] [va] <+> text (show n)-    UNPAIRN n               -> "UNPAIR" <+> text (show n)-    CAR va fa               -> "CAR" <+> renderAnnots [] [fa] [va]-    CDR va fa               -> "CDR" <+> renderAnnots [] [fa] [va]-    LEFT ta va fa1 fa2 t    -> "LEFT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t-    RIGHT ta va fa1 fa2 t   -> "RIGHT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t-    IF_LEFT x y             -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)-    NIL ta va t             -> "NIL" <+> renderAnnots [ta] [] [va] <+> renderTy t-    CONS va                 -> "CONS" <+> renderAnnot va-    IF_CONS x y             -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)-    SIZE va                 -> "SIZE" <+> renderAnnot va-    EMPTY_SET ta va t       -> "EMPTY_SET" <+> renderAnnots [ta] [] [va] <+> renderComp t-    EMPTY_MAP ta va c t     -> "EMPTY_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t-    EMPTY_BIG_MAP ta va c t -> "EMPTY_BIG_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t-    MAP va s                -> "MAP" <+> renderAnnot va <$$> spaces 4 <> nest 5 (renderOps s)-    ITER s                  -> "ITER" <+> nest 6 (renderOps s)-    MEM va                  -> "MEM" <+> renderAnnot va-    GET va                  -> "GET" <+> renderAnnot va-    GETN va n               -> "GET" <+> renderAnnot va <+> text (show n)-    UPDATE va               -> "UPDATE" <+> renderAnnot va-    UPDATEN va n            -> "UPDATE" <+> renderAnnot va <+> text (show n)-    GET_AND_UPDATE va       -> "GET_AND_UPDATE" <+> renderAnnot va-    IF x y                  -> "IF" <+> nest 4 (renderOps x) <$$> spaces 3 <> nest 4 (renderOps y)-    LOOP s                  -> "LOOP" <+> nest 6 (renderOps s)-    LOOP_LEFT s             -> "LOOP_LEFT" <+> nest 11 (renderOps s)-    LAMBDA va t r s         -> "LAMBDA" <+> renderAnnot va <$$> (spaces 2 <> renderTy t) <$$> (spaces 2 <> renderTy r) <$$> spaces 2 <> nest 3 (renderOps s)-    EXEC va                 -> "EXEC" <+> renderAnnot va-    APPLY va                -> "APPLY" <+> renderAnnot va-    DIP s                   -> "DIP" <+> nest 5 (renderOps s)-    DIPN n s                -> "DIP" <+> text (show n) <> line <> indent 4 (renderOps s)-    FAILWITH                -> "FAILWITH"-    CAST va t               -> "CAST" <+> renderAnnot va <+> renderTy t-    RENAME va               -> "RENAME" <+> renderAnnot va-    PACK va                 -> "PACK" <+> renderAnnot va-    UNPACK ta va t          -> "UNPACK" <+> renderAnnots [ta] [] [va] <+> renderTy t-    CONCAT va               -> "CONCAT" <+> renderAnnot va-    SLICE va                -> "SLICE" <+> renderAnnot va-    ISNAT va                -> "ISNAT" <+> renderAnnot va-    ADD va                  -> "ADD" <+> renderAnnot va-    SUB va                  -> "SUB" <+> renderAnnot va-    MUL va                  -> "MUL" <+> renderAnnot va-    EDIV va                 -> "EDIV" <+> renderAnnot va-    ABS va                  -> "ABS" <+> renderAnnot va-    NEG va                  -> "NEG" <+> renderAnnot va-    LSL va                  -> "LSL" <+> renderAnnot va-    LSR va                  -> "LSR" <+> renderAnnot va-    OR  va                  -> "OR" <+> renderAnnot va-    AND va                  -> "AND" <+> renderAnnot va-    XOR va                  -> "XOR" <+> renderAnnot va-    NOT va                  -> "NOT" <+> renderAnnot va-    COMPARE va              -> "COMPARE" <+> renderAnnot va-    EQ va                   -> "EQ" <+> renderAnnot va-    NEQ va                  -> "NEQ" <+> renderAnnot va-    LT va                   -> "LT" <+> renderAnnot va-    GT va                   -> "GT" <+> renderAnnot va-    LE va                   -> "LE" <+> renderAnnot va-    GE va                   -> "GE" <+> renderAnnot va-    INT va                  -> "INT" <+> renderAnnot va-    SELF va fa              -> "SELF" <+> renderAnnots [] [fa] [va]-    CONTRACT va fa t        -> "CONTRACT" <+> renderAnnots [] [fa] [va] <+> renderTy t-    TRANSFER_TOKENS va      -> "TRANSFER_TOKENS" <+> renderAnnot va-    SET_DELEGATE va         -> "SET_DELEGATE" <+> renderAnnot va-    CREATE_CONTRACT va1 va2 contract -> let-      body = enclose space space $ align $ (renderDoc doesntNeedParens contract)-      in "CREATE_CONTRACT" <+> renderAnnots [] [] [va1, va2] <$$> (indent 2 $ braces $ body)-    IMPLICIT_ACCOUNT va     -> "IMPLICIT_ACCOUNT" <+> renderAnnot va-    NOW va                  -> "NOW" <+> renderAnnot va-    AMOUNT va               -> "AMOUNT" <+> renderAnnot va-    BALANCE va              -> "BALANCE" <+> renderAnnot va-    VOTING_POWER va         -> "VOTING_POWER" <+> renderAnnot va-    TOTAL_VOTING_POWER va   -> "TOTAL_VOTING_POWER" <+> renderAnnot va-    CHECK_SIGNATURE va      -> "CHECK_SIGNATURE" <+> renderAnnot va-    SHA256 va               -> "SHA256" <+> renderAnnot va-    SHA512 va               -> "SHA512" <+> renderAnnot va-    BLAKE2B va              -> "BLAKE2B" <+> renderAnnot va-    SHA3 va                 -> "SHA3" <+> renderAnnot va-    KECCAK va               -> "KECCAK" <+> renderAnnot va-    HASH_KEY va             -> "HASH_KEY" <+> renderAnnot va-    PAIRING_CHECK va        -> "PAIRING_CHECK" <+> renderAnnot va-    SOURCE va               -> "SOURCE" <+> renderAnnot va-    SENDER va               -> "SENDER" <+> renderAnnot va-    ADDRESS va              -> "ADDRESS" <+> renderAnnot va-    CHAIN_ID va             -> "CHAIN_ID" <+> renderAnnot va-    LEVEL va                -> "LEVEL" <+> renderAnnot va-    SELF_ADDRESS va         -> "SELF_ADDRESS" <+> renderAnnot va-    NEVER                   -> "NEVER"-    TICKET va               -> "TICKET" <+> renderAnnot va-    READ_TICKET va          -> "READ_TICKET" <+> renderAnnot va-    SPLIT_TICKET va         -> "SPLIT_TICKET" <+> renderAnnot va-    JOIN_TICKETS va         -> "JOIN_TICKETS" <+> renderAnnot va-    where-      renderTy = renderDoc @Ty needsParens-      renderComp = renderDoc @Ty needsParens-      renderOps = renderOpsList False--      renderAnnot :: KnownAnnTag tag => Annotation tag -> Doc-      renderAnnot = renderDoc doesntNeedParens . singleAnnSet--      renderAnnots :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> Doc-      renderAnnots ts fs vs = renderDoc doesntNeedParens $ fullAnnSet ts fs vs--  isRenderable = \case-    EXT extInstr -> isRenderable extInstr-    _ -> True--instance (RenderDoc op, Buildable op) => Buildable (InstrAbstract op) where-  build = \case-    EXT ext -> build ext-    mi -> buildRenderDoc mi--------------------------------------------------------------------------------- JSON serialization-------------------------------------------------------------------------------deriveJSON morleyAesonOptions ''ExpandedOp-deriveJSON morleyAesonOptions ''InstrAbstract

− src/Michelson/Untyped/OpSize.hs

@@ -1,283 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Measuring operation size.------ When originating a contract or making a transfer, tezos node forms operation--- which is submitted over network. Size of this operation depends on content--- of originated contract or transfer parameter resp., and tezos has a hard--- limit on operation size thus it has to be accounted.------ Functions declared in this module allow assessing size of origination or--- transfer operation with up to constant precision because it yet accounts only--- for Michelson primitives participating in the operation.--- Other stuff which affects op size include parameters which user passes to--- origination or transfer themselves, for instance, amount of mutez carried--- to the contract. ATM we don't have necessary primitives in Haskell to be--- able to handle those parameters here, probably waiting for [TM-89].--- Currently, we can assess overall transfer size only approximately, like--- in 'smallTransferOpSize'.-module Michelson.Untyped.OpSize-  ( OpSize (..)-  , opSizeHardLimit-  , smallTransferOpSize--  , instrOpSize-  , expandedInstrsOpSize-  , valueOpSize-  ) where--import Fmt (Buildable(..))-import Prelude hiding (Ordering(..))--import Michelson.Interpret.Utils-import Michelson.Untyped.Aliases-import Michelson.Untyped.Annotation-import Michelson.Untyped.Contract-import Michelson.Untyped.Instr-import Michelson.Untyped.Type-import Michelson.Untyped.Value---- | Operation size in bytes.------ We use newtype wrapper because there are different units of measure--- (another one is gas, and we don't want to confuse them).-newtype OpSize = OpSize { unOpSize :: Word }-  deriving stock (Show, Eq, Ord)--instance Buildable OpSize where-  build = build . unOpSize--instance Semigroup OpSize where-  OpSize a <> OpSize b = OpSize (a + b)-instance Monoid OpSize where-  mempty = OpSize 0---- | Maximal operation size allowed by Tezos production nodes.-opSizeHardLimit :: OpSize-opSizeHardLimit = OpSize 16384---- | Base cost of any transfer of 0 mutez with no extra parameters.--- (Add 'valueOpSize <param>' to it to get assessment of actual transfer op size)-smallTransferOpSize :: OpSize-smallTransferOpSize = OpSize 162--instrOpSize :: InstrAbstract ExpandedOp -> OpSize-instrOpSize = (OpSize 2 <>) . \case-  EXT{} -> mempty-  DROPN n -> stackDepthOpSize n-  DROP -> mempty-  DUP va -> annsOpSize va-  DUPN va n -> annsOpSize va <> stackDepthOpSize n-  SWAP -> mempty-  DIG n -> stackDepthOpSize n-  DUG n -> stackDepthOpSize n-  PUSH va t v -> annsOpSize va <> typeOpSize t <> valueOpSize v-  SOME ta va -> annsOpSize ta va-  NONE ta va t -> annsOpSize ta va <> typeOpSize t-  UNIT ta va -> annsOpSize ta va-  IF_NONE l r -> ifOpSize l r-  PAIR ta va fal far -> annsOpSize ta va fal far-  UNPAIR va1 va2 fal far -> annsOpSize va1 va2 fal far-  PAIRN va n -> annsOpSize va <> stackDepthOpSize n-  UNPAIRN n -> stackDepthOpSize n-  CAR va fa -> annsOpSize va fa-  CDR va fa -> annsOpSize va fa-  LEFT ta va fal far t -> annsOpSize ta va fal far <> typeOpSize t-  RIGHT ta va fal far t -> annsOpSize ta va fal far <> typeOpSize t-  IF_LEFT l r -> ifOpSize l r-  NIL ta va t -> annsOpSize ta va <> typeOpSize t-  CONS va -> annsOpSize va-  IF_CONS l r -> ifOpSize l r-  SIZE va -> annsOpSize va-  EMPTY_SET ta va ct -> annsOpSize ta va <> innerOpSize ct-  EMPTY_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t-  EMPTY_BIG_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t-  MAP va is -> annsOpSize va <> subcodeOpSize is-  ITER is -> subcodeOpSize is-  MEM va -> annsOpSize va-  GET va -> annsOpSize va-  GETN va n -> annsOpSize va <> stackDepthOpSize n-  UPDATE va -> annsOpSize va-  UPDATEN va n -> annsOpSize va <> stackDepthOpSize n-  GET_AND_UPDATE va -> annsOpSize va-  IF l r -> ifOpSize l r-  LOOP is -> expandedInstrsOpSize is-  LOOP_LEFT is -> expandedInstrsOpSize is-  LAMBDA va ti to is ->-    annsOpSize va <> typeOpSize ti <> typeOpSize to <> expandedInstrsOpSize is-  EXEC va -> annsOpSize va-  APPLY va -> annsOpSize va-  DIP is -> subcodeOpSize is-  DIPN n is -> stackDepthOpSize n <> subcodeOpSize is-  FAILWITH -> mempty-  CAST va t -> annsOpSize va <> typeOpSize t-  RENAME va -> annsOpSize va-  PACK va -> annsOpSize va-  UNPACK ta va t -> annsOpSize ta va <> typeOpSize t-  CONCAT va -> annsOpSize va-  SLICE va -> annsOpSize va-  ISNAT va -> annsOpSize va-  ADD va -> annsOpSize va-  SUB va -> annsOpSize va-  MUL va -> annsOpSize va-  EDIV va -> annsOpSize va-  ABS va -> annsOpSize va-  NEG va -> annsOpSize va-  LSL va -> annsOpSize va-  LSR va -> annsOpSize va-  OR va -> annsOpSize va-  AND va -> annsOpSize va-  XOR va -> annsOpSize va-  NOT va -> annsOpSize va-  COMPARE va -> annsOpSize va-  EQ va -> annsOpSize va-  NEQ va -> annsOpSize va-  LT va -> annsOpSize va-  LE va -> annsOpSize va-  GT va -> annsOpSize va-  GE va -> annsOpSize va-  INT va -> annsOpSize va-  SELF va fa -> annsOpSize va fa-  CONTRACT va fa t -> annsOpSize va fa <> typeOpSize t-  TRANSFER_TOKENS va -> annsOpSize va-  SET_DELEGATE va -> annsOpSize va-  CREATE_CONTRACT va1 va2 c -> annsOpSize va1 va2 <> contractOpSize c-  IMPLICIT_ACCOUNT va -> annsOpSize va-  NOW va -> annsOpSize va-  AMOUNT va -> annsOpSize va-  BALANCE va -> annsOpSize va-  VOTING_POWER va -> annsOpSize va-  TOTAL_VOTING_POWER va -> annsOpSize va-  CHECK_SIGNATURE va -> annsOpSize va-  SHA256 va -> annsOpSize va-  SHA512 va -> annsOpSize va-  BLAKE2B va -> annsOpSize va-  SHA3 va -> annsOpSize va-  KECCAK va -> annsOpSize va-  HASH_KEY va -> annsOpSize va-  PAIRING_CHECK va -> annsOpSize va-  SOURCE va -> annsOpSize va-  SENDER va -> annsOpSize va-  ADDRESS va -> annsOpSize va-  CHAIN_ID va -> annsOpSize va-  LEVEL va -> annsOpSize va-  SELF_ADDRESS va -> annsOpSize va-  NEVER -> mempty-  TICKET va -> annsOpSize va-  READ_TICKET va -> annsOpSize va-  SPLIT_TICKET va -> annsOpSize va-  JOIN_TICKETS va -> annsOpSize va-  where-    subcodeOpSize is = expandedInstrOpSize (SeqEx is)-    ifOpSize l r = expandedInstrOpSize (SeqEx l) <> expandedInstrOpSize (SeqEx r)-    stackDepthOpSize n = OpSize 1 <> numOpSize n--expandedInstrOpSize :: ExpandedOp -> OpSize-expandedInstrOpSize = \case-  PrimEx i -> instrOpSize i-  SeqEx is -> OpSize 5 <> expandedInstrsOpSize is-  WithSrcEx _ i -> expandedInstrOpSize i--expandedInstrsOpSize :: [ExpandedOp] -> OpSize-expandedInstrsOpSize = foldMap expandedInstrOpSize--contractOpSize :: Contract -> OpSize-contractOpSize (Contract (ParameterType cp rootAnn) st is _) =-  OpSize 16 <> typeOpSize' [rootAnn] cp <> typeOpSize st <> expandedInstrsOpSize is--numOpSize :: Integral i => i -> OpSize-numOpSize = OpSize . fromIntegral . length . encodeZarithNumber . fromIntegral--valueOpSize :: Value -> OpSize-valueOpSize = (OpSize 1 <>) . \case-  ValueInt i -> numOpSize i-  ValueString s -> (seqOpSize <>) . OpSize . fromIntegral $ length s-  ValueBytes (InternalByteString b) -> (seqOpSize <>) . OpSize . fromIntegral $ length b-  ValueUnit -> baseOpSize-  ValueTrue -> baseOpSize-  ValueFalse -> baseOpSize-  ValuePair l r -> baseOpSize <> valueOpSize l <> valueOpSize r-  ValueLeft x -> baseOpSize <> valueOpSize x-  ValueRight x -> baseOpSize <> valueOpSize x-  ValueSome x -> baseOpSize <> valueOpSize x-  ValueNone -> baseOpSize-  ValueNil -> seqOpSize-  ValueSeq l -> seqOpSize <> foldMap valueOpSize l-  ValueMap m -> seqOpSize <> foldMap eltOpSize m-  ValueLambda m -> seqOpSize <> foldMap expandedInstrOpSize m-  where-    baseOpSize = OpSize 1-    seqOpSize = OpSize 4-    eltOpSize (Elt k v) = OpSize 2 <> valueOpSize k <> valueOpSize v--typeOpSize :: Ty -> OpSize-typeOpSize = typeOpSize' []--typeOpSize' :: [FieldAnn] -> Ty -> OpSize-typeOpSize' anns (Ty t ta) =-  tOpSize t <> annsOpSize ta anns--tOpSize :: T -> OpSize-tOpSize t =-  OpSize 2 <> case t of-    TKey -> mempty-    TUnit -> mempty-    TSignature -> mempty-    TChainId -> mempty-    TOption a -> typeOpSize a-    TList a -> typeOpSize a-    TSet a -> innerOpSize a-    TOperation -> mempty-    TTicket a -> typeOpSize a-    TContract a -> typeOpSize a-    -- Nested variable annotations don't use any extra operation size.-    TPair al ar _ _ l r -> typeOpSize' [al] l <> typeOpSize' [ar] r-    TOr al ar l r -> typeOpSize' [al] l <> typeOpSize' [ar] r-    TLambda i o -> typeOpSize i <> typeOpSize o-    TMap k v -> innerOpSize k <> typeOpSize v-    TBigMap k v -> innerOpSize k <> typeOpSize v-    TInt -> mempty-    TNat -> mempty-    TString -> mempty-    TBytes -> mempty-    TMutez -> mempty-    TBool -> mempty-    TKeyHash -> mempty-    TBls12381Fr -> mempty-    TBls12381G1 -> mempty-    TBls12381G2 -> mempty-    TTimestamp -> mempty-    TAddress -> mempty-    TNever -> mempty--innerOpSize :: Ty -> OpSize-innerOpSize (Ty _ a) =-  (OpSize 2) <> annsOpSize a---- | Accepts an arbitrary number of 'TypeAnn' 'FieldAnn' and/or 'VarAnn' that--- belong to the same entity and returns their total operation size.------ Note that annotations which belong to the same entity (type or instruction)--- __must be__ considered in aggregate using one call of this function and to be--- specified in order. See 'AnnotationSet' for details.-annsOpSize :: AnnsOpSizeVararg x => x-annsOpSize = annsOpSizeVararg emptyAnnSet--class AnnsOpSizeVararg x where-  annsOpSizeVararg :: AnnotationSet -> x--instance (KnownAnnTag t, AnnsOpSizeVararg x) => AnnsOpSizeVararg (Annotation t -> x) where-  annsOpSizeVararg acc an = annsOpSizeVararg (acc <> singleAnnSet an)--instance (KnownAnnTag t, AnnsOpSizeVararg x) => AnnsOpSizeVararg ([Annotation t] -> x) where-  annsOpSizeVararg acc ans = annsOpSizeVararg (acc <> singleGroupAnnSet ans)--instance AnnsOpSizeVararg OpSize where-  annsOpSizeVararg = annsOpSizeImpl--annsOpSizeImpl :: AnnotationSet -> OpSize-annsOpSizeImpl annSet-  | isNoAnnSet annSet = mempty-  | otherwise = OpSize . fromIntegral $ 3 * (minAnnSetSize annSet + 1)

− src/Michelson/Untyped/Type.hs

@@ -1,360 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Michelson types represented in untyped model.--module Michelson.Untyped.Type-  ( Ty (..)-  , T (..)-  , ParameterType (..)-  , toption-  , tpair-  , tor-  , tyint-  , tynat-  , tyunit-  , tybool-  , typair-  , tyor-  , tyImplicitAccountParam-  , isAtomicType-  , isKey-  , isSignature-  , isComparable-  , isMutez-  , isKeyHash-  , isBool-  , isString-  , isInteger-  , isTimestamp-  , isNat-  , isInt-  , isBytes-  , renderType-  , unwrapT-  ) where--import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import Fmt (Buildable(build))-import Language.Haskell.TH.Lift (deriveLift)-import Prelude hiding ((<$>))-import Text.PrettyPrint.Leijen.Text (Doc, align, softbreak, (<$>), (<+>))--import Michelson.Printer.Util-  (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens,-  needsParens, wrapInParens)-import Michelson.Untyped.Annotation-  (AnnotationSet, FieldAnn, RootAnn, TypeAnn, VarAnn, emptyAnnSet, fullAnnSet, noAnn,-  pattern Annotation, singleAnnSet)-import Util.Aeson---- Annotated type.--- We don't name it 'Type' to avoid conflicts with 'Data.Kind.Type'.-data Ty-  = Ty ~T TypeAnn-  deriving stock (Eq, Show, Data, Generic)--unwrapT :: Ty -> T-unwrapT (Ty t _) = t--instance NFData Ty--instance RenderDoc (Prettier Ty) where-  renderDoc pn (Prettier w) = case w of-    (Ty t ta) -> renderType t False pn (singleAnnSet ta)--instance RenderDoc Ty where-  renderDoc pn (Ty t ta) = renderType t True pn (singleAnnSet ta)--instance RenderDoc T where-  renderDoc pn t = renderType t True pn emptyAnnSet---- | Since Babylon parameter type can have special root annotation.-data ParameterType = ParameterType Ty RootAnn-  deriving stock (Eq, Show, Data, Generic)--instance NFData ParameterType--instance RenderDoc (Prettier ParameterType) where-  renderDoc pn (Prettier w) = case w of-    ParameterType (Ty t ta) ra ->-      renderType t False pn (fullAnnSet [ta] [ra] [])--instance RenderDoc ParameterType where-  renderDoc pn (ParameterType (Ty t ta) ra) =-    renderType t True pn (fullAnnSet [ta] [ra] [])---- Ordering between different kinds of annotations is not significant,--- but ordering among annotations of the same kind is. Annotations--- of a same kind must be grouped together.--- (prim @v :t %x arg1 arg2 ...)--- these are equivalent--- PAIR :t @my_pair %x %y--- PAIR %x %y :t @my_pair-renderType-  :: T-  -> Bool-  -> RenderContext-  -> AnnotationSet-  -> Doc-renderType t forceSingleLine pn annSet =-  let annDoc = renderDoc doesntNeedParens annSet-      recRenderer t' annSet' = renderType t' forceSingleLine needsParens annSet'-      renderBranches :: [Doc] -> Doc-      renderBranches ds =-        if forceSingleLine-        then foldl1 (<+>) ds-        else align $ softbreak <> foldl1 (<$>) ds--      collectBranches :: T ->  TypeAnn -> FieldAnn -> [Doc]-      collectBranches (TPair fa1 fa2 va1 _ (Ty t1 ta1) (Ty t2 ta2)) _ (Annotation "")-        = (recRenderer t1 $ (fullAnnSet [ta1] [fa1] [va1])) : collectBranches t2 ta2 fa2-      collectBranches t' ta fa = [recRenderer t' $ fullAnnSet [ta] [fa] []]--  in-  case t of-    TInt              -> wrapInParens pn $ "int" :| [annDoc]-    TNat              -> wrapInParens pn $ "nat" :| [annDoc]-    TString           -> wrapInParens pn $ "string" :| [annDoc]-    TMutez            -> wrapInParens pn $ "mutez" :| [annDoc]-    TBool             -> wrapInParens pn $ "bool" :| [annDoc]-    TKeyHash          -> wrapInParens pn $ "key_hash" :| [annDoc]-    TTimestamp        -> wrapInParens pn $ "timestamp" :| [annDoc]-    TBytes            -> wrapInParens pn $ "bytes" :| [annDoc]-    TAddress          -> wrapInParens pn $ "address" :| [annDoc]-    TKey              -> wrapInParens pn $ "key"  :| [annDoc]-    TBls12381Fr       -> wrapInParens pn $ "bls12_381_fr"  :| [annDoc]-    TBls12381G1       -> wrapInParens pn $ "bls12_381_g1"  :| [annDoc]-    TBls12381G2       -> wrapInParens pn $ "bls12_381_g2"  :| [annDoc]-    TUnit             -> wrapInParens pn $ "unit" :| [annDoc]-    TSignature        -> wrapInParens pn $ "signature" :| [annDoc]-    TChainId          -> wrapInParens pn $ "chain_id" :| [annDoc]-    TOperation        -> wrapInParens pn $ "operation" :| [annDoc]-    TNever            -> wrapInParens pn $ "never" :| [annDoc]--    TOption (Ty t1 ta1) ->-      addParens pn $-      "option" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)--    TList (Ty t1 ta1)       ->-      addParens pn $-      "list" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)--    TSet (Ty t1 ta1) ->-      addParens pn $-      "set" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)--    TContract (Ty t1 ta1)   ->-      addParens pn $-      "contract" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)--    TTicket (Ty t1 ta1)   ->-      addParens pn $-      "ticket" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)--    -- Optimize in comb pair rendering: `pair x y z` instead of `pair x (pair y z)`-    -- Works only if there is no field annotation on nested pair-    p@(TPair _ (Annotation "") _ _ (Ty _ _) (Ty (TPair {}) _)) ->-       let branches = collectBranches p noAnn noAnn-       in-        addParens pn $-          "pair" <+> annDoc <+>-            renderBranches branches--    TPair fa1 fa2 va1 va2 (Ty t1 ta1) (Ty t2 ta2) ->-      addParens pn $-        "pair" <+> annDoc <+>-          renderBranches-            [ recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1]-            , recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2]-            ]--    TOr fa1 fa2 (Ty t1 ta1) (Ty t2 ta2) ->-      addParens pn $-        "or" <+> annDoc <+>-          renderBranches-            [ recRenderer t1 $ fullAnnSet [ta1] [fa1] []-            , recRenderer t2 $ fullAnnSet [ta2] [fa2] []-            ]--    TLambda (Ty t1 ta1) (Ty t2 ta2) ->-      addParens pn $-        "lambda" <+> annDoc <+>-          renderBranches-            [ recRenderer t1 $ singleAnnSet ta1-            , recRenderer t2 $ singleAnnSet ta2-            ]--    TMap (Ty t1 ta1) (Ty t2 ta2) ->-      addParens pn $-        "map" <+> annDoc <+>-          renderBranches-            [ recRenderer t1 $ singleAnnSet ta1-            , recRenderer t2 $ singleAnnSet ta2-            ]--    TBigMap (Ty t1 ta1) (Ty t2 ta2) ->-      addParens pn $-        "big_map" <+> annDoc <+>-          renderBranches-            [ recRenderer t1 $ singleAnnSet ta1-            , recRenderer t2 $ singleAnnSet ta2-            ]--instance Buildable Ty where-  build = buildRenderDoc--instance Buildable ParameterType where-  build = buildRenderDoc---- Michelson Type-data T =-    TKey-  | TUnit-  | TSignature-  | TChainId-  | TOption Ty-  | TList Ty-  | TSet Ty-  | TOperation-  | TContract Ty-  | TTicket Ty-  | TPair FieldAnn FieldAnn VarAnn VarAnn Ty Ty-  | TOr FieldAnn FieldAnn Ty Ty-  | TLambda Ty Ty-  | TMap Ty Ty-  | TBigMap Ty Ty-  | TInt-  | TNat-  | TString-  | TBytes-  | TMutez-  | TBool-  | TKeyHash-  | TBls12381Fr-  | TBls12381G1-  | TBls12381G2-  | TTimestamp-  | TAddress-  | TNever-  deriving stock (Eq, Show, Data, Generic)--instance Buildable T where-  build = buildRenderDoc--instance NFData T--toption :: Ty -> T-toption t = TOption t--tpair :: Ty -> Ty -> T-tpair l r = TPair noAnn noAnn noAnn noAnn l r--tor :: Ty -> Ty -> T-tor l r = TOr noAnn noAnn l r--tyint :: Ty-tyint = Ty TInt noAnn--tynat :: Ty-tynat = Ty TNat noAnn--tyunit :: Ty-tyunit = Ty TUnit noAnn--tybool :: Ty-tybool = Ty TBool noAnn--typair :: Ty -> Ty -> Ty-typair l r = Ty (tpair l r) noAnn--tyor :: Ty -> Ty -> Ty-tyor l r = Ty (tor l r) noAnn---- | For implicit account, which Ty its parameter seems to have--- from outside.-tyImplicitAccountParam :: Ty-tyImplicitAccountParam = Ty TUnit noAnn--isAtomicType :: Ty -> Bool-isAtomicType t@(Ty _ tAnn) | tAnn == noAnn =-    isComparable t || isKey t || isUnit t || isSignature t || isOperation t-isAtomicType _ = False--isKey :: Ty -> Bool-isKey (Ty TKey _) = True-isKey _             = False--isUnit :: Ty -> Bool-isUnit (Ty TUnit _) = True-isUnit _              = False--isSignature :: Ty -> Bool-isSignature (Ty TSignature _) = True-isSignature _                   = False--isOperation :: Ty -> Bool-isOperation (Ty TOperation _) = True-isOperation _                   = False--isComparable :: Ty -> Bool-isComparable (Ty t _) = case t of-  TInt -> True-  TNat -> True-  TString -> True-  TBytes -> True-  TMutez -> True-  TBool -> True-  TKeyHash -> True-  TTimestamp -> True-  TAddress -> True-  _ -> False--isMutez :: Ty -> Bool-isMutez (Ty TMutez _) = True-isMutez _ = False--isTimestamp :: Ty -> Bool-isTimestamp (Ty TTimestamp _) = True-isTimestamp _ = False--isKeyHash :: Ty -> Bool-isKeyHash (Ty TKeyHash _) = True-isKeyHash _ = False--isBool  :: Ty -> Bool-isBool (Ty TBool _) = True-isBool _ = False--isString  :: Ty -> Bool-isString (Ty TString _) = True-isString _ = False--isInteger :: Ty -> Bool-isInteger a = isNat a || isInt a || isMutez a || isTimestamp a--isNat  :: Ty -> Bool-isNat (Ty TNat _) = True-isNat _ = False--isInt  :: Ty -> Bool-isInt (Ty TInt _) = True-isInt _ = False--isBytes :: Ty -> Bool-isBytes (Ty TBytes _) = True-isBytes _ = False--------------------------------------------------------------------------------- TH derivations-------------------------------------------------------------------------------deriveJSON morleyAesonOptions ''Ty-deriveJSON morleyAesonOptions ''T-deriveJSON morleyAesonOptions ''ParameterType--deriveLift ''Ty-deriveLift ''T-deriveLift ''ParameterType

− src/Michelson/Untyped/Value.hs

@@ -1,135 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Untyped Michelson values (i. e. type of a value is not statically known).--module Michelson.Untyped.Value-  ( Value' (..)-  , Elt (..)-  -- Internal types to avoid orphan instances-  , InternalByteString(..)-  , unInternalByteString-  , linearizeRightCombValuePair-  ) where--import Data.Aeson (FromJSON(..), ToJSON(..), withText)-import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import Data.List.NonEmpty ((<|))-import Fmt (Buildable(build))-import Text.Hex (decodeHex, encodeHex)-import Text.PrettyPrint.Leijen.Text-  (Doc, braces, dquotes, enclose, semi, space, text, textStrict, (<+>))--import Michelson.Printer.Util-  (RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens, renderOps)-import Michelson.Text-import Util.Aeson--data Value' op =-    ValueInt     Integer-  | ValueString  MText-  | ValueBytes   InternalByteString-  | ValueUnit-  | ValueTrue-  | ValueFalse-  | ValuePair    (Value' op) (Value' op)-  | ValueLeft    (Value' op)-  | ValueRight   (Value' op)-  | ValueSome    (Value' op)-  | ValueNone-  | ValueNil-  | ValueSeq     (NonEmpty $ Value' op)-  -- ^ A sequence of elements: can be a list, a set or a pair.-  -- We can't distinguish lists and sets during parsing.-  | ValueMap     (NonEmpty $ Elt op)-  | ValueLambda  (NonEmpty op)-  deriving stock (Eq, Show, Functor, Data, Generic)--instance NFData op => NFData (Value' op)--data Elt op = Elt (Value' op) (Value' op)-  deriving stock (Eq, Show, Functor, Data, Generic)--instance NFData op => NFData (Elt op)---- | ByteString does not have an instance for ToJSON and FromJSON, to--- avoid orphan type class instances, make a new type wrapper around it.-newtype InternalByteString = InternalByteString ByteString-  deriving stock (Data, Eq, Show, Generic)--instance NFData InternalByteString--unInternalByteString :: InternalByteString -> ByteString-unInternalByteString (InternalByteString bs) = bs--instance RenderDoc op => RenderDoc (Value' op) where-  renderDoc pn =-    \case-      ValueNil       -> "{ }"-      ValueInt x     -> text . show $ x-      ValueString x  -> dquotes (textStrict $ writeMText x)-      ValueBytes xs  -> "0x" <> (textStrict . encodeHex . unInternalByteString $ xs)-      ValueUnit      -> "Unit"-      ValueTrue      -> "True"-      ValueFalse     -> "False"-      p@(ValuePair _ (ValuePair _ _))  ->-        let encodedValues = linearizeRightCombValuePair p-        in renderValuesList (renderDoc doesntNeedParens) encodedValues-      ValuePair l r  -> addParens pn $-                        "Pair" <+> renderDoc needsParens l <+> renderDoc needsParens r-      ValueLeft l    -> addParens pn $-                        "Left" <+> renderDoc needsParens l-      ValueRight r   -> addParens pn $-                        "Right" <+> renderDoc needsParens r-      ValueSome x    -> addParens pn $-                        "Some"  <+> renderDoc needsParens x-      ValueNone      -> "None"-      ValueSeq xs    -> renderValuesList (renderDoc doesntNeedParens) xs-      ValueMap xs    -> renderValuesList renderElt xs-      ValueLambda xs -> renderOps False xs---- | Converts `Pair a (Pair b c)` to `[a, b, c].`-linearizeRightCombValuePair :: (Value' op) -> NonEmpty (Value' op)-linearizeRightCombValuePair (ValuePair l r) = l <| linearizeRightCombValuePair r-linearizeRightCombValuePair v = v :| []--renderElt :: RenderDoc op => Elt op -> Doc-renderElt (Elt k v) =-   "Elt" <+> renderDoc needsParens k <+> renderDoc needsParens v--instance RenderDoc op => RenderDoc (Elt op) where-  renderDoc _ = renderElt--renderValuesList :: (e -> Doc) -> NonEmpty e -> Doc-renderValuesList renderElem (toList -> es) =-  braces . enclose space space $-    mconcat . intersperse (semi <> space) $-      renderElem <$> es--instance (RenderDoc op) => Buildable (Value' op) where-  build = buildRenderDoc--instance (RenderDoc op) => Buildable (Elt op) where-  build = buildRenderDoc--------------------------------------------------------------------------------- JSON serialization--------------------------------------------------------------------------------- it is not possible to derives these automatically because--- ByteString does not have a ToJSON or FromJSON instance--instance ToJSON InternalByteString where-  toJSON = toJSON . encodeHex . unInternalByteString--instance FromJSON InternalByteString where-  parseJSON =-    withText "Hex-encoded bytestring" $ \t ->-      case decodeHex t of-        Nothing -> fail "Invalid hex encoding"-        Just res -> pure (InternalByteString res)--deriveJSON morleyAesonOptions ''Value'-deriveJSON morleyAesonOptions ''Elt

src/Morley/CLI.hs view

@@ -26,25 +26,25 @@   , mTextOption   ) where -import Named (arg) import Options.Applicative   (footerDoc, fullDesc, header, help, helper, info, long, metavar, option, progDesc, strOption,   switch) import qualified Options.Applicative as Opt-import Text.Read (read) import Options.Applicative.Help.Pretty (Doc)+import Text.Read (read) -import qualified Michelson.Parser as P-import Michelson.Runtime (TxData(..), TxParam(..))-import Michelson.Runtime.GState (genesisAddress)-import Michelson.Text (MText)-import Michelson.Untyped (EpName)-import qualified Michelson.Untyped as U-import Tezos.Address (Address)-import Tezos.Core (Mutez, Timestamp, parseTimestamp, timestampFromSeconds)-import Tezos.Crypto-import Util.CLI-import Util.Named+import Morley.Michelson.Parser (MichelsonSource(..))+import qualified Morley.Michelson.Parser as P+import Morley.Michelson.Runtime (TxData(..), TxParam(..))+import Morley.Michelson.Runtime.GState (genesisAddress)+import Morley.Michelson.Text (MText)+import Morley.Michelson.Untyped (EpName)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (Mutez, Timestamp, parseTimestamp, timestampFromSeconds)+import Morley.Tezos.Crypto+import Morley.Util.CLI+import Morley.Util.Named  ---------------------------------------------------------------------------- -- These options are mostly specifications of 'mkCLOptionParser'@@ -59,10 +59,10 @@   -> "parser" :! Opt.Parser s   -> Opt.ParserInfo s parserInfo-  (arg #usage -> usage)-  (arg #description -> description)-  (arg #header -> clientHeader)-  (arg #parser -> parser) =+  (N usage)+  (N description)+  (N clientHeader)+  (N parser) =   info (helper <*> parser) $   mconcat     [ fullDesc@@ -102,8 +102,8 @@ maxStepsOption :: Opt.Parser Word64 maxStepsOption = mkCLOptionParser   (Just 100500)-  (#name .! "max-steps")-  (#help .! "Max steps that you want the runtime interpreter to use")+  (#name :! "max-steps")+  (#help :! "Max steps that you want the runtime interpreter to use")  -- | Parser for path to database with Morley state. dbPathOption :: Opt.Parser FilePath@@ -119,12 +119,12 @@ txDataOption =   mkTxData     <$> addressOption (Just genesisAddress)-      (#name .! "sender") (#help .! "Sender address")+      (#name :! "sender") (#help :! "Sender address")     <*> valueOption Nothing-      (#name .! "parameter") (#help .! "Parameter of passed contract")+      (#name :! "parameter") (#help :! "Parameter of passed contract")     <*> mutezOption (Just minBound)-      (#name .! "amount") (#help .! "Amount sent by a transaction")-    <*> entrypointOption (#name .! "entrypoint") (#help .! "Entrypoint to call")+      (#name :! "amount") (#help :! "Amount sent by a transaction")+    <*> entrypointOption (#name :! "entrypoint") (#help :! "Entrypoint to call")   where     mkTxData :: Address -> U.Value -> Mutez -> EpName -> TxData     mkTxData addr param amount epName =@@ -187,6 +187,6 @@       parseValue :: String -> Either String U.Value       parseValue =         first (mappend "Failed to parse value: " . displayException) .-        P.parseExpandValue .+        P.parseExpandValue MSCli .         toText   getMetavar = "MICHELSON VALUE"

src/Morley/Micheline.hs view

@@ -8,5 +8,5 @@  import Morley.Micheline.Binary as Exports import Morley.Micheline.Class as Exports-import Morley.Micheline.Json as Exports import Morley.Micheline.Expression as Exports+import Morley.Micheline.Json as Exports

src/Morley/Micheline/Binary.hs view

@@ -20,9 +20,10 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Sequence as Seq import qualified Data.Text.Encoding as TE+import qualified Unsafe (fromIntegral)  import Morley.Micheline.Expression-import Util.Binary (UnpackError(..), ensureEnd, launchGet)+import Morley.Util.Binary (UnpackError(..), ensureEnd, launchGet)  newtype DynamicSize a = DynamicSize { unDynamicSize :: a } @@ -65,19 +66,20 @@       ab = abs n   in     -- Refer to: https://gitlab.com/obsidian.systems/tezos-bake-monitor-lib/-/blob/2cf12e53072bcd966d471430ead25f597db5e23f/tezos-bake-monitor-lib/src/Tezos/Common/Binary.hs#L122-    if ab < 0x40 then Bi.singleton (fromIntegral ab .|. signBit)-    else Bi.singleton (fromIntegral (ab .&. 0x3f) .|. signBit .|. bit 7) <> writeZ (-6) ab+    if ab < 0x40 then Bi.singleton (Unsafe.fromIntegral @Integer @Word8 ab .|. signBit)+    else Bi.singleton (Unsafe.fromIntegral @Integer @Word8 (ab .&. 0x3f) .|. signBit .|. bit 7) <> writeZ (-6) ab -writeZ :: (Integral a, Bits a) => Int -> a -> Bi.Builder+writeZ :: forall a. (Integral a, Bits a) => Int -> a -> Bi.Builder writeZ offset n =-  if n < bit (7 - offset) then Bi.singleton $ fromIntegral $ n `shift` offset-    else Bi.singleton (fromIntegral (((n `shift` offset) .&. 0x7f) `setBit` 7)) <> writeZ (offset - 7) n+  if n < bit (7 - offset) then Bi.singleton $ Unsafe.fromIntegral @a @Word8 $ n `shift` offset+    else Bi.singleton (Unsafe.fromIntegral @a @Word8 (((n `shift` offset) .&. 0x7f) `setBit` 7)) <> writeZ (offset - 7) n  buildDynamic :: (a -> Bi.Builder) -> (DynamicSize a) -> Bi.Builder buildDynamic build (DynamicSize x) =   let b = build x-  in Bi.putWord32be (fromIntegral $ LBS.length $ Bi.toLazyByteString b) <> b+  in Bi.putWord32be (Unsafe.fromIntegral @Int64 @Word32 $ LBS.length $ Bi.toLazyByteString b) <> b + buildText :: Text -> Bi.Builder buildText n =   buildByteString $ TE.encodeUtf8 n@@ -88,7 +90,7 @@ buildPrim :: MichelinePrimitive -> Bi.Builder buildPrim (MichelinePrimitive p) = case Seq.elemIndexL p michelsonPrimitive of   Nothing -> error $ "unknown Michelson/Micheline primitive: " <> p-  Just ix -> buildWord8 (fromIntegral ix)+  Just ix -> buildWord8 (Unsafe.fromIntegral @Int @Word8 ix)  buildAnnotationList :: [Annotation] -> Bi.Builder buildAnnotationList listAnn = buildDynamic buildText (DynamicSize $ unwords . fmap annotToText $ listAnn)@@ -126,16 +128,16 @@   n <- if b `testBit` 7 then readZ 6 (fromIntegral $ b .&. 0x3f) else pure (fromIntegral $ b .&. 0x3f)   pure $ if b `testBit` 6 then negate n else n -readZ :: (Num a, Bits a) => Int -> a -> Bi.Get a+readZ :: forall a. (Integral a, Bits a) => Int -> a -> Bi.Get a readZ offset n = do   b <- Bi.getWord8   if (b == 0) && (offset > 0) then fail "trailing zero" else pure ()-  let n' = (fromIntegral (b .&. 0x7f) `shift` offset) .|. n+  let n' = (Unsafe.fromIntegral @Word8 @a (b .&. 0x7f) `shift` offset) .|. n   if b `testBit` 7 then readZ (offset + 7) n' else pure n'  getDynamic :: (Bi.Get a) -> (Bi.Get (DynamicSize a)) getDynamic getter = do-  len <- fromIntegral <$> Bi.getWord32be+  len <- Unsafe.fromIntegral @Word32 @Int <$> Bi.getWord32be   DynamicSize <$> Bi.isolate len getter  {-# ANN getText ("HLint: ignore Redundant fmap" :: Text) #-}

src/Morley/Micheline/Class.hs view

@@ -16,30 +16,31 @@ import Data.Singletons (SingI(..), demote) import Fmt (Buildable(..), indentF, pretty, unlinesF) -import Michelson.Text (mkMText, unMText)-import Michelson.TypeCheck (TypeCheckMode(..), TypeCheckOptions(..), runTypeCheck, typeCheckingWith)-import Michelson.TypeCheck.Instr (typeCheckValue)-import Michelson.Typed+import Morley.Micheline.Expression+  (Annotation(..), Expression(..), MichelinePrimAp(..), _ExpressionPrim, isAnnotationField,+  isAnnotationType, isAnnotationVariable, mkAnns, mpaAnnotsL, toAnnSet)+import Morley.Michelson.Text (mkMText, unMText)+import Morley.Michelson.TypeCheck+  (TypeCheckMode(..), TypeCheckOptions(..), runTypeCheck, typeCheckingWith)+import Morley.Michelson.TypeCheck.Instr (typeCheckValue)+import Morley.Michelson.Typed   (Contract(..), HasNoOp, Instr, Notes(..), T(..), Value, Value'(..), fromUType, mkUType,   rfAnyInstr, toUType)-import Michelson.Typed.Convert (convertContract, instrToOpsOptimized, untypeValueOptimized)-import qualified Michelson.Untyped as Untyped-import Michelson.Untyped.Annotation+import Morley.Michelson.Typed.Convert (convertContract, instrToOpsOptimized, untypeValueOptimized)+import qualified Morley.Michelson.Untyped as Untyped+import Morley.Michelson.Untyped.Annotation   (AnnotationSet(..), FieldAnn, FieldTag, RootAnn, TypeAnn, TypeTag, VarAnn, VarTag, annsCount,   emptyAnnSet, firstAnn, noAnn, secondAnn)-import Michelson.Untyped.Contract (ContractBlock(..), orderContractBlock)-import Michelson.Untyped.Instr (ExpandedInstr, ExpandedOp(..), InstrAbstract(..))-import Michelson.Untyped.Type (Ty(..))-import Morley.Micheline.Expression-  (Annotation(..), Expression(..), MichelinePrimAp(..), _ExpressionPrim, isAnnotationField,-  isAnnotationType, isAnnotationVariable, mkAnns, mpaAnnotsL, toAnnSet)+import Morley.Michelson.Untyped.Contract (ContractBlock(..), orderContractBlock)+import Morley.Michelson.Untyped.Instr (ExpandedInstr, ExpandedOp(..), InstrAbstract(..))+import Morley.Michelson.Untyped.Type (Ty(..))  -- | Type class that provides an ability to convert -- something to Micheline Expression. class ToExpression a where   toExpression :: a -> Expression -instance forall t . (SingI t, HasNoOp t) => ToExpression (Value t) where+instance (HasNoOp t) => ToExpression (Value t) where   toExpression = toExpression . untypeValueOptimized  instance ToExpression Untyped.Value where

src/Morley/Micheline/Expression.hs view

@@ -46,13 +46,13 @@ import qualified Data.Text as T (uncons) import Fmt (Buildable(..), pretty, (+|), (|+)) -import qualified Michelson.Untyped as U-import Michelson.Untyped.Annotation-  (FieldAnn, FieldTag, KnownAnnTag(..), AnnotationSet(..), TypeAnn, TypeTag,-  VarAnn, VarTag, annPrefix, mkAnnotation, minimizeAnnSet, fullAnnSet) import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode))-import Tezos.Crypto (encodeBase58Check)-import Util.ByteString (HexJSONByteString(..))+import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped.Annotation+  (AnnotationSet(..), FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag,+  annPrefix, fullAnnSet, minimizeAnnSet, mkAnnotation)+import Morley.Tezos.Crypto (encodeBase58Check)+import Morley.Util.ByteString (HexJSONByteString(..))  newtype MichelinePrimitive = MichelinePrimitive Text   deriving newtype (Eq, Ord, ToJSON, FromJSON)

src/Morley/Micheline/Json.hs view

@@ -21,7 +21,7 @@ import Fmt (Buildable(..)) import qualified Text.Show as T -import Tezos.Core (Mutez, mkMutez', mutezToInt64)+import Morley.Tezos.Core (Mutez(..), mkMutez)  printAsString :: Show a => a -> Aeson.Value printAsString a = Aeson.String $ show a@@ -37,6 +37,8 @@   deriving stock (Generic, Eq, Ord, Bounded, Read, Show)   deriving newtype (Enum, Num, Integral, Bits, Real, NFData, Hashable) +type instance IntBaseType (StringEncode a) = IntBaseType a+ type TezosBigNum = StringEncode Integer  instance FromJSON TezosBigNum where@@ -62,12 +64,12 @@   deriving stock (Show, Eq, Ord)  instance ToJSON TezosMutez where-  toJSON = printAsString . mutezToInt64 . unTezosMutez+  toJSON = printAsString . unMutez . unTezosMutez  instance FromJSON TezosMutez where   parseJSON v = do     i <- parseAsString @Int64 v-    either (fail . toString) (pure . TezosMutez) $ mkMutez' i+    either (fail . toString) (pure . TezosMutez) $ mkMutez i  type TezosNat = StringEncode Natural

+ src/Morley/Michelson/Analyzer.hs view

@@ -0,0 +1,118 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Static analysis of Michelson code.++module Morley.Michelson.Analyzer+  ( AnalyzerRes (..)+  , analyze+  ) where++import Data.Default (def)+import qualified Data.HashMap.Strict as HM+import qualified Data.List.NonEmpty as NE+import Fmt (Buildable(..), Builder, blockMapF', hexF, nameF, (+|))+import qualified Unsafe (fromIntegral)++import Morley.Michelson.FailPattern+import Morley.Michelson.Text (MText)+import Morley.Michelson.Typed+import Morley.Util.Text (dquotes)++data AnalyzerRes = AnalyzerRes+  { arConstStrings :: HashMap MText Word+  -- ^ All string constants and number of their occurrences.+  , arConstBytes :: HashMap ByteString Word+  -- ^ All bytes constants and number of their occurrences.+  , arErrorTags :: HashMap MText Word+  -- ^ Which strings are used as error tags and how many times.+  -- There is no notion of "error tag" in Michelson, so we use a heuristic+  -- to find out whether a string is an error tag. Specifically, we consider+  -- three patterns:+  -- 1. A constant string is pushed and then there is `FAILWITH` immediately.+  -- 2. A constant string is pushed, followed by `PAIR` instruction and then+  -- `FAILWITH`.+  -- 3. A constant pair is pushed where the first item is a string and then+  -- there is `FAILWITH.+  } deriving stock (Show, Eq)++instance Buildable AnalyzerRes where+  build (AnalyzerRes+    (toPairs -> constStrings)+    (toPairs -> constBytes)+    (toPairs -> errorTags)+    ) =+    nameF "String constants"+      (buildStrings $ sortByCount constStrings)+    +|+    nameF "Bytes constants"+      (buildBytes $ sortByCount constBytes)+    +|+    nameF "Error tags"+      (buildStrings $ sortByCount errorTags)+    +|+    longest "strings" constStrings buildStrings+    +|+    longest "bytes" constBytes buildBytes+    where+      buildStrings = blockMapF' (dquotes . build) build+      buildBytes = blockMapF' (mappend "0x" . hexF) build++      sortByCount :: [(k, Word)] -> [(k, Word)]+      sortByCount = sortWith snd++      sortByLength :: Container k => [(k, Word)] -> [(k, Word)]+      sortByLength = sortWith (Down . length . fst)++      longest ::+        Container x =>+        Builder -> [(x, Word)] -> ([(x, Word)] -> Builder) -> Builder+      longest name items builder+        | length items > 6 =+          nameF ("Longest " <> name) $ builder $ take 4 $ sortByLength items+        | otherwise = mempty++instance Semigroup AnalyzerRes where+  ar1 <> ar2 = AnalyzerRes+    { arConstStrings = arConstStrings ar1 <+> arConstStrings ar2+    , arConstBytes = arConstBytes ar1 <+> arConstBytes ar2+    , arErrorTags = arErrorTags ar1 <+> arErrorTags ar2+    }+    where+      m1 <+> m2 = HM.unionWith (+) m1 m2++instance Monoid AnalyzerRes where+  mempty = AnalyzerRes+    { arConstStrings = mempty+    , arConstBytes = mempty+    , arErrorTags = mempty+    }++-- | Statically analyze an instruction. Typed representation is used+-- because it's easier to analyze. It means that we can't analyze+-- ill-typed contracts, but hopefully it's not a serious limitation.+analyze :: Instr inp out -> AnalyzerRes+analyze = dfsFoldInstr def{ dsGoToValues = True } step . linearizeLeftDeep+  where+    step :: forall i o. Instr i o -> AnalyzerRes+    step i = analyzeConstants i <> analyzeErrorTags i++    countItems :: (Ord i, Hashable i) => [i] -> HashMap i Word+    countItems = HM.fromList . map f . NE.group . sort+      where+        f ne = (head ne, Unsafe.fromIntegral @Int @Word $ length ne)++    analyzeConstants :: forall i o. Instr i o -> AnalyzerRes+    analyzeConstants = \case+      PUSH v -> mempty+        { arConstStrings = countItems $ allAtomicValues isStringValue v+        , arConstBytes = countItems $ allAtomicValues isBytesValue v+        }+      _ -> mempty++    analyzeErrorTags :: forall i o. Instr i o -> AnalyzerRes+    analyzeErrorTags i+      | Just tfw <- isTypicalFailWith i =+          mempty { arErrorTags = one (typicalFailWithTag tfw, 1) }+      | otherwise = mempty

+ src/Morley/Michelson/Doc.hs view

@@ -0,0 +1,819 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE TypeFamilyDependencies, UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Renderable documentation injected to contract code.+module Morley.Michelson.Doc+  ( DocItem (..)+  , docItemPosition+  , DocItemId (..)+  , DocItemPlacementKind (..)+  , DocItemPos (..)+  , DocItemRef (..)+  , DocItemReferencedKind+  , DocSectionNameStyle (..)+  , SomeDocItem (..)+  , SomeDocDefinitionItem (..)+  , DocElem (..)+  , DocSection (..)+  , DocBlock+  , SubDoc (..)+  , ContractDoc (..)+  , DocGrouping+  , cdContentsL+  , cdDefinitionsL+  , cdDefinitionsSetL+  , cdDefinitionIdsL+  , deIsAtomic+  , subDocToMarkdown+  , docItemToBlock+  , docItemSectionRef+  , lookupDocBlockSection+  , contractDocToMarkdown+  , contractDocToToc+  , docGroupContent+  , docDefinitionRef+  , mdTocFromRef+  , WithFinalizedDoc (..)+  , finalizedAsIs+  , ContainsDoc (..)+  , ContainsUpdateableDoc (..)+  , buildDoc+  , buildMarkdownDoc+  , modifyDoc++  , DGeneralInfoSection (..)+  , DName (..)+  , DDescription (..)+  , DGitRevision (..)+  , GitRepoSettings (..)+  , mkDGitRevision+  , morleyRepoSettings+  , DComment (..)+  , DAnchor (..)+  , DToc (..)+  , DConversionInfo (..)+  , attachGitInfo+  , attachToc+  , attachDocCommons+  ) where++import qualified Data.Map as M+import qualified Data.Map.Merge.Strict as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Typeable (cast, typeRep)+import Development.GitRev (gitCommitDate, gitHash)+import Fmt (Buildable, build, fmt, (+|), (+||), (|+), (||+))+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Lift as TH+import System.Environment (lookupEnv)+import qualified Text.Show++import Morley.Util.Instances ()+import Morley.Util.Lens+import Morley.Util.Markdown+import Morley.Util.Type+import Morley.Util.Typeable++-- | A piece of documentation describing one property of a thing,+-- be it a name or description of a contract, or an error throwable+-- by given endpoint.+--+-- Items of the same type appear close to each other in a rendered documentation+-- and form a /section/.+--+-- Doc items are later injected into a contract code via a dedicated nop-like+-- instruction. Normally doc items which belong to one section appear in+-- resulting doc in the same order in which they appeared in the contract.+--+-- While documentation framework grows, this typeclass acquires more and more+-- methods for fine tuning of existing rendering logic because we don't want+-- to break backward compatibility, hope one day we will make everything+-- concise :(+-- E.g. all rendering and reording stuff could be merged in one method, and+-- we could have several template implementations for it which would allow+-- user to specify only stuff relevant to his case.+class (Typeable d, DOrd d) => DocItem d where+  -- | Position of this item in the resulting documentation;+  -- the smaller the value, the higher the section with this element+  -- will be placed. If the position is the same as other doc items,+  -- they will be placed base on their name, alphabetically.+  --+  -- Documentation structure is not necessarily flat.+  -- If some doc item consolidates a whole documentation block within it,+  -- this block will have its own placement of items independent from outer parts+  -- of the doc.+  docItemPos :: Natural++  -- | When multiple items of the same type belong to one section, how+  -- this section will be called.+  --+  -- If not provided, section will contain just untitled content.+  docItemSectionName :: Maybe Text++  -- | Description of a section.+  --+  -- Can be used to mention some common things about all elements of this section.+  -- Markdown syntax is permitted here.+  docItemSectionDescription :: Maybe Markdown+  docItemSectionDescription = Nothing++  -- | How to render section name.+  --+  -- Takes effect only if section name is set.+  docItemSectionNameStyle :: DocSectionNameStyle+  docItemSectionNameStyle = DocSectionNameBig++  -- | Defines where given doc item should be put. There are two options:+  -- 1. Inline right here (default behaviour);+  -- 2. Put into definitions section.+  --+  -- Note that we require all doc items with "in definitions" placement to+  -- have 'Eq' and 'Ord' instances which comply the following law:+  -- if two documentation items describe the same entity or property, they+  -- should be considered equal.+  type DocItemPlacement d :: DocItemPlacementKind+  type DocItemPlacement _ = 'DocItemInlined++  type DocItemReferenced d :: DocItemReferencedKind+  type DocItemReferenced _ = 'False++  -- | Defines a function which constructs an unique identifier of given doc item,+  -- if it has been decided to put the doc item into definitions section.+  --+  -- Identifier should be unique both among doc items of the same type and items+  -- of other types. Thus, consider using "typeId-contentId" pattern.+  docItemRef :: d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)+  default docItemRef+    :: ( DocItemPlacement d ~ 'DocItemInlined+       , DocItemReferenced d ~ 'False+       )+    => d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)+  docItemRef _ = DocItemNoRef++  -- | Render given doc item to Markdown, preferably one line,+  -- optionally with header.+  --+  -- Accepts the smallest allowed level of header.+  -- (Using smaller value than provided one will interfere with existing+  -- headers thus delivering mess).+  docItemToMarkdown :: HeaderLevel -> d -> Markdown++  -- | Render table of contents entry for given doc item to Markdown.+  docItemToToc :: HeaderLevel -> d -> Markdown+  docItemToToc _ _ = ""++  -- | All doc items which this doc item refers to.+  --+  -- They will automatically be put to definitions as soon as given doc item+  -- is detected.+  docItemDependencies :: d -> [SomeDocDefinitionItem]+  docItemDependencies _ = []++  -- | This function accepts doc items put under the same section in the order+  -- in which they appeared in the contract and returns their new desired order.+  -- It's also fine to use this function for filtering or merging doc items.+  --+  -- Default implementation+  -- * leaves inlined items as is;+  -- * for items put to definitions, lexicographically sorts them by their id.+  docItemsOrder :: [d] -> [d]+  docItemsOrder = \case+    [] -> []+    docItems@(someDocItem : _) -> case docItemRef someDocItem of+      DocItemNoRef -> docItems+      DocItemRef _ ->+        docItemsOrderById docItems+      DocItemRefInlined _ ->+        docItems++-- | Generate 'DToc' entry anchor from 'docItemRef'.+mdTocFromRef :: (DocItem d, DocItemReferenced d ~ 'True) => HeaderLevel -> Markdown -> d -> Markdown+mdTocFromRef lvl text d =+  mdToc lvl text (toAnchor $ docItemRef d)++-- | Get doc item position at term-level.+docItemPosition :: forall d. DocItem d => DocItemPos+docItemPosition = DocItemPos (docItemPos @d, show (typeRep $ Proxy @d))++-- | Render an item into Markdown block with all required adjustments.+docItemToMarkdownFull :: DocItem d => HeaderLevel -> d -> Markdown+docItemToMarkdownFull l d =+  manchor <> docItemToMarkdown l d <> "\n\n"+  where+    manchor = case docItemRef d of+      DocItemRef docItemId -> mdAnchor docItemId+      DocItemRefInlined docItemId -> mdAnchor docItemId+      DocItemNoRef -> ""++-- | Order 'DocItemRef' items by their 'DocItemId'.+docItemsOrderById+  :: forall d. (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)+  => [d] -> [d]+docItemsOrderById docItems =+  let getDocItemId :: d -> DocItemId+      getDocItemId d = case docItemRef d of { DocItemRef di -> di }+  in sortOn getDocItemId docItems++-- | Make a reference to doc item in definitions.+docDefinitionRef+  :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)+  => Markdown -> d -> Markdown+docDefinitionRef refText d = case docItemRef d of+  DocItemRef docItemId -> mdLocalRef refText docItemId++-- | Some unique identifier of a doc item.+--+-- All doc items which should be refer-able need to have this identifier.+newtype DocItemId = DocItemId Text+  deriving stock (Eq, Ord, Show)+  deriving newtype (ToAnchor)++-- | Position of all doc items of some type.+newtype DocItemPos = DocItemPos (Natural, Text)+  deriving stock (Eq, Ord, Show)++instance Buildable DocItemPos where+  build (DocItemPos (a, _)) = build a++-- | Where do we place given doc item.+data DocItemPlacementKind+  = DocItemInlined+    -- ^ Placed in the document content itself.+  | DocItemInDefinitions+    -- ^ Placed in dedicated definitions section; can later be referenced.++-- | Type-level check whether or not a doc item can be referenced.+type DocItemReferencedKind = Bool++data DocItemRef (p :: DocItemPlacementKind) (r :: DocItemReferencedKind) where+  DocItemRef        :: DocItemId -> DocItemRef 'DocItemInDefinitions 'True+  DocItemRefInlined :: DocItemId -> DocItemRef 'DocItemInlined 'True+  DocItemNoRef      :: DocItemRef 'DocItemInlined 'False++instance ToAnchor (DocItemRef d 'True) where+  toAnchor (DocItemRef ref) = toAnchor ref+  toAnchor (DocItemRefInlined ref) = toAnchor ref++-- | How to render section name.+data DocSectionNameStyle+  = DocSectionNameBig+    -- ^ Suitable for block name.+  | DocSectionNameSmall+    -- ^ Suitable for subsection title within block.++-- | Hides some documentation item.+data SomeDocItem where+  SomeDocItem :: DocItem d => d -> SomeDocItem++-- NFData instance is needed for benchmarks and we want to avoid requiring users+-- to implement NFData instance for every single DocItem and they should not+-- affect the performance anyway.+instance NFData SomeDocItem where+  rnf (SomeDocItem _) = ()++-- | Hides some documentation item which is put to "definitions" section.+data SomeDocDefinitionItem where+  SomeDocDefinitionItem+    :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)+    => d -> SomeDocDefinitionItem++instance Eq SomeDocDefinitionItem where+  SomeDocDefinitionItem d1 == SomeDocDefinitionItem d2 =+    d1 `eqExt` d2+instance Ord SomeDocDefinitionItem where+  SomeDocDefinitionItem d1 `compare` SomeDocDefinitionItem d2 =+    d1 `compareExt` d2++-- | To automatically derive @instance Show Morley.Michelson.Typed.Instr@ later.+instance Show SomeDocItem where+  show _ = "<doc item>"++type family DOrd d :: Constraint where+  DOrd d = If (DocItemPlacement d == 'DocItemInDefinitions)+             (Ord d) (() :: Constraint)++-- | A doc item which we store, along with related information.+data DocElem d = DocElem+  { deItem :: d+    -- ^ Doc item itself.+  , deSub :: Maybe SubDoc+    -- ^ Subdocumentation, if given item is a group.+  }++-- | Whether given 'DocElem' is atomic.+--+-- Normally, atomic 'DocElem's are ones appearing in @DOC_ITEM@ instruction,+-- and non-atomic ones are put to @DocGroup@.+deIsAtomic :: DocElem d -> Bool+deIsAtomic = isNothing . deSub++-- | Several doc items of the same type.+data DocSection = forall d. DocItem d => DocSection (NonEmpty $ DocElem d)++instance Show DocSection where+  show (DocSection (ds :: NonEmpty (DocElem d))) =+    "Doc items section: " <> show (typeRep $ Proxy @d) <>+    " / " <> show (length ds) <> " item(s)"++unsafeAppendDocSection+  :: HasCallStack+  => DocSection -> DocSection -> DocSection+unsafeAppendDocSection (DocSection ls) (DocSection rs) =+  DocSection $ unsafeAppendDocSectionImpl ls (toList rs)++unsafeAppendDocSectionImpl+  :: forall d1 d2.+     (Typeable d1, Typeable d2, HasCallStack)+  => NonEmpty d1 -> [d2] -> NonEmpty d1+unsafeAppendDocSectionImpl (l :| ls) rs =+  let rs' = rs <&> \r -> cast r ?: onTypeMismatch+  in l :| ls <> rs'+  where+    onTypeMismatch =+      error $ "appending doc sections for doc items of different types:"+              +|| typeRep (Proxy @d1) ||+ " and " +|| typeRep (Proxy @d2) ||+ ""++-- | A map from positions to document elements.+--+-- This form effeciently keeps documentation for its incremental building.+-- Doc items here appear close to how they were located in the contract;+-- for instance, 'docItemsOrder' is not yet applied at this stage.+-- You only can be sure that items within each group are splitted across+-- sections correctly.+type DocBlock = Map DocItemPos DocSection++-- | Render a documentation block.+docBlockToMarkdown :: HeaderLevel -> DocBlock -> Markdown+docBlockToMarkdown hl block =+  mconcat $ M.elems block <&> \(DocSection items@((_ :: DocElem di) :| _)) ->+    let sectionName = docItemSectionName @di+        sectionNameStyle = docItemSectionNameStyle @di+        (sectionNameFull, headerLevelDelta) =+          case sectionName of+            Nothing -> ("", id)+            Just sn ->+              let sn' = build sn+              in case sectionNameStyle of+                  DocSectionNameBig ->+                    (mdHeader hl sn', nextHeaderLevel)+                  DocSectionNameSmall ->+                    ( mdSubsectionTitle sn' <> "\n"+                    , error $ "Using headers is not allowed when section name is set small\n\+                              \Make sure docItemToMarkdown @" <> show (typeRep $ Proxy @di) <>+                              "does not use its 'header level' argument"+                    )+        sectionDesc = docItemSectionDescription @di+        sectionDescFull =+          case sectionDesc of+            Nothing -> ""+            Just sd -> sd <> "\n\n"+        resItems = docItemsOrder $ map deItem (toList items)+        content =+          mconcat $ resItems <&> \di ->+            docItemToMarkdownFull (headerLevelDelta hl) di+        anchor = maybe "" mdAnchor (docItemSectionAnchor @di)+    in if null resItems+       then ""+       else anchor <> sectionNameFull <> sectionDescFull <> content++-- | Anchor for all the sections (referring them as to headers may cause+-- colissions).+newtype SectionAnchor = SectionAnchor+  { _unSectionAnchor :: Text+    -- ^ Section name+  }++instance ToAnchor SectionAnchor where+  toAnchor (SectionAnchor t) = Anchor ("section-" <> t)++-- | Make an anchor that is to be attached to the given section.+docItemSectionAnchor :: forall di. DocItem di => Maybe SectionAnchor+docItemSectionAnchor = do+  case docItemSectionNameStyle @di of+    DocSectionNameBig -> pass+    DocSectionNameSmall -> mzero+  SectionAnchor <$> docItemSectionName @di++-- | Reference to the given section.+--+-- Will return @Nothing@ if sections of given doc item type are not+-- assumed to be referred outside.+docItemSectionRef :: forall di. DocItem di => Maybe Markdown+docItemSectionRef = do+  name <- docItemSectionName @di+  anchor <- docItemSectionAnchor @di+  return $ mdLocalRef (build name) anchor++-- | Render a part of table of contents from 'DocBlock'.+docBlockToToc :: HeaderLevel -> DocBlock -> Markdown+docBlockToToc hl block =+  mconcat $ M.elems block <&> \(DocSection items@((_ :: DocElem di) :| _)) ->+    let sectionName = docItemSectionName @di+        (sectionNameFull, headerLevelDelta) =+          case (sectionName, docItemSectionAnchor @di) of+            (_, Nothing) -> ("", id)+            (Nothing, _) -> ("", id)+            (Just "Table of contents", _) -> ("", id)+            (Just sn, Just anchor) ->+              (mdToc hl (build sn) anchor, nextHeaderLevel)+        resItems = docItemsOrder $ map deItem (toList items)+        content =+          mconcat $ resItems <&> docItemToToc (headerLevelDelta hl)+    in if null resItems+       then ""+       else sectionNameFull <> content++-- | Lift a doc item to a block, be it atomic doc item or grouping one.+docItemToBlockGeneral :: forall di. DocItem di => di -> Maybe SubDoc -> DocBlock+docItemToBlockGeneral di msub =+  one ( docItemPosition @di+      , DocSection $ one (DocElem di msub)+      )++-- | Lift an atomic doc item to a block.+docItemToBlock :: forall di. DocItem di => di -> DocBlock+docItemToBlock di = docItemToBlockGeneral di Nothing++-- | Find all doc items of the given type.+lookupDocBlockSection :: forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)+lookupDocBlockSection block = do+  DocSection (ds :: NonEmpty (DocElem d')) <- M.lookup (docItemPosition @d) block+  case eqT @d @d' of+    Nothing -> error $ "Invalid DocBlock: item of type " +|| typeRep (Proxy @d) ||+ " \+                       \under position " +| docItemPosition @d |+ ""+    Just Refl -> pure $ map deItem ds++-- | A part of documentation to be grouped. Essentially incapsulates 'DocBlock'.++-- One day we may need to define 'Eq' instance for this thing, and probably+-- we can consider any two entities equal for efficiency.+newtype SubDoc = SubDoc DocBlock++-- | Render documentation for 'SubDoc'.+subDocToMarkdown :: HeaderLevel -> SubDoc -> Markdown+subDocToMarkdown hl (SubDoc d) = docBlockToMarkdown hl d++-- | Render documentation for 'SubDoc'.+subDocToToc :: HeaderLevel -> SubDoc -> Markdown+subDocToToc hl (SubDoc d) = docBlockToToc hl d++-- | Keeps documentation gathered for some piece of contract code.+--+-- Used for building documentation of a contract.+data ContractDoc = ContractDoc+  { cdContents :: DocBlock+    -- ^ All inlined doc items.+  , cdDefinitions :: DocBlock+    -- ^ Definitions used in document.+    --+    -- Usually you put some large and repetitive descriptions here.+    -- This differs from the document content in that+    -- it contains sections which are always at top-level,+    -- disregard the nesting.+    --+    -- All doc items which define @docItemId@ method go here, and only they.+  , cdDefinitionsSet :: Set SomeDocDefinitionItem+    -- ^ We remember all already declared entries to avoid cyclic dependencies+    -- in documentation items discovery.+  , cdDefinitionIds :: Set DocItemId+    -- ^ We remember all already used identifiers.+    -- (Documentation naturally should not declare multiple items with+    -- the same identifier because that would make references to the respective+    -- anchors ambiguous).+  }++makeLensesWith postfixLFields ''ContractDoc++-- | Contract documentation assembly primarily relies on this instance.+instance Semigroup ContractDoc where+  cd1 <> cd2 = ContractDoc+    { cdContents =+        M.merge+          M.preserveMissing M.preserveMissing+          (M.zipWithMatched $ \_k l r -> unsafeAppendDocSection l r)+          (cdContents cd1) (cdContents cd2)+    , cdDefinitions =+        M.merge+          M.preserveMissing M.preserveMissing+          (M.zipWithMatched $ \_k (DocSection ls) (DocSection rs) ->+             let removeDups = filter $ not . (`isDefinedIn` cdDefinitionIds cd1) . deItem+             in DocSection $ unsafeAppendDocSectionImpl ls (removeDups $ toList rs)+          )+          (cdDefinitions cd1) (cdDefinitions cd2)+    , cdDefinitionsSet =+        S.union (cdDefinitionsSet cd1) (cdDefinitionsSet cd2)+    , cdDefinitionIds =+        S.union (cdDefinitionIds cd1) (cdDefinitionIds cd2)+    }+    where+      isDefinedIn :: DocItem d => d -> Set DocItemId -> Bool+      isDefinedIn di defs =+        case docItemRef di of+          DocItemNoRef -> False+          DocItemRef docItemId -> docItemId `S.member` defs+          DocItemRefInlined docItemId -> docItemId `S.member` defs++instance Monoid ContractDoc where+  mempty = ContractDoc+    { cdContents = M.empty+    , cdDefinitions = M.empty+    , cdDefinitionsSet = S.empty+    , cdDefinitionIds = S.empty+    }++-- | Render given contract documentation to markdown document.+contractDocToMarkdown :: ContractDoc -> LText+contractDocToMarkdown ContractDoc{..} =+  let+    contents =+      docBlockToMarkdown (HeaderLevel 1) cdContents |+ "\n\n"+    definitions+      | null cdDefinitions = ""+      | otherwise =+        "# Definitions\n\n" +| docBlockToMarkdown (HeaderLevel 2) cdDefinitions+    total = fmt (contents <> definitions)+  in LT.strip total <> "\n"++contractDocToToc :: ContractDoc -> Markdown+contractDocToToc ContractDoc{..} =+  let+    contents =+      docBlockToToc (HeaderLevel 1) cdContents++    definitions+      | null cdDefinitions = ""+      | otherwise = "\n**[Definitions](#definitions)**\n\n"+          +| docBlockToToc (HeaderLevel 2) cdDefinitions+  in contents <> definitions <> "\n"++-- | A function which groups a piece of doc under one doc item.+type DocGrouping = SubDoc -> SomeDocItem++instance Show DocGrouping where+  show _ = "<doc grouping>"++-- | Apply given grouping to documentation being built.+docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc+docGroupContent grouping doc =+  doc+  { cdContents =+      let sub = SubDoc (cdContents doc)+      in case grouping sub of+           SomeDocItem d -> docItemToBlockGeneral d (Just sub)+  }++-- | Everything that contains doc items that can be used to render the+-- documentation.+class ContainsDoc a where+  -- | Gather documentation.+  --+  -- Calling this method directly is discouraged in prod, see 'buildDoc' instead.+  -- Using this method in tests is fine though.+  buildDocUnfinalized :: a -> ContractDoc++-- | Some contract languages may support documentation update.+class ContainsDoc a => ContainsUpdateableDoc a where+  -- | Modify all documentation items recursively.+  modifyDocEntirely :: (SomeDocItem -> SomeDocItem) -> a -> a++-- | Often there is some tuning recommended prior to rendering the contract,+-- like attaching git revision info; this type designates that those last changes+-- were applied.+--+-- For example, at Michelson level you may want to use 'attachDocCommons'.+--+-- If you want no special tuning (e.g. for tests), say that explicitly with+-- 'finalizedAsIs'.+newtype WithFinalizedDoc a = WithFinalizedDoc (Identity a)+  deriving newtype (Functor, Applicative, Monad)++-- | Mark the code with doc as finalized without any changes.+finalizedAsIs :: a -> WithFinalizedDoc a+finalizedAsIs = WithFinalizedDoc . Identity++-- | Gather documenation.+buildDoc :: ContainsDoc a => WithFinalizedDoc a -> ContractDoc+buildDoc (WithFinalizedDoc (Identity a)) = buildDocUnfinalized a++-- | Construct and format documentation in textual form.+buildMarkdownDoc :: ContainsDoc a => WithFinalizedDoc a -> LText+buildMarkdownDoc = contractDocToMarkdown . buildDoc++-- | Recursevly traverse doc items and modify those that match given type.+--+-- If mapper returns 'Nothing', doc item will remain unmodified.+modifyDoc+  :: (ContainsUpdateableDoc a, DocItem i1, DocItem i2)+  => (i1 -> Maybe i2) -> a -> a+modifyDoc mapper = modifyDocEntirely untypedMapper+  where+  untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do+    di' <- cast di+    newDi <- mapper di'+    return (SomeDocItem newDi)++----------------------------------------------------------------------------+-- Basic doc items+----------------------------------------------------------------------------++-- | General (meta-)information about the contract such as git+-- revision, contract's authors, etc. Should be relatively short (not+-- several pages) because it is put somewhere close to the beginning of+-- documentation.+newtype DGeneralInfoSection = DGeneralInfoSection SubDoc++instance DocItem DGeneralInfoSection where+  docItemPos = 1+  docItemSectionName = Nothing+  docItemToMarkdown lvl (DGeneralInfoSection subDoc) =+    subDocToMarkdown lvl subDoc+  docItemToToc lvl (DGeneralInfoSection subDoc) =+    subDocToToc lvl subDoc++-- | Give a name to document block.+data DName = DName Text SubDoc++instance DocItem DName where+  docItemPos = 3+  docItemSectionName = Nothing+  docItemToMarkdown lvl (DName name doc) =+    mdHeader lvl (build name) <>+    subDocToMarkdown (nextHeaderLevel lvl) doc+  docItemToToc lvl (DName _ doc) =+    subDocToToc (nextHeaderLevel lvl) doc++-- | This instance allows writing something like @docGroup \"Title\"@,+-- this makes sense as the most primitive and basic use case for doc groups+-- is putting a section under name.+instance (di ~ DName) => IsString (SubDoc -> di) where+  fromString = DName . fromString++-- | Description of something.+data DDescription = DDescription Markdown++instance DocItem DDescription where+  docItemPos = 10+  docItemSectionName = Nothing+  docItemToMarkdown _ (DDescription txt) = build txt++-- | Specify version if given contract.+data DGitRevisionInfo = DGitRevisionInfo+  { dgrRepoSettings :: GitRepoSettings+  , dgrCommitSha :: Text+  , dgrCommitDate :: Text+  }++data DGitRevision+  = DGitRevisionKnown DGitRevisionInfo+  | DGitRevisionUnknown++-- | Repository settings for 'DGitRevision'.+newtype GitRepoSettings = GitRepoSettings+  { grsMkGitRevision :: Text -> Text+    -- ^ By commit sha make up a url to that commit in remote repository.++    -- @martoon: I tried to get remote URL automatically, but failed to+    -- find a way. Even "git-link" in emacs performs complex parsing.+  }++morleyRepoSettings :: GitRepoSettings+morleyRepoSettings = GitRepoSettings $ \commit ->+  "https://gitlab.com/morley-framework/morley/-/tree/" <> commit++-- | Make 'DGitRevision'.+--+-- >>> :t $mkDGitRevision+-- ...+-- ... :: GitRepoSettings -> DGitRevision+mkDGitRevision :: TH.ExpQ+mkDGitRevision = [e| \dgrRepoSettings ->+  maybe DGitRevisionUnknown DGitRevisionKnown $+    -- TH does not like do-blocks+    $(pickInfo gitHash "MORLEY_DOC_GIT_COMMIT_SHA") >>= \dgrCommitSha ->+    $(pickInfo gitCommitDate "MORLEY_DOC_GIT_COMMIT_DATE") >>= \dgrCommitDate ->+    return DGitRevisionInfo{..}+  |]+  where+    pickInfo a b = TH.lift =<< pickInfo' a b++    pickInfo' :: TH.ExpQ -> String -> TH.Q (Maybe String)+    pickInfo' askGit envKey =+      liftIO (lookupEnv envKey) >>= \case+        Just "UNSPECIFIED" -> return Nothing+        Just envValue -> return $ Just envValue+        Nothing -> askGit >>= \case+          -- Looks like with GitRev package we can't do anything better+          TH.LitE (TH.StringL "UNKNOWN") -> do+            TH.reportWarning $+              "Contract autodoc: \+              \Not including git repository info because it cannot be deduced. \+              \Either provide repository environment, or pass '" <> envKey <> "' \+              \environmental variable."+            return Nothing+          TH.LitE (TH.StringL str) -> return (Just str)+          value -> error $ "Unknown value returned by git: " <> show value++instance DocItem DGitRevision where+  docItemPos = 2+  docItemSectionName = Nothing+  docItemToMarkdown _ (DGitRevisionKnown DGitRevisionInfo{..}) =+    mconcat+    [ mdSubsection "Code revision" $+        let link = grsMkGitRevision dgrRepoSettings dgrCommitSha+        in mconcat+           [ mdRef (build $ T.take 7 dgrCommitSha) (build link)+           , " "+           , mdItalic $ "(" <> build dgrCommitDate <> ")"+           ]+    ]+  docItemToMarkdown _ DGitRevisionUnknown = ""++-- | Comment in the doc (mostly used for licenses)+data DComment = DComment Text++instance DocItem DComment where+  docItemPos = 0+  docItemSectionName = Nothing+  docItemToMarkdown _ (DComment commentText) =+    "<!---\n" +| commentText |+ "\n-->"++-- | @Table of contents@ to be inserted into the doc in an ad-hoc way.+--+-- It is not intended to be inserted manually. See 'attachToc' to understand+-- how this works.+--+data DToc = DToc Markdown++instance DocItem DToc where+  docItemPos = 11+  docItemSectionName = Just "Table of contents"+  docItemToMarkdown _ (DToc toc) = toc++-- | A hand-made anchor.+data DAnchor = DAnchor Anchor++instance DocItem DAnchor where+  docItemPos = 4+  docItemSectionName = Nothing+  docItemToMarkdown _ (DAnchor a) = mdAnchor a++data DConversionInfo = DConversionInfo++-- TODO: we should also recommend using morley-client when+-- it'll become good enough+instance DocItem DConversionInfo where+  docItemPos = 15+  docItemSectionName = Just "Haskell ⇄ Michelson conversion"+  docItemToMarkdown _ _ =+    "This smart contract is developed in Haskell using the \+    \[Morley framework](https://gitlab.com/morley-framework/morley). \+    \Documentation mentions Haskell types that can be used for interaction with \+    \this contract from Haskell, but for each Haskell type we also mention its \+    \Michelson representation to make interactions outside of Haskell possible.\n\n\+    \There are multiple ways to interact with this contract:\n\n\+    \* Use this contract in your Haskell application, thus all operation submissions \+    \should be handled separately, e.g. via calling `tezos-client`, which will communicate \+    \with the `tezos-node`. In order to be able to call `tezos-client` you'll need to be able \+    \to construct Michelson values from Haskell.\n\n\+    \  The easiest way to do that is to serialize Haskell value using `lPackValue` function \+    \from [`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs) \+    \module, encode resulting bytestring to hexadecimal representation using `encodeHex` function. \+    \Resulting hexadecimal encoded bytes sequence can be decoded back to Michelson value via \+    \`tezos-client unpack michelson data`.\n\n\+    \  Reverse conversion from Michelson value to the \+    \Haskell value can be done by serializing Michelson value using `tezos-client hash data` command, \+    \resulting `Raw packed data` should be decoded from the hexadecimal representation using `decodeHex` \+    \and deserialized to the Haskell value via `lUnpackValue` function from \+    \[`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs).\n\n\+    \* Construct values for this contract directly on Michelson level using types provided in the \+    \documentation."++-- | Attach information about git revision.+-- The code must contain git revision placeholder.+--+-- We do this in two stages because we use TH to deduce git revision information+-- at compile time, and this is best to be done in the very end to recompile+-- less modules.+attachGitInfo :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a+attachGitInfo gitRev = finalizedAsIs ... modifyDoc $ \case+  DGitRevisionUnknown -> Just gitRev+  _ -> Nothing++attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a+attachToc toc = finalizedAsIs ... modifyDoc $ \case+  DToc "" -> Just toc+  _ -> Nothing++-- | Attach common information that is available only in the end.+attachDocCommons :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a+attachDocCommons gitRev code = do+  let toc = DToc $ contractDocToToc (buildDocUnfinalized code)+  pure code+    >>= attachGitInfo gitRev+    >>= attachToc toc

+ src/Morley/Michelson/ErrorPos.hs view

@@ -0,0 +1,94 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.ErrorPos+  ( mkPos+  , unsafeMkPos+  , Pos (..)+  , SrcPos (..)+  , srcPos+  , InstrCallStack (..)+  , LetCallStack+  , LetName (..)+  ) where++import Data.Aeson.TH (deriveJSON)+import Data.Data (Data(..))+import Data.Default (Default(..))+import qualified Data.Text as T+import Fmt (Buildable(..))+import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended, renderAnyBuildable)+import Text.PrettyPrint.Leijen.Text+import qualified Unsafe (fromIntegral)+++import Morley.Util.Aeson+++newtype Pos = Pos {unPos :: Word}+  deriving stock (Eq, Ord, Show, Generic, Data)++instance NFData Pos++unsafeMkPos :: Int -> Pos+unsafeMkPos x+  | x < 0     = error $ "negative pos: " <> show x+  | otherwise = Pos $ Unsafe.fromIntegral @Int @Word x++mkPos :: Int -> Maybe Pos+mkPos x+  | x < 0     = Nothing+  | otherwise = Just $ Pos $ Unsafe.fromIntegral @Int @Word x++data SrcPos =+  SrcPos+  { srcLine :: Pos+  , srcCol :: Pos+  } deriving stock (Eq, Ord, Show, Generic, Data)++instance Buildable SrcPos where+  build (SrcPos (Pos l) (Pos c)) = build l <> ":" <> build c++instance NFData SrcPos++srcPos :: Word -> Word -> SrcPos+srcPos x y = SrcPos (Pos x) (Pos y)++newtype LetName = LetName T.Text+  deriving stock (Eq, Ord, Show, Data, Generic)+  deriving newtype Buildable++instance NFData LetName++type LetCallStack = [LetName]+data InstrCallStack = InstrCallStack+  { icsCallStack :: LetCallStack+  , icsSrcPos    :: SrcPos+  } deriving stock (Eq, Ord, Show, Generic, Data)++instance RenderDoc InstrCallStack where+  renderDoc _ InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos row) (Pos col)} =+    "Error occurred on line" <+> (renderAnyBuildable (row + 1)) <+> "char" <+> (renderAnyBuildable (col + 1))+    <> case icsCallStack of+         [] -> "."+         _ -> " inside these let defenitions:" <+> (list $ fmap (text . show) icsCallStack) <> "."++instance Buildable InstrCallStack where+  build = buildRenderDocExtended++instance NFData InstrCallStack++instance Default Pos where+  def = Pos 0++instance Default SrcPos where+  def = SrcPos def def++instance Default InstrCallStack where+  def = InstrCallStack def def++deriveJSON morleyAesonOptions ''Pos+deriveJSON morleyAesonOptions ''SrcPos+deriveJSON morleyAesonOptions ''LetName+deriveJSON morleyAesonOptions ''InstrCallStack

+ src/Morley/Michelson/FailPattern.hs view

@@ -0,0 +1,126 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- NOTE this pragmas.+-- We disable some wargnings for the sake of speed up.+-- Write code with care.+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}++-- | Typical usages of FAILWITH instruction.++module Morley.Michelson.FailPattern+  ( TypicalFailWith+  , typicalFailWithTag+  , isTypicalFailWith+  , modifyTypicalFailWith+  ) where++import Data.Singletons (withSingI)++import Morley.Michelson.Text (MText)+import Morley.Michelson.Typed++-- | This data type captures typical ways to use `FAILWITH` instruction.+-- Each constructor corresponds to a usage pattern.+data TypicalFailWith+  = FailWithString MText+  -- ^ Push a constant string and fail with it.+  | FailWithConstantPair MText (SomeConstrainedValue ConstantScope)+  -- ^ Push a constant pair where the first item is a string and the+  -- second one is an arbitrary constant. Fail afterwards.+  | FailWithStackValue MText+  -- ^ Push a constant string and apply the 'PAIR' instruction, then fail.++-- | Extract error tag out of 'TypicalFailWith'.+typicalFailWithTag :: TypicalFailWith -> MText+typicalFailWithTag = \case+  FailWithString str -> str+  FailWithConstantPair str _ -> str+  FailWithStackValue str -> str++-- | Check whether given instruction ends with a typical 'FAILWITH'+-- usage. It does not recursively check instructions that can be+-- passed to other instructions.+--+-- The instruction MUST be linearized to the left (see 'linearizeLeft').+isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith+isTypicalFailWith = \case+  Seq i1 FAILWITH -> isTypicalPreFailWith i1+  _ -> Nothing+  where+    isTypicalPreFailWith ::+      Instr inp (a ': out) -> Maybe TypicalFailWith+    isTypicalPreFailWith =+      \case+        PUSH v -> isTypicalErrorConstant v+        Seq _ (PUSH v) -> isTypicalErrorConstant v++        Seq (PUSH v) PAIR -> FailWithStackValue <$> isStringValue v+        Seq (Seq _ (PUSH v)) PAIR -> FailWithStackValue <$> isStringValue v++        _ -> Nothing++isTypicalErrorConstant ::+  forall t. ConstantScope t => Value t -> Maybe TypicalFailWith+isTypicalErrorConstant v+  | Just str <- isStringValue v = Just (FailWithString str)+  | VPair (VString str, secondItem) <- v =+      -- We need to pattern match to deduce `singI` for second item of the pair.+      case sing @t of+        STPair l r -> withSingI l $ withSingI r $ Just (FailWithConstantPair str (SomeConstrainedValue secondItem))+  | otherwise = Nothing++-- | If given instruction ends with a typical 'FAILWITH' usage, modify+-- the tag used there using given transformation function. It can+-- return any value, not necessarily a string.+modifyTypicalFailWith+  :: HasCallStack+  => (MText -> SomeConstrainedValue ConstantScope)+  -> Instr inp out+  -> Instr inp out+modifyTypicalFailWith f = modifyTypicalFailWith' . linearizeLeft+  where+    modifyTypicalFailWith' :: HasCallStack => Instr inp out -> Instr inp out+    modifyTypicalFailWith' =+      \case+        Seq i1 FAILWITH ->+          case i1 of+            PUSH v -> onPush v+            Seq i0 (PUSH v) -> Seq i0 (onPush v)++            -- It is quite hard to move the body of these very similar+            -- cases into a separate function because involved types+            -- are quite sophisticated.+            Seq (PUSH v) PAIR+              | _ :: Value a <- v+              , _ :: Instr (b ': s) ('TPair a b ': s) <- i1 ->+                case sing @('TPair a b) of+                  STPair l r -> withSingI l $ withSingI r $ case isStringValue v of+                    Just (f -> SomeConstrainedValue v') ->+                      PUSH v' `Seq` PAIR `Seq` FAILWITH+                    Nothing ->+                      PUSH v `Seq` PAIR `Seq` FAILWITH+            Seq (Seq i0 (PUSH v)) PAIR+              | _ :: Value a <- v+              , _ :: Instr s0 ('TPair a b ': s) <- i1 ->+                case sing @('TPair a b) of+                  STPair l r -> withSingI l $ withSingI r $ Seq i0 $ case isStringValue v of+                    Just (f -> SomeConstrainedValue v') ->+                      PUSH v' `Seq` PAIR `Seq` FAILWITH+                    Nothing ->+                      PUSH v `Seq` PAIR `Seq` FAILWITH++            _ -> Seq i1 FAILWITH++        i -> i++    onPush ::+      (HasCallStack, ConstantScope v) => Value v -> Instr inp out+    onPush v = case isTypicalErrorConstant v of+      Just (FailWithString (f -> SomeConstrainedValue v')) -> PUSH v' `Seq` FAILWITH+      Just (FailWithConstantPair (f -> SomeConstrainedValue v') (SomeConstrainedValue arg)) ->+        PUSH (VPair (v', arg)) `Seq` FAILWITH+      Just _ -> error "Unexpected TypicalFailWith"+      Nothing -> PUSH v `Seq` FAILWITH

+ src/Morley/Michelson/Interpret.hs view

@@ -0,0 +1,942 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, containing function to interpret Michelson+-- instructions against given context and input stack.+module Morley.Michelson.Interpret+  ( ContractEnv (..)+  , InterpreterState (..)+  , MichelsonFailed (..)+  , MichelsonFailureWithStack (..)+  , RemainingSteps (..)+  , SomeItStack (..)+  , MorleyLogs (..)+  , buildMorleyLogs+  , MorleyLogsBuilder (..)++  , interpret+  , interpretInstr+  , interpretInstrAnnotated+  , ContractReturn++  , mkInitStack+  , fromFinalStack+  , InterpretError (..)+  , InterpretResult (..)+  , EvalM+  , InterpreterStateMonad (..)+  , StkEl (..)+  , starNotesStkEl+  , InstrRunner+  , runInstr+  , runInstrNoGas+  , runUnpack++    -- * Internals+  , initInterpreterState+  , handleContractReturn+  , runInstrImpl+  , assignBigMapIds++    -- * Prisms+  , _MorleyLogs+  ) where++import Prelude hiding (EQ, GT, LT)++import Control.Lens (makeLensesFor, makePrisms, traverseOf, (<<+=))+import Control.Monad.Except (MonadError, throwError)+import Control.Monad.RWS.Strict (RWS, RWST, runRWS)+import Control.Monad.Writer (MonadWriter, WriterT, tell)+import Data.Default (Default(..))+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Vinyl (Rec(..), (<+>))+import Data.Vinyl.Recursive (rmap)+import Fmt (Buildable(build), blockListF, pretty, prettyLn)+import qualified Unsafe (fromIntegral)++import Morley.Michelson.ErrorPos (InstrCallStack(..))+import Morley.Michelson.Interpret.Pack (packValue')+import Morley.Michelson.Interpret.Unpack (UnpackError, unpackValue')+import Morley.Michelson.Runtime.GState+import Morley.Michelson.TypeCheck (SomeParamType(..), TcOriginatedContracts, matchTypes)+import Morley.Michelson.Typed hiding (Branch(..))+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Operation+  (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash)+import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped.Annotation (annQ)+import Morley.Tezos.Address (Address(..), GlobalCounter(..))+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, keccak, sha256, sha3, sha512)+import Morley.Tezos.Crypto.BLS12381 (checkPairing)+import Morley.Util.Peano (LongerThan, Peano)+import Morley.Util.PeanoNatural (PeanoNatural(..))+import Morley.Util.Sing (eqParamSing)+import Morley.Util.TH+import Morley.Util.Type+import Morley.Util.Typeable++-- | Morley logs appearing as interpreter result.+newtype MorleyLogs = MorleyLogs { unMorleyLogs :: [Text] }+  deriving stock (Show, Eq, Generic)+  deriving newtype (Semigroup, Monoid)+  deriving anyclass (NFData)++instance Buildable MorleyLogs where+  build = blockListF . unMorleyLogs++-- | Morley logs accumulator, for incremental building.+newtype MorleyLogsBuilder = MorleyLogsBuilder (Endo [Text])+  deriving stock (Generic)+  deriving newtype (Default, Semigroup, Monoid)++buildMorleyLogs :: MorleyLogsBuilder -> MorleyLogs+buildMorleyLogs (MorleyLogsBuilder builder) =+  MorleyLogs $ appEndo builder []++instance One MorleyLogsBuilder where+  type OneItem MorleyLogsBuilder = Text+  one log = MorleyLogsBuilder $ Endo (log :)++newtype RemainingSteps = RemainingSteps Word64+  deriving stock (Show, Generic)+  deriving newtype (Eq, Ord, Buildable, Num)++instance NFData RemainingSteps++data InterpreterState = InterpreterState+  { isRemainingSteps :: RemainingSteps+  , isGlobalCounter :: GlobalCounter+  , isBigMapCounter :: BigMapCounter+  } deriving stock (Show, Generic)++instance NFData InterpreterState+makeLensesFor+  [ ("isBigMapCounter", "isBigMapCounterL")+  ]+  ''InterpreterState++makePrisms ''MorleyLogs++data StkEl t = StkEl+  { seValue :: Value t+  , seVarAnn :: U.VarAnn+  , seNotes :: Notes t+  } deriving stock (Eq, Show)++makeLensesFor+  [ ("seValue", "seValueL")+  , ("seVarAnn", "seVarAnnL")+  ]+  ''StkEl++starNotesStkEl :: forall t. Value t -> StkEl t+starNotesStkEl v = StkEl v U.noAnn $ withValueTypeSanity v $ starNotes @t++-- | Environment for contract execution.+data ContractEnv = ContractEnv+  { ceNow :: Timestamp+  -- ^ Timestamp returned by the 'NOW' instruction.+  , ceMaxSteps :: RemainingSteps+  -- ^ Number of steps after which execution unconditionally terminates.+  , ceBalance :: Mutez+  -- ^ Current amount of mutez of the current contract.+  , ceContracts :: TcOriginatedContracts+  -- ^ Mapping from existing contracts' addresses to their executable+  -- representation.+  , ceSelf :: Address+  -- ^ Address of the interpreted contract.+  , ceSource :: Address+  -- ^ The contract that initiated the current transaction.+  , ceSender :: Address+  -- ^ The contract that initiated the current internal transaction.+  , ceAmount :: Mutez+  -- ^ Amount of the current transaction.+  , ceVotingPowers :: VotingPowers+  -- ^ Distribution of voting power.+  , ceChainId :: ChainId+  -- ^ Identifier of the current chain.+  , ceOperationHash :: Maybe OperationHash+  -- ^ Hash of the currently executed operation, required for+  -- correct contract address computation in @CREATE_CONTRACT@ instruction.+  , ceLevel :: Natural+  -- ^ Number of blocks before the given one in the chain+  , ceInstrCallStack :: InstrCallStack+  -- ^ Current source position information+  }++-- | Represents @[FAILED]@ state of a Michelson program. Contains+-- value that was on top of the stack when @FAILWITH@ was called.+data MichelsonFailed where+  MichelsonFailedWith :: (SingI t, ConstantScope t) => T.Value t -> MichelsonFailed+  MichelsonArithError+    :: (Typeable n, Typeable m, Typeable instr)+    => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed+  MichelsonGasExhaustion :: MichelsonFailed+  MichelsonFailedTestAssert :: Text -> MichelsonFailed++deriving stock instance Show MichelsonFailed++instance Eq MichelsonFailed where+  MichelsonFailedWith v1 == MichelsonFailedWith v2 = v1 `eqParamSing` v2+  MichelsonFailedWith _ == _ = False+  MichelsonArithError ae1 == MichelsonArithError ae2 = ae1 `eqParam2` ae2+  MichelsonArithError _ == _ = False+  MichelsonGasExhaustion == MichelsonGasExhaustion = True+  MichelsonGasExhaustion == _ = False+  MichelsonFailedTestAssert t1 == MichelsonFailedTestAssert t2 = t1 == t2+  MichelsonFailedTestAssert _ == _ = False++instance Buildable MichelsonFailed where+  build =+    \case+      MichelsonFailedWith v ->+        "Reached FAILWITH instruction with " <> build v+      MichelsonArithError v -> build v+      MichelsonGasExhaustion ->+        "Gas limit exceeded on contract execution"+      MichelsonFailedTestAssert t -> build t++-- | Carries a 'MichelsonFailed' error and the 'InstrCallStack' at which it was raised+data MichelsonFailureWithStack = MichelsonFailureWithStack+  { mfwsFailed :: MichelsonFailed+  , mfwsInstrCallStack :: InstrCallStack+  } deriving stock (Show, Generic, Eq)++instance Buildable MichelsonFailureWithStack where+  build (MichelsonFailureWithStack err loc) = build err <> " at " <> build loc++newtype InterpretError = InterpretError (MichelsonFailureWithStack, MorleyLogs)+  deriving stock (Generic)++deriving stock instance Show InterpretError++instance Buildable InterpretError where+  build (InterpretError (mf, _)) = prettyLn mf++data InterpretResult where+  InterpretResult+    :: ( StorageScope st )+    => { iurOps :: [Operation]+       , iurNewStorage :: T.Value st+       , iurNewState   :: InterpreterState+       , iurMorleyLogs :: MorleyLogs+       }+    -> InterpretResult++deriving stock instance Show InterpretResult++constructIR ::+  (StorageScope st) =>+  (([Operation], Value' Instr st), InterpreterState, MorleyLogs) ->+  InterpretResult+constructIR ((ops, val), st, logs) =+  InterpretResult+  { iurOps = ops+  , iurNewStorage = val+  , iurNewState = st+  , iurMorleyLogs = logs+  }++type ContractReturn st =+  (Either MichelsonFailureWithStack ([Operation], T.Value st), (InterpreterState, MorleyLogs))++handleContractReturn+  :: (StorageScope st)+  => ContractReturn st -> Either InterpretError InterpretResult+handleContractReturn (ei, (s, l)) =+  bimap (InterpretError . (, l)) (constructIR . (, s, l)) ei++-- | Helper function to convert a record of @Value@ to @StkEl@. These will be+-- created with @starNotes@.+mapToStkEl :: Rec T.Value inp -> Rec StkEl inp+mapToStkEl = rmap starNotesStkEl++-- | Helper function to convert a record of @StkEl@ to @Value@. Any present+-- notes will be discarded.+mapToValue :: Rec StkEl inp -> Rec T.Value inp+mapToValue = rmap seValue++interpret'+  :: forall cp st arg.+     Contract cp st+  -> EntrypointCallT cp arg+  -> T.Value arg+  -> T.Value st+  -> ContractEnv+  -> InterpreterState+  -> ContractReturn st+interpret' Contract{..} epc param initSt env ist = first (fmap fromFinalStack) $+  runEvalOp+    (runInstr cCode $ mkInitStack (liftCallArg epc param) cParamNotes initSt cStoreNotes)+    env+    ist++mkInitStack+  :: T.Value param+  -> T.ParamNotes param+  -> T.Value st+  -> T.Notes st+  -> Rec StkEl (ContractInp param st)+mkInitStack param T.UnsafeParamNotes{..} st stNotes = StkEl+  (T.VPair (param, st))+  U.noAnn+  (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn [annQ|parameter|] [annQ|storage|] pnNotes stNotes)+    :& RNil++fromFinalStack :: Rec StkEl (ContractOut st) -> ([T.Operation], T.Value st)+fromFinalStack (StkEl (T.VPair (T.VList ops, st)) _ _ :& RNil) =+  (map (\(T.VOp op) -> op) ops, st)++interpret+  :: Contract cp st+  -> EntrypointCallT cp arg+  -> T.Value arg+  -> T.Value st+  -> GlobalCounter+  -> BigMapCounter+  -> ContractEnv+  -> ContractReturn st+interpret contract epc param initSt globalCounter bmCounter env =+  interpret' contract epc param initSt env (initInterpreterState globalCounter bmCounter env)++initInterpreterState :: GlobalCounter -> BigMapCounter -> ContractEnv -> InterpreterState+initInterpreterState globalCounter bmCounter env =+  InterpreterState (ceMaxSteps env) globalCounter bmCounter++-- | Interpret an instruction in vacuum, putting no extra contraints on+-- its execution.+--+-- Mostly for testing purposes.+interpretInstr+  :: ContractEnv+  -> Instr inp out+  -> Rec T.Value inp+  -> Either MichelsonFailureWithStack (Rec T.Value out)+interpretInstr = fmap mapToValue ... interpretInstrAnnotated++-- | Interpret an instruction in vacuum, putting no extra contraints on+-- its execution while preserving its annotations.+--+-- Mostly for testing purposes.+interpretInstrAnnotated+  :: ContractEnv+  -> Instr inp out+  -> Rec T.Value inp+  -> Either MichelsonFailureWithStack (Rec StkEl out)+interpretInstrAnnotated env instr inpSt =+  fst $+  runEvalOp+    (runInstr instr $ mapToStkEl inpSt)+    env+    InterpreterState+      { isRemainingSteps = 9999999999+      , isBigMapCounter = 0+      , isGlobalCounter = 0+      }++data SomeItStack where+  SomeItStack :: T.ExtInstr inp -> Rec StkEl inp -> SomeItStack++type EvalOp =+  ExceptT MichelsonFailureWithStack $+  RWS ContractEnv MorleyLogsBuilder InterpreterState++runEvalOp+  :: EvalOp a+  -> ContractEnv+  -> InterpreterState+  -> (Either MichelsonFailureWithStack a, (InterpreterState, MorleyLogs))+runEvalOp act env initSt =+  let (res, is, logs) = runRWS (runExceptT act) env initSt+  in (res, (is, buildMorleyLogs logs))++class Monad m => InterpreterStateMonad m where+  getInterpreterState :: m InterpreterState+  getInterpreterState = stateInterpreterState (\s -> (s, s))++  putInterpreterState :: InterpreterState -> m ()+  putInterpreterState s = stateInterpreterState (\_ -> ((), s))++  stateInterpreterState :: (InterpreterState -> (a, InterpreterState)) -> m a+  stateInterpreterState f = do+    s <- getInterpreterState+    let (a, s') = f s+    a <$ putInterpreterState s'++  modifyInterpreterState :: (InterpreterState -> InterpreterState) -> m ()+  modifyInterpreterState f = stateInterpreterState (((), ) . f)++instance Monad m => InterpreterStateMonad (StateT InterpreterState m) where+  stateInterpreterState = state+instance (Monad m, Monoid w) => InterpreterStateMonad (RWST r w InterpreterState m) where+  stateInterpreterState = state++instance InterpreterStateMonad m => InterpreterStateMonad (ReaderT r m) where+  stateInterpreterState = lift . stateInterpreterState+instance (InterpreterStateMonad m, Monoid w) => InterpreterStateMonad (WriterT w m) where+  stateInterpreterState = lift . stateInterpreterState+instance {-# OVERLAPPABLE #-} InterpreterStateMonad m => InterpreterStateMonad (StateT w m) where+  stateInterpreterState = lift . stateInterpreterState+instance {-# OVERLAPPABLE #-}+         (InterpreterStateMonad m, Monoid w) => InterpreterStateMonad (RWST r w s m) where+  stateInterpreterState = lift . stateInterpreterState+instance InterpreterStateMonad m => InterpreterStateMonad (ExceptT e m) where+  stateInterpreterState = lift . stateInterpreterState++type EvalM m =+  ( MonadReader ContractEnv m+  , InterpreterStateMonad m+  , MonadWriter MorleyLogsBuilder m+  , MonadError MichelsonFailureWithStack m+  )++type InstrRunner m =+  forall inp out.+     Instr inp out+  -> Rec StkEl inp+  -> m (Rec StkEl out)++throwMichelson :: EvalM m => MichelsonFailed -> m a+throwMichelson mf = asks ceInstrCallStack >>= throwError . MichelsonFailureWithStack mf++-- | Function to change amount of remaining steps stored in State monad.+runInstr :: EvalM m => InstrRunner m+runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r+runInstr i@(WithLoc _ _) r = runInstrImpl runInstr i r+runInstr i@(Meta _ _i1) r = runInstrImpl runInstr i r+runInstr i@(InstrWithNotes _ _ _i1) r = runInstrImpl runInstr i r+runInstr i@(InstrWithVarNotes _ _i1) r = runInstrImpl runInstr i r+runInstr i@(InstrWithVarAnns _ _i1) r = runInstrImpl runInstr i r+runInstr i@Nop r = runInstrImpl runInstr i r+runInstr i@(Nested _) r = runInstrImpl runInstr i r+runInstr i@(DocGroup _ _i1) r = runInstrImpl runInstr i r+runInstr i@(Fn _ _ _i1) r = runInstrImpl runInstr i r+runInstr i r = do+  rs <- isRemainingSteps <$> getInterpreterState+  if rs == 0+  then throwMichelson MichelsonGasExhaustion+  else do+    modifyInterpreterState (\s -> s {isRemainingSteps = rs - 1})+    runInstrImpl runInstr i r++runInstrNoGas :: EvalM m => InstrRunner m+runInstrNoGas = runInstrImpl runInstrNoGas++-- | Function to interpret Michelson instruction(s) against given stack.+runInstrImpl :: forall m. EvalM m => InstrRunner m -> InstrRunner m+runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'+runInstrImpl runner (WithLoc ics i) r = local (\env -> env{ceInstrCallStack = ics}) $ runner i r+runInstrImpl runner (Meta _ i) r = runner i r+runInstrImpl runner (InstrWithNotes (_ :: Proxy rest) notes instr) inp = do+  out <- runner instr inp+  let zipRec :: Rec Notes topElems -> Rec StkEl (topElems ++ rest) -> Rec StkEl (topElems ++ rest)+      zipRec RNil stkElems = stkElems+      zipRec (stkElemNotes :& xs) (stkElem :& ys) =+        stkElem { seNotes = stkElemNotes } :& zipRec xs ys+  pure $ zipRec notes out+runInstrImpl runner (InstrWithVarNotes _vns i) inp = runner i inp+runInstrImpl runner (InstrWithVarAnns vns i) inp = do+  runner i inp <&> \case+    StkEl v1 _ n1 :& StkEl v2 vn2 n2 :& r -> case vns of+      U.OneVarAnn vn      -> StkEl v1 vn n1 :& StkEl v2 vn2 n2 :& r+      U.TwoVarAnns vn vn' -> StkEl v1 vn n1 :& StkEl v2 vn' n2 :& r+    StkEl v _ n :& r -> case vns of+      U.OneVarAnn vn   -> StkEl v vn n :& r+      U.TwoVarAnns _ _ -> error "Input stack is exhausted but there is still a variable annotation."+    RNil -> error "Input stack is exhausted but there is still variables annotations."+runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do+  let (inp, end) = rsplit @_ @_ @s r+  out <- runInstrImpl runner i inp+  return (out <+> end)+runInstrImpl _ Nop r = pure $ r+runInstrImpl runner (Ext nop) r = r <$ interpretExt runner (SomeItStack nop r)+runInstrImpl runner (Nested sq) r = runner sq r+runInstrImpl runner (DocGroup _ sq) r = runInstrImpl runner sq r+runInstrImpl runner (Fn _ _ i) r = runner i r+runInstrImpl _ DROP (_ :& r) = pure $ r+runInstrImpl runner (DROPN n) stack =+  case n of+    Zero    -> pure stack+    Succ s' -> case stack of+      (_ :& r) -> runInstrImpl runner (DROPN s') r+      -- Note: we intentionally do not use `runner` to recursively+      -- interpret `DROPN` here.+      -- All these recursive calls together correspond to a single+      -- Michelson instruction call.+      -- This recursion is implementation detail of `DROPN`.+      -- The same reasoning applies to other instructions parameterized+      -- by a natural number like 'DIPN'.+runInstrImpl _ DUP (stkEl :& r) = do+  -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s).+  duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl+  pure $ duplicateStkEl :& stkEl :& r+runInstrImpl _ (DUPN s) stack = go s stack+  where+    go :: forall (n :: Peano) inp out a. ConstraintDUPN n inp out a+       => PeanoNatural n -> Rec StkEl inp -> m (Rec StkEl out)+    go (Succ Zero) stk@(stkEl :& _) = do+        -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s).+        duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl+        -- Discard variable annotations. This is consistent with tezos-client.+        pure $ (duplicateStkEl & seVarAnnL .~ U.noAnn) :& stk+    go (Succ n@(Succ _)) (b :& r) =+      go n r <&> \case+        (a :& resTail) -> a :& b :& resTail+runInstrImpl _ SWAP (a :& b :& r) = pure $ b :& a :& r+runInstrImpl _ (DIG s) input0 =+  pure $ go s input0+  where+    go :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a+       => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out+    go Zero stack = stack+    go (Succ n') (b :& r) = case go n' r of+      (a :& resTail) -> a :& b :& resTail+runInstrImpl _ (DUG s) input0 =+  pure $ go s input0+  where+    go :: forall (n :: Peano) inp out a. ConstraintDUG n inp out a+       => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out+    go Zero stack = stack+    go (Succ n') (a :& b :& r) = b :& go n' (a :& r)+runInstrImpl _ SOME ((seValue -> a) :& r) =+  withValueTypeSanity a $+    pure $ starNotesStkEl (VOption (Just a)) :& r+runInstrImpl _ (PUSH v) r = pure $ starNotesStkEl v :& r+runInstrImpl _ NONE r = pure $ starNotesStkEl (VOption Nothing) :& r+runInstrImpl _ UNIT r = pure $ starNotesStkEl VUnit :& r+runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) vn (NTOption _ n) :& r) =+  runner bJust (StkEl a vn n :& r)+runInstrImpl runner (IF_NONE bNone _bJust) (StkEl (VOption Nothing) _ _ :& r) =+  runner bNone r+runInstrImpl _ NEVER inp = case inp of {}+runInstrImpl _ (AnnPAIR{}) ((StkEl a _ _) :& (StkEl b _ _) :& r) =+  pure $ starNotesStkEl (VPair (a, b)) :& r+runInstrImpl _ (AnnUNPAIR{}) ((StkEl (VPair (a, b)) _ _) :& r) =+  pure $ starNotesStkEl a :& starNotesStkEl b :& r+runInstrImpl _ (PAIRN s) stack = pure $ go s stack+  where+    go :: forall n inp. ConstraintPairN n inp => PeanoNatural n -> Rec StkEl inp -> Rec StkEl (PairN n inp)+    go (Succ (Succ Zero)) (StkEl a _ _ :& StkEl b _ _ :& r) =+      -- if n=2+      starNotesStkEl (VPair (a, b)) :& r+    go (Succ n@(Succ (Succ _))) (StkEl a _ _ :& r@(_ :& _ :& _)) =+      -- if n>2+      case go n r of+        StkEl combed _ _ :& r' ->+            starNotesStkEl (VPair (a, combed)) :& r'+runInstrImpl _ (UNPAIRN s) (StkEl pair0 _ pairNotes0 :& r) = do+  pure $ go s pair0 pairNotes0 <+> r+  where+    go+      :: forall n pair. ConstraintUnpairN n pair+      => PeanoNatural n -> Value pair -> Notes pair+      -> Rec StkEl (UnpairN n pair)+    go n pair pairNotes =+      case (n, pair, pairNotes) of+        -- if n=2+        (Succ (Succ Zero), VPair (a, b), NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes) ->+          -- @UNPAIR n@ converts field annotations into var annotations.+          --+          -- > /* [ @pair pair (int %aa) (int %bb) (int %cc) (int %dd) ] */ ;+          -- > UNPAIR 3+          -- > /* [ @aa int : @bb int : pair (int %cc) (int %dd) ] */ ;+          --+          -- Nested var annotations will be discarded.+          --+          -- > /* [ pair (int @c) (int @a) (int @b) ] */ ;+          -- UNPAIR 3+          -- /* [ int : int : int ] */ ;+          StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes+            :& StkEl b (U.convAnn @U.FieldTag @U.VarTag bFieldAnn) bNotes+            :& RNil+        -- if n>2+        (Succ n'@(Succ (Succ _)), VPair (a, b@(VPair _)), NTPair _ aFieldAnn _ _ _ aNotes bNotes) ->+          StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes+            :& go n' b bNotes+runInstrImpl _ (AnnCAR _ _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r+runInstrImpl _ (AnnCDR _ _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r+runInstrImpl _ (AnnLEFT nt nf1 nf2) ((StkEl a _ na) :& r) =+  withValueTypeSanity a $+    pure $ StkEl (VOr $ Left a) U.noAnn (NTOr nt nf1 nf2 na starNotes) :& r+runInstrImpl _ (AnnRIGHT nt nf1 nf2) ((StkEl b _ nb) :& r) =+  withValueTypeSanity b $+    pure $ StkEl (VOr $ Right b) U.noAnn (NTOr nt nf1 nf2 starNotes nb) :& r+runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) =+  runner bLeft (StkEl a vn nl :& r)+runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) vn (NTOr _ _ _ _ nr) :& r) =+  runner bRight (StkEl a vn nr :& r)+runInstrImpl _ NIL r = pure $ starNotesStkEl (VList []) :& r+runInstrImpl _ CONS (a :& StkEl (VList l) _ _ :& r) = pure $ starNotesStkEl (VList (seValue a : l)) :& r+runInstrImpl runner (IF_CONS _ bNil) (StkEl (VList []) _ _ :& r) = runner bNil r+runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) vn ntl@(NTList _ nhd) :& r) =+  runner bCons (StkEl lh vn nhd :& StkEl (VList lr) vn ntl :& r)+runInstrImpl _ SIZE (a :& r) = pure $ starNotesStkEl (VNat $ Unsafe.fromIntegral @Int @Natural $ evalSize $ seValue a) :& r+runInstrImpl _ EMPTY_SET r = pure $ starNotesStkEl (VSet Set.empty) :& r+runInstrImpl _ EMPTY_MAP r = pure $ starNotesStkEl (VMap Map.empty) :& r+runInstrImpl _ EMPTY_BIG_MAP r = do+  bigMap <- assignBigMapIds' $ VBigMap Nothing Map.empty+  pure $ starNotesStkEl bigMap :& r+runInstrImpl runner (MAP (code :: Instr (MapOpInp c ': s) (b ': s))) (StkEl a vn n :& r) = do+  -- Evaluation must preserve all stack modifications that @MAP@'s does.+  (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do+    res <- runner code (val :& curStack)+    case res of+      ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))+    (r, []) ((\el -> StkEl el vn (mapOpNotes n)) <$> mapOpToList @c a)+  pure $ starNotesStkEl (mapOpFromList a (reverse newList)) :& newStack+runInstrImpl runner (ITER (code :: Instr (IterOpEl c ': s) s)) (StkEl a vn n :& r) =+  case iterOpDetachOne @c a of+    (Just x, xs) -> do+      res <- runner code (StkEl x vn (iterOpNotes n) :& r)+      runner (ITER code) (StkEl xs vn n :& res)+    (Nothing, _) -> pure r+runInstrImpl _ MEM (a :& b :& r) = pure $ starNotesStkEl (VBool (evalMem (seValue a) (seValue b))) :& r+runInstrImpl _ GET (a :& b :& r) = pure $ starNotesStkEl (VOption (evalGet (seValue a) (seValue b))) :& r+runInstrImpl _ (GETN s) (StkEl pair _ _ :& r) = do+  pure $ starNotesStkEl (go s pair) :& r+  where+    go+      :: forall ix a. ConstraintGetN ix a+      => PeanoNatural ix -> Value a+      -> Value (GetN ix a)+    go Zero            a                   = a+    go (Succ Zero)      (VPair (left, _))  = left+    go (Succ (Succ n')) (VPair (_, right)) = go n' right+runInstrImpl _ UPDATE (a :& b :& StkEl c _ _ :& r) =+  pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) c) :& r+runInstrImpl _ (UPDATEN s) (StkEl (val :: Value val) _ _  :& StkEl pair _ _ :& r) = do+  pure $ starNotesStkEl (go s pair) :& r+  where+    go+      :: forall ix pair. ConstraintUpdateN ix pair+      => PeanoNatural ix -> Value pair -> Value (UpdateN ix val pair)+    go Zero             _                      = val+    go (Succ Zero)      (VPair (_, right))     = VPair (val, right)+    go (Succ (Succ n')) (VPair (left, right))  = VPair (left, go n' right)+runInstrImpl _ GET_AND_UPDATE (StkEl key _ _ :& StkEl valMb _ _ :& StkEl collection _ _ :& r) =+  pure $+    starNotesStkEl (VOption (evalGet key collection))+    :& starNotesStkEl (evalUpd key valMb collection)+    :& r+runInstrImpl runner (IF bTrue _) (StkEl (VBool True) _ _ :& r) = runner bTrue r+runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) _ _ :& r) = runner bFalse r+runInstrImpl _ (LOOP _) (StkEl (VBool False) _ _ :& r) = pure $ r+runInstrImpl runner (LOOP ops) (StkEl (VBool True) _ _ :& r) = do+  res <- runner ops r+  runner (LOOP ops) res+runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) _ _ :& r) = pure $ starNotesStkEl a :& r+runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) = do+  res <- runner ops (StkEl a vn nl :& r)+  runner (LOOP_LEFT ops) res+runInstrImpl _ (LAMBDA lam) r = pure $ starNotesStkEl lam :& r+runInstrImpl runner EXEC (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) _ _ :& r) = do+  res <- runner lBody (a :& RNil)+  pure $ res <+> r+runInstrImpl _ APPLY (StkEl (a :: T.Value a) _ _ :& StkEl (VLam lBody) _ _ :& r) = do+  pure $ starNotesStkEl (VLam (T.rfMapAnyInstr doApply lBody)) :& r+  where+    doApply :: Instr ('TPair a i ': s) o -> Instr (i ': s) o+    doApply b = PUSH a `Seq` PAIR `Seq` Nested b+runInstrImpl runner (DIP i) (a :& r) = do+  res <- runner i r+  pure $ a :& res+runInstrImpl runner (DIPN s i) stack =+  case s of+    Zero -> runner i stack+    Succ s' -> case stack of+      (a :& r) -> (a :&) <$> runInstrImpl runner (DIPN s' i) r+runInstrImpl _ FAILWITH (a :& _) = throwMichelson $ MichelsonFailedWith (seValue a)+runInstrImpl _ CAST (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r+runInstrImpl _ RENAME (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r+runInstrImpl _ PACK ((seValue -> a) :& r) = pure $ starNotesStkEl (VBytes $ packValue' a) :& r+runInstrImpl _ UNPACK (StkEl (VBytes a) _ _ :& r) =+  pure $ starNotesStkEl (VOption . rightToMaybe $ runUnpack a) :& r+runInstrImpl _ CONCAT (a :& b :& r) = pure $ starNotesStkEl (evalConcat (seValue a) (seValue b)) :& r+runInstrImpl _ CONCAT' (StkEl (VList a) _ _ :& r) = pure $ starNotesStkEl (evalConcat' a) :& r+runInstrImpl _ SLICE (StkEl (VNat o) _ _ :& StkEl (VNat l) _ _ :& StkEl s _ _ :& r) =+  pure $ starNotesStkEl (VOption (evalSlice o l s)) :& r+runInstrImpl _ ISNAT (StkEl (VInt i) _ _ :& r) =+  if i < 0+  then pure $ starNotesStkEl (VOption Nothing) :& r+  else pure $ starNotesStkEl (VOption (Just (VNat $ fromInteger i))) :& r+runInstrImpl _ ADD (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Add) l r+runInstrImpl _ SUB (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r+runInstrImpl _ MUL (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r+runInstrImpl _ EDIV (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @EDiv) l r+runInstrImpl _ ABS ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Abs) a) :& rest+runInstrImpl _ NEG ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neg) a) :& rest+runInstrImpl _ LSL (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s+runInstrImpl _ LSR (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s+runInstrImpl _ OR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r+runInstrImpl _ AND (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r+runInstrImpl _ XOR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r+runInstrImpl _ NOT ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Not) a) :& rest+runInstrImpl _ COMPARE ((seValue -> l) :& (seValue -> r) :& rest) =+  pure $ starNotesStkEl (T.VInt (compareOp l r)) :& rest+runInstrImpl _ EQ ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest+runInstrImpl _ NEQ ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neq) a) :& rest+runInstrImpl _ LT ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Lt) a) :& rest+runInstrImpl _ GT ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Gt) a) :& rest+runInstrImpl _ LE ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Le) a) :& rest+runInstrImpl _ GE ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest+runInstrImpl _ INT (StkEl a _ _ :& r) =+  pure $ starNotesStkEl (evalToIntOp a) :& r+runInstrImpl _ (SELF sepc :: Instr inp out) r = do+  ContractEnv{..} <- ask+  case Proxy @out of+    (_ :: Proxy ('TContract cp ': s)) -> do+      pure $ starNotesStkEl (VContract ceSelf sepc) :& r+runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (StkEl (VAddress epAddr) _ _ :& r) = do+  ContractEnv{..} <- ask+  let T.EpAddress addr addrEpName = epAddr+  let mepName =+        case (instrEpName, addrEpName) of+          (DefEpName, DefEpName) -> Just DefEpName+          (DefEpName, en) -> Just en+          (en, DefEpName) -> Just en+          _ -> Nothing++  let withNotes v = StkEl v U.noAnn (NTOption U.noAnn $ NTContract U.noAnn nt) :& r+  pure $ withNotes $ case mepName of+    Nothing -> VOption Nothing+    Just epName ->+      case addr of+        KeyAddress _ -> castContract addr epName T.tyImplicitAccountParam+        ContractAddress ca ->+          case Map.lookup ca ceContracts of+            Just (SomeParamType _ paramNotes) -> castContract addr epName paramNotes+            Nothing -> VOption Nothing+  where+  castContract+    :: forall p. T.ParameterScope p+    => Address -> EpName -> T.ParamNotes p -> T.Value ('TOption ('TContract a))+  castContract addr epName param = VOption $ do+    -- As we are within Maybe monad, pattern-match failure results in Nothing+    MkEntrypointCallRes na epc <- T.mkEntrypointCall epName param+    Right (Refl, _) <- pure $ matchTypes nt na+    return $ VContract addr (T.SomeEpc epc)++runInstrImpl _ TRANSFER_TOKENS+  (StkEl p _ _ :& StkEl (VMutez mutez) _ _ :& StkEl contract _ _ :& r) = do+    incrementCounter+    globalCounter <- isGlobalCounter <$> getInterpreterState+    pure $ starNotesStkEl (VOp (OpTransferTokens $ TransferTokens p mutez contract globalCounter)) :& r+runInstrImpl _ SET_DELEGATE (StkEl (VOption mbKeyHash) _ _ :& r) = do+  incrementCounter+  globalCounter <- isGlobalCounter <$> getInterpreterState+  case mbKeyHash of+    Just (VKeyHash k) -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate (Just k) globalCounter)) :& r+    Nothing -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate Nothing globalCounter)) :& r+runInstrImpl _ (CREATE_CONTRACT contract)+  (StkEl (VOption mbKeyHash) _ _ :& StkEl (VMutez m) _ _ :& StkEl g _ _ :& r) = do+  originator <- ceSelf <$> ask+  opHash <- ceOperationHash <$> ask+  incrementCounter+  globalCounter <- isGlobalCounter <$> getInterpreterState+  let ops = cCode contract+  let resAddr =+        case opHash of+          Just hash -> mkContractAddress hash globalCounter+          Nothing ->+            mkContractAddress+              (mkOriginationOperationHash (createOrigOp originator mbKeyHash m contract g globalCounter))+              -- If opHash is Nothing it means that interpreter is running in some kind of test+              -- context, therefore we generate dummy contract address with its own origination+              -- operation.+              globalCounter+  let resEpAddr = EpAddress resAddr DefEpName+  let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g ops globalCounter+  pure $ starNotesStkEl (VOp (OpCreateContract resOp))+      :& starNotesStkEl (VAddress resEpAddr)+      :& r+runInstrImpl _ IMPLICIT_ACCOUNT (StkEl (VKeyHash k) _ _ :& r) =+  pure $ (starNotesStkEl (VContract (KeyAddress k) sepcPrimitive)) :& r+runInstrImpl _ NOW r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VTimestamp ceNow) :& r+runInstrImpl _ AMOUNT r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VMutez ceAmount) :& r+runInstrImpl _ BALANCE r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VMutez ceBalance) :& r+runInstrImpl _ VOTING_POWER (StkEl (VKeyHash k) _ _ :& r) = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VNat $ vpPick k ceVotingPowers) :& r+runInstrImpl _ TOTAL_VOTING_POWER r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VNat $ vpTotal ceVotingPowers) :& r+runInstrImpl _ CHECK_SIGNATURE+  (StkEl (VKey k) _ _ :& StkEl (VSignature v) _ _ :& StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBool $ checkSignature k v b) :& r+runInstrImpl _ SHA256 (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ sha256 b) :& r+runInstrImpl _ SHA512 (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ sha512 b) :& r+runInstrImpl _ BLAKE2B (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ blake2b b) :& r+runInstrImpl _ SHA3 (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ sha3 b) :& r+runInstrImpl _ KECCAK (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ keccak b) :& r+runInstrImpl _ HASH_KEY (StkEl (VKey k) _ _ :& r) =+  pure $ starNotesStkEl (VKeyHash $ hashKey k) :& r+runInstrImpl _ PAIRING_CHECK (StkEl (VList pairs) _ _ :& r) = do+  let pairs' = [ (g1, g2) | VPair (VBls12381G1 g1, VBls12381G2 g2) <- pairs ]+  pure $ starNotesStkEl (VBool $ checkPairing pairs') :& r+runInstrImpl _ SOURCE r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VAddress $ EpAddress ceSource DefEpName) :& r+runInstrImpl _ SENDER r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VAddress $ EpAddress ceSender DefEpName) :& r+runInstrImpl _ ADDRESS (StkEl (VContract a sepc) _ _ :& r) =+  pure $ starNotesStkEl (VAddress $ EpAddress a (sepcName sepc)) :& r+runInstrImpl _ CHAIN_ID r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VChainId ceChainId) :& r+runInstrImpl _ LEVEL r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VNat ceLevel) :& r+runInstrImpl _ SELF_ADDRESS r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VAddress $ EpAddress ceSelf DefEpName) :& r+runInstrImpl _ TICKET (StkEl dat _ _ :& StkEl (VNat am) _ _ :& r) = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VTicket ceSelf dat am) :& r+runInstrImpl _ READ_TICKET (te@(StkEl (VTicket addr dat am) _ _) :& r) = do+  pure $+    starNotesStkEl+      (VPair (VAddress (EpAddress addr DefEpName), (VPair (dat, VNat am))))+    :& te :& r+runInstrImpl _ SPLIT_TICKET+    (StkEl tv@(VTicket addr dat am) _ _ :&+     StkEl (VPair (VNat am1, VNat am2)) _ _ :& r) = do+  let result = withValueTypeSanity tv $ VOption do+        guard (am1 + am2 == am)+        return $ VPair (VTicket addr dat am1, VTicket addr dat am2)+  pure $ starNotesStkEl result :& r+runInstrImpl _ JOIN_TICKETS+  (StkEl (VPair (tv1@(VTicket addr1 dat1 am1), VTicket addr2 dat2 am2)) _ _ :& r) = do+  let result = withValueTypeSanity tv1 $ VOption do+        guard (addr1 == addr2)+        guard (dat1 == dat2)+        return $ VTicket addr1 dat1 (am1 + am2)+  pure $ starNotesStkEl result :& r++-- | Evaluates an arithmetic operation and either fails or proceeds.+runArithOp+  :: (ArithOp aop n m, EvalM monad)+  => proxy aop+  -> StkEl n+  -> StkEl m+  -> monad (StkEl (ArithRes aop n m))+runArithOp op l r = case evalOp op (seValue l) (seValue r) of+  Left  err -> throwMichelson $ MichelsonArithError err+  Right res -> pure $ starNotesStkEl res++-- | Unpacks given raw data into a typed value.+runUnpack+  :: forall t. (UnpackedValScope t)+  => ByteString+  -> Either UnpackError (T.Value t)+runUnpack bs =+  -- TODO [TM-80] Gas consumption here should depend on unpacked data size+  -- and size of resulting expression, errors would also spend some (all equally).+  -- Fortunately, the inner decoding logic does not need to know anything about gas use.+  unpackValue' bs++createOrigOp+  :: (ParameterScope param, StorageScope store)+  => Address+  -> Maybe (T.Value 'T.TKeyHash)+  -> Mutez+  -> Contract param store+  -> Value' Instr store+  -> GlobalCounter+  -> OriginationOperation+createOrigOp originator mbDelegate bal contract storage counter =+  OriginationOperation+    { ooOriginator = originator+    , ooDelegate = unwrapMbKeyHash mbDelegate+    , ooBalance = bal+    , ooStorage = storage+    , ooContract = contract+    , ooCounter = counter+    }++unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash+unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash++interpretExt :: EvalM m => InstrRunner m -> SomeItStack -> m ()+interpretExt _ (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do+  let getEl (Left l) = l+      getEl (Right str) = withStackElem str st (pretty . seValue)+  tell . one $ mconcat (map getEl pc)++interpretExt runner (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do+  ost <- runInstrImpl runner instr st+  let ((seValue -> T.fromVal -> succeeded) :& _) = ost+  unless succeeded $ do+    interpretExt runner (SomeItStack (T.PRINT pc) st)+    throwMichelson $ MichelsonFailedTestAssert $ "TEST_ASSERT " <> nm <> " failed"++interpretExt _ (SomeItStack T.DOC_ITEM{} _) = pass+interpretExt _ (SomeItStack T.COMMENT_ITEM{} _) = pass+interpretExt _ (SomeItStack T.STACKTYPE{} _) = pass++-- | Access given stack reference (in CPS style).+withStackElem+  :: forall st a.+     T.StackRef st+  -> Rec StkEl st+  -> (forall t. StkEl t -> a)+  -> a+withStackElem (T.StackRef sn) vals cont =+  loop (vals, sn)+  where+    loop+      :: forall s (n :: Peano). (LongerThan s n)+      => (Rec StkEl s, PeanoNatural n) -> a+    loop = \case+      (e :& _, Zero) -> cont e+      (_ :& es, Succ n) -> loop (es, n)++assignBigMapIds' :: EvalM m => Value t -> m (Value t)+assignBigMapIds' val = do+  bigMapCounter0 <- view isBigMapCounterL <$> getInterpreterState+  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds val) bigMapCounter0+  modifyInterpreterState (set isBigMapCounterL bigMapCounter1)+  pure storageWithIds++-- | All big_maps stored in a chain have a globally unique ID.+--+-- We use this function to assign a new ID whenever a big_map is created.+assignBigMapIds :: MonadState BigMapCounter m => Value t -> m (Value t)+assignBigMapIds =+  dfsTraverseValue \case+    VBigMap _ vBigMap -> do+      bigMapId <- bigMapCounter <<+= 1+      pure $ VBigMap (Just bigMapId) vBigMap+    v -> pure v++incrementCounter :: (InterpreterStateMonad m) => m ()+incrementCounter = modifyInterpreterState $ \iState ->+      iState { isGlobalCounter = isGlobalCounter iState + 1 }++(deriveGADTNFData ''MichelsonFailed)++instance NFData MichelsonFailureWithStack

+ src/Morley/Michelson/Interpret/Pack.hs view

@@ -0,0 +1,44 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, carrying logic of @PACK@ instruction.+--+-- This is nearly symmetric to adjacent Unpack.hs module.+module Morley.Michelson.Interpret.Pack+  ( packValue+  , packValue'+  , packValuePrefix+  , toBinary+  , toBinary'+  ) where++import Prelude hiding (EQ, GT, LT)++import Morley.Micheline.Binary (encodeExpression, encodeExpression')+import Morley.Micheline.Class (ToExpression(..))+import Morley.Michelson.Typed++-- | Generic serializer.+toBinary :: ToExpression a => a -> LByteString+toBinary = encodeExpression . toExpression++-- | Same as 'toBinary', for strict bytestring.+toBinary' :: ToExpression a => a -> ByteString+toBinary' = encodeExpression' . toExpression++-- | Serialize a value given to @PACK@ instruction.+packValue :: PackedValScope t => Value t -> LByteString+packValue x =+  let uval = untypeValueHashable x+  in packValuePrefix <> (encodeExpression $ toExpression uval)++-- | Same as 'packValue', for strict bytestring.+packValue' :: PackedValScope t => Value t -> ByteString+packValue' x =+  let uval = untypeValueHashable x+  in packValuePrefix <> (encodeExpression' $ toExpression uval)++-- | Prefix prepended to the binary representation of a value.+packValuePrefix :: IsString s => s+packValuePrefix = "\x05"

+ src/Morley/Michelson/Interpret/Unpack.hs view

@@ -0,0 +1,84 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{- | Module, carrying logic of @UNPACK@ instruction.++This is nearly symmetric to adjacent Pack.hs module.++When implementing this the following sources were used:++* https://pastebin.com/8gfXaRvp++* https://gitlab.com/tezos/tezos/-/blob/767de2b6665ec2cc21e41e6348f8a0b369d26450/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501++* https://github.com/tezbridge/tezbridge-crypto/blob/f7d93d8d04201557972e839967758cff5bbe5345/PsddFKi3/codec.js#L513++-}+module Morley.Michelson.Interpret.Unpack+  ( UnpackError (..)+  , unpackInstr'+  , unpackUValue'+  , unpackValue'+  ) where++import Prelude hiding (EQ, Ordering(..), get)++import qualified Data.ByteString as BS+import Data.Constraint (Dict(..))+import Fmt (pretty)++import Morley.Micheline.Binary (eitherDecodeExpression)+import Morley.Micheline.Class (FromExpression(..))+import Morley.Michelson.Typed (UnpackedValScope)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Untyped+import qualified Morley.Michelson.Untyped as U+import Morley.Util.Binary++{- Implementation notes:++* We need to know which exact type we unpack to.+For instance, serialized signatures are indistinguishable from+plain serialized bytes, so if we want to return "Value" (typed or untyped),+we need to know currently expected type. The reference implementation does+the same.++* It occurred to be easier to decode to typed values and untyped instructions.+When decoding lambda, we type check given instruction, and when decoding+@PUSH@ call we untype decoded value.+One may say that this gives unreasonable performance overhead, but with the+current definition of "Value" types (typed and untyped) we cannot avoid it+anyway, because when deserializing bytearray-like data (keys, signatures, ...),+we have to convert raw bytes to human-readable 'Text' and later parse them+to bytes back at type check stage.+We console ourselves that lambdas are rarely packed.++-}++-- | Deserialize bytes into the given value.+-- Suitable for @UNPACK@ operation only.+unpackValue'+  :: forall t. (UnpackedValScope t)+  => ByteString -> Either UnpackError (T.Value t)+unpackValue' = unpackImpl @(T.Value t)+  where+    _reallyNeedThisConstraint = Dict @(UnpackedValScope t)++-- | Deserialize an instruction into the given value.+unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]+unpackInstr' = unpackImpl @([ExpandedOp])++-- | Deserialize bytes into 'U.Value'.+unpackUValue' :: ByteString -> Either UnpackError U.Value+unpackUValue' = unpackImpl @U.Value++unpackImpl :: forall t. (FromExpression t)+           => ByteString+           -> Either UnpackError t+unpackImpl bs = do+  (tag, bs') <- maybeToRight (UnpackError "Empty bytes") (BS.uncons bs)+  when (tag /= 0x05) . Left . UnpackError $+    "Unexpected tag: '" <> (show tag) <> "'. '0x05' tag expected."+  expr <- eitherDecodeExpression bs'+  either (Left . UnpackError . pretty) Right $ fromExpression @t expr

+ src/Morley/Michelson/Interpret/Utils.hs view

@@ -0,0 +1,44 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | General utilities used by interpreter.+--+-- This is not supposed to import any Michelson modules.+module Morley.Michelson.Interpret.Utils+  ( encodeZarithNumber+  ) where++import Control.Exception (assert)+import qualified Data.Bits as Bits+import qualified Unsafe (fromIntegral)++-- | Encode a number as tezos does this.+--+-- In the Tezos reference implementation this encoding is called @zarith@.+encodeZarithNumber :: Integer -> NonEmpty Word8+encodeZarithNumber = doEncode True+  where+    {- Numbers, when packed by tezos, are represented as follows:++    byte 0:         1              _         ______   ||  lowest digits+            has continuation  is negative   payload   ||+                                                      ||+    byte 1:         1                       _______   ||+    ...             1                       _______   ||+    byte n:         0                       _______   ||+            has continuation                payload   \/  highest digits+    -}+    doEncode :: Bool -> Integer -> NonEmpty Word8+    doEncode isFirst a+      | a >= byteWeight =+          let (hi, lo) = a `divMod` byteWeight+              byte = Bits.setBit (Unsafe.fromIntegral @Integer @Word8 lo) 7+          in byte :| toList (doEncode False hi)+      | a >= 0 =+          one (Unsafe.fromIntegral @Integer @Word8 a)+      | otherwise = assert isFirst $+          let h :| t = doEncode True (-a)+          in Bits.setBit h 6 :| t+      where+        byteWeight = if isFirst then 64 else 128

+ src/Morley/Michelson/Let.hs view

@@ -0,0 +1,31 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Let+  ( LetType (..)+  , LetValue (..)+  ) where++import Data.Aeson.TH (deriveJSON)+import qualified Data.Text as T++import Morley.Michelson.Macro (ParsedOp)+import Morley.Michelson.Untyped (Ty, Value')+import Morley.Util.Aeson++-- | A programmer-defined constant+data LetValue = LetValue+  { lvName :: T.Text+  , lvSig :: Ty+  , lvVal :: (Value' ParsedOp)+  } deriving stock (Eq, Show)++-- | A programmer-defined type-synonym+data LetType = LetType+  { ltName :: T.Text+  , ltSig :: Ty+  } deriving stock (Eq, Show)++deriveJSON morleyAesonOptions ''LetValue+deriveJSON morleyAesonOptions ''LetType

+ src/Morley/Michelson/Macro.hs view

@@ -0,0 +1,462 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Macro+  (+  -- * Macros types+    CadrStruct (..)+  , PairStruct (..)+  , UnpairStruct (..)+  , Macro (..)+  , LetMacro (..)++  -- * Morley Parsed value types+  , ParsedValue++  -- * Morley Parsed instruction types+  , ParsedInstr+  , ParsedOp (..)+  , ParsedUExtInstr++    -- * For utilities+  , expandContract+  , expandValue++    -- * For parsing+  , mapPairLeaves++    -- * Internals exported for tests+  , expand+  , expandList+  , expandMacro+  , expandPapair+  , expandUnpapair+  , expandCadr+  , expandSetCadr+  , expandMapCadr+  ) where++import Data.Aeson.TH (deriveJSON)+import Data.Data (Data(..))+import qualified Data.Text as T+import Fmt (Buildable(build), GenericBuildable(..), (+|), (+||), (|+), (||+))++import Morley.Michelson.ErrorPos+import Morley.Michelson.Printer (RenderDoc(..))+import Morley.Michelson.Untyped+import Morley.Util.Aeson+import Morley.Util.Generic+import Morley.Util.Positive++-- | A programmer-defined macro+data LetMacro = LetMacro+  { lmName :: T.Text+  , lmSig :: StackFn+  , lmExpr :: [ParsedOp]+  }+  deriving stock (Eq, Show, Data, Generic)+  deriving Buildable via GenericBuildable LetMacro++instance NFData LetMacro++data PairStruct+  = F FieldAnn+  | P PairStruct PairStruct+  deriving stock (Eq, Show, Data, Generic)+  deriving Buildable via GenericBuildable PairStruct++instance NFData PairStruct++data UnpairStruct+  = UF+  | UP UnpairStruct UnpairStruct+  deriving stock (Eq, Show, Data, Generic)+  deriving Buildable via GenericBuildable UnpairStruct++instance NFData UnpairStruct++data CadrStruct+  = A+  | D+  deriving stock (Eq, Show, Data, Generic)+  deriving Buildable via GenericBuildable CadrStruct++instance NFData CadrStruct++-- | Unexpanded instructions produced directly by the @ops@ parser, which+-- contains primitive Michelson Instructions, inline-able macros and sequences+data ParsedOp+  = Prim ParsedInstr SrcPos -- ^ Primitive Michelson instruction+  | Mac Macro        SrcPos -- ^ Built-in Michelson macro defined by the specification+  | LMac LetMacro    SrcPos -- ^ User-defined macro with instructions to be inlined+  | Seq [ParsedOp]   SrcPos -- ^ A sequence of instructions+  deriving stock (Eq, Show, Data, Generic)++instance RenderDoc ParsedOp where+  renderDoc pn parsedOp = renderDoc pn $ expand [] parsedOp++instance Buildable ParsedOp where+  build = \case+    Prim parseInstr _ -> "<Prim: "+|parseInstr|+">"+    Mac macro _       -> "<Mac: "+|macro|+">"+    LMac letMacro _   -> "<LMac: "+|letMacro|+">"+    Seq parsedOps _   -> "<Seq: "+|parsedOps|+">"++instance NFData ParsedOp++-------------------------------------+-- Types produced by parser+-------------------------------------++type ParsedUExtInstr = ExtInstrAbstract ParsedOp++type ParsedInstr = InstrAbstract ParsedOp++type ParsedValue = Value' ParsedOp++-- | Built-in Michelson Macros defined by the specification+data Macro+  = CASE (NonEmpty [ParsedOp])+  | TAG Natural (NonEmpty Ty)+  | ACCESS Natural Positive+  | SET Natural Positive+  | CONSTRUCT (NonEmpty [ParsedOp])+  | VIEW [ParsedOp]+  | VOID [ParsedOp]+  | CMP ParsedInstr VarAnn+  | IFX ParsedInstr [ParsedOp] [ParsedOp]+  | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]+  | FAIL+  | PAPAIR PairStruct TypeAnn VarAnn+  | UNPAPAIR UnpairStruct+  | CADR [CadrStruct] VarAnn FieldAnn+  | CARN VarAnn Word+  | CDRN VarAnn Word+  | SET_CADR [CadrStruct] VarAnn FieldAnn+  | MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]+  | DIIP Word [ParsedOp]+  | DUUP Word VarAnn+  | ASSERT+  | ASSERTX ParsedInstr+  | ASSERT_CMP ParsedInstr+  | ASSERT_NONE+  | ASSERT_SOME+  | ASSERT_LEFT+  | ASSERT_RIGHT+  | IF_SOME [ParsedOp] [ParsedOp]+  | IF_RIGHT [ParsedOp] [ParsedOp]+  deriving stock (Eq, Show, Data, Generic)++instance Buildable Macro where+  build = \case+    TAG idx ty -> "<TAG: #"+||idx||+" from "+|toList ty|+""+    CASE parsedInstrs -> "<CASE: "+|toList parsedInstrs|+">"+    ACCESS idx size -> "<ACCESS: #"+||idx||+"/"+|size|+""+    SET idx size -> "<SET: #"+||idx||+"/"+|size|+""+    CONSTRUCT parsedInstrs -> "<CONSTRUCT: "+|toList parsedInstrs|+">"+    VIEW code -> "<VIEW: "+|code|+">"+    VOID code -> "<VOID: "+|code|+">"+    CMP parsedInstr carAnn -> "<CMP: "+|parsedInstr|+", "+|carAnn|+">"+    IFX parsedInstr parsedOps1 parsedOps2 -> "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"+    IFCMP parsedInstr varAnn parsedOps1 parsedOps2 -> "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"+    FAIL -> "FAIL"+    PAPAIR pairStruct typeAnn varAnn -> "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"+    UNPAPAIR pairStruct -> "<UNPAPAIR: "+|pairStruct|+">"+    CADR cadrStructs varAnn fieldAnn -> "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+    CARN varAnn idx -> "<CAR: #"+||idx||+","+||varAnn||+">"+    CDRN varAnn idx -> "<CDR: #"+||idx||+","+||varAnn||+">"+    SET_CADR cadrStructs varAnn fieldAnn -> "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+    MAP_CADR cadrStructs varAnn fieldAnn parsedOps -> "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"+    DIIP integer parsedOps -> "<DIIP: "+|integer|+", "+|parsedOps|+">"+    DUUP integer varAnn -> "<DUUP: "+|integer|+", "+|varAnn|+">"+    ASSERT -> "ASSERT"+    ASSERTX parsedInstr -> "<ASSERTX: "+|parsedInstr|+">"+    ASSERT_CMP parsedInstr -> "<ASSERT_CMP: "+|parsedInstr|+">"+    ASSERT_NONE  -> "ASSERT_NONE"+    ASSERT_SOME  -> "ASSERT_SOME"+    ASSERT_LEFT  -> "ASSERT_LEFT"+    ASSERT_RIGHT -> "ASSERT_RIGHT"+    IF_SOME parsedOps1 parsedOps2 -> "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"+    IF_RIGHT parsedOps1 parsedOps2 -> "<IF_RIGHT: "+|parsedOps1|+", "+|parsedOps2|+">"++instance NFData Macro++expandList :: [ParsedOp] -> [ExpandedOp]+expandList = fmap (expand [])++-- | Expand all macros in parsed contract.+expandContract :: Contract' ParsedOp -> Contract+expandContract contract =+  contract { contractCode = expandList (contractCode contract) }++-- Probably, some SYB can be used here+expandValue :: ParsedValue -> Value+expandValue = \case+  ValuePair l r -> ValuePair (expandValue l) (expandValue r)+  ValueLeft x -> ValueLeft (expandValue x)+  ValueRight x -> ValueRight (expandValue x)+  ValueSome x -> ValueSome (expandValue x)+  ValueNil -> ValueNil+  ValueSeq valueList -> ValueSeq (map expandValue valueList)+  ValueMap eltList -> ValueMap (map expandElt eltList)+  ValueLambda opList ->+    maybe ValueNil ValueLambda $+    nonEmpty (expandList $ toList opList)+  x -> fmap (expand []) x++expandElt :: Elt ParsedOp -> Elt ExpandedOp+expandElt (Elt l r) = Elt (expandValue l) (expandValue r)++expand :: LetCallStack -> ParsedOp -> ExpandedOp+expand cs = let ics pos = InstrCallStack cs pos in \case+  -- We handle this case specially, because it's essentially just PAIR.+  -- It's needed because we have a hack in parser: we parse PAIR as PAPAIR.+  -- We need to do something better eventually.+  (Mac (PAPAIR (P (F a) (F b)) t v) pos) ->+    WithSrcEx (ics pos) $ PrimEx (PAIR t v a b)+  -- DIIP is now always represented as a single instruction.+  -- `expandMacro` always returns a list which we wrap into `SeqEx`, so we+  -- can't use it.+  -- As the above comment says, we need to do something better eventually+  -- (e. g. to avoid `error` usage inside `expandMacro`).+  (Mac (DIIP n ops) pos) ->+    WithSrcEx (ics pos) $ PrimEx (DIPN n (expand cs <$> ops))+  -- Similarly to above, DUUP is now always represented as a single instruction.+  (Mac (DUUP n v) pos) ->+    WithSrcEx (ics pos) $ PrimEx $ DUPN v n+  (Mac m pos) -> WithSrcEx (ics pos) $ SeqEx $ expandMacro (ics pos) m+  (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand cs <$> i+  (Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand cs <$> s+  (LMac l pos) -> expandLetMac l+    where+      expandLetMac :: LetMacro -> ExpandedOp+      expandLetMac LetMacro {..} =+        let newCS = LetName lmName : cs in+        let ics' = InstrCallStack newCS pos in+        WithSrcEx ics' $ PrimEx . EXT . FN lmName lmSig $ expand newCS <$> lmExpr++expandMacro :: InstrCallStack -> Macro -> [ExpandedOp]+expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case+  VIEW a             -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)+                        , PrimEx (DIP $ oprimEx $ DUPN noAnn 2)+                        , PrimEx $ PAIR noAnn noAnn noAnn noAnn ] +++                        (expand cs <$> a) +++                        [ PrimEx (DIP [PrimEx $ AMOUNT noAnn])+                        , PrimEx $ TRANSFER_TOKENS noAnn+                        , PrimEx $ NIL noAnn noAnn (Ty TOperation noAnn)+                        , PrimEx $ SWAP+                        , PrimEx $ CONS noAnn+                        , PrimEx $ PAIR noAnn noAnn noAnn noAnn+                        ]+  VOID a             -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)+                        , PrimEx SWAP+                        , PrimEx $ DIP $ expand cs <$> a+                        , PrimEx SWAP+                        , PrimEx $ EXEC noAnn+                        , PrimEx FAILWITH+                        ]+  CASE ops           -> expandCase (map (expand cs) <$> ops)+  TAG idx uty        -> expandTag idx uty+  ACCESS idx size    -> expandAccess idx size+  SET idx size       -> expandSet idx size+  CONSTRUCT ops      -> expandConstruct (map (expand cs) <$> ops)+  CMP i v            -> [PrimEx (COMPARE v), xo i]+  IFX i bt bf        -> [xo i, PrimEx $ IF (xp bt) (xp bf)]+  IFCMP i v bt bf    -> PrimEx <$> [COMPARE v, expand cs <$> i, IF (xp bt) (xp bf)]+  IF_SOME bt bf      -> [PrimEx (IF_NONE (xp bf) (xp bt))]+  IF_RIGHT bt bf     -> [PrimEx (IF_LEFT (xp bf) (xp bt))]+  FAIL               -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH]+  ASSERT             -> oprimEx $ IF [] (expandMacro p FAIL)+  ASSERTX i          -> [expand cs $ mac $ IFX i [] [mac FAIL]]+  ASSERT_CMP i       -> [expand cs $ mac $ IFCMP i noAnn [] [mac FAIL]]+  ASSERT_NONE        -> oprimEx $ IF_NONE [] (expandMacro p FAIL)+  ASSERT_SOME        -> oprimEx $ IF_NONE (expandMacro p FAIL) []+  ASSERT_LEFT        -> oprimEx $ IF_LEFT [] (expandMacro p FAIL)+  ASSERT_RIGHT       -> oprimEx $ IF_LEFT (expandMacro p FAIL) []+  PAPAIR ps t v      -> expandPapair p ps t v+  UNPAPAIR ps        -> expandUnpapair p ps+  CADR c v f         -> expandCadr p c v f+  CARN v idx         -> [PrimEx (GETN v (2 * idx + 1))]+  CDRN v idx         -> [PrimEx (GETN v (2 * idx))]+  SET_CADR c v f     -> expandSetCadr p c v f+  MAP_CADR c v f ops -> expandMapCadr p c v f ops+  -- We handle DIIP and DUUP outside.+  DIIP {}            -> error "expandMacro DIIP is unreachable"+  DUUP {}            -> error "expandMacro DUUP is unreachable"++  where+    mac = flip Mac macroPos+    oprimEx = one . PrimEx+    xo = PrimEx . fmap (expand cs)+    xp = fmap (expand cs)++-- | The macro expansion rules below were taken from: https://tezos.gitlab.io/active/michelson.html#syntactic-conveniences+--+-- The correctness of type-annotation expansion is currently untested, as these+-- expansions are not explicitly documented in the Michelson Specification.+expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp]+expandPapair ics ps t v = case ps of+  P (F a) (F b) -> [PrimEx $ PAIR t v a b]++  -- > PA(\right)R / S => DIP ((\right)R) ; PAIR / S+  P (F a) r     -> PrimEx <$> [ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)+                              , PAIR t v a noAnn]++  -- > P(\left)IR / S => (\left)R ; PAIR / S+  P l     (F b) -> expandMacro ics (PAPAIR l noAnn noAnn) +++                   [PrimEx $ PAIR t v noAnn b]++  -- > P(\left)(\right)R =>  (\left)R ; DIP ((\right)R) ; PAIR / S+  P l     r     -> expandMacro ics (PAPAIR l noAnn noAnn) +++                   [ PrimEx $ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)+                   , PrimEx $ PAIR t v noAnn noAnn]++  -- It's impossible from the structure of PairStruct and considered cases above,+  -- but if it accidentally happened let's just do nothing.+  F _           -> []++-- | The macro expansion rules below were taken from: https://tezos.gitlab.io/active/michelson.html#syntactic-conveniences+expandUnpapair :: InstrCallStack -> UnpairStruct -> [ExpandedOp]+expandUnpapair ics = \case+  UP UF UF ->+    [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn) ]++  -- > UNPA(\right)R / S => UNPAIR ; DIP (UN(\right)R) / S+  UP UF r ->+    PrimEx <$> [ UNPAIR noAnn noAnn noAnn noAnn+               , DIP (expandMacro ics (UNPAPAIR r))+               ]++  -- > UNP(\left)IR / S => UNPAIR ; UN(\left)R / S+  UP l UF ->+    PrimEx (UNPAIR noAnn noAnn noAnn noAnn)+      : expandMacro ics (UNPAPAIR l)++  -- > UNP(\left)(\right)R => UNPAIR ; DIP (UN(\right)R) ; UN(\left)R / S+  UP l r ->+    [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)+    , PrimEx $ DIP $ expandMacro ics $ UNPAPAIR r+    ] +++    expandMacro ics (UNPAPAIR l)++  -- It's impossible from the structure of UnpairStruct and considered cases above,+  -- but if it accidentally happened let's just do nothing.+  UF -> []++expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]+expandCadr ics cs v f = case cs of+  []    -> []+  [A]  -> [PrimEx $ CAR v f]+  [D]  -> [PrimEx $ CDR v f]+  A:css -> PrimEx (CAR noAnn noAnn) : expandMacro ics (CADR css v f)+  D:css -> PrimEx (CDR noAnn noAnn) : expandMacro ics (CADR css v f)++carNoAnn :: InstrAbstract op+carNoAnn = CAR [annQ|%%|] noAnn++cdrNoAnn :: InstrAbstract op+cdrNoAnn = CDR [annQ|%%|] noAnn++pairNoAnn :: VarAnn -> InstrAbstract op+pairNoAnn v = PAIR noAnn v [annQ|@|] [annQ|@|]++expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]+expandSetCadr ics cs v f = PrimEx <$> case cs of+  []    -> []+  [A]   -> [DUP noAnn, CAR noAnn f, DROP,+           -- ↑ These operations just check that the left element of pair has %f+           cdrNoAnn, SWAP, PAIR noAnn v f [annQ|@|]]+  [D]   -> [DUP noAnn, CDR noAnn f, DROP,+           -- ↑ These operations just check that the right element of pair has %f+           carNoAnn, PAIR noAnn v [annQ|@|] f]+  A:css -> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (SET_CADR css noAnn f)), cdrNoAnn, SWAP, pairNoAnn v]+  D:css -> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (SET_CADR css noAnn f)), carNoAnn, pairNoAnn v]++expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp]+expandMapCadr ics@InstrCallStack{icsCallStack=cls} cs v f ops = case cs of+  []    -> []+  [A]   -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand cls <$> ops)], SWAP, PAIR noAnn v f [annQ|@|]]+  [D]   -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand cls <$> ops)], PrimEx <$> [SWAP, carNoAnn, PAIR noAnn v [annQ|@|] f]]+  A:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), cdrNoAnn, SWAP, pairNoAnn v]+  D:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), carNoAnn, pairNoAnn v]++expandCase :: NonEmpty [ExpandedOp] -> [ExpandedOp]+expandCase = mkGenericTree (\_ l r -> one . PrimEx $ IF_LEFT l r)++expandTag :: Natural -> NonEmpty Ty -> [ExpandedOp]+expandTag idx unionTy =+  reverse . fst $ mkGenericTree merge (([], ) <$> unionTy)+  where+    merge i (li, lt) (ri, rt) =+      let ty = Ty (TOr noAnn noAnn lt rt) noAnn+      in if idx < i+          then (PrimEx (LEFT noAnn noAnn noAnn noAnn rt) : li, ty)+          else (PrimEx (RIGHT noAnn noAnn noAnn noAnn lt) : ri, ty)++expandAccess :: Natural -> Positive -> [ExpandedOp]+expandAccess idx size =+  mkGenericTree merge (replicateNE size [])+  where+    merge i li ri =+      if idx < i+        then PrimEx (CAR noAnn noAnn) : li+        else PrimEx (CDR noAnn noAnn) : ri++expandSet :: Natural -> Positive -> [ExpandedOp]+expandSet idx size =+  PrimEx <$>+  appEndo (mkGenericTree merge (replicateNE size base)) []+  where+    base = pre $ DIP [PrimEx DROP]+    merge i li ri = mconcat $+      if idx < i+        then [ pre $ DIP+                 (map PrimEx [DUP n, DIP [PrimEx $ CDR n n], CAR n n])+             , li+             , pre $ PAIR n n n n+             ]+        else [ pre $ DIP+                 (map PrimEx [DUP n, DIP [PrimEx $ CAR n n], CDR n n])+             , ri+             , pre $ SWAP+             , pre $ PAIR n n n n+             ]+    pre e = Endo (e :)+    n = noAnn++expandConstruct :: NonEmpty [ExpandedOp] -> [ExpandedOp]+expandConstruct ctors =+  appEndo (mkGenericTree merge $ map toBase ctors) []+  where+    toBase ops = Endo (ops ++)+    merge _ li ri =+      mconcat+        [ li+        , pre . PrimEx $ DIP (appEndo ri [])+        , pre . PrimEx $ PAIR noAnn noAnn noAnn noAnn+        ]+    pre e = Endo (e :)++mapPairLeaves :: [FieldAnn] -> PairStruct -> PairStruct+mapPairLeaves fs p = evalState (pairLeavesST p) fs++pairLeavesST :: PairStruct -> State [FieldAnn] PairStruct+pairLeavesST = \case+  (P l r) -> do+    l' <- pairLeavesST l+    r' <- pairLeavesST r+    return $ P l' r'+  (F _) -> do+    f <- state getLeaf+    return $ F f+    where+      getLeaf (a:as) = (a, as)+      getLeaf _      = (noAnn, [])++deriveJSON morleyAesonOptions ''ParsedOp+deriveJSON morleyAesonOptions ''LetMacro+deriveJSON morleyAesonOptions ''PairStruct+deriveJSON morleyAesonOptions ''UnpairStruct+deriveJSON morleyAesonOptions ''CadrStruct+deriveJSON morleyAesonOptions ''Macro

+ src/Morley/Michelson/Optimizer.hs view

@@ -0,0 +1,641 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- NOTE this pragmas.+-- We disable some wargnings for the sake of speed up.+-- Write code with care.+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}++-- | Optimizer for typed instructions.+--+-- It's quite experimental and incomplete.++module Morley.Michelson.Optimizer+  ( optimize+  , optimizeWithConf+  , defaultOptimizerConf+  , defaultRules+  , defaultRulesAndPushPack+  , orRule+  , orSimpleRule+  , Rule+  , OptimizerConf (..)+  , ocGotoValuesL+  ) where++import Prelude hiding (EQ, GT, LT)++import Control.Lens (makeLensesFor)+import Data.Constraint (Dict(..))+import Data.Default (Default(def))+import Data.Singletons (sing)++import Morley.Michelson.Interpret.Pack (packValue')+import Morley.Michelson.Typed.Aliases (Value)+import Morley.Michelson.Typed.Arith+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.Scope (ConstantScope, PackedValScope, checkScope)+import Morley.Michelson.Typed.Sing+import Morley.Michelson.Typed.T+import Morley.Michelson.Typed.Util (DfsSettings(..), dfsInstr)+import Morley.Michelson.Typed.Value+import Morley.Util.PeanoNatural++----------------------------------------------------------------------------+-- High level+----------------------------------------------------------------------------++data OptimizerConf = OptimizerConf+  { ocGotoValues :: Bool+  , ocRuleset    :: [Rule]+  }++-- | Default config - all commonly useful rules will be applied to all the code.+defaultOptimizerConf :: OptimizerConf+defaultOptimizerConf = OptimizerConf+  { ocGotoValues = True+  , ocRuleset    = defaultRules+  }++instance Default OptimizerConf where+  def = defaultOptimizerConf++-- | Optimize a typed instruction by replacing some sequences of+-- instructions with smaller equivalent sequences.+-- Applies default set of rewrite rules.+optimize :: Instr inp out -> Instr inp out+optimize = optimizeWithConf def++-- | Optimize a typed instruction using a custom set of rules.+-- The set is divided into several stages, as applying+-- some rules can prevent others to be performed.+optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out+optimizeWithConf (OptimizerConf ocGotoValues rules) instr = foldl (flip performOneStage) instrRHS rules+  where+    dfsSettings = def{ dsGoToValues = ocGotoValues }+    performOneStage stageRules = (fst .)+      $ dfsInstr dfsSettings+      $ (adapter .)+      $ applyOnce stageRules+    instrRHS = applyOnce (fixpoint flattenSeqLHS) instr++----------------------------------------------------------------------------+-- Rewrite rules+----------------------------------------------------------------------------++-- Type of a single rewrite rule, wrapped in `newtype`. It takes an instruction+-- and tries to optimize its head (first few instructions). If optimization+-- succeeds, it returns `Just` the optimized instruction, otherwise it returns `Nothing`.+newtype Rule = Rule {unRule :: forall inp out. Instr inp out -> Maybe (Instr inp out)}++defaultRules :: [Rule]+defaultRules = map fixpoint+  [ mainStageRules+  , glueAdjacentDropsStageRules+  ]+  where+    glueAdjacentDropsStageRules = flattenSeqLHS `orSimpleRule` adjacentDrops++-- | We do not enable 'pushPack' rule by default because it is+-- potentially dangerous.+-- There are various code processing functions that may depend on constants,+-- e. g. string transformations.+-- need helper+defaultRulesAndPushPack :: [Rule]+defaultRulesAndPushPack =+  case defaultRules of+    -- Perhaps one day main rules will not be performed on the first stage.+    -- We need another way to add `pushPack` to `mainStageRules` in that case.+    _ : otherStagesRules -> do+      let mainStageRulesAndPushPack = fixpoint $ mainStageRules `orSimpleRule` pushPack+      mainStageRulesAndPushPack : otherStagesRules+    _ -> error "`defaultRules` should not be empty"++mainStageRules :: Rule -> Rule+mainStageRules =+  flattenSeqLHS+    `orSimpleRule` removeNesting+    `orSimpleRule` removeExtStackType+    `orSimpleRule` flattenFn+    `orSimpleRule` dipDrop2swapDrop+    `orSimpleRule` ifNopNop2Drop+    `orSimpleRule` nopIsNeutralForSeq+    `orSimpleRule` variousNops+    `orSimpleRule` dupSwap2dup+    `orSimpleRule` noDipNeeded+    `orSimpleRule` branchShortCut+    `orSimpleRule` compareWithZero+    `orSimpleRule` simpleDrops+    `orSimpleRule` internalNop+    `orSimpleRule` simpleDips+    `orSimpleRule` adjacentDips+    `orSimpleRule` isSomeOnIf+    `orSimpleRule` specificPush+    `orSimpleRule` pairUnpair+    `orSimpleRule` pairMisc+    `orSimpleRule` unpairMisc+    `orSimpleRule` swapBeforeCommutative+    `orSimpleRule` justDrops+    `orSimpleRule` justDoubleDrops++flattenSeqLHS :: Rule -> Rule+flattenSeqLHS toplevel = Rule $ \case+  it@(Seq (Seq _ _) _) -> Just $ linearizeAndReapply toplevel it+  _                    -> Nothing++removeNesting :: Rule+removeNesting = Rule $ \case+  Nested i -> Just i+  _        -> Nothing++-- | STACKTYPE is currently a Nop and may safely be removed.+removeExtStackType :: Rule+removeExtStackType = Rule $ \case+  Ext (STACKTYPE{}) -> Just Nop+  _                 -> Nothing++flattenFn :: Rule+flattenFn = Rule $ \case+  Fn _ _ i -> Just i+  _        -> Nothing++dipDrop2swapDrop :: Rule+dipDrop2swapDrop = Rule $ \case+  DIP DROP -> Just $ SWAP :# DROP+  _        -> Nothing++ifNopNop2Drop :: Rule+ifNopNop2Drop = Rule $ \case+  IF Nop Nop -> Just DROP+  _          -> Nothing++nopIsNeutralForSeq :: Rule+nopIsNeutralForSeq = Rule $ \case+  Nop :# i   -> Just i+  i   :# Nop -> Just i+  _          -> Nothing++variousNops :: Rule+variousNops = Rule $ \case+  DUP                :# DROP :# c -> Just c+  DUPN _             :# DROP :# c -> Just c+  SWAP               :# SWAP :# c -> Just c+  PUSH _             :# DROP :# c -> Just c+  NONE               :# DROP :# c -> Just c+  UNIT               :# DROP :# c -> Just c+  NIL                :# DROP :# c -> Just c+  EMPTY_SET          :# DROP :# c -> Just c+  EMPTY_MAP          :# DROP :# c -> Just c+  EMPTY_BIG_MAP      :# DROP :# c -> Just c+  LAMBDA _           :# DROP :# c -> Just c+  SELF _             :# DROP :# c -> Just c+  NOW                :# DROP :# c -> Just c+  AMOUNT             :# DROP :# c -> Just c+  BALANCE            :# DROP :# c -> Just c+  TOTAL_VOTING_POWER :# DROP :# c -> Just c+  SOURCE             :# DROP :# c -> Just c+  SENDER             :# DROP :# c -> Just c+  CHAIN_ID           :# DROP :# c -> Just c+  LEVEL              :# DROP :# c -> Just c+  SELF_ADDRESS       :# DROP :# c -> Just c+  READ_TICKET        :# DROP :# c -> Just c++  DUP                :# DROP -> Just Nop+  DUPN _             :# DROP -> Just Nop+  SWAP               :# SWAP -> Just Nop+  PUSH _             :# DROP -> Just Nop+  NONE               :# DROP -> Just Nop+  UNIT               :# DROP -> Just Nop+  NIL                :# DROP -> Just Nop+  EMPTY_SET          :# DROP -> Just Nop+  EMPTY_MAP          :# DROP -> Just Nop+  EMPTY_BIG_MAP      :# DROP -> Just Nop+  LAMBDA _           :# DROP -> Just Nop+  SELF _             :# DROP -> Just Nop+  NOW                :# DROP -> Just Nop+  AMOUNT             :# DROP -> Just Nop+  BALANCE            :# DROP -> Just Nop+  TOTAL_VOTING_POWER :# DROP -> Just Nop+  SOURCE             :# DROP -> Just Nop+  SENDER             :# DROP -> Just Nop+  CHAIN_ID           :# DROP -> Just Nop+  LEVEL              :# DROP -> Just Nop+  SELF_ADDRESS       :# DROP -> Just Nop+  READ_TICKET        :# DROP -> Just Nop+  _                          -> Nothing++dupSwap2dup :: Rule+dupSwap2dup = Rule $ \case+  DUP :# SWAP :# c -> Just (DUP :# c)+  DUP :# SWAP      -> Just DUP+  _                -> Nothing++noDipNeeded :: Rule+noDipNeeded = Rule $ \case+  -- If we put a constant value on stack and then do something under it,+  -- we can do this "something" on original stack and then put that constant.+  PUSH x    :# DIP f :# c -> Just $ f :# PUSH x :# c+  PUSH x    :# DIP f      -> Just $ f :# PUSH x+  UNIT      :# DIP f :# c -> Just $ f :# UNIT :# c+  UNIT      :# DIP f      -> Just $ f :# UNIT+  NOW       :# DIP f :# c -> Just $ f :# NOW :# c+  NOW       :# DIP f      -> Just $ f :# NOW+  SENDER    :# DIP f :# c -> Just $ f :# SENDER :# c+  SENDER    :# DIP f      -> Just $ f :# SENDER+  EMPTY_MAP :# DIP f :# c -> Just $ f :# EMPTY_MAP :# c+  EMPTY_MAP :# DIP f      -> Just $ f :# EMPTY_MAP+  EMPTY_SET :# DIP f :# c -> Just $ f :# EMPTY_SET :# c+  EMPTY_SET :# DIP f      -> Just $ f :# EMPTY_SET++  -- If we do something ignoring top of the stack and then immediately+  -- drop top of the stack, we can drop that item in advance and+  -- not use 'DIP' at all.+  DIP f :# DROP :# c -> Just $ DROP :# f :# c+  DIP f :# DROP         -> Just $ DROP :# f++  _ -> Nothing++branchShortCut :: Rule+branchShortCut = Rule $ \case+  LEFT  :# IF_LEFT f _ :# c -> Just (f :# c)+  RIGHT :# IF_LEFT _ f :# c -> Just (f :# c)+  CONS  :# IF_CONS f _ :# c -> Just (f :# c)+  NIL   :# IF_CONS _ f :# c -> Just (f :# c)+  NONE  :# IF_NONE f _ :# c -> Just (f :# c)+  SOME  :# IF_NONE _ f :# c -> Just (f :# c)++  PUSH vOr@(VOr eitherVal) :# IF_LEFT f g :# c -> case vOr of+    (_ :: Value ('TOr l r)) -> case eitherVal of+      Left val -> case checkScope @(ConstantScope l) of+        Right Dict -> Just (PUSH val :# f :# c)+        _          -> Nothing+      Right val -> case checkScope @(ConstantScope r) of+        Right Dict -> Just (PUSH val :# g :# c)+        _          -> Nothing+  PUSH (VList (x : xs))     :# IF_CONS f _ :# c -> Just (PUSH (VList xs) :# PUSH x :# f :# c)+  PUSH (VList _)            :# IF_CONS _ f :# c -> Just (f :# c)+  PUSH (VOption Nothing)    :# IF_NONE f _ :# c -> Just (f :# c)+  PUSH (VOption (Just val)) :# IF_NONE _ f :# c -> Just (PUSH val :# f :# c)+  PUSH (VBool True)         :# IF f _      :# c -> Just (f :# c)+  PUSH (VBool False)        :# IF _ f      :# c -> Just (f :# c)++  LEFT  :# IF_LEFT f _ -> Just f+  RIGHT :# IF_LEFT _ f -> Just f+  CONS  :# IF_CONS f _ -> Just f+  NIL   :# IF_CONS _ f -> Just f+  NONE  :# IF_NONE f _ -> Just f+  SOME  :# IF_NONE _ f -> Just f++  PUSH vOr@(VOr eitherVal) :# IF_LEFT f g -> case vOr of+    (_ :: Value ('TOr l r)) -> case eitherVal of+      Left val -> case checkScope @(ConstantScope l) of+        Right Dict -> Just (PUSH val :# f)+        _          -> Nothing+      Right val -> case checkScope @(ConstantScope r) of+        Right Dict -> Just (PUSH val :# g)+        _          -> Nothing+  PUSH (VList (x : xs))     :# IF_CONS f _ -> Just (PUSH (VList xs) :# PUSH x :# f)+  PUSH (VList _)            :# IF_CONS _ f -> Just f+  PUSH (VOption Nothing)    :# IF_NONE f _ -> Just f+  PUSH (VOption (Just val)) :# IF_NONE _ f -> Just (PUSH val :# f)+  PUSH (VBool True)         :# IF f _      -> Just f+  PUSH (VBool False)        :# IF _ f      -> Just f++  _ -> Nothing++compareWithZero :: Rule+compareWithZero = Rule $ \case+  PUSH (VInt 0) :# COMPARE :# EQ :# c -> Just $ EQ :# c+  PUSH (VNat 0) :# COMPARE :# EQ :# c -> Just $ INT :# EQ :# c+  PUSH (VInt 0) :# COMPARE :# EQ      -> Just $ EQ+  PUSH (VNat 0) :# COMPARE :# EQ      -> Just $ INT :# EQ+  _                                   -> Nothing++simpleDrops :: Rule+simpleDrops = Rule $ \case+  -- DROP 0 is Nop+  DROPN Zero :# c -> Just c+  DROPN Zero -> Just Nop++  -- DROP 1 is DROP.+  -- @gromak: DROP seems to be cheaper (in my experiments it consumed 3 less gas).+  -- It is packed more efficiently.+  -- Unfortunately I do not know how to convince GHC that types match here.+  -- Specifically, it can not deduce that `inp` is not empty+  -- (`DROP` expects non-empty input).+  -- We have `LongerOrSameLength inp (S Z)` here, but that is not enough to+  -- convince GHC.+  -- I will leave this note and rule here in hope that someone will manage to+  -- deal with this problem one day.++  -- DROPN One :# c -> Just (DROP :# c)+  -- DROPN One -> Just DROP++  _ -> Nothing++-- If an instruction takes another instruction as an argument and that+-- internal instruction is 'Nop', sometimes the whole instruction is+-- 'Nop'.+-- For now we do it only for 'DIP', but ideally we should do it for+-- 'MAP' as well (which is harder).+internalNop :: Rule+internalNop = Rule $ \case+  DIP Nop      -> Just Nop+  DIP Nop :# c -> Just c++  _ -> Nothing++simpleDips :: Rule+simpleDips = Rule $ \case+  -- DIP 0 is redundant+  DIPN Zero i :# c -> Just (i :# c)+  DIPN Zero i -> Just i++  -- @gromak: same situation as with `DROP 1` (see above).+  -- DIPN One i :# c -> Just (DIP i :# c)+  -- DIPN One i -> Just (DIP i)++  _ -> Nothing++adjacentDips :: Rule+adjacentDips = Rule $ \case+  DIP f :# DIP g -> Just (DIP (f :# g))+  DIP f :# DIP g :# c -> Just (DIP (f :# g) :# c)++  _ -> Nothing++-- TODO (#299): optimize sequences of more than 2 DROPs.+-- | Sequences of @DROP@s can be turned into single @DROP n@.+-- When @n@ is greater than 2 it saves size and gas.+-- When @n@ is 2 it saves gas only.+adjacentDrops :: Rule+adjacentDrops = Rule $ \case+  DROP :# DROP -> Just (DROPN Two)+  DROP :# DROP :# c -> Just (DROPN Two :# c)++  -- Does not compile, need to do something smart+  -- DROPN Two :# DROP -> Just (DROPN (Succ Two))++  _ -> Nothing++specificPush :: Rule+specificPush = Rule $ \case+  push@PUSH{}         -> optimizePush push+  push@PUSH{} :# c -> (:# c) <$> optimizePush push++  _ -> Nothing+  where+    optimizePush :: Instr inp out -> Maybe (Instr inp out)+    optimizePush = \case+      PUSH v | _ :: Value v <- v -> case v of+        VUnit -> Just UNIT+        VMap m+          | null m -> case sing @v of STMap{} -> Just EMPTY_MAP+        VSet m+          | null m -> case sing @v of STSet{} -> Just EMPTY_SET+        _ -> Nothing++      _ -> Nothing+++isSomeOnIf :: Rule+isSomeOnIf = Rule $ \case+  IF (PUSH (VOption Just{})) (PUSH (VOption Nothing)) :# c -> case c of+    IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True)) :# s -> Just s+    IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True))      -> Just Nop+    _ -> Nothing+  _ -> Nothing++pairUnpair :: Rule+pairUnpair = Rule $ \case+  PAIR :# UNPAIR :# c -> Just c+  PAIR :# UNPAIR      -> Just Nop++  UNPAIR :# PAIR :# c -> Just c+  UNPAIR :# PAIR      -> Just Nop++  _ -> Nothing++pairMisc :: Rule+pairMisc = Rule $ \case+  PAIR :# CDR :# c -> Just $ DROP :# c+  PAIR :# CDR      -> Just DROP++  PAIR :# CAR :# c -> Just $ (DIP DROP) :# c+  PAIR :# CAR      -> Just $ DIP DROP++  _ -> Nothing++unpairMisc :: Rule+unpairMisc = Rule $ \case+  DUP :# CAR :# DIP CDR      -> Just $ UNPAIR+  DUP :# CAR :# DIP CDR :# c -> Just $ UNPAIR :# c++  DUP :# CDR :# DIP CAR      -> Just $ UNPAIR :# SWAP+  DUP :# CDR :# DIP CAR :# c -> Just $ UNPAIR :# SWAP :# c++  UNPAIR :# DROP             -> Just CDR+  UNPAIR :# DROP :# c        -> Just $ CDR :# c+  _ -> Nothing++commuteArith ::+  forall n m s out. Instr (n ': m ': s) out -> Maybe (Instr (m ': n ': s) out)+commuteArith = \case+  ADD -> do Dict <- commutativityProof @Add @n @m; Just ADD+  MUL -> do Dict <- commutativityProof @Mul @n @m; Just MUL+  OR -> do Dict <- commutativityProof @Or @n @m; Just OR+  AND -> do Dict <- commutativityProof @And @n @m; Just AND+  XOR -> do Dict <- commutativityProof @Xor @n @m; Just XOR+  _ -> Nothing++swapBeforeCommutative :: Rule+swapBeforeCommutative = Rule $ \case+  SWAP :# i :# c -> (:# c) <$> commuteArith i+  SWAP :# i -> commuteArith i++  _ -> Nothing++pushPack :: Rule+pushPack = Rule $ \case+  PUSH x :# PACK -> Just (pushPacked x)+  PUSH x :# PACK :# c -> Just (pushPacked x :# c)++  _ -> Nothing+  where+    pushPacked :: PackedValScope t => Value t -> Instr s ('TBytes ': s)+    pushPacked = PUSH . VBytes . packValue'++justDrops :: Rule+justDrops = Rule $ \case+  CAR              :# DROP :# c -> Just $ DROP :# c+  CDR              :# DROP :# c -> Just $ DROP :# c+  SOME             :# DROP :# c -> Just $ DROP :# c+  LEFT             :# DROP :# c -> Just $ DROP :# c+  RIGHT            :# DROP :# c -> Just $ DROP :# c+  SIZE             :# DROP :# c -> Just $ DROP :# c+  GETN _           :# DROP :# c -> Just $ DROP :# c+  CAST             :# DROP :# c -> Just $ DROP :# c+  RENAME           :# DROP :# c -> Just $ DROP :# c+  PACK             :# DROP :# c -> Just $ DROP :# c+  UNPACK           :# DROP :# c -> Just $ DROP :# c+  CONCAT'          :# DROP :# c -> Just $ DROP :# c+  ISNAT            :# DROP :# c -> Just $ DROP :# c+  ABS              :# DROP :# c -> Just $ DROP :# c+  NEG              :# DROP :# c -> Just $ DROP :# c+  NOT              :# DROP :# c -> Just $ DROP :# c+  EQ               :# DROP :# c -> Just $ DROP :# c+  NEQ              :# DROP :# c -> Just $ DROP :# c+  LT               :# DROP :# c -> Just $ DROP :# c+  GT               :# DROP :# c -> Just $ DROP :# c+  LE               :# DROP :# c -> Just $ DROP :# c+  GE               :# DROP :# c -> Just $ DROP :# c+  INT              :# DROP :# c -> Just $ DROP :# c+  CONTRACT _ _     :# DROP :# c -> Just $ DROP :# c+  SET_DELEGATE     :# DROP :# c -> Just $ DROP :# c+  IMPLICIT_ACCOUNT :# DROP :# c -> Just $ DROP :# c+  VOTING_POWER     :# DROP :# c -> Just $ DROP :# c+  SHA256           :# DROP :# c -> Just $ DROP :# c+  SHA512           :# DROP :# c -> Just $ DROP :# c+  BLAKE2B          :# DROP :# c -> Just $ DROP :# c+  SHA3             :# DROP :# c -> Just $ DROP :# c+  KECCAK           :# DROP :# c -> Just $ DROP :# c+  HASH_KEY         :# DROP :# c -> Just $ DROP :# c+  PAIRING_CHECK    :# DROP :# c -> Just $ DROP :# c+  ADDRESS          :# DROP :# c -> Just $ DROP :# c+  JOIN_TICKETS     :# DROP :# c -> Just $ DROP :# c++  CAR              :# DROP      -> Just DROP+  CDR              :# DROP      -> Just DROP+  SOME             :# DROP      -> Just DROP+  LEFT             :# DROP      -> Just DROP+  RIGHT            :# DROP      -> Just DROP+  SIZE             :# DROP      -> Just DROP+  GETN _           :# DROP      -> Just DROP+  CAST             :# DROP      -> Just DROP+  RENAME           :# DROP      -> Just DROP+  PACK             :# DROP      -> Just DROP+  UNPACK           :# DROP      -> Just DROP+  CONCAT'          :# DROP      -> Just DROP+  ISNAT            :# DROP      -> Just DROP+  ABS              :# DROP      -> Just DROP+  NEG              :# DROP      -> Just DROP+  NOT              :# DROP      -> Just DROP+  EQ               :# DROP      -> Just DROP+  NEQ              :# DROP      -> Just DROP+  LT               :# DROP      -> Just DROP+  GT               :# DROP      -> Just DROP+  LE               :# DROP      -> Just DROP+  GE               :# DROP      -> Just DROP+  INT              :# DROP      -> Just DROP+  CONTRACT _ _     :# DROP      -> Just DROP+  SET_DELEGATE     :# DROP      -> Just DROP+  IMPLICIT_ACCOUNT :# DROP      -> Just DROP+  VOTING_POWER     :# DROP      -> Just DROP+  SHA256           :# DROP      -> Just DROP+  SHA512           :# DROP      -> Just DROP+  BLAKE2B          :# DROP      -> Just DROP+  SHA3             :# DROP      -> Just DROP+  KECCAK           :# DROP      -> Just DROP+  HASH_KEY         :# DROP      -> Just DROP+  PAIRING_CHECK    :# DROP      -> Just DROP+  ADDRESS          :# DROP      -> Just DROP+  JOIN_TICKETS     :# DROP      -> Just DROP+  _                             -> Nothing++justDoubleDrops :: Rule+justDoubleDrops = Rule $ \case+  PAIR         :# DROP :# c -> Just $ DROP :# DROP :# c+  MEM          :# DROP :# c -> Just $ DROP :# DROP :# c+  GET          :# DROP :# c -> Just $ DROP :# DROP :# c+  APPLY        :# DROP :# c -> Just $ DROP :# DROP :# c+  CONCAT       :# DROP :# c -> Just $ DROP :# DROP :# c+  ADD          :# DROP :# c -> Just $ DROP :# DROP :# c+  SUB          :# DROP :# c -> Just $ DROP :# DROP :# c+  MUL          :# DROP :# c -> Just $ DROP :# DROP :# c+  EDIV         :# DROP :# c -> Just $ DROP :# DROP :# c+  OR           :# DROP :# c -> Just $ DROP :# DROP :# c+  AND          :# DROP :# c -> Just $ DROP :# DROP :# c+  XOR          :# DROP :# c -> Just $ DROP :# DROP :# c+  COMPARE      :# DROP :# c -> Just $ DROP :# DROP :# c+  TICKET       :# DROP :# c -> Just $ DROP :# DROP :# c+  SPLIT_TICKET :# DROP :# c -> Just $ DROP :# DROP :# c+  SWAP :# DROP :# DROP :# c -> Just $ DROP :# DROP :# c++  PAIR         :# DROP      -> Just $ DROP :# DROP+  MEM          :# DROP      -> Just $ DROP :# DROP+  GET          :# DROP      -> Just $ DROP :# DROP+  APPLY        :# DROP      -> Just $ DROP :# DROP+  CONCAT       :# DROP      -> Just $ DROP :# DROP+  ADD          :# DROP      -> Just $ DROP :# DROP+  SUB          :# DROP      -> Just $ DROP :# DROP+  MUL          :# DROP      -> Just $ DROP :# DROP+  EDIV         :# DROP      -> Just $ DROP :# DROP+  OR           :# DROP      -> Just $ DROP :# DROP+  AND          :# DROP      -> Just $ DROP :# DROP+  XOR          :# DROP      -> Just $ DROP :# DROP+  COMPARE      :# DROP      -> Just $ DROP :# DROP+  TICKET       :# DROP      -> Just $ DROP :# DROP+  SPLIT_TICKET :# DROP      -> Just $ DROP :# DROP+  SWAP :# DROP :# DROP      -> Just $ DROP :# DROP++  _ -> Nothing++-- | Append LHS of v'Seq' to RHS and re-run pointwise ocRuleset at each point.+--   That might cause reinvocation of this function (see 'defaultRules'),+--   but effectively this ensures it will flatten any v'Seq'-tree right-to-left,+--   while evaling no more than once on each node.+--+--   The reason this function invokes ocRuleset is when you append an instr+--   to already-optimised RHS of v'Seq', you might get an optimisable tree.+--+--   The argument is a local, non-structurally-recursive ocRuleset.+linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out+linearizeAndReapply restart = \case+  Seq (Seq a b) c ->+    applyOnce restart $ Seq a (linearizeAndReapply restart (Seq b c))++  other -> applyOnce restart other++----------------------------------------------------------------------------+-- Generic functions working with rules+----------------------------------------------------------------------------++-- | Combine two rule fixpoints.+orRule :: (Rule -> Rule) -> (Rule -> Rule) -> (Rule -> Rule)+orRule l r topl = Rule $ \instr ->+  (unRule (l topl) $ instr) <|> (unRule (r topl) $ instr)++-- | Combine a rule fixpoint and a simple rule.+orSimpleRule :: (Rule -> Rule) -> Rule -> (Rule -> Rule)+orSimpleRule l r topl = Rule $ \instr ->+  (unRule (l topl) $ instr) <|> (unRule r $ instr)++-- | Turn rule fixpoint into rule.+fixpoint :: (Rule -> Rule) -> Rule+fixpoint r = go+  where+    go :: Rule+    go = whileApplies (r go)++-- | Apply the rule once, if it fails, return the instruction unmodified.+applyOnce :: Rule -> Instr inp out -> Instr inp out+applyOnce r i = maybe i id (unRule r $ i)++-- | An adapter for `dfsInstr`.+adapter :: a -> (a, ())+adapter a = (a, ())++-- | Apply a rule to the same code, until it fails.+whileApplies :: Rule -> Rule+whileApplies r = Rule go+  where+    go :: Instr inp out -> Maybe (Instr inp out)+    go i = maybe (Just i) go (unRule r $ i)++----------------------------------------------------------------------------+-- TH+----------------------------------------------------------------------------++makeLensesFor [("ocGotoValues", "ocGotoValuesL")] ''OptimizerConf

+ src/Morley/Michelson/Parser.hs view

@@ -0,0 +1,322 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Parser+  ( -- * Main parser type+    Parser++  -- * Parsers+  , program+  , value++  -- * Errors+  , CustomParserException (..)+  , ParseErrorBundle+  , ParserException (..)+  , StringLiteralParserException (..)++  -- * Additional helpers+  , MichelsonSource (..)+  , codeSrc+  , parseNoEnv+  , parseValue+  , parseExpandValue++  -- * For tests+  , codeEntry+  , ops+  , type_+  , letInner+  , letType+  , stringLiteral+  , bytesLiteral+  , intLiteral+  , parsedOp+  , printComment++  -- * Quoters+  , utypeQ+  , uparamTypeQ++  -- * Re-exports+  , errorBundlePretty+  ) where++import Prelude hiding (try)++import Fmt (pretty)+import qualified Language.Haskell.TH.Lift as TH+import qualified Language.Haskell.TH.Quote as TH+import Text.Megaparsec+  (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead,+  parse, try)+import Text.Megaparsec.Pos (SourcePos(..), unPos)++import Morley.Michelson.ErrorPos (SrcPos(..), unsafeMkPos)+import Morley.Michelson.Macro+  (LetMacro, Macro(..), ParsedInstr, ParsedOp(..), ParsedValue, expandValue)+import Morley.Michelson.Parser.Annotations (noteF)+import Morley.Michelson.Parser.Error+import Morley.Michelson.Parser.Ext+import Morley.Michelson.Parser.Instr+import Morley.Michelson.Parser.Let+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Macro+import Morley.Michelson.Parser.Type+import Morley.Michelson.Parser.Types+import Morley.Michelson.Parser.Value+import Morley.Michelson.Untyped+import qualified Morley.Michelson.Untyped as U++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Parse with empty environment+parseNoEnv ::+     Parser a+  -> MichelsonSource+  -> Text+  -> Either (ParseErrorBundle Text CustomParserException) a+parseNoEnv p src = parse (runReaderT p noLetEnv <* eof) (pretty src)++-------------------------------------------------------------------------------+-- Parsers+-------------------------------------------------------------------------------++-- Contract+------------------++-- | Michelson contract with let definitions+program :: Parsec CustomParserException Text (Contract' ParsedOp)+program = runReaderT programInner noLetEnv <* eof+  where+    programInner :: Parser (Contract' ParsedOp)+    programInner = do+      mSpace+      env <- fromMaybe noLetEnv <$> (optional (letBlock parsedOp))+      local (const env) contract++cbParameter :: Parser ParameterType+cbParameter = symbol "parameter" *> cbParameterBare++cbParameterBare :: Parser ParameterType+cbParameterBare = do+  prefixRootAnn <- optional noteF+  (inTypeRootAnn, t) <- field+  rootAnn <- case (prefixRootAnn, inTypeRootAnn) of+    -- TODO: [#310] Handle cases where there are 2 empty root annotations.+    -- For example: root % (unit %) which should throw the error.+    (Just a, b) | a == noAnn && b == noAnn -> pure noAnn+    (Just a, b) | b == noAnn -> pure a+    (Nothing, b) -> pure b+    (Just _, _) -> customFailure MultiRootAnnotationException+  pure $ ParameterType t rootAnn++cbStorage :: Parser Ty+cbStorage = symbol "storage" *> type_++cbCode :: Parser [ParsedOp]+cbCode = symbol "code" *> codeEntry++contractBlock :: Parser (ContractBlock ParsedOp)+contractBlock = choice+  [ (CBParam <$> cbParameter)+  , (CBStorage <$> cbStorage)+  , (CBCode <$> cbCode)+  ]++-- | This ensures that the error message will point to the correct line.+ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()+ensureNotDuplicate blocks result =+  let+    failDuplicateField a = fail $ "Duplicate contract field: " <> a+  in+    case (result, blocks) of+      (CBParam _, CBParam _ : _) -> failDuplicateField "parameter"+      (CBStorage _, CBStorage _: _) -> failDuplicateField "storage"+      (CBCode _, CBCode _: _) -> failDuplicateField "code"+      (_, _:xs) -> ensureNotDuplicate xs result+      (_, []) -> pure ()++-- | Michelson contract+contract :: Parser (Contract' ParsedOp)+contract = do+  mSpace+  result <- braces contractTuple <|> contractTuple+  case orderContractBlock result of+    Just contract' ->+      return contract'+    Nothing ->+      fail $ "Duplicate contract field: " <> show result+  where+    -- | @ensureNotDuplicate@ provides a better message and point to the correct line+    -- when the parser fails.+    contractTuple = do+      result1 <- contractBlock+      semicolon++      result2 <- do+        r <- contractBlock+        ensureNotDuplicate [result1] r+        pure r+      semicolon++      result3 <- do+        r <- contractBlock+        ensureNotDuplicate [result1, result2] r+        pure r+      optional semicolon+      pure (result1, result2, result3)++-- Value+------------------++value :: Parser ParsedValue+value = value' parsedOp++-- | Parse untyped value from text which comes from something that is+-- not a file (which is often the case). So we assume it does not need+-- any parsing environment.+--+-- >>> parseValue MSUnspecified "{PUSH int aaa}"+-- Left 1:11:+--   |+-- 1 | {PUSH int aaa}+--   |           ^^^^+-- unexpected "aaa}"+-- expecting value+-- <BLANKLINE>+parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue+parseValue = first ParserException ... parseNoEnv value++-- | Like 'parseValue', but also expands macros.+parseExpandValue :: MichelsonSource -> Text -> Either ParserException U.Value+parseExpandValue = fmap expandValue ... parseValue++-- Primitive instruction+------------------++prim :: Parser ParsedInstr+prim = primInstr contract parsedOp++-- Parsed operations (primitive instructions, macros, extras, etc.)+------------------++-- | Parses code block after "code" keyword of a contract.+--+-- This function is part of the module API, its semantics should not change.+codeEntry :: Parser [ParsedOp]+codeEntry = bracewrappedOps++bracewrappedOps :: Parser [ParsedOp]+bracewrappedOps = lookAhead (symbol "{") *> ops++-- |+-- >>> first ParserException $ parseNoEnv parsedOp "" "{a}"+-- Left 1:2:+--   |+-- 1 | {a}+--   |  ^+-- unexpected 'a'+-- expecting '{', '}', macro, morley instruction, or primitive instruction+-- <BLANKLINE>+parsedOp :: Parser ParsedOp+parsedOp = do+  lms <- asks letMacros+  pos <- getSrcPos+  choice+    [ flip Prim pos <$> (EXT <$> extInstr ops)+    , lmacWithPos (mkLetMac lms)+    , flip Prim pos <$> prim+    , flip Mac pos <$> macro parsedOp+    , primOrMac+    , flip Seq pos <$> bracewrappedOps+    ]+  where+    lmacWithPos :: Parser LetMacro -> Parser ParsedOp+    lmacWithPos act = do+      srcPos <- getSrcPos+      flip LMac srcPos <$> act++getSrcPos :: Parser SrcPos+getSrcPos = do+  sp <- getSourcePos+  let l = unPos $ sourceLine sp+  let c = unPos $ sourceColumn sp+  -- reindexing starting from 0+  pure $ SrcPos (unsafeMkPos $ l - 1) (unsafeMkPos $ c - 1)++primWithPos :: Parser ParsedInstr -> Parser ParsedOp+primWithPos act = do+  srcPos <- getSrcPos+  flip Prim srcPos <$> act++macWithPos :: Parser Macro -> Parser ParsedOp+macWithPos act = do+  srcPos <- getSrcPos+  flip Mac srcPos <$> act++ops :: Parser [ParsedOp]+ops = ops' parsedOp++-------------------------------------------------------------------------------+-- Mixed parsers+-- These are needed for better error messages+-------------------------------------------------------------------------------++ifOrIfX :: Parser ParsedOp+ifOrIfX = do+  pos <- getSrcPos+  symbol' "IF"+  a <- eitherP cmpOp ops+  case a of+    Left cmp -> flip Mac pos <$> (IFX cmp <$> ops <*> ops)+    Right op -> flip Prim pos <$> (IF op <$> ops)++-- Some of the operations and macros have the same prefixes in their names+-- So this case should be handled separately+primOrMac :: Parser ParsedOp+primOrMac = hidden+   $  (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)+  <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))+  <|> (try (primWithPos pairOp) <|> try (primWithPos pairNOp) <|> macWithPos pairMac)+  <|> (try (macWithPos duupMac) <|> primWithPos dupOp)+  <|> (try (macWithPos carnMac) <|> try (macWithPos cdrnMac) <|> try (macWithPos cadrMac) <|> primWithPos carOp <|> primWithPos cdrOp)++-------------------------------------------------------------------------------+-- Safe construction of Haskell values+-------------------------------------------------------------------------------++parserToQuasiQuoter :: TH.Lift a => Parser a -> TH.QuasiQuoter+parserToQuasiQuoter parser = TH.QuasiQuoter+  { TH.quoteExp = \s ->+      case parseNoEnv (mSpace *> parser) "quasi-quoter" (toText s) of+        Left err -> fail $ errorBundlePretty err+        Right res -> [e| res |]+  , TH.quotePat = \_ -> fail "Cannot be used as pattern"+  , TH.quoteType = \_ -> fail "Cannot be used as type"+  , TH.quoteDec = \_ -> fail "Cannot be used as declaration"+  }++-- | Creates 'U.Ty' by its Morley representation.+--+-- >>> [utypeQ| (int :a | nat :b) |]+-- Ty (TOr % % (Ty TInt :a) (Ty TNat :b)) :+--+-- >>> [utypeQ|a|]+-- <BLANKLINE>+-- ...+--   |+-- 1 | a+--   | ^+-- unexpected 'a'+-- expecting type+-- ...+utypeQ :: TH.QuasiQuoter+utypeQ = parserToQuasiQuoter type_++-- | Creates 'U.ParameterType' by its Morley representation.+uparamTypeQ :: TH.QuasiQuoter+uparamTypeQ = parserToQuasiQuoter cbParameterBare

+ src/Morley/Michelson/Parser/Annotations.hs view

@@ -0,0 +1,96 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Parser.Annotations+  ( note+  , noteF+  , noteV+  , noteDef+  , noteV2Def+  , notesTVF+  , notesTVF2Def+  , notesVVFF+  , notesTV+  , notesTF+  , notesVF+  , fieldType+  , permute2Def+  , permute3Def+  ) where++import Prelude hiding (note)++import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)+import qualified Data.Text as T+import Text.Megaparsec (satisfy, takeWhileP)+import Text.Megaparsec.Char (string)++import Morley.Michelson.Parser.Helpers (parseDef)+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Types (Parser)+import Morley.Michelson.Untyped.Annotation+import Morley.Util.Default++-- | General T/V/F Annotation parser, including Special Annotations+note :: forall tag. KnownAnnTag tag => Parser (Annotation tag)+note = lexeme $ string (annPrefix @tag) >> (specialNote <|> note' <|> emptyNote)+  where+    -- TODO [#48] these are special annotations and should not always be accepted+    specialVNote = unsafeMkAnnotation <$> asum (map string specialVarAnns)+    specialFNote = unsafeMkAnnotation <$> string specialFieldAnn+    specialNote = specialVNote <|> specialFNote+    emptyNote = pure noAnn+    note' = do+      a <- satisfy isValidAnnStart+      b <- takeWhileP Nothing isValidAnnBodyChar+      return . unsafeMkAnnotation $ T.cons a b++noteV :: Parser VarAnn+noteV = note++noteDef :: KnownAnnTag tag => Parser (Annotation tag)+noteDef = parseDef note++noteF :: Parser FieldAnn+noteF = note++noteV2Def :: Parser (VarAnn, VarAnn)+noteV2Def = permute2Def note note++notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn)+notesTVF = permute3Def note note note++notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))+notesTVF2Def = permute3Def note note (permute2Def note note)++-- | Parse 0/1/2 var anns and 0/1/2 field anns.+-- It doesn't matter which come first, so long as annotations of the same type appear together.+--+-- E.g.:+--+-- * "" is valid+-- * "%a" is valid+-- * "%a @c" is valid+-- * "%a %b @c @d" is valid+-- * "@c @d %a %b" is valid+-- * "@c %a %b @d" is not valid, because the two var anns are not "grouped" together.+-- * "%a @c @d %b" is not valid, because the two fields anns are not "grouped" together.+notesVVFF :: Parser ((VarAnn, VarAnn), (FieldAnn, FieldAnn))+notesVVFF = permute2Def (liftA2 (,) note noteDef) (liftA2 (,) note noteDef)++notesVF :: Parser (VarAnn, FieldAnn)+notesVF = permute2Def note note++notesTV :: Parser (TypeAnn, VarAnn)+notesTV = permute2Def note note++notesTF :: Parser (TypeAnn, FieldAnn)+notesTF = permute2Def note note++fieldType :: Default a+          => Parser a+          -> Parser (a, TypeAnn)+fieldType fp = runPermutation $+  (,) <$> toPermutationWithDefault  def     fp+      <*> toPermutationWithDefault noAnn note

+ src/Morley/Michelson/Parser/Error.hs view

@@ -0,0 +1,73 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- |  Custom exceptions that can happen during parsing.++module Morley.Michelson.Parser.Error+  ( CustomParserException (..)+  , StringLiteralParserException (..)+  , ParseErrorBundle+  , ParserException (..)+  ) where++import Data.Data (Data(..))+import Fmt (Buildable(build), (+|), (|+))+import Text.Megaparsec (ParseErrorBundle, ShowErrorComponent(..), errorBundlePretty)+import qualified Text.Show (show)++import Morley.Util.Instances ()+import Morley.Util.Positive++data CustomParserException+  = StringLiteralException StringLiteralParserException+  | OddNumberBytesException+  | WrongTagArgs Natural Positive+  | WrongAccessArgs Natural Positive+  | WrongSetArgs Natural Positive+  | ExcessFieldAnnotation+  | MultiRootAnnotationException+  deriving stock (Eq, Data, Ord, Show, Generic)++instance NFData CustomParserException++instance ShowErrorComponent CustomParserException where+  showErrorComponent (StringLiteralException e) = showErrorComponent e+  showErrorComponent OddNumberBytesException = "odd number bytes"+  showErrorComponent ExcessFieldAnnotation = "excess field annotation"+  showErrorComponent MultiRootAnnotationException = "unexpected multiple root annotations"+  showErrorComponent (WrongTagArgs idx size) =+    "TAG: too large index: " +| idx |+ " \+           \exceedes union size " +| size |+ ""+  showErrorComponent (WrongAccessArgs idx size) =+    "ACCESS: too large index: " +| idx |+ " \+           \exceedes tuple size " +| size |+ ""+  showErrorComponent (WrongSetArgs idx size) =+    "SET: too large index: " +| idx |+ " \+           \exceedes tuple size " +| size |+ ""++data StringLiteralParserException+  = InvalidEscapeSequence Char+  | InvalidChar Char+  deriving stock (Eq, Data, Ord, Show, Generic)++instance NFData StringLiteralParserException++instance ShowErrorComponent StringLiteralParserException where+  showErrorComponent (InvalidEscapeSequence c) =+    "invalid escape sequence '\\" <> [c] <> "'"+  showErrorComponent (InvalidChar c) =+    "invalid character '" <> [c] <> "'"++data ParserException =+  ParserException (ParseErrorBundle Text CustomParserException)+  deriving stock (Eq)++instance Show ParserException where+  show (ParserException bundle) = errorBundlePretty bundle++instance Exception ParserException where+  displayException (ParserException bundle) = errorBundlePretty bundle++instance Buildable ParserException where+  build = build @String . show

+ src/Morley/Michelson/Parser/Ext.hs view

@@ -0,0 +1,72 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Parsing logic for extra instructions (Morley extensions)++module Morley.Michelson.Parser.Ext+  ( extInstr+  , stackType++  -- * For tests+  , printComment+  ) where++import Prelude hiding (try)++import Text.Megaparsec (choice, label, satisfy, try)+import Text.Megaparsec.Char (alphaNumChar, string)+import qualified Text.Megaparsec.Char.Lexer as L++import Morley.Michelson.Macro (ParsedOp(..), ParsedUExtInstr)+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Type+import Morley.Michelson.Parser.Types (Parser)+import qualified Morley.Michelson.Untyped as U++extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr+extInstr opsParser = label "morley instruction" $ choice [stackOp, testAssertOp opsParser, printOp]++stackOp :: Parser ParsedUExtInstr+stackOp = word' "STACKTYPE" U.STACKTYPE <*> stackType++testAssertOp :: Parser [ParsedOp] -> Parser ParsedUExtInstr+testAssertOp opsParser =+  word' "TEST_ASSERT" U.UTEST_ASSERT <*> testAssert opsParser++printOp :: Parser ParsedUExtInstr+printOp = word' "PRINT" U.UPRINT <*> printComment++testAssert :: Parser [ParsedOp] -> Parser (U.TestAssert ParsedOp)+testAssert opsParser = do+  n <- lexeme (toText <$> some alphaNumChar)+  c <- printComment+  o <- opsParser+  return $ U.TestAssert n c o++printComment :: Parser U.PrintComment+printComment = do+  string "\""+  let validChar = toText <$> some (satisfy (\x -> x /= '%' && x /= '"'))+  c <- many (Right <$> stackRef <|> Left <$> validChar)+  symbol "\""+  return $ U.PrintComment c++stackRef :: Parser U.StackRef+stackRef = do+  string "%"+  n <- brackets' L.decimal+  return $ U.StackRef n++stackType :: Parser U.StackTypePattern+stackType = symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)+  where+    emptyStk = try $ symbol "]" $> U.StkEmpty+    stkRest = try $ symbol "..." >> symbol "]" $> U.StkRest+    stkCons = try $ do+      t <- tyVar+      s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk+      return $ U.StkCons t s++tyVar :: Parser U.TyVar+tyVar = (U.TyCon <$> type_) <|> (U.VarID <$> varID)

+ src/Morley/Michelson/Parser/Helpers.hs view

@@ -0,0 +1,57 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Parser.Helpers+  ( mkParser+  , sepEndBy1+  , some'+  , sepBy1+  , sepBy2+  , parseDef+  , positive+  ) where++import Data.Default (Default(..))+import qualified Data.List.NonEmpty as NE+import qualified Text.Megaparsec as P+import Text.Megaparsec.Char.Lexer (decimal)++import Morley.Michelson.Parser.Lexer (word')+import Morley.Michelson.Parser.Types (Parser)+import Morley.Util.Positive++-- | Version of 'P.sepEndBy1' returning a 'NonEmpty' list+sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)+sepEndBy1 = fmap NE.fromList ... P.sepEndBy1++-- | Version of 'P.some' returning a 'NonEmpty' list+some' :: MonadPlus f => f a -> f (NonEmpty a)+some' = fmap NE.fromList . P.some++-- | Version of 'P.sepBy1' returning a 'NonEmpty' list+sepBy1 :: MonadPlus f => f a -> f sep -> f (NonEmpty a)+sepBy1 = fmap NE.fromList ... P.sepBy1++-- | @endBy2 p sep@ parses two or more occurrences of @p@, separated by @sep@.+sepBy2 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)+sepBy2 parser sep = do+  e <- parser+  void sep+  es <- P.sepBy1 parser sep+  return $ e :| es++-- | Make a parser from a string+mkParser :: (a -> Text) -> a -> Parser a+mkParser f a = P.try $ word' (f a) a++-- | Apply given parser and return default value if it fails.+parseDef :: Default a => Parser a -> Parser a+parseDef a = P.try a <|> pure def++-- | Parse a positive number.+positive :: Parser Positive+positive = do+  n :: Integer <- decimal+  mkPositive n+    & either (fail . toString) pure

+ src/Morley/Michelson/Parser/Instr.hs view

@@ -0,0 +1,443 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Parsing of Michelson instructions.++module Morley.Michelson.Parser.Instr+  ( primInstr+  , ops'+  -- * These are handled separately to have better error messages+  , mapOp+  , pairOp+  , unpairOp+  , pairNOp+  , cmpOp+  , dupOp+  , carOp+  , cdrOp+  ) where++import Prelude hiding (EQ, GT, LT, many, note, some, try)++import Text.Megaparsec (choice, label, notFollowedBy, sepEndBy, try)+import qualified Text.Megaparsec.Char.Lexer as L++import Morley.Michelson.Let (LetValue(..))+import Morley.Michelson.Macro (ParsedInstr, ParsedOp(..))+import Morley.Michelson.Parser.Annotations+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Type+import Morley.Michelson.Parser.Types (Parser, letValues)+import Morley.Michelson.Parser.Value+import Morley.Michelson.Untyped++-- | Parser for primitive Michelson instruction (no macros and extensions).+primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr+primInstr contractParser opParser = label "primitive instruction" $ choice+  [ dropOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp+  , ifNoneOp opParser, leftOp, rightOp, ifLeftOp opParser, nilOp+  , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser+  , memOp, getAndUpdateOp, getOp, updateOp, loopLOp opParser, loopOp opParser+  , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp, levelOp+  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, selfAddressOp, addOp, subOp+  , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp+  , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp+  , transferTokensOp, setDelegateOp+  , createContractOp contractParser, implicitAccountOp, nowOp, amountOp+  , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp, pairingCheckOp+  , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp, neverOp+  , votingPowerOp, totalVotingPowerOp, try unpairNOp+  , unpairOp+  , ticketOp, readTicketOp, splitTicketOp, joinTicketsOp+  ]++-- | Parse a sequence of instructions.+ops' :: Parser ParsedOp -> Parser [ParsedOp]+ops' opParser = (braces $ sepEndBy opParser (optional semicolon)) <|> (pure <$> opParser)++-- Control Structures++failWithOp :: Parser ParsedInstr+failWithOp = word' "FAILWITH" FAILWITH++loopOp :: Parser ParsedOp -> Parser ParsedInstr+loopOp opParser = word' "LOOP" LOOP <*> ops' opParser++loopLOp :: Parser ParsedOp -> Parser ParsedInstr+loopLOp opParser = word' "LOOP_LEFT" LOOP_LEFT <*> ops' opParser++execOp :: Parser ParsedInstr+execOp = word' "EXEC" EXEC <*> noteDef++applyOp :: Parser ParsedInstr+applyOp = word' "APPLY" APPLY <*> noteDef++-- Parses both `DIP` and `DIP n`.+dipOp :: Parser ParsedOp -> Parser ParsedInstr+dipOp opParser = parseWithOptionalParameter "DIP" DIPN DIP <*> ops' opParser++-- Helper for instructions which have optional numeric non-negative parameter.+parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser instr+parseWithOptionalParameter instrName constructorWithParam constructorNoParam =+  symbol' instrName *>+  (try (constructorWithParam <$> lexeme L.decimal) <|> pure constructorNoParam)++-- Stack Operations++-- Parses both `DROP` and `DROP n`.+dropOp :: Parser ParsedInstr+dropOp = parseWithOptionalParameter "DROP" DROPN DROP++dupOp :: Parser ParsedInstr+dupOp = do+  symbol' "DUP"+  varAnn <- noteDef+  optional (lexeme L.decimal) <&> maybe (DUP varAnn) (DUPN varAnn)++swapOp :: Parser ParsedInstr+swapOp = word' "SWAP" SWAP++digOp :: Parser ParsedInstr+digOp = word' "DIG" DIG <*> lexeme L.decimal++dugOp :: Parser ParsedInstr+dugOp = word' "DUG" DUG <*> lexeme L.decimal++pushOp :: Parser ParsedOp -> Parser ParsedInstr+pushOp opParser = do+  symbol' "PUSH"+  v <- noteDef+  (try $ pushLet v) <|> (push' v)+  where+    pushLet v = do+      lvs <- asks letValues+      lv <- mkLetVal lvs+      return $ PUSH v (lvSig lv) (lvVal lv)+    push' v = PUSH v <$> type_ <*> value' opParser++unitOp :: Parser ParsedInstr+unitOp = do symbol' "UNIT"; (t, v) <- notesTV; return $ UNIT t v++lambdaOp :: Parser ParsedOp -> Parser ParsedInstr+lambdaOp opParser =+  word' "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser++neverOp :: Parser ParsedInstr+neverOp = word' "NEVER" NEVER+-- Generic comparison++cmpOp :: Parser ParsedInstr+cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp++eqOp :: Parser ParsedInstr+eqOp = word' "EQ" EQ <*> noteDef++neqOp :: Parser ParsedInstr+neqOp = word' "NEQ" NEQ <*> noteDef++ltOp :: Parser ParsedInstr+ltOp = word' "LT" LT <*> noteDef++gtOp :: Parser ParsedInstr+gtOp = word' "GT" GT <*> noteDef++leOp :: Parser ParsedInstr+leOp = word' "LE" LE <*> noteDef++geOp :: Parser ParsedInstr+geOp = word' "GE" GE <*> noteDef++-- ad-hoc comparison++compareOp :: Parser ParsedInstr+compareOp = word' "COMPARE" COMPARE <*> noteDef++-- Operations on booleans++orOp :: Parser ParsedInstr+orOp = word' "OR"  OR <*> noteDef++andOp :: Parser ParsedInstr+andOp = word' "AND" AND <*> noteDef++xorOp :: Parser ParsedInstr+xorOp = word' "XOR" XOR <*> noteDef++notOp :: Parser ParsedInstr+notOp = word' "NOT" NOT <*> noteDef++-- Operations on integers and natural numbers++addOp :: Parser ParsedInstr+addOp = word' "ADD" ADD <*> noteDef++subOp :: Parser ParsedInstr+subOp = word' "SUB" SUB <*> noteDef++mulOp :: Parser ParsedInstr+mulOp = word' "MUL" MUL <*> noteDef++edivOp :: Parser ParsedInstr+edivOp = word' "EDIV"EDIV <*> noteDef++absOp :: Parser ParsedInstr+absOp = word' "ABS" ABS <*> noteDef++negOp :: Parser ParsedInstr+negOp = word' "NEG" NEG <*> noteDef++-- Bitwise logical operators++lslOp :: Parser ParsedInstr+lslOp = word' "LSL" LSL <*> noteDef++lsrOp :: Parser ParsedInstr+lsrOp = word' "LSR" LSR <*> noteDef++-- Operations on string's++concatOp :: Parser ParsedInstr+concatOp = word' "CONCAT" CONCAT <*> noteDef++sliceOp :: Parser ParsedInstr+sliceOp = word' "SLICE" SLICE <*> noteDef++-- Operations on pairs+pairOp :: Parser ParsedInstr+pairOp = do+  symbol' "PAIR"+  (t, v, (p, q)) <- notesTVF2Def++  -- Make sure this is a `PAIR` instruction,+  -- and not a `PAIR n` instruction.+  notFollowedBy (lexeme L.decimal :: Parser Word)++  return $ PAIR t v p q++unpairOp :: Parser ParsedInstr+unpairOp = do+  symbol' "UNPAIR"+  ((vn1, vn2), (fn1, fn2)) <- notesVVFF++  -- Make sure this is an `UNPAIR` instruction,+  -- and not an `UNPAIR n` instruction.+  notFollowedBy (lexeme L.decimal :: Parser Word)++  return $ UNPAIR vn1 vn2 fn1 fn2++pairNOp :: Parser ParsedInstr+pairNOp = do+  symbol' "PAIR"+  PAIRN+    <$> noteDef+    <*> lexeme L.decimal++unpairNOp :: Parser ParsedInstr+unpairNOp =+  word' "UNPAIR" UNPAIRN <*> lexeme L.decimal++carOp :: Parser ParsedInstr+carOp = do symbol' "CAR"; (v, f) <- notesVF; return $ CAR v f++cdrOp :: Parser ParsedInstr+cdrOp = do symbol' "CDR"; (v, f) <- notesVF; return $ CDR v f++-- Operations on collections (sets, maps, lists)++emptySetOp :: Parser ParsedInstr+emptySetOp = do symbol' "EMPTY_SET"; (t, v) <- notesTV;+                EMPTY_SET t v <$> type_++emptyMapOp :: Parser ParsedInstr+emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- type_;+                EMPTY_MAP t v a <$> type_++emptyBigMapOp :: Parser ParsedInstr+emptyBigMapOp = do symbol' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- type_;+                   EMPTY_BIG_MAP t v a <$> type_++memOp :: Parser ParsedInstr+memOp = word' "MEM" MEM <*> noteDef++updateOp :: Parser ParsedInstr+updateOp = do+  symbol' "UPDATE"+  varAnn <- noteDef+  ix <- optional (lexeme L.decimal)+  pure $ maybe (UPDATE varAnn) (UPDATEN varAnn) ix++getAndUpdateOp :: Parser ParsedInstr+getAndUpdateOp = word' "GET_AND_UPDATE" GET_AND_UPDATE <*> noteDef++iterOp :: Parser ParsedOp -> Parser ParsedInstr+iterOp opParser = word' "ITER" ITER <*> ops' opParser++sizeOp :: Parser ParsedInstr+sizeOp = word' "SIZE" SIZE <*> noteDef++mapOp :: Parser ParsedOp -> Parser ParsedInstr+mapOp opParser = word' "MAP" MAP <*>  noteDef <*> ops' opParser++getOp :: Parser ParsedInstr+getOp = do+  symbol' "GET"+  varAnn <- noteDef+  ix <- optional (lexeme L.decimal)+  pure $ maybe (GET varAnn) (GETN varAnn) ix++nilOp :: Parser ParsedInstr+nilOp = do symbol' "NIL"; (t, v) <- notesTV; NIL t v <$> type_++consOp :: Parser ParsedInstr+consOp = do+  try . lexeme $ do+    void $ string' "CONS"+    notFollowedBy (string' "T")+  CONS <$> noteDef++ifConsOp :: Parser ParsedOp -> Parser ParsedInstr+ifConsOp opParser = word' "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser++-- Operations on options++someOp :: Parser ParsedInstr+someOp = do symbol' "SOME"; (t, v) <- notesTV; return $ SOME t v++noneOp :: Parser ParsedInstr+noneOp = do symbol' "NONE"; (t, v) <- notesTV; NONE t v <$> type_++ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr+ifNoneOp opParser = word' "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser++-- Operations on unions++leftOp :: Parser ParsedInstr+leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2Def;+               LEFT t v f f' <$> type_++rightOp :: Parser ParsedInstr+rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2Def;+               RIGHT t v f f' <$> type_++ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr+ifLeftOp opParser = word' "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser++-- Operations on contracts++createContractOp :: Parser (Contract' ParsedOp) -> Parser ParsedInstr+createContractOp contractParser =+  word' "CREATE_CONTRACT" CREATE_CONTRACT+    <*> noteDef <*> noteDef <*> braces contractParser++transferTokensOp :: Parser ParsedInstr+transferTokensOp = word' "TRANSFER_TOKENS" TRANSFER_TOKENS <*> noteDef++setDelegateOp :: Parser ParsedInstr+setDelegateOp = word' "SET_DELEGATE" SET_DELEGATE <*> noteDef++balanceOp :: Parser ParsedInstr+balanceOp = word' "BALANCE" BALANCE <*> noteDef++contractOp :: Parser ParsedInstr+contractOp = word' "CONTRACT" CONTRACT <*> noteDef <*> noteDef <*> type_++sourceOp :: Parser ParsedInstr+sourceOp = word' "SOURCE" SOURCE <*> noteDef++senderOp :: Parser ParsedInstr+senderOp = word' "SENDER" SENDER <*> noteDef++amountOp :: Parser ParsedInstr+amountOp = word' "AMOUNT" AMOUNT <*> noteDef++votingPowerOp :: Parser ParsedInstr+votingPowerOp = word' "VOTING_POWER" VOTING_POWER <*> noteDef++totalVotingPowerOp :: Parser ParsedInstr+totalVotingPowerOp = word' "TOTAL_VOTING_POWER" TOTAL_VOTING_POWER <*> noteDef++implicitAccountOp :: Parser ParsedInstr+implicitAccountOp = word' "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef++selfOp :: Parser ParsedInstr+selfOp = word' "SELF" SELF <*> noteDef <*> noteDef++addressOp :: Parser ParsedInstr+addressOp = word' "ADDRESS" ADDRESS <*> noteDef++selfAddressOp :: Parser ParsedInstr+selfAddressOp = word' "SELF_ADDRESS" SELF_ADDRESS <*> noteDef++-- Special Operations++nowOp :: Parser ParsedInstr+nowOp = word' "NOW" NOW <*> noteDef++levelOp :: Parser ParsedInstr+levelOp = word' "LEVEL" LEVEL <*> noteDef++chainIdOp :: Parser ParsedInstr+chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef++-- Operations on bytes++packOp :: Parser ParsedInstr+packOp = word' "PACK" PACK <*> noteDef++unpackOp :: Parser ParsedInstr+unpackOp = do symbol' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_++-- Cryptographic Primitives++checkSigOp :: Parser ParsedInstr+checkSigOp = word' "CHECK_SIGNATURE" CHECK_SIGNATURE <*> noteDef++blake2BOp :: Parser ParsedInstr+blake2BOp = word' "BLAKE2B" BLAKE2B <*> noteDef++sha256Op :: Parser ParsedInstr+sha256Op = word' "SHA256" SHA256 <*> noteDef++sha512Op :: Parser ParsedInstr+sha512Op = word' "SHA512" SHA512 <*> noteDef++sha3Op :: Parser ParsedInstr+sha3Op = word' "SHA3" SHA3 <*> noteDef++keccakOp :: Parser ParsedInstr+keccakOp = word' "KECCAK" KECCAK <*> noteDef++hashKeyOp :: Parser ParsedInstr+hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef++pairingCheckOp :: Parser ParsedInstr+pairingCheckOp = word' "PAIRING_CHECK" PAIRING_CHECK <*> noteDef++-- Type operations++castOp :: Parser ParsedInstr+castOp = word' "CAST" CAST <*> noteDef <*> type_++renameOp :: Parser ParsedInstr+renameOp = word' "RENAME" RENAME <*> noteDef++isNatOp :: Parser ParsedInstr+isNatOp = word' "ISNAT" ISNAT <*> noteDef++intOp :: Parser ParsedInstr+intOp = word' "INT" INT <*> noteDef++-- Ticket Operations++ticketOp :: Parser ParsedInstr+ticketOp = word' "TICKET" TICKET <*> noteDef++readTicketOp :: Parser ParsedInstr+readTicketOp = word' "READ_TICKET" READ_TICKET <*> noteDef++splitTicketOp :: Parser ParsedInstr+splitTicketOp = word' "SPLIT_TICKET" SPLIT_TICKET <*> noteDef++joinTicketsOp :: Parser ParsedInstr+joinTicketsOp = word' "JOIN_TICKETS" JOIN_TICKETS <*> noteDef

+ src/Morley/Michelson/Parser/Let.hs view

@@ -0,0 +1,125 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Parsing of let blocks++module Morley.Michelson.Parser.Let+  ( letBlock+  , mkLetMac+  -- * For tests+  , letInner+  , letType+  ) where++import Prelude hiding (try)++import qualified Data.Char as Char+import qualified Data.Map as Map+import qualified Data.Set as Set++import Text.Megaparsec (choice, satisfy, try)+import Text.Megaparsec.Char (lowerChar, upperChar)++import Morley.Michelson.Let (LetType(..), LetValue(..))+import Morley.Michelson.Macro (LetMacro(..), ParsedOp(..))+import Morley.Michelson.Parser.Ext+import Morley.Michelson.Parser.Helpers+import Morley.Michelson.Parser.Instr+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Type+import Morley.Michelson.Parser.Types (LetEnv(..), Parser, noLetEnv)+import Morley.Michelson.Parser.Value+import Morley.Michelson.Untyped (StackFn(..), Ty(..), mkAnnotation, noAnn)++-- | Element of a let block+data Let = LetM LetMacro | LetV LetValue | LetT LetType++-- | let block parser+letBlock :: Parser ParsedOp -> Parser LetEnv+letBlock opParser = do+  symbol "let"+  symbol "{"+  ls <- local (const noLetEnv) (letInner opParser)+  symbol "}"+  semicolon+  return ls++-- | Incrementally build the let environment+letInner :: Parser ParsedOp -> Parser LetEnv+letInner opParser = do+  env <- ask+  l <- lets opParser+  semicolon+  local (addLet l) (letInner opParser) <|> return (addLet l env)++-- | Add a Let to the environment in the correct place+addLet :: Let -> LetEnv -> LetEnv+addLet l (LetEnv lms lvs lts) = case l of+  LetM lm -> LetEnv (Map.insert (lmName lm) lm lms) lvs lts+  LetV lv -> LetEnv lms (Map.insert (lvName lv) lv lvs) lts+  LetT lt -> LetEnv lms lvs (Map.insert (ltName lt) lt lts)++lets :: Parser ParsedOp -> Parser Let+lets opParser = choice+  [ (LetM <$> letMacro opParser)+  , (LetV <$> letValue opParser)+  , (LetT <$> letType)+  ]++-- | Build a let name parser from a leading character parser+letName :: Parser Char -> Parser Text+letName p = lexeme $ do+  v <- p+  -- FIXME (#557): It is possible to define a let name such as "add3", but then+  -- the parser doesn't recognize when it's used as an instruction.+  let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')+  vs <- many (satisfy validChar)+  return $ toText (v:vs)++letMacro :: Parser ParsedOp -> Parser LetMacro+letMacro opParser = lexeme $ do+  n <- try $ do+    n <- letName lowerChar+    symbol "::"+    return n+  s <- stackFn+  symbol "="+  o <- ops' opParser+  return $ LetMacro n s o++letType :: Parser LetType+letType = lexeme $ do+  n <- try $ do+    symbol "type"+    n <- letName upperChar <|> letName lowerChar+    symbol "="+    return n+  t@(Ty t' a) <- type_+  if a == noAnn+    then case mkAnnotation n of+      Right an -> return $ LetType n (Ty t' an)+      Left err -> fail $ toString err+    else return $ LetType n t++letValue :: Parser ParsedOp -> Parser LetValue+letValue opParser = lexeme $ do+  n <- try $ do+    n <- letName upperChar+    symbol "::"+    return n+  t <- type_+  symbol "="+  v <- value' opParser+  return $ LetValue n t v++mkLetMac :: Map Text LetMacro -> Parser LetMacro+mkLetMac lms = choice $ mkParser lmName <$> (Map.elems lms)++stackFn :: Parser StackFn+stackFn = do+  vs <- (optional (symbol "forall" >> some varID <* symbol "."))+  a <- stackType+  symbol "->"+  b <- stackType+  return $ StackFn (Set.fromList <$> vs) a b

+ src/Morley/Michelson/Parser/Lexer.hs view

@@ -0,0 +1,81 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Parser.Lexer+  ( lexeme+  , mSpace+  , symbol+  , symbol'+  , word+  , word'+  , string'+  , parens+  , braces+  , brackets+  , brackets'+  , semicolon+  , comma+  , varID+  ) where++import Data.Char (isDigit, isLower, toLower)+import qualified Data.Text as T+import Text.Megaparsec (MonadParsec, Tokens, between, satisfy)+import Text.Megaparsec.Char (lowerChar, space, space1, string)+import qualified Text.Megaparsec.Char.Lexer as L++import Morley.Michelson.Parser.Types (Parser)+import qualified Morley.Michelson.Untyped as U++-- Lexing+lexeme :: Parser a -> Parser a+lexeme = L.lexeme mSpace++mSpace :: Parser ()+mSpace = L.space space1+  (L.skipLineComment "#")+  (L.skipBlockComment "/*" "*/" >> space >> void (optional semicolon))+++symbol :: Tokens Text -> Parser ()+symbol = void . L.symbol mSpace++symbol' :: Text -> Parser ()+symbol' str = symbol str <|> symbol (T.map toLower str)++word :: Tokens Text -> a -> Parser a+word str val = symbol str $> val++word' :: Tokens Text -> a -> Parser a+word' str val = symbol' str $> val++string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text+string' str = string str <|> string (T.map toLower str)++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++brackets' :: Parser a -> Parser a+brackets' = between (string "[") (string "]")++semicolon :: Parser ()+semicolon = symbol ";"++comma :: Parser ()+comma = symbol ","++varID :: Parser U.Var+varID = lexeme $ do+  v <- lowerChar+  vs <- many lowerAlphaNumChar+  return $ U.Var (toText (v:vs))+  where+    lowerAlphaNumChar :: Parser Char+    lowerAlphaNumChar = satisfy (\x -> isLower x || isDigit x)

+ src/Morley/Michelson/Parser/Macro.hs view

@@ -0,0 +1,170 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Parsing of built-in Michelson macros.++module Morley.Michelson.Parser.Macro+  ( macro+  -- * These are handled separately to have better error messages+  , duupMac+  , pairMac+  , ifCmpMac+  , mapCadrMac+  , cadrMac+  , carnMac+  , cdrnMac+  ) where++import Prelude hiding (note, try)++import Text.Megaparsec (customFailure, label, notFollowedBy, skipMany, try)+import Text.Megaparsec.Char.Lexer (decimal)+import qualified Unsafe (fromIntegral)++import Morley.Michelson.Macro+  (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..))+import qualified Morley.Michelson.Macro as Macro+import Morley.Michelson.Parser.Annotations+import Morley.Michelson.Parser.Error+import Morley.Michelson.Parser.Helpers+import Morley.Michelson.Parser.Instr+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Type+import Morley.Michelson.Parser.Types (Parser)+import Morley.Michelson.Untyped (T(..), Ty(..), noAnn)+import Morley.Util.Positive++macro :: Parser ParsedOp -> Parser Macro+macro opParser = label "macro"+   $  word' "CASE" CASE <*> someNE ops+  <|> symbol' "TAG" *> tagMac+  <|> symbol' "ACCESS" *> accessMac+  <|> symbol' "SET " *> setMac+  <|> word' "CONSTRUCT" CONSTRUCT <*> someNE ops+  <|> word' "VIEW" VIEW <*> ops+  <|> word' "VOID" VOID <*> ops+  <|> word' "CMP" CMP <*> cmpOp <*> noteDef+  <|> word' "IF_SOME" IF_SOME <*> ops <*> ops+  <|> word' "IF_RIGHT" IF_RIGHT <*> ops <*> ops+  <|> word' "FAIL" FAIL+  <|> word' "ASSERT_CMP" ASSERT_CMP <*> cmpOp+  <|> word' "ASSERT_NONE" ASSERT_NONE+  <|> word' "ASSERT_SOME" ASSERT_SOME+  <|> word' "ASSERT_LEFT" ASSERT_LEFT+  <|> word' "ASSERT_RIGHT" ASSERT_RIGHT+  <|> word' "ASSERT_" ASSERTX <*> cmpOp+  <|> word' "ASSERT" ASSERT+  <|> do string' "DI"; n <- num "I"; symbol' "P"; DIIP (n + 1) <$> ops+  <|> unpairMac+  <|> setCadrMac+  where+   ops = ops' opParser+   num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str)++duupMac :: Parser Macro+duupMac = do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef+  where+    num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str)++pairMacInner :: Parser PairStruct+pairMacInner = do+  string' "P"+  l <- (string' "A" $> F noAnn) <|> pairMacInner+  r <- (string' "I" $> F noAnn) <|> pairMacInner+  return $ P l r++pairMac :: Parser Macro+pairMac = do+  a <- pairMacInner+  symbol' "R"+  (tn, vn, fns) <- permute3Def noteDef note (some note)+  let ps = Macro.mapPairLeaves fns a+  return $ PAPAIR ps tn vn++unpairMacInner :: Parser UnpairStruct+unpairMacInner = do+  string' "P"+  l <- (string' "A" $> UF) <|> unpairMacInner+  r <- (string' "I" $> UF) <|> unpairMacInner+  return $ UP l r++unpairMac :: Parser Macro+unpairMac = do+  string' "UN"+  a <- unpairMacInner+  symbol' "R"+  skipMany $ (void noteF) <|> (void noteV)+  return $ UNPAPAIR a++cadrMac :: Parser Macro+cadrMac = lexeme $ do+  string' "C"+  a <- some $ try $ cadrInner <* notFollowedBy (string' "R")+  b <- cadrInner+  symbol' "R"+  (vn, fn) <- notesVF+  return $ CADR (a ++ pure b) vn fn++cadrInner :: Parser CadrStruct+cadrInner = (string' "A" $> A) <|> (string' "D" $> D)++carnMac :: Parser Macro+carnMac = symbol' "CAR" *> (CARN <$> noteDef <*> lexeme decimal)++cdrnMac :: Parser Macro+cdrnMac = symbol' "CDR" *> (CDRN <$> noteDef <*> lexeme decimal)++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}+setCadrMac :: Parser Macro+setCadrMac = do+  string' "SET_C"+  a <- some cadrInner+  symbol' "R"+  (v, f) <- notesVF+  return $ SET_CADR a v f++mapCadrMac :: Parser ParsedOp -> Parser Macro+mapCadrMac opParser = do+  string' "MAP_C"+  a <- some cadrInner+  symbol' "R"+  (v, f) <- notesVF+  MAP_CADR a v f <$> ops' opParser++ifCmpMac :: Parser ParsedOp -> Parser Macro+ifCmpMac opParser =+  word' "IFCMP" IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser++tagMac :: Parser Macro+tagMac = do+  idx <- decimal+  mSpace+  ty <- type_+  let utys = unrollUnion ty []+  when (Unsafe.fromIntegral @Natural @Int idx >= length utys) $+    customFailure $ WrongTagArgs idx (lengthNE utys)+  return $ TAG idx utys+  where+  unrollUnion ty =+    case ty of+      Ty (TOr _ _ l r) _ -> unrollUnion l . toList . unrollUnion r+      _ -> (ty :|)++accessMac :: Parser Macro+accessMac = do+  idx <- decimal+  mSpace+  size <- positive+  when (idx >= unPositive size) $+    customFailure $ WrongAccessArgs idx size+  return $ ACCESS idx size++setMac :: Parser Macro+setMac = do+  idx <- decimal+  mSpace+  size <- positive+  when (idx >= unPositive size) $+    customFailure $ WrongSetArgs idx size+  return $ SET idx size

+ src/Morley/Michelson/Parser/Type.hs view

@@ -0,0 +1,307 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Parsing of Michelson types.++module Morley.Michelson.Parser.Type+  ( type_+  , field+  ) where++import Prelude hiding (note, some, try)++import Data.Default (Default, def)+import qualified Data.Map as Map+import Fmt (pretty)+import Text.Megaparsec (choice, customFailure, label, sepBy)++import Morley.Michelson.Let (LetType(..))+import Morley.Michelson.Parser.Annotations+import Morley.Michelson.Parser.Error+import Morley.Michelson.Parser.Helpers+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Types (Parser, letTypes)+import Morley.Michelson.Untyped+import Morley.Util.Generic++-- | This parses arbitrary type expressions.+--+-- Note that this includes parenthesized ones for efficiency, see 't_operator'.+-- That is to say, @int@, @(int)@, @((int))@, etc will match with this parser and produce @TInt@.+type_ :: Parser Ty+type_ = snd <$> typeInner (pure noAnn)++field :: Parser (FieldAnn, Ty)+field = typeInner note++-- | 't_operator' parses tuples @(a, b, c)@, variants @(a | b | c)@, and also type expressions in+-- parentheses @(a)@ and unit @()@. This is done this way for performance considerations.+--+-- Consequently, 't_unit' doesn't bother with parsing @()@.+t_operator :: Parser FieldAnn -> Parser (FieldAnn, Ty)+t_operator fp = do+  whole <- parens do+    optional do+      ty   <- field+      rest <- optional do+        isOr <- (symbol' "|" >> return True)+            <|> (symbol' "," >> return False)+        others <- field `sepBy` symbol' if isOr then "|" else ","+        return (isOr, others)+      return (ty, rest)++  (f, t) <- fieldType fp+  case whole of+    Just (ty, Just (isOr, tys)) -> do+      let (f', Ty ty' _) = mkGenericTree (mergeTwo isOr) (ty :| tys)+      f'' <- mergeAnnots f f'+      return (f'', Ty ty' t)+    Just (res, _) -> do+      return res+    Nothing -> do+      return (f, Ty TUnit t)+  where+    mergeTwo isOr _ (l, a) (r, b) =+      (noAnn, Ty ((if isOr then TOr l r else TPair l r noAnn noAnn) a b) noAnn)++    mergeAnnots l r+      | l == def  = return r+      | r == def  = return l+      | otherwise = customFailure ExcessFieldAnnotation++typeInner+  :: Parser FieldAnn -> Parser (FieldAnn, Ty)+typeInner fp = label "type" $ lexeme $ choice $ (\x -> x fp) <$>+  [ t_operator+  , t_int, t_nat, t_string, t_bytes, t_mutez, t_bool+  , t_keyhash, t_timestamp, t_address+  , t_key, t_unit, t_never, t_signature, t_chain_id+  , t_bls12381fr, t_bls12381g1, t_bls12381g2+  , t_option, t_list, t_set+  , t_operation, t_contract, t_ticket, t_pair, t_or+  , t_lambda, t_map, t_big_map, t_view+  , t_void, t_letType+  ]++----------------------------------------------------------------------------+-- Non-comparable types+----------------------------------------------------------------------------++mkType :: T -> (a, TypeAnn) -> (a, Ty)+mkType t (a, ta) = (a, Ty t ta)+++t_int :: (Default a) => Parser a -> Parser (a, Ty)+t_int fp = word' "Int" (mkType TInt) <*> fieldType fp++t_nat :: (Default a) => Parser a -> Parser (a, Ty)+t_nat fp = word' "Nat" (mkType TNat) <*> fieldType fp++t_string :: (Default a) => Parser a -> Parser (a, Ty)+t_string fp = word' "String" (mkType TString) <*> fieldType fp++t_bytes :: (Default a) => Parser a -> Parser (a, Ty)+t_bytes fp = word' "Bytes" (mkType TBytes) <*> fieldType fp++t_mutez :: (Default a) => Parser a -> Parser (a, Ty)+t_mutez fp = word' "Mutez" (mkType TMutez) <*> fieldType fp++t_bool :: (Default a) => Parser a -> Parser (a, Ty)+t_bool fp = word' "Bool" (mkType TBool) <*> fieldType fp++t_keyhash :: (Default a) => Parser a -> Parser (a, Ty)+t_keyhash fp = ((word' "KeyHash" (mkType TKeyHash)) <|> (word "key_hash" (mkType TKeyHash))) <*> fieldType fp++t_timestamp :: (Default a) => Parser a -> Parser (a, Ty)+t_timestamp fp = word' "Timestamp" (mkType TTimestamp) <*> fieldType fp++t_address :: (Default a) => Parser a -> Parser (a, Ty)+t_address fp = word' "Address" (mkType TAddress) <*> fieldType fp++t_key :: (Default a) => Parser a -> Parser (a, Ty)+t_key fp = word' "Key" (mkType TKey) <*> fieldType fp++t_signature :: (Default a) => Parser a -> Parser (a, Ty)+t_signature fp = word' "Signature" (mkType TSignature) <*> fieldType fp++t_bls12381fr :: (Default a) => Parser a -> Parser (a, Ty)+t_bls12381fr fp = do+  symbol' "bls12_381_fr" <|> symbol' "Bls12381Fr"+  mkType TBls12381Fr <$> fieldType fp++t_bls12381g1 :: (Default a) => Parser a -> Parser (a, Ty)+t_bls12381g1 fp = do+  symbol' "bls12_381_g1" <|> symbol' "Bls12381G1"+  mkType TBls12381G1 <$> fieldType fp++t_bls12381g2 :: (Default a) => Parser a -> Parser (a, Ty)+t_bls12381g2 fp = do+  symbol' "bls12_381_g2" <|> symbol' "Bls12381G2"+  mkType TBls12381G2 <$> fieldType fp++t_chain_id :: (Default a) => Parser a -> Parser (a, Ty)+t_chain_id fp = do+  symbol' "ChainId" <|> symbol' "chain_id"+  mkType TChainId <$> fieldType fp++t_operation :: (Default a) => Parser a -> Parser (a, Ty)+t_operation fp = word' "Operation" (mkType TOperation) <*> fieldType fp++t_contract :: (Default a) => Parser a -> Parser (a, Ty)+t_contract fp = do+  symbol' "Contract"+  (f, t) <- fieldType fp+  a <- type_+  return (f, Ty (TContract a) t)++t_ticket :: (Default a) => Parser a -> Parser (a, Ty)+t_ticket fp = do+  symbol' "Ticket"+  (f, t) <- fieldType fp+  a <- type_+  return (f, Ty (TTicket a) t)++-- | Parses a @unit@ type. Unit type admits two variants of syntax, @unit@ and @()@. This parser+-- handles only the former, the latter is handled in 't_operator'+t_unit :: (Default a) => Parser a -> Parser (a, Ty)+t_unit fp = do+  symbol' "Unit"+  (f,t) <- fieldType fp+  return (f, Ty TUnit t)++t_never :: (Default a) => Parser a -> Parser (a, Ty)+t_never fp = do+  symbol' "Never" <|> symbol' "⊥"+  (f,t) <- fieldType fp+  return (f, Ty TNever t)++t_pair :: (Default a) => Parser a -> Parser (a, Ty)+t_pair fp = do+  symbol' "Pair"+  (fieldAnn, typeAnn) <- fieldType fp+  fields <- many field+  tPair <- go fields+  pure $ (fieldAnn, Ty tPair typeAnn)+  where+    go :: [(FieldAnn, Ty)] -> Parser T+    go = \case+      [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."+      [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."+      [(fieldAnnL, typeL), (fieldAnnR, typeR)] ->+        pure $ TPair fieldAnnL fieldAnnR noAnn noAnn typeL typeR+      (fieldAnnL, typeL) : fields -> do+        rightCombedT <- go fields+        pure $ TPair fieldAnnL noAnn noAnn noAnn typeL (Ty rightCombedT noAnn)++t_or :: (Default a) => Parser a -> Parser (a, Ty)+t_or fp = do+  symbol' "Or"+  (f, t) <- fieldType fp+  (l, a) <- field+  (r, b) <- field+  return (f, Ty (TOr l r a b) t)++t_option :: (Default a) => Parser a -> Parser (a, Ty)+t_option fp = do+  symbol' "Option"+  (f, t) <- fieldType fp+  a <- snd <$> typeInner (pure noAnn)+  return (f, Ty (TOption a) t)++t_lambda :: (Default a) => Parser a -> Parser (a, Ty)+t_lambda fp = core <|> slashLambda+  where+    core = do+      symbol' "Lambda"+      (f, t) <- fieldType fp+      a <- type_+      b <- type_+      return (f, Ty (TLambda a b) t)+    slashLambda = do+      symbol "\\"+      (f, t) <- fieldType fp+      a <- type_+      symbol "->"+      b <- type_+      return (f, Ty (TLambda a b) t)++-- Container types+t_list :: (Default a) => Parser a -> Parser (a, Ty)+t_list fp = core <|> bracketList+  where+    core = do+      symbol' "List"+      (f, t) <- fieldType fp+      a <- type_+      return (f, Ty (TList a) t)+    bracketList = do+      a <- brackets type_+      (f, t) <- fieldType fp+      return (f, Ty (TList a) t)++t_set :: (Default a) => Parser a -> Parser (a, Ty)+t_set fp = core <|> braceSet+  where+    core = do+      symbol' "Set"+      (f, t) <- fieldType fp+      a <- type_+      return (f, Ty (TSet a) t)+    braceSet = do+      a <- braces type_+      (f, t) <- fieldType fp+      return (f, Ty (TSet a) t)++t_map_like+  :: Default a+  => Parser a -> Parser (Ty, Ty, a, TypeAnn)+t_map_like fp = do+  (f, t) <- fieldType fp+  a <- type_+  b <- type_+  return (a, b, f, t)++t_map :: (Default a) => Parser a -> Parser (a, Ty)+t_map fp = do+  symbol' "Map"+  (a, b, f, t) <- t_map_like fp+  return (f, Ty (TMap a b) t)++t_big_map :: (Default a) => Parser a -> Parser (a, Ty)+t_big_map fp = do+  symbol' "BigMap" <|> symbol "big_map"+  (a, b, f, t) <- t_map_like fp+  return (f, Ty (TBigMap a b) t)++----------------------------------------------------------------------------+-- Non-standard types (Morley extensions)+----------------------------------------------------------------------------++t_view :: Default a => Parser a -> Parser (a, Ty)+t_view fp = do+  symbol' "View"+  a <- type_+  r <- type_+  (f, t) <- fieldType fp+  let c' = Ty (TContract r) noAnn+  return (f, Ty (TPair noAnn noAnn noAnn noAnn a c') t)++t_void :: Default a => Parser a -> Parser (a, Ty)+t_void fp = do+  symbol' "Void"+  a <- type_+  b <- type_+  (f, t) <- fieldType fp+  let c = Ty (TLambda b b) noAnn+  return (f, Ty (TPair noAnn noAnn noAnn noAnn a c) t)++t_letType :: Default fp => Parser fp -> Parser (fp, Ty)+t_letType fp = do+  lts <- asks letTypes+  lt <- ltSig <$> (mkLetType lts)+  f <- parseDef fp+  return (f, lt)++mkLetType :: Map Text LetType -> Parser LetType+mkLetType lts = choice $ mkParser ltName <$> (Map.elems lts)

+ src/Morley/Michelson/Parser/Types.hs view

@@ -0,0 +1,83 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Core parser types++module Morley.Michelson.Parser.Types+  ( Parser+  , LetEnv (..)+  , noLetEnv++  , MichelsonSource (.., MSStdin, MSCli)+  , codeSrc+  ) where++import Data.Default (Default(..))+import qualified Data.Map as Map+import Fmt (Buildable(..))+import GHC.Stack (SrcLoc(..))+import Text.Megaparsec (Parsec)++import Morley.Michelson.Let (LetType, LetValue)+import Morley.Michelson.Macro (LetMacro)+import Morley.Michelson.Parser.Error++type Parser = ReaderT LetEnv (Parsec CustomParserException Text)++instance Default a => Default (Parser a) where+  def = pure def++-- | The environment containing lets from the let-block+data LetEnv = LetEnv+  { letMacros :: Map Text LetMacro+  , letValues :: Map Text LetValue+  , letTypes  :: Map Text LetType+  } deriving stock (Show, Eq)++noLetEnv :: LetEnv+noLetEnv = LetEnv Map.empty Map.empty Map.empty++-- | Where a contract or value in Michelson comes from.+data MichelsonSource+  -- | From given file.+  = MSFile FilePath+  -- | Only source name is known.+  | MSName Text+  -- | Defined in Haskell code.+  | MSCode SrcLoc+  -- | Some unknown source.+  | MSUnspecified+  deriving stock (Show, Eq)++-- | Designates @stdin@ source.+pattern MSStdin :: MichelsonSource+pattern MSStdin = MSName "<stdin>"++-- | Designates command line input source.+pattern MSCli :: MichelsonSource+pattern MSCli = MSName "<cli>"++instance IsString MichelsonSource where+  fromString = MSName . fromString++-- Dunno why these are necessary, hlint behaves weirdly+{-# ANN module ("HLint: ignore Use 'callStack' from Universum" :: Text) #-}+{-# ANN module ("HLint: ignore Use 'getCallStack' from Universum" :: Text) #-}++-- | 'MichelsonSource' that points to the current position.+codeSrc :: HasCallStack => MichelsonSource+codeSrc = MSCode $+  case reverse (getCallStack callStack) of+    [] -> error "Unexpectedly empty callstack"+    (_funName, srcLoc) : _ -> srcLoc++instance Buildable MichelsonSource where+  build = \case+    MSFile file -> build file+    MSStdin -> "<user input>"+    MSCli -> "<user input via CLI>"+    MSName name -> build name+    MSCode SrcLoc{..} ->+      build srcLocFile <> ":" <> build srcLocStartLine <> ":" <> build srcLocStartCol+    MSUnspecified -> ""

+ src/Morley/Michelson/Parser/Value.hs view

@@ -0,0 +1,173 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Parsing of untyped Michelson values.++module Morley.Michelson.Parser.Value+  ( value'+  , mkLetVal++  -- * For tests+  , stringLiteral+  , bytesLiteral+  , intLiteral+  ) where++import Prelude hiding (many, note, try)++import qualified Data.Char as Char+import qualified Data.Map as Map+import qualified Text.Hex as Hex++import Text.Megaparsec (anySingle, choice, customFailure, label, manyTill, satisfy, takeWhileP, try)+import Text.Megaparsec.Char (char, string)+import qualified Text.Megaparsec.Char.Lexer as L++import Morley.Michelson.Let (LetValue(..))+import Morley.Michelson.Macro (ParsedOp, ParsedValue)+import Morley.Michelson.Parser.Error+import Morley.Michelson.Parser.Helpers+import Morley.Michelson.Parser.Lexer+import Morley.Michelson.Parser.Types (Parser, letValues)+import Morley.Michelson.Text (isMChar, unsafeMkMText)+import qualified Morley.Michelson.Untyped as U++{-+Note [Exponential backtracking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider the following input string:++@+(Pair 1 (Pair 2 (Pair 3 (Pair 4 5))))+@++until we've parsed it completely, we can't decide whether the first+opening parenthesis is starting a tuple, or a simple expression.+The same applies to all subsequent parentheses. At one point, our parser+first tried to parse the whole expression as a tuple, then backtracked,+then tried to parse the same expression as a value (which includes+a tuple). Hence it incurred the exponential backtracking.++To avoid that, we first try to parse anything that starts with @(@, i.e.+a comma-separated tuple, or a plain value in parentheses. The choice+between the two is trivial: if there's one value it's just value, if+there are multiple, it's a tuple.++If we don't find @(@ we then try to parse anything that /doesn't/ start+with a parenthesis, i.e. everything else.+-}++-- | Parse untyped 'ParsedValue'. Take instruction parser as argument+-- to avoid cyclic dependencies between modules, hence ' in its name.+value' :: Parser ParsedOp -> Parser ParsedValue+value' opParser = lexeme $ parensOrTuple opParser <|> valueInnerWithoutParens opParser++parensOrTuple :: Parser ParsedOp -> Parser ParsedValue+parensOrTuple opParser = parens $ foldr1 U.ValuePair <$> value' opParser `sepBy1` comma++valueInnerWithoutParens :: Parser ParsedOp -> Parser ParsedValue+valueInnerWithoutParens opParser = label "value" $ choice $+  [ stringLiteral, bytesLiteral, intLiteral, unitValue+  , trueValue, falseValue, pairValueCore opParser, leftValue opParser+  , rightValue opParser, someValue opParser, noneValue, nilValue+  , seqOrLambda opParser, mapValue opParser, dataLetValue+  ]++seqOrLambda :: Parser ParsedOp -> Parser ParsedValue+seqOrLambda opParser = try (lambdaValue opParser) <|> seqValue opParser++stringLiteral :: Parser ParsedValue+stringLiteral = U.ValueString . unsafeMkMText . toText <$> do+  _ <- try $ string "\""+  manyTill validChar (string "\"")+  where+      validChar :: Parser Char+      validChar = choice+        [ strEscape+        , satisfy (\x -> x /= '"' && isMChar x)+        , anySingle >>= stringLiteralFailure . InvalidChar+        ]++      strEscape :: Parser Char+      strEscape = try (char '\\') >> esc+        where+          esc = choice+            [ char '\\'+            , char '"'+            , char 'n' $> '\n'+            , anySingle >>= stringLiteralFailure . InvalidEscapeSequence+            ]+      stringLiteralFailure = customFailure . StringLiteralException++-- It is safe not to use `try` here because bytesLiteral is the only+-- thing that starts from 0x (at least for now)+bytesLiteral :: Parser (U.Value' op)+bytesLiteral = do+  string "0x"+  hexdigits <- takeWhileP Nothing Char.isHexDigit+  let mBytes = Hex.decodeHex hexdigits+  maybe+    (customFailure OddNumberBytesException)+    (return . U.ValueBytes . U.InternalByteString)+    mBytes++intLiteral :: Parser (U.Value' op)+intLiteral = try $ U.ValueInt <$> L.signed pass L.decimal++unitValue :: Parser ParsedValue+unitValue = word "Unit" U.ValueUnit++trueValue :: Parser ParsedValue+trueValue = word "True" U.ValueTrue++falseValue :: Parser ParsedValue+falseValue = word "False" U.ValueFalse++pairValueCore :: Parser ParsedOp -> Parser ParsedValue+pairValueCore opParser = symbol "Pair" *> pairInner+  where+    pairInner = U.ValuePair+      <$> value' opParser+      <*> (foldr1 U.ValuePair <$> some' (value' opParser))++leftValue :: Parser ParsedOp -> Parser ParsedValue+leftValue opParser = word "Left" U.ValueLeft <*> value' opParser++rightValue :: Parser ParsedOp -> Parser ParsedValue+rightValue opParser = word "Right" U.ValueRight <*> value' opParser++someValue :: Parser ParsedOp -> Parser ParsedValue+someValue opParser = word "Some" U.ValueSome <*> value' opParser++noneValue :: Parser ParsedValue+noneValue = word "None" U.ValueNone++nilValue :: Parser ParsedValue+nilValue = U.ValueNil <$ (try $ braces pass)++lambdaValue :: Parser ParsedOp -> Parser ParsedValue+lambdaValue opParser = U.ValueLambda <$> ops1+  where+    ops1 :: Parser (NonEmpty ParsedOp)+    ops1 = braces $ sepEndBy1 opParser semicolon++seqValue :: Parser ParsedOp -> Parser ParsedValue+seqValue opParser =+  U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon)++eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp)+eltValue opParser = word "Elt" U.Elt <*> value' opParser <*> value' opParser++mapValue :: Parser ParsedOp -> Parser ParsedValue+mapValue opParser =+  U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon)++dataLetValue :: Parser ParsedValue+dataLetValue = do+  lvs <- asks letValues+  lvVal <$> (mkLetVal lvs)++mkLetVal :: Map Text LetValue -> Parser LetValue+mkLetVal lvs = choice $ mkParser lvName <$> Map.elems lvs

+ src/Morley/Michelson/Preprocess.hs view

@@ -0,0 +1,53 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Apply some transformations to Michelson code.++module Morley.Michelson.Preprocess+  ( transformStrings+  , transformBytes+  ) where++import Data.Default (def)++import Morley.Michelson.Text (MText)+import Morley.Michelson.Typed++-- Note: we may add such transformation for long bytestrings as well if deemed necessary.+-- And for other constants which may be arbitrarily large (e. g. lists).+-- For now we need it only for strings and probably won't need for anything else.++-- | Transform all strings in a typed instructions using given+-- function. The first argument specifies whether we should go into+-- arguments that contain instructions.+transformStrings :: Bool -> (MText -> MText) -> Instr inp out -> Instr inp out+transformStrings goToValues f = transformConstants goToValues mapStr+  where+    mapStr :: Value t -> Value t+    mapStr = \case+      VString str -> VString $ f str+      v -> v++-- | Similar to 'transformStrings' but for bytes.+transformBytes :: Bool -> (ByteString -> ByteString) -> Instr inp out -> Instr inp out+transformBytes goToValues f = transformConstants goToValues mapBytes+  where+    mapBytes :: Value t -> Value t+    mapBytes = \case+      VBytes bytes -> VBytes $ f bytes+      v -> v++transformConstants ::+     forall inp out.+     Bool+  -> (forall t. Value t -> Value t)+  -- ^ Should transform only atomic values, 'dfsMapValue' will be applied to it.+  -> Instr inp out+  -> Instr inp out+transformConstants dsGoToValues f = fst . dfsInstr def{ dsGoToValues } step+  where+    step :: forall i o. Instr i o -> (Instr i o, ())+    step = (,()) . \case+      PUSH v -> PUSH (dfsMapValue f v)+      i -> i

+ src/Morley/Michelson/Printer.hs view

@@ -0,0 +1,62 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Printer+  ( RenderDoc(..)+  , renderAnyBuildable+  , printDoc+  , printUntypedContract+  , printTypedContractCode+  , printTypedContract+  , printSomeContract+  , printTypedValue+  , printUntypedValue+  ) where++import Data.Constraint (withDict)+import Data.Singletons (SingI)+import qualified Data.Text.Lazy as TL++import Morley.Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, printDoc, renderAnyBuildable)+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U++-- | Convert an untyped contract into a textual representation which+-- will be accepted by the OCaml reference client: tezos-client.+printUntypedContract :: (RenderDoc op) => Bool -> U.Contract' op -> TL.Text+printUntypedContract forceSingleLine = printDoc forceSingleLine . renderDoc doesntNeedParens++-- | Convert a typed contract into a textual representation which+-- will be accepted by the OCaml reference client: tezos-client.+printTypedContractCode :: (SingI p, SingI s) => Bool -> T.ContractCode p s -> TL.Text+printTypedContractCode forceSingleLine =+  printUntypedContract forceSingleLine . T.convertContractCode++-- | Convert typed contract into a textual representation which+-- will be accepted by the OCaml reference client: tezos-client.+printTypedContract :: Bool -> T.Contract p s -> TL.Text+printTypedContract forceSingleLine fc@T.Contract{} =+  printUntypedContract forceSingleLine $ T.convertContract fc++-- | Convert typed value into a textual representation which+-- will be accepted by the OCaml reference client: tezos-client.+printTypedValue+  :: forall t.+      (T.ProperUntypedValBetterErrors t)+  => Bool -> T.Value t -> TL.Text+printTypedValue forceSingleLine =+  withDict (T.properUntypedValEvi @t) $+  printUntypedValue forceSingleLine . T.untypeValue++-- | Convert untyped value into a textual representation which+-- will be accepted by the OCaml reference client: tezos-client.+printUntypedValue :: (RenderDoc op) => Bool -> U.Value' op -> TL.Text+printUntypedValue forceSingleLine =+  printDoc forceSingleLine . renderDoc doesntNeedParens++-- | Convert 'T.SomeContract' into a textual representation which+-- will be accepted by the OCaml reference client: tezos-client.+printSomeContract :: Bool -> T.SomeContract -> TL.Text+printSomeContract forceSingleLine (T.SomeContract fc) =+  printTypedContract forceSingleLine fc

+ src/Morley/Michelson/Printer/Util.hs view

@@ -0,0 +1,161 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities for rendering Michelson code in a format compatible with+-- Tezos software (e.g @tezos-client@)+module Morley.Michelson.Printer.Util+  ( RenderDoc(..)+  , Prettier(..)+  , printDoc+  , printDocB+  , printDocS+  , renderOps+  , renderOpsList+  , renderOpsListNoBraces+  , renderAnyBuildable+  , spaces+  , wrapInParens+  , buildRenderDoc+  , buildRenderDocExtended+  , renderDocList++    -- * Smart parentheses+  , RenderContext+  , needsParens+  , doesntNeedParens+  , addParens+  , assertParensNotNeeded+  ) where++import Control.Exception (assert)+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Builder (Builder)+import Fmt (Buildable, pretty)+import Text.PrettyPrint.Leijen.Text+  (Doc, SimpleDoc, align, braces, displayB, displayT, enclose, encloseSep, hcat, isEmpty, lbracket,+  parens, punctuate, rbracket, renderOneLine, renderPretty, semi, space, text, vcat, (<+>))++-- | Environment carried during recursive rendering.+newtype RenderContext = RenderContext+  { _rcWillNeedParens :: Bool+    -- ^ Whether the current expression is going to be used as part of+    -- top-level expression or in a similar context.+    -- When set to 'True', you may need to wrap your rendered expression into+    -- parentheses.+  }++-- | Generalize converting a type into a+-- Text.PrettyPrint.Leijen.Text.Doc. Used to pretty print Michelson code+-- and define Fmt.Buildable instances.+class RenderDoc a where+  renderDoc :: RenderContext -> a -> Doc++  -- | Whether a value can be represented in Michelson code.+  -- Normally either all values of some type are renderable or not renderable.+  -- However, in case of instructions we have extra instructions which should+  -- not be rendered.+  -- Note: it's not sufficient to just return 'mempty' for such instructions,+  -- because sometimes we want to print lists of instructions and we need to+  -- ignore them complete (to avoid putting redundant separators).+  isRenderable :: a -> Bool+  isRenderable _ = True++-- | Renders a list of 'RenderDoc' elements surrounded with square brackets,+-- separated by a comma and a space.+renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc+renderDocList context = encloseSep lbracket rbracket ", " . fmap (renderDoc context)++renderAnyBuildable :: Buildable a => a -> Doc+renderAnyBuildable = text . pretty++-- | A new type that can wrap values so that the RenderDoc+-- instances of the combined value can have a different+-- behavior for the pretty printer.+newtype Prettier a = Prettier a++-- | Convert 'Doc' to 'Text' with a line width of 80.+printDoc :: Bool -> Doc -> LT.Text+printDoc oneLine = displayT . doRender oneLine++-- | Convert 'Doc' to 'Builder' in the same manner as 'printDoc'.+printDocB :: Bool -> Doc -> Builder+printDocB oneLine = displayB . doRender oneLine++-- | Convert 'Doc' to 'String' in the same manner as 'printDoc'.+printDocS :: Bool -> Doc -> String+printDocS oneLine = toString . printDoc oneLine++-- | Generic way to render the different op types that get passed+-- to a contract.+renderOps :: (RenderDoc op) => Bool -> NonEmpty op -> Doc+renderOps oneLine = renderOpsList oneLine . toList++-- | Join a non-empty list of 'Doc' by spaces+spacecat :: NonEmpty Doc -> Doc+spacecat = foldr (<+>) mempty++-- | Render a comma-separated list of items in braces+renderOpsList :: (RenderDoc op) => Bool -> [op] -> Doc+renderOpsList oneLine ops =+  braces $ enclose space space $ renderOpsListNoBraces oneLine ops++-- | Render a comma-separated list of items without braces+renderOpsListNoBraces :: RenderDoc op => Bool -> [op] -> Doc+renderOpsListNoBraces oneLine ops =+  cat' $ punctuate semi $+    renderDoc doesntNeedParens <$> filter isRenderable ops+  where+    cat' = if oneLine then maybe "" spacecat . nonEmpty else align . vcat++-- | Create a specific number of spaces.+spaces :: Int -> Doc+spaces x = hcat $ replicate x space++-- | Wrap documents in parentheses if there are two or more in the list.+wrapInParens :: RenderContext -> NonEmpty Doc -> Doc+wrapInParens (RenderContext pn) ds =+  let moreThanOne = length (filter (not . isEmpty) (toList ds)) > 1+  in  addParens (RenderContext (pn && moreThanOne)) $+        foldr (<+>) mempty ds++-- | Turn something that is instance of `RenderDoc` into a `Builder`.+-- It's formatted the same way as `printDoc` formats docs.+buildRenderDoc :: RenderDoc a => a -> Builder+buildRenderDoc = printDocB True . renderDoc doesntNeedParens++-- | Works as 'buildRenderDoc' above, but doesn't force the doc to be printed in one line+buildRenderDocExtended :: RenderDoc a => a -> Builder+buildRenderDocExtended = printDocB False . renderDoc doesntNeedParens+++-- | Here using a page width of 80 and a ribbon width of 1.0+-- https://hackage.haskell.org/package/wl-pprint-1.2.1/docs/Text-PrettyPrint-Leijen.html+doRender :: Bool -> Doc -> SimpleDoc+doRender oneLine = if oneLine then renderOneLine else renderPretty 1.0 80++-- Smart parentheses+----------------------------------------------------------------------------++{- Motivation:++Some expressions may need to be wrapped into parentheses, but only if they+are part of other expression, and are not already wrapped into braces or+brackets.+-}++-- | Constructors for 'RenderContext'+needsParens, doesntNeedParens :: RenderContext+needsParens = RenderContext True+doesntNeedParens = RenderContext False++-- | Add parentheses if needed.+addParens :: RenderContext -> Doc -> Doc+addParens = \case+  RenderContext True -> parens+  RenderContext False -> id++-- | Ensure parentheses are not required, for case when you cannot+-- sensibly wrap your expression into them.+assertParensNotNeeded :: RenderContext -> a -> a+assertParensNotNeeded (RenderContext pn) = assert (not pn)

+ src/Morley/Michelson/Runtime.hs view

@@ -0,0 +1,801 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Executor and typechecker of a contract in Morley language.++module Morley.Michelson.Runtime+  (+    -- * High level interface for end user+    originateContract+  , runContract+  , transfer++  -- * Other helpers+  , parseContract+  , parseExpandContract+  , readAndParseContract+  , prepareContract++  -- * Re-exports+  , ContractState (..)+  , AddressState (..)+  , VotingPowers+  , mkVotingPowers+  , mkVotingPowersFromMap+  , TxData (..)+  , TxParam (..)++  -- * For testing+  , ExecutorOp (..)+  , ExecutorRes (..)+  , ExecutorError' (..)+  , ExecutorError+  , ExecutorM+  , runExecutorM+  , runExecutorMWithDB+  , executeGlobalOperations+  , executeGlobalOrigination+  , executeOrigination+  , executeTransfer++  -- * To avoid warnings (can't generate lenses only for some fields)+  , erInterpretResults+  , erUpdates+  , erGState+  , erRemainingSteps+  , elInterpreterResults+  , elUpdates+  ) where++import Control.Lens (assign, at, makeLenses, (.=), (<>=))+import Control.Monad.Except (Except, liftEither, runExcept, throwError)+import Data.Default (def)+import qualified Data.HashSet as HS+import Data.Semigroup.Generic+import Data.Text.IO (getContents)+import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Fmt (Buildable(build), blockListF, fmt, fmtLn, indentF, nameF, pretty, (+|), (|+))+import Text.Megaparsec (parse)++import Morley.Michelson.Interpret+  (ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),+  RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret)+import Morley.Michelson.Macro (ParsedOp, expandContract)+import qualified Morley.Michelson.Parser as P+import Morley.Michelson.Runtime.GState+import Morley.Michelson.Runtime.TxData+import Morley.Michelson.TypeCheck+import Morley.Michelson.Typed+  (CreateContract(..), EntrypointCallT, EpName, Operation'(..), SomeContractAndStorage(..),+  SomeStorage(..), SomeValue(..), TransferTokens(..), starNotes, starParamNotes, untypeValue)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Operation+import Morley.Michelson.Untyped (Contract)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address(..), GlobalCounter(..), isKeyAddress)+import Morley.Tezos.Core+  (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez, zeroMutez)+import Morley.Tezos.Crypto (KeyHash, parseKeyHash)+import Morley.Util.Named++----------------------------------------------------------------------------+-- Auxiliary types+----------------------------------------------------------------------------++-- | Operations executed by interpreter.+-- In our model one Michelson's operation (@operation@ type in Michelson)+-- corresponds to 0 or 1 interpreter operation.+--+-- Note: 'Address' is not part of 'TxData', because 'TxData' is+-- supposed to be provided by the user, while 'Address' can be+-- computed by our code.+data ExecutorOp+  = OriginateOp OriginationOperation+  -- ^ Originate a contract.+  | TransferOp TransferOperation+  -- ^ Transfer tokens to the address.+  | SetDelegateOp SetDelegateOperation+  -- ^ Set the delegate of a contract.+  deriving stock (Show)++instance Buildable ExecutorOp where+  build = \case+    TransferOp (TransferOperation addr TxData{..} _)->+      "Transfer " +| tdAmount |+ " tokens from " +| tdSenderAddress |+ " to " +| addr |+ ""+    OriginateOp OriginationOperation{..} ->+      "Originate a contract with" <>+      " delegate " +| maybe "<nobody>" build ooDelegate |++      " and balance = " +| ooBalance |+ ""+    SetDelegateOp SetDelegateOperation{..} ->+      "Set delegate of contract " +| sdoContract |++      " to " +| maybe "<nobody>" build sdoDelegate |+ ""++-- | Result of a single execution of interpreter.+data ExecutorRes = ExecutorRes+  { _erGState :: GState+  -- ^ New 'GState'.+  , _erUpdates :: [GStateUpdate]+  -- ^ Updates applied to 'GState'.+  , _erInterpretResults :: [(Address, InterpretResult)]+  -- ^ During execution a contract can print logs and in the end it returns+  -- a pair. All logs and returned values are kept until all called contracts+  -- are executed. In the end they are printed.+  , _erRemainingSteps :: RemainingSteps+  -- ^ Now much gas all remaining executions can consume.+  } deriving stock (Show)++data ExecutorEnv = ExecutorEnv+  { _eeNow :: Timestamp+  , _eeLevel :: Natural+  }+  deriving stock (Show, Generic)++data ExecutorState = ExecutorState+  { _esGState :: GState+  , _esRemainingSteps :: RemainingSteps+  , _esSourceAddress :: Maybe Address+  , _esLog :: ExecutorLog+  , _esOperationHash :: ~OperationHash+  , _esPrevCounters :: HashSet GlobalCounter+  }+  deriving stock (Show, Generic)++data ExecutorLog = ExecutorLog+  { _elUpdates :: [GStateUpdate]+  , _elInterpreterResults :: [(Address, InterpretResult)]+  }+  deriving stock (Show, Generic)+  deriving (Semigroup, Monoid) via GenericSemigroupMonoid ExecutorLog++makeLenses ''ExecutorRes+makeLenses ''ExecutorEnv+makeLenses ''ExecutorState+makeLenses ''ExecutorLog++-- | Errors that can happen during contract interpreting.+-- Type parameter @a@ determines how contracts will be represented+-- in these errors, e.g. 'Address'.+data ExecutorError' a+  = EEUnknownContract a+  -- ^ The interpreted contract hasn't been originated.+  | EEInterpreterFailed a+                        InterpretError+  -- ^ Interpretation of Michelson contract failed.+  | EEAlreadyOriginated a+                        ContractState+  -- ^ A contract is already originated.+  | EEUnknownSender a+  -- ^ Sender address is unknown.+  | EEUnknownManager a+  -- ^ Manager address is unknown.+  | EENotEnoughFunds a Mutez+  -- ^ Sender doesn't have enough funds.+  | EEZeroTransaction a+  -- ^ Sending 0tz towards an address.+  | EEFailedToApplyUpdates GStateUpdateError+  -- ^ Failed to apply updates to GState.+  | EEIllTypedParameter a TCError+  -- ^ Contract parameter is ill-typed.+  | EEUnexpectedParameterType a T.T T.T+  -- ^ Contract parameter is well-typed, but its type does+  -- not match the entrypoint's type.+  | EEUnknownEntrypoint EpName+  -- ^ Specified entrypoint to run is not found.+  | EETransactionFromContract a Mutez+  -- ^ A transaction from an originated contract was attempted as a global operation.+  | EEWrongParameterType a+  -- ^ Type of parameter in transfer to an implicit account is not Unit.+  | EEOperationReplay ExecutorOp+  -- ^ An attempt to perform the operation duplicated with @DUP@ instruction.+  deriving stock (Show, Functor)++instance (Buildable a) => Buildable (ExecutorError' a) where+  build =+    \case+      EEUnknownContract addr -> "The contract is not originated " +| addr |+ ""+      EEInterpreterFailed addr err ->+        "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""+      EEAlreadyOriginated addr cs ->+        "The following contract is already originated: " +| addr |++        ", " +| cs |+ ""+      EEUnknownSender addr -> "The sender address is unknown " +| addr |+ ""+      EEUnknownManager addr -> "The manager address is unknown " +| addr |+ ""+      EENotEnoughFunds addr amount ->+        "The sender (" +| addr |++        ") doesn't have enough funds (has only " +| amount |+ ")"+      EEZeroTransaction addr ->+        "Transaction of 0ꜩ towards a key address " +| addr |+ " which has no code is prohibited"+      EEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""+      EEIllTypedParameter _ err -> "The contract parameter is ill-typed: " +| err |+ ""+      EEUnexpectedParameterType _ actualT expectedT ->+        "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n" <>+        "Expected: " +| expectedT |+ "\n" <>+        "Got: " +| actualT |+ ""+      EEUnknownEntrypoint epName -> "The contract does not contain entrypoint '" +| epName |+ "'"+      EETransactionFromContract addr amount ->+        "Global transaction of funds (" +| amount |+ ") from an originated contract (" +| addr |+ ") is prohibited."+      EEWrongParameterType addr ->+        "Bad contract parameter for: " +| addr |+ ""+      EEOperationReplay op ->+        "Operation replay attempt:\n" +| indentF 2 (build op) |+ ""++type ExecutorError = ExecutorError' Address++instance (Typeable a, Show a, Buildable a) => Exception (ExecutorError' a) where+  displayException = pretty++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- | Parse a contract from 'Text'.+parseContract ::+     P.MichelsonSource -> Text -> Either P.ParserException (U.Contract' ParsedOp)+parseContract source =+  first P.ParserException . parse P.program (pretty source)++-- | Parse a contract from 'Text' and expand macros.+parseExpandContract ::+     P.MichelsonSource -> Text -> Either P.ParserException Contract+parseExpandContract = fmap expandContract ... parseContract++-- | Read and parse a contract from give path or `stdin` (if the+-- argument is 'Nothing'). The contract is not expanded.+readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp)+readAndParseContract mFilename = do+  code <- readCode mFilename+  either throwM pure $ parseContract (toSrc mFilename) code+  where+    readCode :: Maybe FilePath -> IO Text+    readCode = maybe getContents Utf8.readFile++    toSrc :: Maybe FilePath -> P.MichelsonSource+    toSrc = maybe P.MSUnspecified P.MSFile++-- | Read a contract using 'readAndParseContract', expand and+-- flatten. The contract is not type checked.+prepareContract :: Maybe FilePath -> IO Contract+prepareContract mFile = expandContract <$> readAndParseContract mFile++-- | Originate a contract. Returns the address of the originated+-- contract.+originateContract+  :: FilePath+  -> TypeCheckOptions+  -> Address+  -> Maybe KeyHash+  -> Mutez+  -> U.Value+  -> U.Contract+  -> "verbose" :! Bool+  -> IO Address+originateContract dbPath tcOpts originator delegate balance uStorage uContract verbose = do+  origination <- either throwM pure . typeCheckingWith tcOpts $+    mkOrigination <$> typeCheckContractAndStorage uContract uStorage+  -- pass 100500 as maxSteps, because it doesn't matter for origination,+  -- as well as 'now'+  fmap snd $ runExecutorMWithDB Nothing Nothing dbPath 100500 verbose (#dryRun :? Nothing) $ do+    executeGlobalOrigination origination+  where+    mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation+      { ooOriginator = originator+      , ooDelegate = delegate+      , ooBalance = balance+      , ooStorage = storage+      , ooContract = contract+      , ooCounter = 0+      }++-- | Run a contract. The contract is originated first (if it's not+-- already) and then we pretend that we send a transaction to it.+runContract+  :: Maybe Timestamp+  -> Maybe Natural+  -> Word64+  -> Mutez+  -> FilePath+  -> TypeCheckOptions+  -> U.Value+  -> U.Contract+  -> TxData+  -> "verbose" :! Bool+  -> "dryRun" :! Bool+  -> IO SomeStorage+runContract maybeNow maybeLevel maxSteps initBalance dbPath tcOpts uStorage uContract txData+  verbose (N dryRun) = do+  origination <- either throwM pure . typeCheckingWith tcOpts $+    mkOrigination <$> typeCheckContractAndStorage uContract uStorage+  (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do+    -- Here we are safe to bypass executeGlobalOperations for origination,+    -- since origination can't generate more operations.+    addr <- executeGlobalOrigination origination+    let transferOp = TransferOp $ TransferOperation addr txData 1+    executeGlobalOperations tcOpts [transferOp]+    getContractStorage addr+  return newSt+  where+    -- We hardcode some random key hash here as delegate to make sure that:+    -- 1. Contract's address won't clash with already originated one (because+    -- it may have different storage value which may be confusing).+    -- 2. If one uses this functionality twice with the same contract and+    -- other data, the contract will have the same address.+    delegate =+      either (error . mappend "runContract can't parse delegate: " . pretty) id $+      parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"+    mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation+      { ooOriginator = genesisAddress+      , ooDelegate = Just delegate+      , ooBalance = initBalance+      , ooStorage = storage+      , ooContract = contract+      , ooCounter = 0+      }++    getContractStorage :: Address -> ExecutorM SomeStorage+    getContractStorage addr = do+      addrs <- use (esGState . gsAddressesL)+      case addrs ^. at addr of+        Nothing -> error $ pretty addr <> " is unknown"+        Just (ASSimple {}) -> error $ pretty addr <> " is a simple address"+        Just (ASContract (ContractState{..})) -> return $ SomeStorage csStorage++-- | Send a transaction to given address with given parameters.+transfer ::+     Maybe Timestamp+  -> Maybe Natural+  -> Word64+  -> FilePath+  -> TypeCheckOptions+  -> Address+  -> TxData+  -> "verbose" :! Bool+  -> "dryRun" :? Bool+  -> IO ()+transfer maybeNow maybeLevel maxSteps dbPath tcOpts destination txData verbose dryRun = do+  void $ runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose dryRun $+    executeGlobalOperations tcOpts [TransferOp $ TransferOperation destination txData 0]++----------------------------------------------------------------------------+-- Executor+----------------------------------------------------------------------------++-- | A monad in which contract executor runs.+type ExecutorM =+  ReaderT ExecutorEnv+    (StateT ExecutorState+      (Except ExecutorError)+    )++-- | Run some executor action, returning its result and final executor state in 'ExecutorRes'.+--+-- The action has access to the hash of currently executed global operation, in order to construct+-- addresses of originated contracts. It is expected that the action uses @#isGlobalOp :! True@+-- to specify this hash. Otherwise it is initialized with 'error'.+runExecutorM+  :: Timestamp+  -> Natural+  -> RemainingSteps+  -> GState+  -> ExecutorM a+  -> Either ExecutorError (ExecutorRes, a)+runExecutorM now level remainingSteps gState action =+  fmap preResToRes+    $ runExcept+    $ runStateT (runReaderT action $ ExecutorEnv now level)+      initialState+  where+    initialOpHash = error "Initial OperationHash touched"++    initialState = ExecutorState+      { _esGState = gState+      , _esRemainingSteps = remainingSteps+      , _esSourceAddress = Nothing+      , _esLog = mempty+      , _esOperationHash = initialOpHash+      , _esPrevCounters = mempty+      }++    preResToRes :: (a, ExecutorState) -> (ExecutorRes, a)+    preResToRes (r, ExecutorState{..}) =+      ( ExecutorRes+          { _erGState = _esGState+          , _erUpdates = _esLog ^. elUpdates+          , _erInterpretResults = _esLog ^. elInterpreterResults+          , _erRemainingSteps = _esRemainingSteps+          }+      , r+      )++-- | Run some executor action, reading state from the DB on disk.+--+-- Unless @dryRun@ is @False@, the final state is written back to the disk.+--+-- If the executor fails with 'ExecutorError' it will be thrown as an exception.+runExecutorMWithDB+  :: Maybe Timestamp+  -> Maybe Natural+  -> FilePath+  -> RemainingSteps+  -> "verbose" :! Bool+  -> "dryRun" :? Bool+  -> ExecutorM a+  -> IO (ExecutorRes, a)+runExecutorMWithDB maybeNow maybeLevel dbPath remainingSteps+  (N verbose)+  (argDef #dryRun False -> dryRun)+  action = do+  gState <- readGState dbPath+  now <- maybe getCurrentTime pure maybeNow+  let level = fromMaybe 0 maybeLevel+  (res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now level remainingSteps gState action++  unless dryRun $+    writeGState dbPath _erGState++  mapM_ printInterpretResult _erInterpretResults+  when (verbose && not (null _erUpdates)) $ do+    fmtLn $ nameF "Updates" (blockListF _erUpdates)+    putTextLn $ "Remaining gas: " <> pretty _erRemainingSteps <> "."++  return (res, a)+  where+    printInterpretResult+      :: (Address, InterpretResult) -> IO ()+    printInterpretResult (addr, InterpretResult {..}) = do+      putTextLn $ "Executed contract " <> pretty addr+      case iurOps of+        [] -> putTextLn "It didn't return any operations."+        _ -> fmt $ nameF "It returned operations" (blockListF iurOps)+      putTextLn $+        "It returned storage: " <> pretty (untypeValue iurNewStorage) <> "."+      let MorleyLogs logs = iurMorleyLogs+      unless (null logs) $ do+        putTextLn "And produced logs:"+        mapM_ putTextLn logs+      putTextLn "" -- extra break line to separate logs from two sequence contracts++-- | Execute a list of global operations, discarding their results.+executeGlobalOperations+  :: TypeCheckOptions+  -> [ExecutorOp]+  -> ExecutorM ()+executeGlobalOperations tcOpts = mapM_ $ \op ->+  executeMany (#isGlobalOp :! True) [op]+  where+    -- | Execute a list of operations and additional operations they return, until there are none.+    executeMany :: "isGlobalOp" :! Bool -> [ExecutorOp] -> ExecutorM ()+    executeMany isGlobalOp = \case+        [] -> pass+        (op:opsTail) -> do+          case op of+            OriginateOp origination -> do+              void $ executeOrigination isGlobalOp origination+              executeMany (#isGlobalOp :! False) opsTail+            SetDelegateOp operation -> do+              executeDelegation isGlobalOp operation+              executeMany (#isGlobalOp :! False) opsTail+            TransferOp transferOperation -> do+              moreOps <- executeTransfer isGlobalOp tcOpts transferOperation+              executeMany (#isGlobalOp :! False) $ moreOps <> opsTail++-- | Execute a global origination operation.+executeGlobalOrigination :: OriginationOperation -> ExecutorM Address+executeGlobalOrigination = executeOrigination ! #isGlobalOp True++-- | Execute an origination operation.+executeOrigination+  :: "isGlobalOp" :! Bool+  -> OriginationOperation+  -> ExecutorM Address+executeOrigination (N isGlobalOp) origination@(OriginationOperation{..}) = do+  when isGlobalOp $ do+    beginGlobalOperation+    assign esOperationHash $ mkOriginationOperationHash origination++  checkOperationReplay $ OriginateOp origination++  opHash <- use esOperationHash++  gs <- use esGState++  -- Add big_map IDS to storage+  let bigMapCounter0 = gs ^. gsBigMapCounterL+  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds ooStorage) bigMapCounter0++  let contractState = ContractState ooBalance ooContract storageWithIds ooDelegate++  let originatorAddress = ooOriginator+  originatorBalance <- case gsAddresses gs ^. at originatorAddress of+    Nothing -> throwError (EEUnknownManager originatorAddress)+    Just (asBalance -> oldBalance)+      | oldBalance < ooBalance ->+        throwError $ EENotEnoughFunds originatorAddress oldBalance+      | otherwise ->+        -- Subtraction is safe because we have checked its+        -- precondition in guard.+        return $ oldBalance `unsafeSubMutez` ooBalance+  let+    address = mkContractAddress opHash ooCounter+    updates =+      catMaybes+        [ Just $ GSAddAddress address (ASContract contractState)+        , Just $ GSSetBalance originatorAddress originatorBalance+        , Just GSIncrementCounter+        , if bigMapCounter0 == bigMapCounter1+            then Nothing+            else Just $ GSSetBigMapCounter bigMapCounter1+        ]++  case applyUpdates updates gs of+    Left _ ->+      throwError $ EEAlreadyOriginated address contractState+    Right newGS -> do+      esGState .= newGS+      esLog <>= ExecutorLog updates []++      return address++-- | Execute delegation operation.+executeDelegation+  :: "isGlobalOp" :! Bool+  -> SetDelegateOperation+  -> ExecutorM ()+executeDelegation (N isGlobalOp) delegation@(SetDelegateOperation{..}) = do+  when isGlobalOp $ do+    beginGlobalOperation+    assign esOperationHash $ mkDelegationOperationHash delegation++  checkOperationReplay $ SetDelegateOp delegation++  gs <- use esGState++  let updates = [GSSetDelegate sdoContract sdoDelegate]+  case applyUpdates updates gs of+    Left err -> throwError $ EEFailedToApplyUpdates err+    Right newGS -> do+      esGState .= newGS+      esLog <>= ExecutorLog updates []++      return ()++-- | Execute a transfer operation.+executeTransfer+  :: "isGlobalOp" :! Bool+  -> TypeCheckOptions+  -> TransferOperation+  -> ExecutorM [ExecutorOp]+executeTransfer (N isGlobalOp) tcOpts transferOperation@(TransferOperation addr txData _) = do+    when isGlobalOp $+      beginGlobalOperation++    now <- view eeNow+    level <- view eeLevel+    gs <- use esGState+    remainingSteps <- use esRemainingSteps+    mSourceAddr <- use esSourceAddress++    let globalCounter = gsCounter gs+    let addresses = gsAddresses gs+    let senderAddr = tdSenderAddress txData+    let sourceAddr = fromMaybe senderAddr mSourceAddr+    let isZeroTransfer = tdAmount txData == zeroMutez++    checkOperationReplay $ TransferOp transferOperation++    when (badParamToImplicitAccount addr $ tdParameter txData) $+      throwError $ EEWrongParameterType addr++    -- Transferring 0 XTZ to a key address is prohibited.+    when (isZeroTransfer && isKeyAddress addr) $+      throwError $ EEZeroTransaction addr+    mDecreaseSenderBalance <- case (isZeroTransfer, addresses ^. at senderAddr) of+      (True, _) -> pure Nothing+      (False, Nothing) -> throwError $ EEUnknownSender senderAddr+      (False, Just (asBalance -> balance))+        | balance < tdAmount txData ->+          throwError $ EENotEnoughFunds senderAddr balance+        | otherwise ->+          -- Subtraction is safe because we have checked its+          -- precondition in guard.+          return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData)+    when (not (isKeyAddress senderAddr) && isGlobalOp && not isZeroTransfer) $+      throwError $ EETransactionFromContract senderAddr $ tdAmount txData+    let onlyUpdates updates = return (updates, [], Nothing, remainingSteps)+    (otherUpdates, sideEffects, maybeInterpretRes :: Maybe InterpretResult, newRemSteps)+        <- case (addresses ^. at addr, addr) of+      (Nothing, ContractAddress _) ->+        throwError $ EEUnknownContract addr+      (Nothing, KeyAddress _) -> do+        let+          transferAmount = tdAmount txData+          addrState = ASSimple transferAmount+          upd = GSAddAddress addr addrState+        onlyUpdates [upd]+      (Just (ASSimple oldBalance), _) -> do+        -- can't overflow if global state is correct (because we can't+        -- create money out of nowhere)+        let+          newBalance = oldBalance `unsafeAddMutez` tdAmount txData+          upd = GSSetBalance addr newBalance+        onlyUpdates [upd]+      (Just (ASContract (ContractState {..})), _) -> do+        let+          existingContracts = extractAllContracts gs+          -- can't overflow if global state is correct (because we can't+          -- create money out of nowhere)+          newBalance = csBalance `unsafeAddMutez` tdAmount txData+          epName = tdEntrypoint txData++        T.MkEntrypointCallRes _ (epc :: EntrypointCallT cp epArg)+          <- T.mkEntrypointCall epName (T.cParamNotes csContract)+             & maybe (throwError $ EEUnknownEntrypoint epName) pure++        -- If the parameter has already been typechecked, simply check if+        -- its type matches the contract's entrypoint's type.+        -- Otherwise (e.g. if it was parsed from stdin via the CLI),+        -- we need to typecheck the parameter.+        typedParameter <-+          case tdParameter txData of+            TxTypedParam (typedVal :: T.Value t) -> do+              T.castM @t @epArg typedVal (throwError ... EEUnexpectedParameterType addr)+            TxUntypedParam untypedVal ->+              liftEither $ first (EEIllTypedParameter addr) $ typeCheckingWith tcOpts $+                typeVerifyParameter @epArg existingContracts untypedVal++        let bigMapCounter0 = gs ^. gsBigMapCounterL+        let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds typedParameter) bigMapCounter0++        -- I'm not entirely sure why we need to pattern match on `()` here,+        -- but, if we don't, we get a compiler error that I suspect is somehow related+        -- to the existential types we're matching on a few lines above.+        --+        -- • Couldn't match type ‘a0’+        --                  with ‘(InterpretResult, RemainingSteps, [Operation], [GStateUpdate])’+        --     ‘a0’ is untouchable inside the constraints: StorageScope st1+        () <- when isGlobalOp $+          esOperationHash .= mkTransferOperationHash+            addr+            typedParameterWithIds+            (tdEntrypoint txData)+            (tdAmount txData)++        opHash <- use esOperationHash+        let+          contractEnv = ContractEnv+            { ceNow = now+            , ceMaxSteps = remainingSteps+            , ceBalance = newBalance+            , ceContracts = existingContracts+            , ceSelf = addr+            , ceSource = sourceAddr+            , ceSender = senderAddr+            , ceAmount = tdAmount txData+            , ceVotingPowers = gsVotingPowers gs+            , ceChainId = gsChainId gs+            , ceOperationHash = Just opHash+            , ceLevel = level+            , ceInstrCallStack = def+            }++        iur@InterpretResult+          { iurOps = sideEffects+          , iurNewStorage = newValue+          , iurNewState = InterpreterState newRemainingSteps globalCounter2 bigMapCounter2+          }+          <- liftEither $ first (EEInterpreterFailed addr) $+             handleContractReturn $+                interpret+                  csContract+                  epc+                  typedParameterWithIds+                  csStorage+                  (gsCounter gs)+                  bigMapCounter1+                  contractEnv++        let+          updBalance+            | newBalance == csBalance = Nothing+            | otherwise = Just $ GSSetBalance addr newBalance+          updStorage+            | SomeValue newValue == SomeValue csStorage = Nothing+            | otherwise = Just $ GSSetStorageValue addr newValue+          updBigMapCounter+            | bigMapCounter0 == bigMapCounter2 = Nothing+            | otherwise = Just $ GSSetBigMapCounter bigMapCounter2+          updGlobalCounter+            | globalCounter == globalCounter2 = Nothing+            | otherwise = Just $ GSUpdateCounter globalCounter2+          updates = catMaybes+            [ updBalance+            , updStorage+            , updBigMapCounter+            , updGlobalCounter+            ]+        return (updates, sideEffects, Just iur, newRemainingSteps)++    let+      -- According to the reference implementation, counter is incremented for transfers as well.+      updates = (maybe id (:) mDecreaseSenderBalance otherUpdates) ++ [GSIncrementCounter]++    newGState <- liftEither $ first EEFailedToApplyUpdates $ applyUpdates updates gs++    esGState .= newGState+    esRemainingSteps .= newRemSteps+    esSourceAddress .= Just sourceAddr++    esLog <>= ExecutorLog updates (maybe mempty (one . (addr, )) maybeInterpretRes)++    return $ convertOp addr <$> sideEffects++----------------------------------------------------------------------------+-- Simple helpers+----------------------------------------------------------------------------++checkOperationReplay :: ExecutorOp -> ExecutorM ()+checkOperationReplay op = do+  let+    opCounter = op & \case+      OriginateOp OriginationOperation{..} -> ooCounter+      TransferOp TransferOperation{..} -> toCounter+      SetDelegateOp SetDelegateOperation{..} -> sdoCounter+  prevCounters <- use esPrevCounters+  when (opCounter `HS.member` prevCounters) $+    throwError $ EEOperationReplay op+  esPrevCounters <>= one opCounter++-- The argument is the address of the contract that generated this operation.+convertOp :: Address -> T.Operation -> ExecutorOp+convertOp interpretedAddr =+  \case+    OpTransferTokens tt ->+      case ttContract tt of+        T.VContract destAddress sepc ->+          let txData =+                TxData+                  { tdSenderAddress = interpretedAddr+                  , tdEntrypoint = T.sepcName sepc+                  , tdParameter = TxTypedParam (ttTransferArgument tt)+                  , tdAmount = ttAmount tt+                  }+              transferOperation =+                TransferOperation+                  { toDestination = destAddress+                  , toTxData = txData+                  , toCounter = ttCounter tt+                  }+          in TransferOp transferOperation+    OpSetDelegate T.SetDelegate{..} -> SetDelegateOp SetDelegateOperation+      { sdoContract = interpretedAddr+      , sdoDelegate = sdMbKeyHash+      , sdoCounter = sdCounter+      }+    OpCreateContract cc ->+      let origination = OriginationOperation+            { ooOriginator = ccOriginator cc+            , ooDelegate = ccDelegate cc+            , ooBalance = ccBalance cc+            , ooStorage = ccStorageVal cc+            , ooContract =+                T.Contract+                  { cCode = ccContractCode cc+                  , cParamNotes = starParamNotes+                  , cStoreNotes = starNotes+                  , cEntriesOrder = U.canonicalEntriesOrder+                  }+            , ooCounter = ccCounter cc+            }+       in OriginateOp origination++-- | Reset source address before executing a global operation.+beginGlobalOperation :: ExecutorM ()+beginGlobalOperation =+  esSourceAddress .= Nothing++-- | Return True if address is an implicit account yet the param is not Unit.+badParamToImplicitAccount :: Address -> TxParam -> Bool+badParamToImplicitAccount (ContractAddress _) _                       = False+badParamToImplicitAccount (KeyAddress _) (TxTypedParam T.VUnit)       = False+badParamToImplicitAccount (KeyAddress _) (TxUntypedParam U.ValueUnit) = False+badParamToImplicitAccount _ _                                         = True

+ src/Morley/Michelson/Runtime/Dummy.hs view

@@ -0,0 +1,86 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Dummy data to be used in tests or demos where it's not essential.++module Morley.Michelson.Runtime.Dummy+  ( dummyNow+  , dummyLevel+  , dummyMaxSteps+  , dummyVotingPowers+  , dummyBigMapCounter+  , dummyContractEnv+  , dummyGlobalCounter+  , dummyOrigination+  ) where++import Data.Default (def)++import Morley.Michelson.Interpret (ContractEnv(..), RemainingSteps)+import Morley.Michelson.Runtime.GState (BigMapCounter, dummyVotingPowers, genesisAddress)+import Morley.Michelson.Typed (ParameterScope, StorageScope)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Operation (OriginationOperation(..))+import Morley.Tezos.Address (GlobalCounter(..))+import Morley.Tezos.Core (Timestamp(..), dummyChainId, toMutez)++-- | Dummy timestamp, can be used to specify current @NOW@ value or+-- maybe something else.+dummyNow :: Timestamp+dummyNow = Timestamp 100++dummyLevel :: Natural+dummyLevel = 4000++-- | Dummy value for maximal number of steps a contract can+-- make. Intentionally quite large, because most likely if you use+-- dummy value you don't want the interpreter to stop due to gas+-- exhaustion. On the other hand, it probably still prevents the+-- interpreter from working for eternity.+dummyMaxSteps :: RemainingSteps+dummyMaxSteps = 100500++dummyBigMapCounter :: BigMapCounter+dummyBigMapCounter = 0++dummyGlobalCounter :: GlobalCounter+dummyGlobalCounter = 0++-- | Dummy 'ContractEnv' with some reasonable hardcoded values. You+-- can override values you are interested in using record update+-- syntax.+dummyContractEnv :: ContractEnv+dummyContractEnv = ContractEnv+  { ceNow = dummyNow+  , ceMaxSteps = dummyMaxSteps+  , ceBalance = toMutez 100+  , ceContracts = mempty+  , ceSelf = genesisAddress+  , ceSource = genesisAddress+  , ceSender = genesisAddress+  , ceAmount = toMutez 100+  , ceVotingPowers = dummyVotingPowers+  , ceChainId = dummyChainId+  , ceOperationHash = Nothing+  , ceLevel = dummyLevel+  , ceInstrCallStack = def+  }++-- | 'OriginationOperation' with most data hardcoded to some+-- reasonable values. Contract and initial values must be passed+-- explicitly, because otherwise it hardly makes sense.+dummyOrigination+  :: (ParameterScope cp, StorageScope st)+  => T.Value st+  -> T.Contract cp st+  -> GlobalCounter+  -> OriginationOperation+dummyOrigination storage contract counter = OriginationOperation+  { ooOriginator = genesisAddress+  , ooDelegate = Nothing+  , ooBalance = toMutez 100+  , ooStorage = storage+  , ooContract = contract+  , ooCounter = counter+  }

+ src/Morley/Michelson/Runtime/GState.hs view

@@ -0,0 +1,433 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Global blockchain state (emulated).++module Morley.Michelson.Runtime.GState+  (+    -- * Auxiliary types+    ContractState (..)+  , AddressState (..)+  , asBalance+  , VotingPowers (..)+  , vpPick+  , vpTotal+  , mkVotingPowers+  , mkVotingPowersFromMap+  , dummyVotingPowers+  , BigMapCounter(..)+  , bigMapCounter++  -- * GState+  , GState (..)+  , gsChainIdL+  , gsAddressesL+  , gsVotingPowersL+  , gsCounterL+  , gsBigMapCounterL+  , genesisAddresses+  , genesisKeyHashes+  , genesisAddress+  -- * More genesisAddresses which can be used in tests+  , genesisAddress1+  , genesisAddress2+  , genesisAddress3+  , genesisAddress4+  , genesisAddress5+  , genesisAddress6+  , genesisKeyHash+  -- * Genesis secret keys+  , genesisSecretKey+  , genesisSecrets++  , initGState+  , readGState+  , writeGState++  -- * Operations on GState+  , GStateUpdate (..)+  , GStateUpdateError (..)+  , applyUpdate+  , applyUpdates+  , extractAllContracts+  ) where++import Control.Lens (at, makeLenses)+import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.:?), (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as Aeson+import Data.Aeson.TH (deriveJSON)+import qualified Data.ByteString.Lazy as LBS+import Data.Default (def)+import Data.List.NonEmpty ((!!))+import qualified Data.Map.Strict as Map+import Data.Type.Equality ((:~:)(..))+import Fmt (Buildable(build), (+|), (|+))+import System.IO.Error (IOError, isDoesNotExistError)++import Morley.Michelson.TypeCheck+  (SomeParamType(..), TcOriginatedContracts, typeCheckContractAndStorage, typeCheckingWith)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Existential (SomeContractAndStorage(..))+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Untyped (Contract, Value)+import Morley.Tezos.Address (Address(..), ContractHash, GlobalCounter(..))+import Morley.Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId)+import Morley.Tezos.Crypto+import Morley.Util.Aeson+import Morley.Util.Lens+import Morley.Util.Sing (eqI)++-- | State of a contract with code.+data ContractState =+  forall cp st. (ParameterScope cp, StorageScope st) => ContractState+  { csBalance :: Mutez+  -- ^ Amount of mutez owned by this contract.+  , csContract :: T.Contract cp st+  -- ^ Contract itself.+  , csStorage :: T.Value st+  -- ^ Storage value associated with this contract.+  , csDelegate :: Maybe KeyHash+  -- ^ Delegate associated with this contract.+  }++deriving stock instance Show ContractState++instance ToJSON ContractState where+  toJSON ContractState{..} =+    object .+    maybe id ((:) . ("delegate" .=)) csDelegate $+    [ "balance" .= csBalance+    , "storage" .= T.untypeValue csStorage+    , "contract" .= T.convertContract csContract+    ]++-- These instance is a bit hacky because it is quite painful to+-- write proper JSON instances for typed `Instr` and `Value` so+-- we typecheck untyped representation instead of parsing.+instance FromJSON ContractState where+  parseJSON =+    withObject "contractstate" $ \o -> do+      (balance :: Mutez) <- o .: "balance"+      (uStorage :: Value) <- o .: "storage"+      (uContract :: Contract) <- o .: "contract"+      (delegate :: Maybe KeyHash) <- o .:? "delegate"+      case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of+        Right (SomeContractAndStorage contract storage) ->+          pure $ ContractState balance contract storage delegate+        Left err -> fail $ "Unable to parse `ContractState`: " <> (show err)++instance Buildable ContractState where+  build ContractState{..} =+    "Contractstate:\n Balance: " +| csBalance |++    "\n  Storage: " +| T.untypeValue csStorage |++    "\n  Contract: " +| T.convertContract csContract |++    "\n  Delegate: " +| csDelegate |+ ""++-- | State of an arbitrary address.+data AddressState+  = ASSimple Mutez+  -- ^ For contracts without code we store only its balance.+  | ASContract ContractState+  -- ^ For contracts with code we store more state represented by+  -- 'ContractState'.+  deriving stock (Show, Generic)++instance Buildable AddressState where+  build =+    \case+      ASSimple balance -> "Balance = " +| balance |+ ""+      ASContract cs -> build cs++deriveJSON morleyAesonOptions ''AddressState++-- | Extract balance from 'AddressState'.+asBalance :: AddressState -> Mutez+asBalance =+  \case+    ASSimple b -> b+    ASContract cs -> csBalance cs++-- | Distribution of voting power among the contracts.+--+-- Voting power reflects the ability of bakers to accept, deny or pass new+-- proposals for protocol updates. I.e. each baker has its vote weight.+--+-- This datatype definition may change in future, so its internals are not+-- exported.+newtype VotingPowers+  = VotingPowers (Map KeyHash Natural)+  deriving stock (Show)++deriveJSON morleyAesonOptions ''VotingPowers++-- | Get voting power of the given address.+vpPick :: KeyHash -> VotingPowers -> Natural+vpPick key (VotingPowers distr) = Map.lookup key distr ?: 0++-- | Get total voting power.+vpTotal :: VotingPowers -> Natural+vpTotal (VotingPowers distr) = sum distr++-- | Create voting power distribution from map.+mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers+mkVotingPowersFromMap = VotingPowers++-- | Create voting power distribution.+--+-- If some key is encountered multiple times, voting power will be summed up.+mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers+mkVotingPowers = mkVotingPowersFromMap . Map.fromListWith (+)++-- | All big_maps stored in a chain have a globally unique ID.+--+-- We use this counter to keep track of how many big_maps have been created so far,+-- and to generate new IDs whenever a new big_map is created.+newtype BigMapCounter = BigMapCounter { _bigMapCounter :: Natural }+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)+  deriving newtype (ToJSON, FromJSON, Num, Buildable)++makeLenses ''BigMapCounter++-- | Persistent data passed to Morley contracts which can be updated+-- as result of contract execution.+data GState = GState+  { gsChainId :: ChainId+  -- ^ Identifier of chain.+  , gsAddresses :: Map Address AddressState+  -- ^ All known addresses and their state.+  , gsVotingPowers :: VotingPowers+  -- ^ Voting power distribution.+  , gsCounter :: GlobalCounter+  -- ^ Ever increasing operation counter.+  , gsBigMapCounter :: BigMapCounter+  } deriving stock (Show)++makeLensesWith postfixLFields ''GState++deriveJSON morleyAesonOptions ''GState++-- | Number of genesis addresses.+genesisAddressesNum :: Word+genesisAddressesNum = 10++-- | Secrets from which genesis addresses are derived from.+genesisSecrets :: NonEmpty SecretKey+genesisSecrets = do+  i <- 1 :| [2 .. genesisAddressesNum]+  let seed = encodeUtf8 (show i :: Text)+  return $ detSecretKey seed++-- | KeyHash of genesis address.+genesisKeyHashes :: NonEmpty KeyHash+genesisKeyHashes = hashKey . toPublic <$> genesisSecrets++-- | Initially these addresses have a lot of money.+genesisAddresses :: NonEmpty Address+genesisAddresses = KeyAddress <$> genesisKeyHashes++-- | One of genesis key hashes.+genesisKeyHash :: KeyHash+genesisKeyHash = head genesisKeyHashes++-- | One of genesis addresses.+genesisAddress :: Address+genesisAddress = head genesisAddresses++-- | Secret key assotiated with 'genesisAddress'.+genesisSecretKey :: SecretKey+genesisSecretKey = head genesisSecrets++-- | More genesis addresses+--+-- We know size of @genesisAddresses@, so it is safe to use @!!@+genesisAddress1, genesisAddress2, genesisAddress3 :: Address+genesisAddress4, genesisAddress5, genesisAddress6 :: Address+genesisAddress1 = genesisAddresses !! 1+genesisAddress2 = genesisAddresses !! 2+genesisAddress3 = genesisAddresses !! 3+genesisAddress4 = genesisAddresses !! 4+genesisAddress5 = genesisAddresses !! 5+genesisAddress6 = genesisAddresses !! 6++-- | Dummy 'VotingPowers'. We give all the voting power to two genesis addreses+-- as the addresses holding lot of money. Only two addresses are involved for+-- simplicity.+dummyVotingPowers :: VotingPowers+dummyVotingPowers = case genesisKeyHashes of+  k1 :| k2 : _ -> mkVotingPowers [(k1, 50), (k2, 50)]+  _ -> error "Insufficient number of genesis addresses"++-- | Initial 'GState'. It's supposed to be used if no 'GState' is+-- provided. It puts plenty of money on each genesis address.+initGState :: GState+initGState =+  GState+  { gsChainId = dummyChainId+  , gsAddresses = Map.fromList+    [ (genesis, ASSimple money)+    | let (money, _) = maxBound @Mutez `divModMutezInt` genesisAddressesNum+                    ?: error "Number of genesis addresses is 0"+    , genesis <- toList genesisAddresses+    ]+  , gsVotingPowers = dummyVotingPowers+  , gsCounter = GlobalCounter 0+  , gsBigMapCounter = BigMapCounter 0+  }++data GStateParseError =+  GStateParseError String+  deriving stock (Show)++instance Exception GStateParseError where+  displayException (GStateParseError str) = "Failed to parse GState: " <> str++-- | Read 'GState' from a file.+readGState :: FilePath -> IO GState+readGState fp = (LBS.readFile fp >>= parseFile) `catch` onExc+  where+    parseFile :: LByteString -> IO GState+    parseFile lByteString =+      if null lByteString+      then pure initGState+      else (either (throwM . GStateParseError) pure . Aeson.eitherDecode') lByteString+    onExc :: IOError -> IO GState+    onExc exc+      | isDoesNotExistError exc = pure initGState+      | otherwise = throwM exc++-- | Write 'GState' to a file.+writeGState :: FilePath -> GState -> IO ()+writeGState fp gs = LBS.writeFile fp (Aeson.encodePretty' config gs)+  where+    config =+      Aeson.defConfig+      { Aeson.confTrailingNewline = True+      }++-- | Updates that can be applied to 'GState'.+data GStateUpdate where+  GSAddAddress :: Address -> AddressState -> GStateUpdate+  GSSetStorageValue :: StorageScope st => Address -> T.Value st -> GStateUpdate+  GSSetBalance :: Address -> Mutez -> GStateUpdate+  GSIncrementCounter :: GStateUpdate+  GSUpdateCounter :: GlobalCounter -> GStateUpdate+  GSSetBigMapCounter :: BigMapCounter -> GStateUpdate+  GSSetDelegate :: Address -> Maybe KeyHash -> GStateUpdate++deriving stock instance Show GStateUpdate++instance Buildable GStateUpdate where+  build =+    \case+      GSAddAddress addr st ->+        "Add address " +| addr |+ " with state " +| st |+ ""+      GSSetStorageValue addr tVal ->+        "Set storage value of address " +| addr |+ " to " +| T.untypeValue tVal |+ ""+      GSSetBalance addr balance ->+        "Set balance of address " +| addr |+ " to " +| balance |+ ""+      GSIncrementCounter ->+        "Increment internal counter after operation"+      GSUpdateCounter v ->+        "Set internal counter to " +| v |+ " after interpreting " <>+        "several 'CREATE_CONTRACT' instructions"+      GSSetBigMapCounter inc ->+        "Increment internal big_map counter by: " +| build inc+      GSSetDelegate addr key ->+        "Set delegate for contract " +| addr |+ " to " +| maybe "<nobody>" build key++data GStateUpdateError+  = GStateAddressExists Address+  | GStateUnknownAddress Address+  | GStateNotContract Address+  | GStateStorageNotMatch Address+  deriving stock (Show)++instance Buildable GStateUpdateError where+  build =+    \case+      GStateAddressExists addr -> "Address already exists: " <> build addr+      GStateUnknownAddress addr -> "Unknown address: " <> build addr+      GStateNotContract addr -> "Address doesn't have contract: " <> build addr+      GStateStorageNotMatch addr ->+        "Storage type does not match the contract in run-time state\+        \ when updating new storage value to address: " <> build addr++-- | Apply 'GStateUpdate' to 'GState'.+applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState+applyUpdate =+  \case+    GSAddAddress addr st ->+      maybeToRight (GStateAddressExists addr) . addAddress addr st+    GSSetStorageValue addr newValue ->+      setStorageValue addr newValue+    GSSetBalance addr newBalance -> setBalance addr newBalance+    GSIncrementCounter -> Right . over gsCounterL (+1)+    GSUpdateCounter newCounter -> Right . set gsCounterL newCounter+    GSSetBigMapCounter bmCounter -> Right . set gsBigMapCounterL bmCounter+    GSSetDelegate addr key -> setDelegate addr key++-- | Apply a list of 'GStateUpdate's to 'GState'.+applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState+applyUpdates = flip (foldM (flip applyUpdate))++-- | Add an address if it hasn't been added before.+addAddress :: Address -> AddressState -> GState -> Maybe GState+addAddress addr st gs+    | addr `Map.member` accounts = Nothing+    | otherwise = Just (gs {gsAddresses = accounts & at addr .~ Just st})+  where+    accounts = gsAddresses gs++-- | Update storage value associated with given address.+setStorageValue :: forall st. (StorageScope st) =>+     Address -> T.Value st -> GState -> Either GStateUpdateError GState+setStorageValue addr newValue = updateAddressState addr modifier+  where+    modifier :: AddressState -> Either GStateUpdateError AddressState+    modifier (ASSimple _) = Left (GStateNotContract addr)+    modifier (ASContract ContractState{csStorage = _ :: T.Value st', ..}) = do+      case eqI @st @st' of+        Just Refl -> Right $ ASContract $ ContractState{csStorage = newValue, ..}+        _ -> Left $ GStateStorageNotMatch addr++-- | Update balance value associated with given address.+setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState+setBalance addr newBalance = updateAddressState addr $ Right . \case+  ASSimple _ -> ASSimple newBalance+  ASContract cs -> ASContract (cs {csBalance = newBalance})++-- | Set delegate for a given address+setDelegate :: Address -> Maybe KeyHash -> GState -> Either GStateUpdateError GState+setDelegate addr key = updateAddressState addr \case+  ASSimple _ -> Left $ GStateNotContract addr+  ASContract cs -> Right $ ASContract cs{csDelegate = key}++updateAddressState ::+     Address+  -> (AddressState -> Either GStateUpdateError AddressState)+  -> GState+  -> Either GStateUpdateError GState+updateAddressState addr f gs =+  case addresses ^. at addr of+    Nothing -> Left (GStateUnknownAddress addr)+    Just as -> do+      newState <- f as+      return $ gs { gsAddresses = addresses & at addr .~ Just newState }+  where+    addresses = gsAddresses gs++-- | Retrieve all contracts stored in GState+extractAllContracts :: GState -> TcOriginatedContracts+extractAllContracts = Map.fromList . mapMaybe extractContract . toPairs . gsAddresses+ where+    extractContract+      :: (Address, AddressState) -> Maybe (ContractHash, SomeParamType)+    extractContract =+      \case (KeyAddress _, ASSimple {}) -> Nothing+            (KeyAddress _, _) -> error "broken GState"+            (ContractAddress ca, ASContract (ContractState{..})) ->+              Just (ca, SomeParamType sing $ T.cParamNotes $ csContract)+            (ContractAddress _, _) -> error "broken GState"

+ src/Morley/Michelson/Runtime/Import.hs view

@@ -0,0 +1,211 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Runtime.Import+  (+    -- * Read, parse, typecheck contract+    readContract+  , readSomeContract+  , readUntypedContract+  , importContract+  , importSomeContract+  , importUntypedContract+  , ContractReadError(..)++    -- * Read, parse, typecheck value+  , readValue+  , importValue+  , importSomeValue+  , importUntypedValue+  , ValueReadError (..)++    -- * Generic helpers+  , MichelsonSource(..)+  , importUsing+  ) where++import Data.Default (def)+import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Fmt (Buildable(build), pretty, unlessF, (+|), (|+))++import Morley.Michelson.Parser (parseExpandValue)+import Morley.Michelson.Parser.Error (ParserException(..))+import Morley.Michelson.Parser.Types (MichelsonSource(..))+import Morley.Michelson.Runtime (parseExpandContract)+import Morley.Michelson.TypeCheck+  (TCError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith, typeVerifyContract,+  typeVerifyTopLevelType)+import Morley.Michelson.Typed (Contract(..), SingI, SomeContract(..), SomeValue, Value)+import qualified Morley.Michelson.Untyped as U++----------------------------------------------------------------------------+-- Reading, parsing, typechecking contract+----------------------------------------------------------------------------++-- | Purely read an untyped contract from Michelson textual representation.+--+-- 'FilePath' is accepted solely as a hint for error messages.+readUntypedContract+  :: MichelsonSource+  -> Text+  -> Either ContractReadError U.Contract+readUntypedContract source txt = do+  first (CREParse source) $ parseExpandContract source txt++-- | Purely read a typed contract from Michelson textual representation.+readSomeContract+  :: MichelsonSource+  -> Text+  -> Either ContractReadError SomeContract+readSomeContract source txt = do+  contract <- readUntypedContract source txt+  first (CRETypeCheck source) $+    typeCheckingWith def $ typeCheckContract contract++-- | Purely read a typed contract from Michelson textual representation,+-- failing if parameter or storage types mismatch with the expected ones.+readContract+  :: forall cp st .+     Each '[SingI] [cp, st]+  => MichelsonSource+  -> Text+  -> Either ContractReadError (Contract cp st)+readContract source txt = do+  contract <- readUntypedContract source txt+  first (CRETypeCheck source) $+    typeCheckingWith def $ typeVerifyContract contract++-- | Read a thing from a file, using the provided parsing function.+importUsing+  :: (Exception e)+  => (MichelsonSource -> Text -> Either e a)+  -> FilePath -> IO a+importUsing readFn file =+  either throwM pure . readFn (MSFile file) =<< Utf8.readFile file++-- | Import untyped contract from a given file path.+--+-- This function reads file, and parses a contract.+--+-- This function may throw t'Control.Exception.IOException' and 'ContractReadError'.+importUntypedContract :: FilePath -> IO U.Contract+importUntypedContract = importUsing readUntypedContract++-- | Import contract from a given file path.+--+-- This function reads file, parses and type checks a contract.+-- Within the typechecking we assume that no contracts are originated,+-- otherwise a type checking error will be caused.+--+-- This function may throw t'Control.Exception.IOException' and 'ContractReadError'.+importContract+  :: forall cp st .+     Each '[SingI] [cp, st]+  => FilePath -> IO (Contract cp st)+importContract = importUsing readContract++-- | Version of 'importContract' that doesn't require you to know+-- contract's parameter and storage types.+importSomeContract :: FilePath -> IO SomeContract+importSomeContract = importUsing readSomeContract++-- | Error type for 'importContract' function.+data ContractReadError+  = CREParse MichelsonSource ParserException+  | CRETypeCheck MichelsonSource TCError+  deriving stock (Show, Eq)++instance Buildable ContractReadError where+  build =+    \case+      CREParse source e -> mconcat+        [ unlessF (source == MSUnspecified) $+            "Error at " +| source |+ "\n"+        , "Failed to parse the contract: " +| e |+ "\n"+        ]+      CRETypeCheck source e -> mconcat+        [ unlessF (source == MSUnspecified) $+            "Error at " +| source |+ "\n"+        , "The contract is ill-typed: " +| e |+ "\n"+        ]++instance Exception ContractReadError where+  displayException = pretty++----------------------------------------------------------------------------+-- Reading, parsing, typechecking value+----------------------------------------------------------------------------++-- | Purely read an untyped Michelson value from textual representation.+--+-- 'FilePath' is accepted solely as a hint for error messages.+readUntypedValue+  :: MichelsonSource+  -> Text+  -> Either ValueReadError U.Value+readUntypedValue source txt = do+  first (VREParse source) $ parseExpandValue source txt++-- | Purely read a typed Michelson value from textual representation.+--+-- Expected type is provided explicitly.+readSomeValue+  :: U.Ty+  -> MichelsonSource+  -> Text+  -> Either ValueReadError SomeValue+readSomeValue ty source txt = do+  valueU <- readUntypedValue source txt+  first (VRETypeCheck source) $+    typeCheckingWith def $ typeCheckTopLevelType Nothing ty valueU++-- | Purely read a typed Michelson value from textual representation.+readValue+  :: forall t. SingI t+  => MichelsonSource+  -> Text+  -> Either ValueReadError (Value t)+readValue source txt = do+  valueU <- readUntypedValue source txt+  first (VRETypeCheck source) $+    typeCheckingWith def $ typeVerifyTopLevelType Nothing valueU++-- | Import an untyped value from a given file path.+importUntypedValue :: FilePath -> IO U.Value+importUntypedValue = importUsing readUntypedValue++-- | Import a typed value from a given file path.+--+-- Expected type is provided explicitly.+importSomeValue :: U.Ty -> FilePath -> IO SomeValue+importSomeValue = importUsing . readSomeValue++-- | Import a typed value from a given file path.+importValue+  :: forall t . SingI t+  => FilePath -> IO (Value t)+importValue = importUsing readValue++-- | Error type for 'importValue' function.+data ValueReadError+  = VREParse MichelsonSource ParserException+  | VRETypeCheck MichelsonSource TCError+  deriving stock (Show, Eq)++instance Buildable ValueReadError where+  build =+    \case+      VREParse source e -> mconcat+        [ unlessF (source == MSUnspecified) $+            "Error at " +| source |+ "\n"+        , "Failed to parse the value: " +| e |+ "\n"+        ]+      VRETypeCheck source e -> mconcat+        [ unlessF (source == MSUnspecified) $+            "Error at " +| source |+ "\n"+        , "Invalid value for required type: " +| e |+ "\n"+        ]++instance Exception ValueReadError where+  displayException = pretty

+ src/Morley/Michelson/Runtime/TxData.hs view

@@ -0,0 +1,41 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 'TxData' type and associated functionality.++module Morley.Michelson.Runtime.TxData+       ( TxData (..)+       , TxParam(..)+       , tdSenderAddressL+       , tdParameterL+       , tdEntrypointL+       , tdAmountL+       ) where++import Control.Lens (makeLensesWith)++import Morley.Michelson.Typed (ParameterScope)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Untyped (EpName)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (Mutez)+import Morley.Util.Lens (postfixLFields)++-- | A parameter associated with a particular transaction.+data TxParam where+  TxTypedParam :: forall t. ParameterScope t => T.Value t -> TxParam+  TxUntypedParam :: U.Value -> TxParam++deriving stock instance Show TxParam++-- | Data associated with a particular transaction.+data TxData = TxData+  { tdSenderAddress :: Address+  , tdParameter :: TxParam+  , tdEntrypoint :: EpName+  , tdAmount :: Mutez+  } deriving stock Show++makeLensesWith postfixLFields ''TxData

+ src/Morley/Michelson/Text.hs view

@@ -0,0 +1,216 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- deriving 'Container' automatically produces extra constraints.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Strings compliant with Michelson constraints.+--+-- When writting a Michelson contract, you can only mention characters with+-- codes from @[32 .. 126]@ range in string literals. Same restriction applies+-- to string literals passed to @tezos-client@.+--+-- However, Michelson allows some control sequences: @"\n"@. You have to write+-- it exactly in this form, and internally it will be transformed to line feed+-- character (this behaviour can be observed when looking at @Pack@ed data).+--+-- See tests for examples of good and bad strings.+module Morley.Michelson.Text+  ( MText (..)+  , mkMText+  , unsafeMkMText+  , mkMTextCut+  , writeMText+  , takeMText+  , dropMText+  , isMChar+  , minBoundMChar+  , maxBoundMChar++    -- * Misc+  , qqMText+  , mt+  , DoNotUseTextError+  , symbolToMText+  , labelToMText+  , mtextHeadToUpper+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..))+import qualified Data.Char as C+import Data.Data (Data)+import qualified Data.Text as T+import Fmt (Buildable)+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH++import Morley.Util.CLI+import Morley.Util.Label (Label(..), labelToText)+import Morley.Util.TypeLits++-- | Michelson string value.+--+-- This is basically a mere text with limits imposed by the language:+-- <https://tezos.gitlab.io/whitedoc/michelson.html#constants>+-- Although, this document seems to be not fully correct, and thus we applied+-- constraints deduced empirically.+--+-- You construct an item of this type using one of the following ways:+--+-- * With QuasyQuotes when need to create a string literal.+--+-- >>> [mt|Some text|]+-- UnsafeMText {unMText = "Some text"}+--+-- * With 'mkMText' when constructing from a runtime text value.+--+-- * With 'unsafeMkMText' or 'UnsafeMText' when absolutelly sure that+-- given string does not violate invariants.+--+-- * With 'mkMTextCut' when not sure about text contents and want+-- to make it compliant with Michelson constraints.+newtype MText = UnsafeMText { unMText :: Text }+  deriving stock (Show, Eq, Ord, Data, Generic)+  deriving newtype (Semigroup, Monoid, Container, Buildable, Hashable)++instance NFData MText++minBoundMChar, maxBoundMChar :: Int+minBoundMChar = 32+maxBoundMChar = 126++-- | Constraint on literals appearing in Michelson contract code.+isMChar :: Char -> Bool+isMChar c = fromEnum c >= minBoundMChar && fromEnum c <= maxBoundMChar++-- | Error message indicating bad character in a string literal.+invalidMCharError :: Char -> Text+invalidMCharError c = "Invalid character in string literal: " <> toText [c]++-- | Wrap a Haskell text into 'MText', performing necessary checks.+--+-- You can use e.g. @'\n'@ character directly in supplied argument,+-- but attempt to use other bad characters like @'\r'@ will cause failure.+mkMText :: Text -> Either Text MText+mkMText txt = mapM checkMChar (toString txt) $> UnsafeMText txt+  where+    checkMChar c+      | isMChar c || c == '\n' = pass+      | otherwise = Left $ invalidMCharError c++-- | Contruct 'MText' from a Haskell text, failing if provided Haskell text+-- is invalid Michelson string.+unsafeMkMText :: HasCallStack => Text -> MText+unsafeMkMText = either error id . mkMText++-- | Construct 'MText' from a Haskell text, eliminating all characters which+-- should not appear in Michelson strings.+-- Characters which can be displayed normally via escaping are preserved.+mkMTextCut :: Text -> MText+mkMTextCut txt =+  UnsafeMText . toText . filter isAllowed $ toString txt+  where+    isAllowed c = isMChar c || c == '\n'++-- | Print 'MText' for Michelson code, with all unusual characters escaped.+writeMText :: MText -> Text+writeMText (UnsafeMText t) = t+  & T.replace "\\" "\\\\"+  & T.replace "\n" "\\n"+  & T.replace "\"" "\\\""++takeMText :: Int -> MText -> MText+takeMText n (UnsafeMText txt) = UnsafeMText $ T.take n txt++dropMText :: Int -> MText -> MText+dropMText n (UnsafeMText txt) = UnsafeMText $ T.drop n txt++instance ToText MText where+  toText = unMText++instance ToJSON MText where+  toJSON = toJSON . unMText+instance FromJSON MText where+  parseJSON v =+    either (fail . toString) pure . mkMText =<< parseJSON @Text v++instance HasCLReader MText where+  getReader = eitherReader (first toString . mkMText . toText)+  getMetavar = "MICHELSON STRING"++-- | QuasyQuoter for constructing Michelson strings.+--+-- Validity of result will be checked at compile time.+-- Note:+--+-- * slash must be escaped+-- * newline character must appear as '\n'+-- * use quotes as is+-- * other special characters are not allowed.++-- TODO: maybe enforce one space in the beginning and one in the end?+-- compare:+-- >>> [mt|mystuff|]+-- vs+-- >>> [mt| mystuff |]+mt :: TH.QuasiQuoter+mt = TH.QuasiQuoter+  { TH.quoteExp = \s ->+      case qqMText s of+        Left err -> fail $ toString err+        Right txt -> [e| UnsafeMText (toText @String txt) |]+  , TH.quotePat = \s ->+      case qqMText s of+        Left err -> fail $ toString err+        Right txt -> [p| UnsafeMText $(TH.litP $ TH.StringL txt) |]+  , TH.quoteType = \_ ->+      fail "Cannot use this QuasiQuoter at type position"+  , TH.quoteDec = \_ ->+      fail "Cannot use this QuasiQuoter at declaration position"+  }++{-# ANN module ("HLint: ignore Use list literal pattern" :: Text) #-}++-- | Parser used in 'mt' quasi quoter.+qqMText :: String -> Either Text String+qqMText txt = scan txt+  where+  scan = \case+    '\\' : [] -> Left "Unterminated '\\' in string literal"+    '\\' : '\\' : s -> ('\\' :) <$> scan s+    '\\' : 'n'  : s -> ('\n' :) <$> scan s+    '\\' : c : _ -> Left $ "Unknown escape sequence: '\\" <> toText [c] <> "'"+    c : s+      | isMChar c -> (c :) <$> scan s+      | otherwise -> Left $ invalidMCharError c+    [] -> Right []++-- | A type error asking to use 'MText' instead of t'Text'.+type family DoNotUseTextError where+  DoNotUseTextError = TypeError+    ( 'Text "`Text` is not isomorphic to Michelson strings," ':$$:+      'Text "consider using `MText` type instead"+    )++-- | Create a 'MText' from type-level string.+--+-- We assume that no unicode characters are used in plain Haskell code,+-- so unless special tricky manipulations are used this should be safe.+symbolToMText :: forall name. KnownSymbol name => MText+symbolToMText = unsafeMkMText $ symbolValT' @name++-- | Create a 'MText' from label.+--+-- We assume that no unicode characters are used in plain Haskell code,+-- so unless special tricky manipulations are used this should be safe.+labelToMText :: Label name -> MText+labelToMText = unsafeMkMText . labelToText++-- | Leads first character of text to upper case.+--+-- For empty text this will throw an error.+mtextHeadToUpper :: HasCallStack => MText -> MText+mtextHeadToUpper (UnsafeMText txt) = case T.uncons txt of+  Nothing -> error "Empty text"+  Just (c, cs) -> UnsafeMText $ T.cons (C.toUpper c) cs

+ src/Morley/Michelson/TypeCheck.hs view

@@ -0,0 +1,33 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.TypeCheck+  ( typeCheckContract+  , typeCheckContractAndStorage+  , typeCheckExt+  , typeCheckInstr+  , typeCheckList+  , typeCheckListNoExcept+  , typeCheckParameter+  , typeCheckStorage+  , typeCheckTopLevelType+  , typeCheckValue+  , typeVerifyContract+  , typeVerifyParameter+  , typeVerifyStorage+  , typeVerifyTopLevelType+  , module E+  , module M+  , module T+  , eqType+  , matchTypes+  ) where++import Morley.Michelson.TypeCheck.Error as E+import Morley.Michelson.TypeCheck.Ext+import Morley.Michelson.TypeCheck.Instr+import Morley.Michelson.TypeCheck.TypeCheck as T+import Morley.Michelson.TypeCheck.Types as M++import Morley.Michelson.TypeCheck.Helpers (eqType, matchTypes)

+ src/Morley/Michelson/TypeCheck/Error.hs view

@@ -0,0 +1,367 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Errors that can occur when some code is being typechecked.++module Morley.Michelson.TypeCheck.Error+  ( TypeContext (..)+  , TopLevelType (..)+  , TCTypeError (..)+  , TCError (..)+  , ExtError (..)+  , StackSize (..)+  , pairWithNodeIndex+  , pairWithElems+  ) where++import Fmt (Buildable(..), pretty, (+|), (|+), (||+))+import Prelude hiding (empty, (<$>))+import Text.PrettyPrint.Leijen.Text hiding (bool, pretty)+import qualified Text.Show (show)++import Morley.Michelson.ErrorPos (InstrCallStack(..))+import Morley.Michelson.Printer.Util+  (RenderDoc(..), buildRenderDoc, buildRenderDocExtended, doesntNeedParens, renderAnyBuildable,+  renderDoc, renderDocList)+import Morley.Michelson.TypeCheck.TypeCheckedOp (TypeCheckedOp)+import Morley.Michelson.TypeCheck.Types (SomeHST(..))+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Annotation (AnnConvergeError(..))+import Morley.Michelson.Untyped (StackFn, Ty, Var)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address)+import Morley.Tezos.Crypto (CryptoParseError)+import qualified Morley.Tezos.Crypto.BLS12381 as BLS+import Morley.Util.Named++-- | Contexts where type error can occur.+data TypeContext+  = LambdaArgument+  | LambdaCode+  | DipCode+  | ConsArgument+  | ComparisonArguments+  | ContractParameter+  | ContractStorage+  | ArithmeticOperation+  | Iteration+  | Cast+  | UnpairArgument+  | CarArgument+  | CdrArgument+  | If+  | ConcatArgument+  | ContainerKeyType+  | ContainerValueType+  | FailwithArgument+  | TicketsJoin+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)++instance RenderDoc TypeContext where+  renderDoc _ = \case+    LambdaArgument -> "argument to some lambda"+    LambdaCode -> "code in LAMBDA"+    DipCode -> "code in DIP"+    ConsArgument -> "argument to CONS"+    ComparisonArguments -> "arguments to comparison function"+    ContractParameter -> "contract parameter"+    ContractStorage -> "contract storage"+    ArithmeticOperation -> "arguments to arithmetic operation"+    Iteration -> "iteration (ITER / MAP / etc) code"+    Cast -> "argument to CAST"+    UnpairArgument -> "argument to UNPAIR"+    CarArgument -> "argument to CAR"+    CdrArgument -> "argument to CDR"+    If -> "conditional expression"+    ConcatArgument -> "argument to CONCAT"+    ContainerKeyType -> "container key type"+    ContainerValueType -> "container value type"+    FailwithArgument -> "argument to FAILWITH"+    TicketsJoin -> "join of two tickets"++data TopLevelType+  = TltParameterType+  | TltStorageType+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)++instance Buildable TopLevelType where+  build = buildRenderDoc++instance RenderDoc TopLevelType where+  renderDoc _ = \case+    TltParameterType -> "parameter"+    TltStorageType -> "storage"++instance Buildable TypeContext where+  build = buildRenderDoc++-- | Data type that represents various errors+-- which are related to type system.+-- These errors are used to specify info about type check errors+-- in @TCError@ data type.+data TCTypeError+  = AnnError AnnConvergeError+  -- ^ Annotation unify error+  | TypeEqError T.T T.T+  -- ^ Type equality error+  | StackEqError [T.T] [T.T]+  -- ^ Stacks equality error+  | UnsupportedTypeForScope T.T T.BadTypeForScope+  -- ^ Error that happens when type cannot be used in the corresponding scope.+  -- Argument of this constructor carries type which violates+  -- the restriction, e.g. @big_map@ in @UNPACK@, and a concrete reason why the+  -- type is unsuported.+  | NotNumericTypes T.T T.T+  -- ^ Arithmetic operation is applied to types, at least one of which is not numeric+  -- (e.g. @timestamp@ and @timestamp@ passed to @MUL@ instruction).+  | UnexpectedType (NonEmpty (NonEmpty Text))+  -- ^ Error that happens when actual types are different from the type that instruction expects.+  -- The param is an non-empty list of all expected stack types that the instruction would accept.+  -- Each expected stack types is represented as non-empty list as well.+  | UnexpectedTopLevelType TopLevelType ("expected" :! T.T) ("got" :! T.T)+  -- ^ Error that happens when the caller expected one top-level type, but+  -- the contract has another type specified.+  | InvalidInstruction U.ExpandedInstr Text+  -- ^ Some instruction is invalid or used in an invalid way.+  -- For example, @PAIR 0@ or @PAIR 1@, or a @SELF@ instruction was used in a @LAMBDA@.+  -- The 'Text' argument is a user-readable explanation of why this instruction is invalid.+  | InvalidValueType T.T+  -- ^ Error that happens when a `U.Value` is never a valid source for this type+  -- (e.g. @timestamp@ cannot be obtained from a `U.ValueTrue`)+  | NotEnoughItemsOnStack+  -- ^ There are not enough items on stack to perform a certain instruction.+  | IllegalEntrypoint T.EpNameFromRefAnnError+  -- ^ Invalid entrypoint name provided+  | UnknownContract Address+  -- ^ Contract with given address is not originated.+  | EntrypointNotFound T.EpName+  -- ^ Given entrypoint is not present.+  | IllegalParamDecl T.ParamEpError+  -- ^ Incorrect parameter declaration (with respect to entrypoints feature).+  | NegativeNat+  -- ^ Natural numbers cannot be negative+  | MutezOverflow+  -- ^ Exceeds the maximal mutez value+  | InvalidAddress T.ParseEpAddressError+  -- ^ Address couldn't be parsed from its textual representation+  | InvalidKeyHash CryptoParseError+  -- ^ KeyHash couldn't be parsed from its textual representation+  | InvalidBls12381Object BLS.DeserializationError+  -- ^ BLS12-381 primitive couldn't be parsed+  | InvalidTimestamp+  -- ^ Timestamp is not RFC339 compliant+  | CodeAlwaysFails+  -- ^ Code always fails, but shouldn't, like in ITER body.+  -- This is actually more general, any instruction that allows no continuation+  -- (like @NEVER@) cannot appear as part of another instruction's body.+  | EmptyCode+  -- ^ Empty block of code, like ITER body.+  | AnyError+  -- ^ Generic error when instruction does not match something sensible.+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)++instance Buildable TCTypeError where+  build = buildRenderDocExtended++instance RenderDoc TCTypeError where+  renderDoc context = \case+    AnnError e -> renderAnyBuildable e+    TypeEqError type1 type2 ->+      "Types not equal:" <+> (renderDoc context type1) <+> "/=" <+> (renderDoc context type2)+    StackEqError st1 st2 ->+      "Stacks not equal:"<+> (renderDocList context st1) <+> "/=" <+> (renderDocList context st2)+    UnsupportedTypeForScope typ reason ->+      "Type '" <> (renderDoc context typ) <> "' is unsupported here because it"+      <+> (renderDoc context reason)+    NotNumericTypes t1 t2 ->+      "Some of the types in an arithmetic operation are not numeric:"+      <+> (renderDoc context t1) <+> "and" <+> (renderDoc context t2)+    UnexpectedType (t :| ts) ->+      "Wrong stack type for instruction, expect stack type to begin with " <+>+        (cat $ punctuate "or"+          $ fmap (\(x :| xs) -> list $ fmap (renderAnyBuildable) (x:xs))+          $ (t:ts)+        )+    UnexpectedTopLevelType tyDesc (N expected) (N got) ->+      "Unexpected" <+> renderDoc context tyDesc <+> "type:"+      <$$> renderLargeType got+      <$$> "Expected:"+      <$$> renderLargeType expected+    InvalidInstruction instr reason ->+      "Invalid instruction" <+> (renderDoc context instr)+      <$$> "Reason:" <+> textStrict reason+    InvalidValueType t ->+      "Value type is never a valid" <+> enclose "`" "`" (renderDoc context t)+    NotEnoughItemsOnStack ->+      "Not enough items on stack"+    UnknownContract addr ->+      "Contract is not registered:" <+> (renderAnyBuildable addr)+    IllegalEntrypoint err -> renderDoc context err+    EntrypointNotFound ep ->+      "No such entrypoint" <+> enclose "`" "`" (renderAnyBuildable ep)+    IllegalParamDecl err -> renderDoc context err+    NegativeNat -> "Natural number cannot be negative"+    MutezOverflow -> "Exceeds maximal value for mutez"+    InvalidAddress e -> renderDoc context e+    InvalidKeyHash e -> renderDoc context e+    InvalidBls12381Object e -> renderDoc context e+    InvalidTimestamp -> "Is not a valid RFC3339 timestamp"+    CodeAlwaysFails ->+      "Cannot use a terminate instruction (like FAILWITH) as part of another \+      \instruction's body"+    EmptyCode -> "Code block is empty"+    AnyError -> "Some of the arguments have invalid types"+    where+      renderLargeType :: T.T -> Doc+      renderLargeType = indent 2 . renderDoc doesntNeedParens . T.toUType++-- | Type check error+data TCError+  = TCFailedOnInstr U.ExpandedInstr SomeHST InstrCallStack (Maybe TypeContext) (Maybe TCTypeError)+  | TCFailedOnValue U.Value T.T Text InstrCallStack (Maybe TCTypeError)+  | TCContractError Text (Maybe TCTypeError)+  | TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp)+  | TCExtError SomeHST InstrCallStack ExtError+  | TCIncompletelyTyped TCError (U.Contract' TypeCheckedOp)+  deriving stock (Eq, Generic)++instance NFData TCError++instance Buildable TCError where+  build = buildRenderDocExtended++instance RenderDoc TCError where+  renderDoc context = \case+    TCFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTCTypeError -> line+      <> "Error checking expression:"+      <> surroundWithNewLines (renderDoc context instr)+      <> "against input stack type:"+      <> surroundWithNewLines (renderDoc context t)+      <> maybe "" (\c -> "Error in" <+> renderDoc context c) mbTCTypeContext+      <> maybe "" (\e -> ":" <+> (renderDoc context e) <> "." <$$> line) mbTCTypeError+      <> (renderDoc context ics)+    TCFailedOnValue v t custom ics mbTCTypeError ->+      "Error checking value"+      <$$> (renderDoc context v) <+> "against type"+      <+> (renderDoc context t) <> (bool (":" <+> (renderAnyBuildable custom)) "." (null custom))+      <+> (maybe "" (\e -> line <> (renderDoc context e) <> line) mbTCTypeError)+      <+> (renderDoc context ics)+    TCContractError msg typeError ->+      "Error occurred during contract typecheck:"+      <$$> (renderAnyBuildable msg) <> (maybe "" (\e -> " " <> (renderDoc context e)) typeError)+    TCUnreachableCode ics instrs ->+      "Unreachable code:" <$$> buildTruncated 3 (toList instrs) <> "."+      <+> (renderDoc context ics)+    TCExtError (SomeHST t) ics e ->+      "Error occurred during Morley extension typecheck:" <>+      (renderAnyBuildable e) <+> "on stack" <+> (renderDoc context t) <> "."+      <+> (renderDoc context ics)+    TCIncompletelyTyped err contract ->+      line+      <> renderDoc doesntNeedParens contract+      <$> renderDoc context err+    where+    buildTruncated k l+      | null (drop k l) = renderDocList context l+      | otherwise = (renderDocList context (take k l)) <> " ..."++    -- | Helper to format a line using empty lines at the end and at the beginning,+    -- and 4-space indents for the line itself+    surroundWithNewLines :: Doc -> Doc+    surroundWithNewLines l =+      line+      <$$> indent 4 l+      <$$> line++instance Show TCError where+  show = pretty++instance Exception TCError++newtype StackSize = StackSize Natural+  deriving stock (Show, Eq, Generic)++instance NFData StackSize++-- | Various type errors possible when checking Morley extension commands+data ExtError =+    LengthMismatch U.StackTypePattern+  | VarError Text StackFn+  | TypeMismatch U.StackTypePattern Int TCTypeError+  | TyVarMismatch Var Ty U.StackTypePattern Int TCTypeError+  | StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError+  | TestAssertError Text+  | InvalidStackReference U.StackRef StackSize+  deriving stock (Eq, Generic)++instance NFData ExtError++instance Buildable ExtError where+  build = \case+    LengthMismatch stk ->+      "Unexpected length of stack: pattern "+      +| stk |+ " has length "+      +| (length . fst . U.stackTypePatternToList) stk |+ ""+    VarError t sf ->+      "In defenition of " +| t |+ ": VarError "+      +| sf |+ ""+    TypeMismatch stk i e ->+      "TypeMismatch: Pattern " +| stk |+ " at index "+      +| i |+ " with error: " +| e |+ ""+    TyVarMismatch v t stk i e ->+      "TyVarMismach: Variable " +| v |+ " is bound to type "+      +| t |+ " but pattern " +| stk |+ " failed at index "+      +| i |+ " with error: " +| e |+ ""+    StkRestMismatch stk (SomeHST r) (SomeHST r') e ->+      "StkRestMismatch in pattern " +| stk |++      " against stacks " +| r ||+ " and " +| r' ||++      " with error: " +| e |+ ""+    TestAssertError t ->+      "TestAssertError: " +| t |+ ""+    InvalidStackReference i lhs ->+      "InvalidStackReference: reference is out of the stack: "+      +| i ||+ " >= " +| lhs ||+ ""++----------------------------------------------------------------------------+-- Helpers for formatting types+----------------------------------------------------------------------------++-- | Given a node index @ix@, creates a string representing the+-- smallest possible right-combed pair with at least @ix+1@ nodes.+--+-- Since the node index 0 is valid even for non-pair values+-- (e.g. we can run @GET 0@ on a @string@ or an @int@),+-- we simply return a type variable @'a@ in this case.+--+-- >>> pairWithNodeIndex 0+-- "'a"+--+-- >>> pairWithNodeIndex 4+-- "pair 'a1 'a2 'a3"+--+-- >>> pairWithNodeIndex 5+-- "pair 'a1 'a2 'a3 'a4"+pairWithNodeIndex :: Word -> Text+pairWithNodeIndex = \case+  0 -> "'a"+  ix -> pairWithElems (minPairLength ix)+  where+    -- | Given a node index @ix@, calculates the minimum number of+    -- elements a pair must have for that index to be valid.+    minPairLength :: Word -> Word+    minPairLength = \case+      0 -> 2+      ix -> (ix + 3) `div` 2++-- | Given a number @n@, creates a string representing a+-- right-combed pair of arity @n@.+--+-- > pairType 3 == "pair 'a1 'a2 'a3"+pairWithElems :: Word -> Text+pairWithElems n =+  "pair "+  <> mconcat (intersperse " " ([1 .. n] <&> \i -> "'a" <> show i))

+ src/Morley/Michelson/TypeCheck/Ext.hs view

@@ -0,0 +1,187 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Type-checking of Morley extension.+module Morley.Michelson.TypeCheck.Ext+  ( typeCheckExt+  ) where++import Control.Lens ((%=))+import Control.Monad.Except (MonadError, liftEither, throwError)+import Data.Constraint (Dict(..))+import Data.Map.Lazy (insert, lookup)+import Data.Singletons (SingI)+import Data.Typeable ((:~:)(..))++import Morley.Michelson.ErrorPos+import Morley.Michelson.TypeCheck.Error+import Morley.Michelson.TypeCheck.Helpers+import Morley.Michelson.TypeCheck.TypeCheck+import Morley.Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..))+import Morley.Michelson.TypeCheck.Types+import Morley.Michelson.Typed (Notes(..), converge, mkUType, notesT, withUType)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Untyped+  (ExpandedOp, StackFn, Ty, TyVar(..), Var, VarAnn, sfnInPattern, sfnOutPattern, sfnQuantifiedVars,+  varSet)+import qualified Morley.Michelson.Untyped as U+import Morley.Util.PeanoNatural (PeanoNatural(..))++-- | Perform some, possibly throwing, action presumably making use of a supplied+-- external instruction. In case of an error, return @IllTypedSeq@ wrapping the+-- thrown error and the instruction. If the action successfully returns+-- @SomeInstr@, wrap it in a @WellTypedSeq@.+workOnInstr+  :: U.ExpandedExtInstr+  -> TypeCheckInstr (SomeInstr s)+  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)+workOnInstr ext = tcEither+  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx $ U.EXT ext])+  (pure . WellTypedSeq)++typeCheckExt+  :: forall s. SingI s+  => TcInstrHandler+  -> U.ExpandedExtInstr+  -> HST s+  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)+typeCheckExt tcInstr ext hst = do+  instrPos <- ask+  case ext of+    U.STACKTYPE s -> workOnInstr ext $+      liftExtError hst $ stackTypeSomeInstr s <$ checkStackType noBoundVars s hst+    U.FN t sf op  -> checkFn tcInstr t sf op hst instrPos+    U.UPRINT pc   -> workOnInstr ext $+      verifyPrint pc <&> \tpc -> toSomeInstr (T.PRINT tpc)+    U.UTEST_ASSERT U.TestAssert{..} -> do+      let cons = U.EXT . U.UTEST_ASSERT . U.TestAssert tassName tassComment+      preserving (typeCheckImpl tcInstr tassInstrs hst) cons $ \(_ :/ si) -> case si of+        AnyOutInstr _ -> throwError $ TCExtError (SomeHST hst) instrPos $ TestAssertError+                         "TEST_ASSERT has to return Bool, but it always fails"+        instr ::: (((_ :: (T.Notes b, Dict (T.WellTyped b), VarAnn)) ::& _)) -> do+          Refl <- liftEither $ first+            (const $ TCExtError (SomeHST hst) instrPos $+              TestAssertError "TEST_ASSERT has to return Bool, but returned something else")+            (eqType @b @'T.TBool)+          tcom <- verifyPrint tassComment+          pure . toSomeInstr $ T.TEST_ASSERT $ T.TestAssert tassName tcom instr+        _ ->+          throwError $ TCExtError (SomeHST hst) instrPos $+            TestAssertError "TEST_ASSERT has to return Bool, but the stack is empty"++    U.UCOMMENT t ->+      -- TODO if we are going to analyze/parse programs from files,+      -- there should be parsing of string and creation of FunctionStarted/FunctionFinished/etc+      pure $ WellTypedSeq $ toSomeInstr $ T.COMMENT_ITEM $ T.JustComment t+  where+    verifyPrint :: U.PrintComment -> TypeCheckInstr (T.PrintComment s)+    verifyPrint (U.PrintComment pc) = do+      let checkStRef (Left txt)             = pure $ Left txt+          checkStRef (Right (U.StackRef i)) = Right <$> createStackRef i hst+      T.PrintComment <$> traverse checkStRef pc++    toSomeInstr ext' = hst :/ T.Ext ext' ::: hst+    stackTypeSomeInstr s = hst :/ T.Ext (T.STACKTYPE s) ::: hst++liftExtError :: SingI s => HST s -> Either ExtError a -> TypeCheckInstr a+liftExtError hst ei = do+  instrPos <- ask+  liftEither $ first (TCExtError (SomeHST hst) instrPos) ei++-- | Check that the optional "forall" variables are consistent if present+checkVars :: Text -> StackFn -> Either ExtError ()+checkVars t sf = case sfnQuantifiedVars sf of+  Just qs+    | varSet (sfnInPattern sf) /= qs -> Left $ VarError t sf+  _ -> pass++-- | Executes function body, pushing @ExtFrame@ onto the state and checks+-- the pattern in @FN@.+checkFn+  :: SingI inp+  => TcInstrHandler+  -> Text+  -> StackFn+  -> [ExpandedOp]+  -> HST inp+  -> InstrCallStack+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+checkFn tcInstr t sf body inp loc = do+  guarding (con body) (checkStart inp) $ \vars ->+    preserving (typeCheckImplStripped tcInstr body inp) con $ \someI@(_ :/ instrAndOut) ->+      case instrAndOut of+        _ ::: out -> checkEnd vars out $> mapSomeInstr (T.WithLoc loc . T.Fn t sf) someI+        AnyOutInstr{} -> pure someI+  where+    checkStart hst = do+      liftExtError hst $ checkVars t sf+      vars <- liftExtError hst $ checkStackType noBoundVars (sfnInPattern sf) hst+      tcExtFramesL %= (vars :)+      return vars++    checkEnd :: SingI out => BoundVars -> HST out -> TypeCheckInstr ()+    checkEnd vars out = liftExtError out $+      void $ checkStackType vars (sfnOutPattern sf) out++    con :: [op] -> U.InstrAbstract op+    con = U.EXT . U.FN t sf++-- | Check that a @StackTypePattern@ matches the type of the current stack+checkStackType+  :: SingI xs+  => BoundVars+  -> U.StackTypePattern+  -> HST xs+  -> Either ExtError BoundVars+checkStackType (BoundVars vars boundStkRest) s hst = go vars 0 s hst+  where+    go :: SingI xs => Map Var Ty -> Int -> U.StackTypePattern -> HST xs+       -> Either ExtError BoundVars+    go m _ U.StkRest sr = case boundStkRest of+      Nothing -> pure $ BoundVars m (Just $ SomeHST sr)+      Just si@(SomeHST sr') ->+        bimap (StkRestMismatch s (SomeHST sr) si)+              (const $ BoundVars m (Just si))+              (eqHST sr sr')+    go m _ U.StkEmpty SNil = pure $ BoundVars m Nothing+    go _ _ U.StkEmpty _    = Left $ LengthMismatch s+    go _ _ _ SNil        = Left $ LengthMismatch s+    go m n (U.StkCons tyVar ts) ((xann :: Notes xt, _, _) ::& xs) =+      let+        handleType :: U.Ty -> Either ExtError BoundVars+        handleType t =+          withUType t $ \(tann :: Notes t) -> do+            Refl <- first+              (\_ -> TypeMismatch s n $ TypeEqError (notesT xann) (notesT tann))+              (eqType @xt @t)+            void $ first (TypeMismatch s n . AnnError) (converge tann xann)+            go m (n + 1) ts xs+      in case tyVar of+        TyCon t -> handleType t+        VarID v -> case lookup v m of+          Nothing -> let t = mkUType xann in go (insert v t m) (n + 1) ts xs+          Just t -> handleType t++-- | Create stack reference accessing element with a given index.+--+-- Fails when index is too large for the given stack.+createStackRef+  :: (MonadError TCError m, MonadReader InstrCallStack m, SingI s)+  => Natural -> HST s -> m (T.StackRef s)+createStackRef idx hst =+  case doCreate (hst, idx) of+    Just sr -> pure sr+    Nothing -> do+      instrPos <- ask+      throwError $+        TCExtError (SomeHST hst) instrPos $+          InvalidStackReference (U.StackRef idx) (StackSize $ lengthHST hst)+  where+    doCreate :: forall s. (HST s, Natural) -> Maybe (T.StackRef s)+    doCreate = \case+      (SNil, _) -> Nothing+      ((_ ::& _), 0) -> Just (T.StackRef Zero)+      ((_ ::& st), i) -> do+        T.StackRef ns <- doCreate (st, i - 1)+        return $ T.StackRef (Succ ns)

+ src/Morley/Michelson/TypeCheck/Helpers.hs view

@@ -0,0 +1,967 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.TypeCheck.Helpers+    ( deriveSpecialVN+    , deriveSpecialFNs+    , deriveVN+    , deriveNsOr+    , deriveNsOption+    , convergeHSTEl+    , convergeHST+    , hstToTs+    , eqHST+    , eqHST1+    , lengthHST++    , ensureDistinctAsc+    , eqType+    , onTypeCheckInstrAnnErr+    , onTypeCheckInstrErr+    , onScopeCheckInstrErr+    , typeCheckInstrErr+    , typeCheckInstrErr'+    , typeCheckImpl+    , typeCheckImplStripped+    , matchTypes++    , memImpl+    , getImpl+    , updImpl+    , getUpdImpl+    , sliceImpl+    , concatImpl+    , concatImpl'+    , sizeImpl+    , arithImpl+    , addImpl+    , subImpl+    , mulImpl+    , edivImpl+    , unaryArithImpl+    , unaryArithImplAnnotated+    , withCompareableCheck+    ) where++import Prelude hiding (EQ, GT, LT)++import Control.Lens (unsnoc)+import Control.Monad.Except (MonadError, throwError)+import Data.Constraint (Dict(..), withDict)+import Data.Default (def)+import Data.Singletons (Sing, SingI(sing), demote)+import Data.Singletons.Decide+import qualified Data.Text as T+import Data.Vinyl (Rec(..))+import Fmt ((+||), (||+))++import Morley.Michelson.ErrorPos (InstrCallStack)+import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..), TypeContext(..))+import Morley.Michelson.TypeCheck.TypeCheck+import Morley.Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..))+import Morley.Michelson.TypeCheck.Types+import Morley.Michelson.Typed+  (BadTypeForScope(..), CommentType(StackTypeComment), Comparable, ExtInstr(COMMENT_ITEM),+  Instr(..), Notes(..), SingT(..), T(..), WellTyped, converge, getComparableProofS, notesT,+  requireEq, starNotes)+import Morley.Michelson.Typed.Annotation (AnnConvergeError, isStar)+import Morley.Michelson.Typed.Arith (Add, ArithOp(..), EDiv, Mul, Sub, UnaryArithOp(..))+import Morley.Michelson.Typed.Polymorphic+  (ConcatOp, EDivOp(..), GetOp(..), MemOp(..), SizeOp, SliceOp, UpdOp(..))+import qualified Morley.Michelson.Untyped as Un+import Morley.Michelson.Untyped.Annotation+  (Annotation(..), FieldAnn, VarAnn, annQ, noAnn, orAnn, unsafeMkAnnotation)+import Morley.Util.Sing (eqI)+import Morley.Util.Type (onFirst)++-- | Function which derives special annotations+-- for PAIR instruction.+--+-- Namely, it does following transformation:+--+-- > PAIR %@ %@ [ @p.a int : @p.b int : .. ]+-- > ~+-- > [ @p pair (int %a) (int %b) : .. ]+--+-- All relevant cases (e.g. @PAIR %myf %@@ @)+-- are handled as they should be according to spec.+deriveSpecialFNs+  :: FieldAnn -> FieldAnn+  -> VarAnn -> VarAnn+  -> VarAnn+  -> (VarAnn, FieldAnn, FieldAnn)+deriveSpecialFNs pfn qfn pvn qvn vn = (vn', pfn', qfn')+  where+    (vn1, pfn') = bool (vn, pfn) (splitLastDot pvn) (unAnnotation pfn == "@")+    (vn2, qfn') = bool (vn, qfn) (splitLastDot qvn) (unAnnotation qfn == "@")+    vn' = bool vn (commonPrefix vn1 vn2) (vn == def)++    splitLastDot :: VarAnn -> (VarAnn, FieldAnn)+    splitLastDot v = case unsnoc $ T.splitOn "." $ unAnnotation v of+      Nothing      -> def+      Just (_, "") -> (def, Un.convAnn v)+      Just (vs, l) -> (foldMap unsafeMkAnnotation vs, bool (unsafeMkAnnotation l) def (l == "car" || l == "cdr"))++    commonPrefix :: VarAnn -> VarAnn -> VarAnn+    commonPrefix = curry \case+      (v1, v2) | v1 == v2 -> v1+      (v1, v2) | v2 == noAnn -> v1+      (v1, v2) | v1 == noAnn -> v2+      _ -> def++-- | Function which derives special annotations+-- for CDR / CAR instructions.+deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn+deriveSpecialVN vn elFn pairVN elVn+  | (unAnnotation vn) == "%" = Un.convAnn elFn+  -- TODO [#534]:+  -- In the `%%` branch, if the pair's field annotation (`elFn`) is empty, we should default it to "cdr"/"car".+  -- See: <https://tezos.gitlab.io/008/michelson.html#automatic-variable-and-field-annotations-inferring>+  | (unAnnotation vn) == "%%" = pairVN <> Un.convAnn elFn+  | otherwise = vn `orAnn` elVn++-- | Append suffix to variable annotation (if it's not empty)+deriveVN :: VarAnn -> VarAnn -> VarAnn+deriveVN suffix vn = bool (suffix <> vn) def (vn == def)++-- | Function which extracts annotations for @or@ type+-- (for left and right parts).+--+-- It extracts field/type annotations and also auto-generates variable+-- annotations if variable annotation is not provided as second argument.+deriveNsOr :: Notes ('TOr a b) -> VarAnn -> (Notes a, Notes b, VarAnn, VarAnn)+deriveNsOr (NTOr _ afn bfn an bn) ovn =+  let avn = deriveVN (Un.convAnn afn `orAnn` [annQ|left|]) ovn+      bvn = deriveVN (Un.convAnn bfn `orAnn` [annQ|right|]) ovn+   in (an, bn, avn, bvn)++-- | Function which extracts annotations for @option t@ type.+--+-- It extracts field/type annotations and also auto-generates variable+-- annotation for @Some@ case if it is not provided as second argument.+deriveNsOption :: Notes ('TOption a) -> VarAnn -> (Notes a, VarAnn)+deriveNsOption (NTOption _ an) ovn =+  let avn = deriveVN [annQ|some|] ovn+   in (an, avn)++convergeHSTEl+  :: (Notes t, Dict (WellTyped t), VarAnn)+  -> (Notes t, Dict (WellTyped t), VarAnn)+  -> Either AnnConvergeError (Notes t, Dict (WellTyped t), VarAnn)+convergeHSTEl (an, d@Dict, avn) (bn, _, bvn) =+  (,,) <$> converge an bn <*> pure d+      <*> pure (bool def avn $ avn == bvn)++-- | Combine annotations from two given stack types+convergeHST :: HST ts -> HST ts -> Either AnnConvergeError (HST ts)+convergeHST SNil SNil = pure SNil+convergeHST (a ::& as) (b ::& bs) =+    liftA2 (::&) (convergeHSTEl a b) (convergeHST as bs)++-- | Extract singleton for each single type of the given stack.+hstToTs :: HST st -> [T]+hstToTs = \case+  SNil -> []+  (notes, _, _) ::& hst -> notesT notes : hstToTs hst++-- | Check whether the given stack types are equal.+eqHST+  :: forall as bs. (SingI as, SingI bs)+  => HST as -> HST bs -> Either TCTypeError (as :~: bs)+eqHST (hst :: HST xs) (hst' :: HST ys) = do+  case eqI @as @bs of+    Nothing -> Left $ StackEqError (hstToTs hst) (hstToTs hst')+    Just Refl -> do+      void $ convergeHST hst hst' `onFirst` AnnError+      return Refl++-- | Check whether the given stack has size 1 and its only element matches the+-- given type. This function is a specialized version of `eqHST`.+eqHST1+  :: forall t st. (SingI st, WellTyped t)+  => HST st -> Either TCTypeError (st :~: '[t])+eqHST1 hst = do+  let hst' = sing @t -:& SNil+  case eqI @'[t] @st of+    Nothing -> Left $ StackEqError (hstToTs hst') (hstToTs hst)+    Just Refl -> Right Refl++lengthHST :: HST xs -> Natural+lengthHST (_ ::& xs) = 1 + lengthHST xs+lengthHST SNil = 0++--------------------------------------------+-- Typechecker auxiliary+--------------------------------------------++-- | Check whether elements go in strictly ascending order and+-- return the original list (to keep only one pass on the original list).+ensureDistinctAsc :: (Ord b, Show a) => (a -> b) -> [a] -> Either Text [a]+ensureDistinctAsc toCmp = \case+  (e1 : e2 : l) ->+    if toCmp e1 < toCmp e2+    then (e1 :) <$> ensureDistinctAsc toCmp (e2 : l)+    else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ ")"+  l -> Right l++-- | Function @eqType@ is a simple wrapper around @Data.Singletons.decideEquality@ suited+-- for use within @Either TCTypeError a@ applicative.+eqType+  :: forall (a :: T) (b :: T). (Each '[SingI] [a, b])+  => Either TCTypeError (a :~: b)+eqType =+  requireEq @a @b $ Left ... TypeEqError++onTypeCheckInstrErr+  :: (MonadReader InstrCallStack m, MonadError TCError m)+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> Either TCTypeError a -> m a+onTypeCheckInstrErr instr hst mContext ei = do+  either (typeCheckInstrErr' instr hst mContext) return ei++onScopeCheckInstrErr+  :: forall (t :: T) m a.+      (MonadReader InstrCallStack m, MonadError TCError m, SingI t)+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> Either BadTypeForScope a -> m a+onScopeCheckInstrErr instr hst mContext = \case+  Right a -> return a+  Left e -> do+    pos <- ask+    throwError $ TCFailedOnInstr instr hst pos mContext $+      Just $ UnsupportedTypeForScope (demote @t) e++typeCheckInstrErr+  :: (MonadReader InstrCallStack m, MonadError TCError m)+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> m a+typeCheckInstrErr instr hst mContext = do+  pos <- ask+  throwError $ TCFailedOnInstr instr hst pos mContext Nothing++typeCheckInstrErr'+  :: (MonadReader InstrCallStack m, MonadError TCError m)+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> TCTypeError -> m a+typeCheckInstrErr' instr hst mContext err = do+  pos <- ask+  throwError $ TCFailedOnInstr instr hst pos mContext (Just err)++onTypeCheckInstrAnnErr+  :: (MonadReader InstrCallStack m, MonadError TCError m, SingI ts)+  => Un.ExpandedInstr -> HST ts -> Maybe TypeContext+  -> Either AnnConvergeError a -> m a+onTypeCheckInstrAnnErr instr i mContext ei =+  onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onFirst` AnnError)++withCompareableCheck+  :: forall a m v ts. (SingI ts, MonadReader InstrCallStack m, MonadError TCError m)+  => Sing a+  -> Un.ExpandedInstr+  -> HST ts+  -> (Comparable a => v)+  -> m v+withCompareableCheck sng instr i act = case getComparableProofS sng of+  Just d@Dict -> pure $ withDict d act+  Nothing -> typeCheckInstrErr instr (SomeHST i) $ Just ComparisonArguments++typeCheckOpImpl+  :: forall inp. SingI inp+  => TcInstrHandler+  -> Un.ExpandedOp+  -> HST inp+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+typeCheckOpImpl tcInstr op' hst = case op' of+  Un.WithSrcEx _ op@Un.WithSrcEx{} -> typeCheckOpImpl tcInstr op hst+  Un.WithSrcEx loc (Un.PrimEx op)  -> typeCheckPrimWithLoc loc op+  Un.WithSrcEx loc (Un.SeqEx sq)   -> typeCheckSeqWithLoc loc sq+  Un.PrimEx op                     -> typeCheckPrim op+  Un.SeqEx sq                      -> typeCheckSeq sq+  where+    -- If we know source location from the untyped instruction, keep it in the typed one.+    typeCheckPrimWithLoc :: InstrCallStack -> Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+    typeCheckPrimWithLoc loc op = local (const loc)+      (wrapWithLoc loc <$> typeCheckPrim op)++    typeCheckPrim :: Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+    typeCheckPrim op = tcInstr op hst <&> mapSeq addNotes++    typeCheckSeqWithLoc :: InstrCallStack -> [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+    typeCheckSeqWithLoc loc = fmap (wrapWithLoc loc) . local (const loc) . typeCheckSeq++    typeCheckSeq :: [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+    typeCheckSeq sq = typeCheckImpl tcInstr sq hst+                  <&> mapSeq (addNotes . mapSomeInstr Nested)++    addNotes :: SomeInstr inp -> SomeInstr inp+    addNotes (inp :/ i ::: out) = inp :/ wrapWithNotes out i ::: out+    addNotes i = i++    wrapWithNotes :: HST d -> Instr c d -> Instr c d+    wrapWithNotes outputStack instr = case instr of+      -- Abstractions for instructions:+      Nop -> instr'+      Seq _ _ -> instr'+      Nested _ -> instr'+      DocGroup _ _ -> instr'+      Ext _ -> instr'+      FrameInstr _ _ -> instr'+      WithLoc _ _ -> instr'+      Meta _ _ -> instr'+      Fn {} -> instr'+      -- These three shouldn't happen, since annotations are added here.+      InstrWithNotes {} -> instr'+      InstrWithVarAnns _ _ -> instr'+      InstrWithVarNotes _ _ -> instr'++      -- Instructions that don't produce notes:+      DROP -> instr'+      DROPN _ -> instr'+      SWAP -> instr'+      DIG _ -> instr'+      DUG _ -> instr'+      IF_NONE _ _ -> instr'+      IF_LEFT _ _ -> instr'+      IF_CONS _ _ -> instr'+      ITER _ -> instr'+      IF _ _ -> instr'+      LOOP _ -> instr'+      LOOP_LEFT _ -> instr'+      DIP _ -> instr'+      DIPN _ _ -> instr'+      FAILWITH -> instr'+      NEVER -> instr'++      -- These instructions technically may have one/two explicit var anns, BUT because they support special var anns,+      -- the var anns are stored directly inside the instruction's constructor.+      -- For this reason, they must NOT be wrapped in `InstrWithVarNotes`.+      AnnCAR _ _ -> instr'+      AnnCDR _ _ -> instr'+      AnnUNPAIR{} ->+        case outputStack of+          (notes1, _, varAnn1) ::& (notes2, _, varAnn2) ::& _ ->+            let withNotes+                  | isStar notes1 && isStar notes2 = id+                  | isStar notes2 = InstrWithNotes Proxy (notes1 :& RNil)+                  | otherwise = InstrWithNotes Proxy (notes1 :& notes2 :& RNil)+                withVarAnns+                  | varAnn1 == def && varAnn2 == def = id+                  | varAnn2 == def = InstrWithVarAnns $ Un.OneVarAnn varAnn1+                  | otherwise = InstrWithVarAnns (Un.TwoVarAnns varAnn1 varAnn2)+            in withNotes $ withVarAnns instr++      -- We purposefully don't wrap `UNPAIRN` in meta-instructions+      -- like `InstrWithNotes` and `InstrWithVarAnns`.+      -- See !769 for a lengthy explanation.+      UNPAIRN _ -> instr++      -- Instructions that produce at most two notes:+      CREATE_CONTRACT _ -> case outputStack of+        ((np, _, vp) ::& (_, _, vs) ::& _) ->+          let withNotes = if isStar np then id else InstrWithNotes Proxy (np :& RNil)+              withVarNotes = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarNotes (vp :| [vs])+              withVarNotes' = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns vp vs+           in withNotes . withVarNotes . withVarNotes' $ instr++      GET_AND_UPDATE -> case outputStack of+        ((valNotes, _, valVarAnn) ::& (mapNotes, _, mapVarAnn) ::& _) ->+          let+              -- `GET_AND_UPDATE` can have one var ann argument (e.g. 'GET_AND_UPDATE @var'),+              -- which is applied to the 2nd element of the stack (the updated map).+              withVarNotes = if mapVarAnn == Un.noAnn then id else InstrWithVarNotes (one mapVarAnn)+              -- `GET_AND_UPDATE` puts two elements on the top of the stack, both of which+              -- can have type/field/var annotations.+              withNotes = if isStar valNotes && isStar mapNotes then id else InstrWithNotes Proxy (valNotes :& mapNotes :& RNil)+              withVarNotes' = if valVarAnn == Un.noAnn && mapVarAnn == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns valVarAnn mapVarAnn+          in  withNotes . withVarNotes . withVarNotes' $ instr++      DUP -> instr''+      DUPN _ -> instr''+      PUSH _ -> instr''+      UNIT -> instr''+      SOME -> instr''+      NONE -> instr''+      AnnPAIR{} -> instr''+      AnnLEFT{} -> instr''+      AnnRIGHT{} -> instr''+      NIL -> instr''+      CONS -> instr''+      SIZE -> instr''+      MAP _ -> instr''+      MEM -> instr''+      EMPTY_SET -> instr''+      EMPTY_MAP -> instr''+      EMPTY_BIG_MAP -> instr''+      UPDATE -> instr''+      UPDATEN _ -> instr''+      GET -> instr''+      GETN _ -> instr''+      LAMBDA _ -> instr''+      EXEC -> instr''+      ADD -> instr''+      SUB -> instr''+      CONCAT -> instr''+      CONCAT' -> instr''+      MUL -> instr''+      OR -> instr''+      AND -> instr''+      XOR -> instr''+      NOT -> instr''+      ABS -> instr''+      ISNAT -> instr''+      INT -> instr''+      NEG -> instr''+      EDIV -> instr''+      LSL -> instr''+      LSR -> instr''+      COMPARE -> instr''+      EQ -> instr''+      NEQ -> instr''+      LT -> instr''+      GT -> instr''+      LE -> instr''+      GE -> instr''+      ADDRESS -> instr''+      CONTRACT _ _ -> instr''+      SET_DELEGATE -> instr''+      IMPLICIT_ACCOUNT -> instr''+      NOW -> instr''+      LEVEL -> instr''+      AMOUNT -> instr''+      BALANCE -> instr''+      HASH_KEY -> instr''+      CHECK_SIGNATURE -> instr''+      BLAKE2B -> instr''+      SOURCE -> instr''+      SENDER -> instr''+      SELF _ -> instr''+      SELF_ADDRESS -> instr''+      CAST -> instr''+      RENAME -> instr''+      CHAIN_ID -> instr''+      APPLY -> instr''+      PAIRN _ -> instr''+      PACK -> instr''+      UNPACK -> instr''+      SLICE -> instr''+      TRANSFER_TOKENS -> instr''+      VOTING_POWER -> instr''+      TOTAL_VOTING_POWER -> instr''+      SHA256 -> instr''+      SHA512 -> instr''+      SHA3 -> instr''+      KECCAK -> instr''+      PAIRING_CHECK -> instr''+      TICKET -> instr''+      READ_TICKET -> instr''+      SPLIT_TICKET -> instr''+      JOIN_TICKETS -> instr''+      where+        instr' = addNotesNoVarAnn outputStack instr+        instr'' = addNotesOneVarAnn outputStack instr++    addNotesOneVarAnn :: HST d -> Instr c d -> Instr c d+    addNotesOneVarAnn outputStack instr = case outputStack of+      ((n, _, v) ::& _) ->+        let withNotes = if isStar n then id else InstrWithNotes Proxy (n :& RNil)+            withVarNotes = if v == Un.noAnn then id else InstrWithVarNotes (one v)+            withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v+         in withNotes . withVarNotes . withVarNotes' $ instr+      SNil -> instr++    addNotesNoVarAnn :: HST d -> Instr c d -> Instr c d+    addNotesNoVarAnn outputStack instr = case outputStack of+      ((n, _, v) ::& _) ->+          let withNotes = if isStar n then id else InstrWithNotes Proxy (n :& RNil)+              withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v+           in withNotes . withVarNotes' $ instr+      SNil -> instr++-- | Like 'typeCheckImpl' but doesn't add a stack type comment after the+-- sequence.+typeCheckImplNoLastTypeComment+  :: forall inp . SingI inp+  => TcInstrHandler+  -> [Un.ExpandedOp]+  -> HST inp+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+typeCheckImplNoLastTypeComment _ [] inputStack+  = pure (WellTypedSeq (inputStack :/ Nop ::: inputStack))+typeCheckImplNoLastTypeComment tcInstr [op] inputStack = do+  typeCheckOpImpl tcInstr op inputStack+      >>= mapMSeq prependStackTypeComment+typeCheckImplNoLastTypeComment tcInstr (op : ops) inputStack = do+  done <- typeCheckOpImpl tcInstr op inputStack+      >>= mapMSeq prependStackTypeComment+  continueTypeChecking tcInstr done ops++continueTypeChecking+  :: forall inp. ()+  => TcInstrHandler+  -> TypeCheckedSeq inp+  -> [Un.ExpandedOp]+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+continueTypeChecking tcInstr done rest = case done of+  WellTypedSeq instr -> handleFirst instr+  MixedSeq i e left -> pure (MixedSeq i e (left <> map NonTypedInstr rest))+  IllTypedSeq e left -> pure (IllTypedSeq e (left <> map NonTypedInstr rest))+  where+    handleFirst :: SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+    handleFirst packedInstr@(inputStack :/ instrAndOutputStack) = do+      case instrAndOutputStack of+        instr ::: outputStack -> do+          nextPiece <- typeCheckImplNoLastTypeComment tcInstr rest outputStack+          let combiner = combine inputStack instr+          pure case nextPiece of+            WellTypedSeq nextInstr -> WellTypedSeq (combiner nextInstr)+            MixedSeq nextInstr err left -> MixedSeq (combiner nextInstr) err left+            IllTypedSeq err left -> MixedSeq packedInstr err left+        AnyOutInstr{} -> pure case rest of+          [] -> WellTypedSeq packedInstr+          op : ops -> (MixedSeq+                        packedInstr+                        (TCUnreachableCode (extractOpPos op) (op :| ops))+                        (map NonTypedInstr ops))++    combine inp Nop (_ :/ nextPart) = inp :/ nextPart+    combine inp i1 (_ :/ nextPart) = inp :/ mapSomeInstrOut (Seq i1) nextPart++    extractOpPos :: Un.ExpandedOp -> InstrCallStack+    extractOpPos (Un.WithSrcEx loc _) = loc+    extractOpPos _ = def++-- | Like 'typeCheckImpl' but without the first and the last stack type+-- comments. Useful to reduce duplication of stack type comments.+typeCheckImplStripped+  :: forall inp . SingI inp+  => TcInstrHandler+  -> [Un.ExpandedOp]+  -> HST inp+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+typeCheckImplStripped tcInstr [] inp+  = typeCheckImplNoLastTypeComment tcInstr [] inp+typeCheckImplStripped tcInstr (op : ops) inp = do+  done <- typeCheckOpImpl tcInstr op inp+  continueTypeChecking tcInstr done ops++typeCheckImpl+  :: forall inp . SingI inp+  => TcInstrHandler+  -> [Un.ExpandedOp]+  -> HST inp+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+typeCheckImpl tcInstr ops inputStack = do+  tcSeq <- typeCheckImplNoLastTypeComment tcInstr ops inputStack+  mapMSeq appendTypeComment tcSeq+  where+    appendTypeComment packedI@(inp :/ iAndOut) = do+      verbose <- lift (asks tcVerbose)+      pure case (verbose, iAndOut) of+        (True, i ::: out) -> inp :/ Seq i (stackTypeComment out) ::: out+        (True, AnyOutInstr i) -> inp :/ AnyOutInstr (Seq i noStackTypeComment)+        _ -> packedI+++prependStackTypeComment+  :: SomeInstr inp -> TypeCheckInstrNoExcept (SomeInstr inp)+prependStackTypeComment packedInstr@(inp :/ _) = do+  verbose <- lift (asks tcVerbose)+  pure if verbose && (not (isNop' packedInstr))+    then mapSomeInstr (Seq (stackTypeComment inp)) packedInstr+    else packedInstr++isNop' :: SomeInstr inp -> Bool+isNop' (_ :/ i ::: _) = isNop i+isNop' (_ :/ AnyOutInstr i) = isNop i++isNop :: Instr inp out -> Bool+isNop (WithLoc _ i) = isNop i+isNop (InstrWithNotes _ _ i) = isNop i+isNop (InstrWithVarNotes _ i) = isNop i+isNop (FrameInstr _ i) = isNop i+isNop (Seq i1 i2) = isNop i1 && isNop i2+isNop (Nested i) = isNop i+isNop Nop = True+isNop (Ext _) = True+isNop _ = False++mapMSeq+  :: Applicative f+  => (SomeInstr inp -> f (SomeInstr inp'))+  -> TypeCheckedSeq inp+  -> f (TypeCheckedSeq inp')+mapMSeq f v = case v of+  WellTypedSeq instr -> f instr <&> WellTypedSeq+  MixedSeq instr err tail' -> f instr <&> \instr' -> MixedSeq instr' err tail'+  IllTypedSeq err tail' -> pure $ IllTypedSeq err tail'++mapSeq+  :: (SomeInstr inp -> SomeInstr inp')+  -> TypeCheckedSeq inp+  -> TypeCheckedSeq inp'+mapSeq f = runIdentity . mapMSeq (Identity . f)++stackTypeComment :: HST st -> Instr st st+stackTypeComment = Ext . COMMENT_ITEM . StackTypeComment . Just . hstToTs++noStackTypeComment :: Instr st st+noStackTypeComment = Ext (COMMENT_ITEM (StackTypeComment Nothing))++wrapWithLoc :: InstrCallStack -> TypeCheckedSeq inp -> TypeCheckedSeq inp+wrapWithLoc loc = mapSeq $ \someInstr -> case someInstr of+  (_ :/ WithLoc{} ::: _) -> someInstr+  (inp :/ instr ::: out) -> inp :/ WithLoc loc instr ::: out+  (inp :/ AnyOutInstr instr) -> inp :/ (AnyOutInstr $ WithLoc loc instr)++-- | Check whether given types are structurally equal and annotations converge.+matchTypes+  :: forall t1 t2.+      (Each '[SingI] [t1, t2])+  => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)+matchTypes n1 n2 = do+  Refl <- eqType @t1 @t2+  nr <- converge n1 n2 `onFirst` AnnError+  return (Refl, nr)++--------------------------------------------+-- Some generic instruction implementation+--------------------------------------------++-- | Generic implementation for MEMeration+memImpl+  :: forall c memKey rs inp m .+    ( MemOp c+    , SingI (MemOpKey c)+    , inp ~ (memKey : c : rs)+    , SingI rs+    , MonadReader InstrCallStack m+    , MonadError TCError m+    )+  => Notes (MemOpKey c)+  -> HST inp+  -> VarAnn+  -> m (SomeInstr inp)+memImpl cKeyNotes inputHST@(hst0 ::& _ ::& hstTail) varAnn =+  case eqType @memKey @(MemOpKey c) of+    Right Refl -> do+      _ <- onTypeCheckInstrAnnErr uInstr inputHST+        (Just ContainerKeyType) (converge memKeyNotes cKeyNotes)+      pure $ inputHST :/+        MEM ::: ((starNotes, Dict, varAnn) ::& hstTail)+    Left m ->+      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m+  where+    (memKeyNotes, Dict, _) = hst0+    uInstr = Un.MEM varAnn++getImpl+  :: forall c getKey rs inp m .+    ( GetOp c, SingI (GetOpKey c)+    , WellTyped (GetOpVal c)+    , inp ~ (getKey : c : rs)+    , SingI rs+    , MonadReader InstrCallStack m+    , MonadError TCError m+    )+  => Notes (GetOpKey c)+  -> HST inp+  -> Notes (GetOpVal c)+  -> VarAnn+  -> m (SomeInstr inp)+getImpl notesKeyC inputHST@(hst0 ::& _ ::& hstTail) valueNotes varAnn =+  case eqType @getKey @(GetOpKey c) of+    Right Refl -> do+      _ <- onTypeCheckInstrAnnErr uInstr inputHST+        (Just ContainerKeyType) (converge getKeyNotes notesKeyC)+      pure $ inputHST :/+        GET ::: ((NTOption def valueNotes, Dict, varAnn) ::& hstTail)+    Left m ->+      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m+  where+    (getKeyNotes, Dict, _) = hst0+    uInstr = Un.GET varAnn++updImpl+  :: forall c updKey updParams rs inp m .+    ( UpdOp c+    , SingI (UpdOpKey c), SingI (UpdOpParams c)+    , SingI rs+    , inp ~ (updKey : updParams : c : rs)+    , MonadReader InstrCallStack m+    , MonadError TCError m+    )+  => Notes (UpdOpKey c)+  -> HST inp+  -> Notes (UpdOpParams c)+  -> VarAnn+  -> m (SomeInstr inp)+updImpl cKeyNotes inputHST@(hst0 ::& hst1 ::& cTuple ::& hstTail) cValueNotes varAnn =+  case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of+    (Right Refl, Right Refl) -> do+      _ <- onTypeCheckInstrAnnErr uInstr inputHST+        (Just ContainerKeyType) (converge updKeyNotes cKeyNotes)+      _ <- onTypeCheckInstrAnnErr uInstr inputHST+        (Just ContainerValueType) (converge updValueNotes cValueNotes)+      let vn = varAnn `orAnn` (cTuple ^. _3)+      pure $ inputHST :/+        UPDATE ::: ((cTuple & _3 .~ vn) ::& hstTail)+    (Left m, _) ->+      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m+    (_, Left m) ->+      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerValueType) m+  where+    (updKeyNotes, Dict, _) = hst0+    (updValueNotes, Dict, _) = hst1+    uInstr = Un.UPDATE varAnn++getUpdImpl+  :: forall c updKey updParams rs inp m .+    ( UpdOp c, GetOp c+    , SingI (UpdOpKey c)+    , SingI (GetOpVal c)+    , inp ~ (updKey : updParams : c : rs)+    , SingI rs+    , GetOpKey c ~ UpdOpKey c+    , UpdOpParams c ~ 'TOption (GetOpVal c)+    , MonadReader InstrCallStack m+    , MonadError TCError m+    )+  => Notes (UpdOpKey c)+  -> HST inp+  -> Notes (UpdOpParams c)+  -> VarAnn+  -> m (SomeInstr inp)+getUpdImpl cKeyNotes inputHST@(hst0 ::& hst1 ::& cTuple ::& hstTail) cValueNotes varAnn =+  case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of+    (Right Refl, Right Refl) -> do+      _ <- onTypeCheckInstrAnnErr uInstr inputHST+        (Just ContainerKeyType) (converge updKeyNotes cKeyNotes)+      _ <- onTypeCheckInstrAnnErr uInstr inputHST+        (Just ContainerValueType) (converge updValueNotes cValueNotes)+      let vn = varAnn `orAnn` (cTuple ^. _3)+      pure $ inputHST :/+        GET_AND_UPDATE ::: (hst1 ::& (cTuple & _3 .~ vn) ::& hstTail)+    (Left m, _) ->+      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m+    (_, Left m) ->+      typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerValueType) m+  where+    (updKeyNotes, Dict, _) = hst0+    (updValueNotes, Dict, _) = hst1+    uInstr = Un.GET_AND_UPDATE varAnn++sizeImpl+  :: (SizeOp c, inp ~ (c ': rs), Monad m)+  => HST inp+  -> VarAnn+  -> m (SomeInstr inp)+sizeImpl i@(_ ::& rs) vn =+  pure $ i :/ SIZE ::: ((starNotes, Dict, vn) ::& rs)++sliceImpl+  :: (SliceOp c, inp ~ ('TNat ': 'TNat ': c ': rs), Monad m)+  => HST inp+  -> Un.VarAnn+  -> m (SomeInstr inp)+sliceImpl i@(_ ::& _ ::& (cn, Dict, cvn) ::& rs) vn = do+  let vn' = vn `orAnn` deriveVN [annQ|slice|] cvn+      rn = NTOption def cn+  pure $ i :/ SLICE ::: ((rn, Dict, vn') ::& rs)++concatImpl'+  :: (ConcatOp c, WellTyped c, inp ~ ('TList c : rs), Monad m)+  => HST inp+  -> Un.VarAnn+  -> m (SomeInstr inp)+concatImpl' i@((NTList _ n, Dict, _) ::& rs) vn = do+  pure $ i :/ CONCAT' ::: ((n, Dict, vn) ::& rs)++concatImpl+  :: ( ConcatOp c, inp ~ (c ': c ': rs)+     , WellTyped c+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )+  => HST inp+  -> Un.VarAnn+  -> m (SomeInstr inp)+concatImpl i@((cn1, _, _) ::& (cn2, _, _) ::& rs) vn = do+  cn <- onTypeCheckInstrAnnErr (Un.CONCAT vn) i (Just ConcatArgument) (converge cn1 cn2)+  pure $ i :/ CONCAT ::: ((cn, Dict, vn) ::& rs)++-- | Helper function to construct instructions for binary arithmetic+-- operations.+arithImpl+  :: forall aop inp m n s t.+     ( ArithOp aop n m+     , WellTyped (ArithRes aop n m)+     , inp ~ (n ': m ': s)+     , MonadReader InstrCallStack t+     , MonadError TCError t+     )+  => Instr inp (ArithRes aop n m ': s)+  -> HST inp+  -> VarAnn+  -> Un.ExpandedInstr+  -> t (SomeInstr inp)+arithImpl mkInstr i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do+  case convergeArith (Proxy @aop) an bn of+    Right cn ->+      pure $ i :/ mkInstr ::: ((cn, Dict, vn) ::& rs)+    Left err -> do+      typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err++addImpl+  :: forall a b inp rs m.+     ( Each '[SingI] [a, b]+     , inp ~ (a ': b ': rs)+     , SingI rs+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )+  => Sing a -> Sing b+  -> HST inp+  -> VarAnn+  -> Un.ExpandedInstr+  -> m (SomeInstr inp)+addImpl t1 t2 = case (t1, t2) of+  (STInt, STInt) -> arithImpl @Add ADD+  (STInt, STNat) -> arithImpl @Add ADD+  (STNat, STInt) -> arithImpl @Add ADD+  (STNat, STNat) -> arithImpl @Add ADD+  (STInt, STTimestamp) -> arithImpl @Add ADD+  (STTimestamp, STInt) -> arithImpl @Add ADD+  (STMutez, STMutez) -> arithImpl @Add ADD+  (STBls12381Fr, STBls12381Fr) -> arithImpl @Add ADD+  (STBls12381G1, STBls12381G1) -> arithImpl @Add ADD+  (STBls12381G2, STBls12381G2) -> arithImpl @Add ADD+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)++edivImpl+  :: forall a b inp rs m.+     ( SingI rs+     , Each '[SingI] [a, b]+     , inp ~ (a ': b ': rs)+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )+  => Sing a -> Sing b+  -> HST inp+  -> VarAnn+  -> Un.ExpandedInstr+  -> m (SomeInstr inp)+edivImpl t1 t2 = case (t1, t2) of+  (STInt, STInt) -> edivImplDo+  (STInt, STNat) -> edivImplDo+  (STNat, STInt) -> edivImplDo+  (STNat, STNat) -> edivImplDo+  (STMutez, STMutez) -> edivImplDo+  (STMutez, STNat) -> edivImplDo+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)++edivImplDo+  :: ( ArithOp EDiv n m+     , ArithRes EDiv n m ~ 'TOption ('TPair (EDivOpRes n m) (EModOpRes n m))+     , EDivOp n m+     , WellTyped (EModOpRes n m)+     , WellTyped (EDivOpRes n m)+     , inp ~ (n ': m ': s)+     , MonadReader InstrCallStack t+     , MonadError TCError t+     )+  => HST inp+  -> VarAnn+  -> Un.ExpandedInstr+  -> t (SomeInstr inp)+edivImplDo i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do+  case convergeEDiv an bn of+    Right cn ->+      pure $ i :/ EDIV ::: ((cn, Dict, vn) ::& rs)+    Left err -> do+      typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err++subImpl+  :: forall a b inp rs m.+     ( Each '[SingI] [a, b]+     , inp ~ (a ': b ': rs)+     , SingI rs+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )+  => Sing a -> Sing b+  -> HST inp+  -> VarAnn+  -> Un.ExpandedInstr+  -> m (SomeInstr inp)+subImpl t1 t2 = case (t1, t2) of+  (STInt, STInt) -> arithImpl @Sub SUB+  (STInt, STNat) -> arithImpl @Sub SUB+  (STNat, STInt) -> arithImpl @Sub SUB+  (STNat, STNat) -> arithImpl @Sub SUB+  (STTimestamp, STTimestamp) -> arithImpl @Sub SUB+  (STTimestamp, STInt) -> arithImpl @Sub SUB+  (STMutez, STMutez) -> arithImpl @Sub SUB+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)++mulImpl+  :: forall a b inp rs m.+     ( Each '[SingI] [a, b]+     , inp ~ (a ': b ': rs)+     , SingI rs+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )+  => Sing a -> Sing b+  -> HST inp+  -> VarAnn+  -> Un.ExpandedInstr+  -> m (SomeInstr inp)+mulImpl t1 t2 = case (t1, t2) of+  (STInt, STInt) -> arithImpl @Mul MUL+  (STInt, STNat) -> arithImpl @Mul MUL+  (STNat, STInt) -> arithImpl @Mul MUL+  (STNat, STNat) -> arithImpl @Mul MUL+  (STNat, STMutez) -> arithImpl @Mul MUL+  (STMutez, STNat) -> arithImpl @Mul MUL+  (STInt, STBls12381Fr) -> arithImpl @Mul MUL+  (STNat, STBls12381Fr) -> arithImpl @Mul MUL+  (STBls12381Fr, STInt) -> arithImpl @Mul MUL+  (STBls12381Fr, STNat) -> arithImpl @Mul MUL+  (STBls12381Fr, STBls12381Fr) -> arithImpl @Mul MUL+  (STBls12381G1, STBls12381Fr) -> arithImpl @Mul MUL+  (STBls12381G2, STBls12381Fr) -> arithImpl @Mul MUL+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)++-- | Helper function to construct instructions for unary arithmetic+-- operations.+unaryArithImpl+  :: ( WellTyped (UnaryArithRes aop n)+     , inp ~ (n ': s)+     , Monad t+     )+  => Instr inp (UnaryArithRes aop n ': s)+  -> HST inp+  -> VarAnn+  -> t (SomeInstr inp)+unaryArithImpl mkInstr i@(_ ::& rs) vn = do+  pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs)++-- | Helper function to construct instructions for unary arithmetic+-- operations that should preserve annotations.+unaryArithImplAnnotated+  :: ( WellTyped (UnaryArithRes aop n)+     , inp ~ (n ': s)+     , Monad t+     , n ~ UnaryArithRes aop n+     )+  => Instr inp (UnaryArithRes aop n ': s)+  -> HST inp+  -> VarAnn+  -> t (SomeInstr inp)+unaryArithImplAnnotated mkInstr i@((n, _, _) ::& rs) vn = do+  pure $ i :/ mkInstr ::: ((n, Dict, vn) ::& rs)

+ src/Morley/Michelson/TypeCheck/Instr.hs view

@@ -0,0 +1,1717 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, providing functions for conversion from+-- instruction and value representation from @Morley.Michelson.Type@ module+-- to strictly-typed GADT-based representation from @Morley.Michelson.Value@ module.+--+-- This conversion is labeled as type check because that's what we are obliged+-- to do on our way.+--+-- Type check algorithm relies on the property of Michelson language that each+-- instruction on a given input stack type produces a definite output stack+-- type.+-- Michelson contract defines concrete types for storage and parameter, from+-- which input stack type is deduced. Then this type is being combined with+-- each subsequent instruction, producing next stack type after each+-- application.+--+-- Function @typeCheck@ takes list of instructions and returns value of type+-- @Instr inp out@ along with @HST inp@ and @HST out@ all wrapped into+-- @SomeInstr@ data type. This wrapping is done to satsify Haskell type+-- system (which has no support for dependent types).+-- Functions @typeCheckInstr@, @typeCheckValue@ behave similarly.+--+-- When a recursive call is made within @typeCheck@, @typeCheckInstr@ or+-- @typeCheckValue@, result of a call is unwrapped from @SomeInstr@ and type+-- information from @HST inp@ and @HST out@ is being used to assert that+-- recursive call returned instruction of expected type+-- (error is thrown otherwise).+module Morley.Michelson.TypeCheck.Instr+    ( typeCheckContract+    , typeCheckContractAndStorage+    , typeCheckInstr+    , typeCheckList+    , typeCheckListNoExcept+    , typeCheckParameter+    , typeCheckStorage+    , typeCheckTopLevelType+    , typeCheckValue+    , typeVerifyContract+    , typeVerifyParameter+    , typeVerifyStorage+    , typeVerifyTopLevelType+    ) where++import Prelude hiding (EQ, GT, LT)++import Control.Monad.Except (MonadError, catchError, liftEither, throwError)+import Data.Default (def)+import Data.Generics (everything, mkQ)+import Data.Singletons (Sing, demote, withSingI, withSomeSing)+import Data.Typeable ((:~:)(..))+import Fmt (pretty)++import Morley.Michelson.ErrorPos+import Morley.Michelson.TypeCheck.Error+import Morley.Michelson.TypeCheck.Ext+import Morley.Michelson.TypeCheck.Helpers+import Morley.Michelson.TypeCheck.TypeCheck+import Morley.Michelson.TypeCheck.TypeCheckedSeq+  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), someInstrToOp,+  tcsEither)+import Morley.Michelson.TypeCheck.Types+import Morley.Michelson.TypeCheck.Value+import Morley.Michelson.Typed.Value++import Morley.Michelson.Typed hiding (Branch(..))+import Morley.Util.Named ((!))+import Morley.Util.Peano+import Morley.Util.PeanoNatural+import Morley.Util.Sing (SingI1(..))+import Morley.Util.Type (onFirst, type (++))++import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped.Annotation (FieldTag, VarAnn, VarTag, annQ, convAnn, orAnn)++-- | Type check a contract and verify that the given storage+-- is of the type expected by the contract.+typeCheckContractAndStorage+  :: U.Contract -> U.Value -> TypeCheckResult SomeContractAndStorage+typeCheckContractAndStorage uContract uStorage = do+  SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract uContract+  storage <- typeVerifyStorage @st uStorage+  pure $ SomeContractAndStorage contract storage++typeCheckContract+  :: U.Contract+  -> TypeCheckResult SomeContract+typeCheckContract c = do+  paramType <- liftEither $ mkSomeParamType (U.contractParameter c)+  runTypeCheck (TypeCheckContract paramType) $ typeCheckContractImpl c++typeVerifyContract+  :: forall cp st.+     (SingI cp, SingI st)+  => U.Contract -> TypeCheckResult (Contract cp st)+typeVerifyContract uContract = do+  SomeContract tContract@(Contract{} :: Contract cp' st') <-+    typeCheckContract uContract+  Refl <- requireEq @cp' @cp (mkErr TltParameterType)+  Refl <- requireEq @st' @st (mkErr TltParameterType)+  return tContract+  where+    mkErr :: TopLevelType -> T -> T -> TypeCheckResult any+    mkErr tyDesc got expected =+      throwError $ TCContractError "error in contract type" $ Just $+          UnexpectedTopLevelType tyDesc+            ! #expected expected+            ! #got got++withWTP :: forall t a. SingI t => (WellTyped t => TypeCheck a) -> TypeCheck a+withWTP fn = case getWTP @t of+  Right Dict -> fn+  Left (NotWellTyped t cause) -> throwError $ TCContractError+    ("Not a well typed value: '" <> show t <> "' because it " <> pretty cause) Nothing++withWTPInstr_ :: forall t a. SingI t => U.ExpandedInstr -> SomeHST -> (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a+withWTPInstr_ v t fn = case getWTP @t of+  Right Dict -> fn+  Left (NotWellTyped badType cause) -> do+    loc <- ask+    throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType cause)++withWTPInstr'_+  :: forall t inp. SingI t+  => U.ExpandedInstr+  -> SomeHST+  -> (WellTyped t => TypeCheckInstrNoExcept (TypeCheckedSeq inp))+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+withWTPInstr'_ v t fn = case getWTP @t of+  Right Dict -> fn+  Left (NotWellTyped badType cause) -> do+    loc <- ask+    let err = TCFailedOnInstr v t loc Nothing+              (Just $ UnsupportedTypeForScope badType cause)+    pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx v]++typeCheckContractImpl+  :: U.Contract+  -> TypeCheck SomeContract+typeCheckContractImpl (U.Contract wholeParam@(U.ParameterType mParam rootAnn) mStorage pCode entriesOrder) = do+  _ <- maybe (throwError $ TCContractError "no instructions in contract code" $ Just EmptyCode)+                pure (nonEmpty pCode)+  withUType mParam $ \(paramNote :: Notes param) ->+    withUType mStorage $ \(storageNote :: Notes st) -> do+      withWTP @st $ do+        withWTP @param $ do+          Dict <- either (hasTypeError @param "parameter") pure+            $ checkScope @(ParameterScope param)+          Dict <- either (hasTypeError @st "storage") pure+            $ checkScope @(StorageScope st)+          let param = [annQ|parameter|]+          let store = [annQ|storage|]+          let inpNote = NTPair def def def param store paramNote storageNote+          let inp = (inpNote, Dict, def) ::& SNil++          codeRes <- usingReaderT def $+                     liftNoExcept $+                     typeCheckImpl typeCheckInstr pCode inp+          codeRes & tcsEither+            (onFailedTypeCheck)+            (onSuccessfulTypeCheck (NTPair def def def def def starNotes storageNote))+  where+    hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a+    hasTypeError name reason = throwError $+      TCContractError ("contract " <> name <> " type error") $+      Just $ UnsupportedTypeForScope (demote @t) reason++    onFailedTypeCheck :: [TypeCheckedOp] -> TCError -> TypeCheck SomeContract+    onFailedTypeCheck ops err = do+      verbose <- asks tcVerbose+      throwError if verbose+        then TCIncompletelyTyped err U.Contract+             { contractParameter = wholeParam+             , contractStorage = mStorage+             , contractCode = ops+             , entriesOrder = entriesOrder+             }+        else err++    onSuccessfulTypeCheck+      :: forall st param+      . (ParameterScope param, StorageScope st, WellTyped st)+      => Notes (ContractOut1 st)+      -> SomeInstr (ContractInp param st)+      -> TypeCheck SomeContract+    onSuccessfulTypeCheck outNote i@(inp' :/ instrOut) = wrapErrorsIfVerbose i $ do+      let (paramNotesRaw, cStoreNotes) = case inp' of+            (NTPair _ _ _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes)+      cParamNotes <-+        liftEither $+        mkParamNotes paramNotesRaw rootAnn `onFirst`+            (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl)+      case instrOut of+        instr ::: out -> liftEither $ do+          case eqHST1 @(ContractOut1 st) out of+            Right Refl -> do+              let (outN, _, _) ::& SNil = out+              _ <- converge outN outNote+                      `onFirst`+                  ((TCContractError "contract output type violates convention:") . Just . AnnError)+              pure $ SomeContract Contract+                { cCode = instr+                , cParamNotes+                , cStoreNotes+                , cEntriesOrder = entriesOrder+                }+            Left err -> Left $ TCContractError "contract output type violates convention:" $ Just err+        AnyOutInstr instr ->+          pure $ SomeContract Contract+            { cCode = instr+            , cParamNotes+            , cStoreNotes+            , cEntriesOrder = entriesOrder+            }++    wrapErrorsIfVerbose :: SomeInstr inp -> TypeCheck SomeContract -> TypeCheck SomeContract+    wrapErrorsIfVerbose instr action =+      action `catchError` (onFailedTypeCheck [someInstrToOp instr])++-- | Function @typeCheckList@ converts list of Michelson instructions+-- given in representation from @Morley.Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- Types are checked along the way which is neccessary to construct a+-- strictly typed value.+--+-- As a second argument, @typeCheckList@ accepts input stack type representation.+typeCheckList+  :: (SingI inp)+  => [U.ExpandedOp]+  -> HST inp+  -> TypeCheck (SomeInstr inp)+typeCheckList = throwingTCError' ... typeCheckListNoExcept++-- | Function @typeCheckListNoExcept@ converts list of Michelson instructions+-- given in representation from @Morley.Michelson.Type@ module to representation in a+-- partially typed tree. See @TypeCheckedSeq@ and @TypeCheckedOp@.+--+-- Types are checked along the way. It is necessary to embed well typed node as+-- well as type checking errors into the tree.+typeCheckListNoExcept+  :: (SingI inp)+  => [U.ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)+typeCheckListNoExcept = usingReaderT def ... typeCheckImpl typeCheckInstr++-- | Function @typeCheckValue@ converts a single Michelson value+-- given in representation from @Morley.Michelson.Untyped@ module hierarchy to+-- representation in strictly typed GADT.+--+-- @typeCheckValue@ is polymorphic in the expected type of value.+--+-- Type checking algorithm pattern-matches on parse value representation,+-- expected type @t@ and constructs @Value t@ value.+--+-- If there was no match on a given pair of value and expected type,+-- that is interpreted as input of wrong type and type check finishes with+-- error.+typeCheckValue+  :: forall t. SingI t+  => U.Value+  -> TypeCheckInstr (Value t)+typeCheckValue = typeCheckValImpl @t Nothing typeCheckInstr++typeVerifyParameter+  :: SingI t+  => TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)+typeVerifyParameter originatedContracts = typeVerifyTopLevelType (Just originatedContracts)++typeVerifyStorage+  :: SingI t+  => U.Value -> TypeCheckResult (Value t)+typeVerifyStorage = typeVerifyTopLevelType Nothing++typeVerifyTopLevelType+  :: forall t. SingI t+  => Maybe TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)+typeVerifyTopLevelType mOriginatedContracts valueU =+  runTypeCheck (TypeCheckValue (valueU, demote @t)) $ usingReaderT def $+    typeCheckValImpl mOriginatedContracts typeCheckInstr valueU++-- | Like 'typeCheckValue', but for values to be used as parameter.+--+-- Also accepts a 'TcOriginatedContracts' in order to be able to type-check+-- @contract p@ values (which can only be part of a parameter).+typeCheckParameter+  :: TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult SomeValue+typeCheckParameter originatedContracts = typeCheckTopLevelType (Just originatedContracts)++-- | Like 'typeCheckValue', but for values to be used as storage.+typeCheckStorage+  :: U.Ty -> U.Value -> TypeCheckResult SomeValue+typeCheckStorage = typeCheckTopLevelType Nothing++typeCheckTopLevelType+  :: Maybe TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult SomeValue+typeCheckTopLevelType mOriginatedContracts typeU valueU =+  withSomeSing (fromUType typeU) $ \(s :: Sing t) ->+    withSingI s $ SomeValue <$> typeVerifyTopLevelType @t mOriginatedContracts valueU++-- | Helper data type we use to typecheck DUPN.+data TCDupNHelper inp where+  TCDupNHelper ::+    forall (n :: Peano) inp out a.+    (SingI out, ConstraintDUPN n inp out a, DupableScope a) =>+    PeanoNatural n -> HST out -> TCDupNHelper inp++-- | Helper data type we use to typecheck DROPN.+data TCDropHelper inp where+  TCDropHelper ::+    forall (n :: Peano) inp out.+    (SingI out, LongerOrSameLength inp n, Drop n inp ~ out) =>+    PeanoNatural n -> HST out -> TCDropHelper inp++-- | Helper data type we use to typecheck DIG.+data TCDigHelper inp where+  TCDigHelper ::+    forall (n :: Peano) inp out a.+    (SingI out, ConstraintDIG n inp out a) =>+    PeanoNatural n -> HST out -> TCDigHelper inp++-- | Helper data type we use to typecheck DUG.+data TCDugHelper inp where+  TCDugHelper ::+    forall (n :: Peano) inp out a.+    (SingI out, ConstraintDUG n inp out a) =>+    PeanoNatural n -> HST out -> TCDugHelper inp++-- | Helper data type we use to typecheck PAIRN.+--+-- It holds all the necessary data to construct a typed PAIRN+-- instruction once we're done traversing the stack.+data TCPairNHelper inp where+  TCPairNHelper ::+    forall (n :: Peano) (inp :: [T]).+    (SingI (PairN n inp), ConstraintPairN n inp) =>+    PeanoNatural n -> HST (PairN n inp) -> TCPairNHelper inp++-- | Helper data type we use to typecheck UNPAIRN.+--+-- It holds all the necessary data to construct a typed UNPAIRN+-- instruction once we're done traversing the pair.+data TCUnpairNHelper (inp :: [T]) where+  TCUnpairNHelper ::+    forall (n :: Peano) (a :: T) (b :: T) (rest :: [T]).+    (SingI (UnpairN n ('TPair a b) ++ rest), ConstraintUnpairN n ('TPair a b)) =>+    PeanoNatural n -> HST (UnpairN n ('TPair a b) ++ rest) -> TCUnpairNHelper ('TPair a b : rest)++-- | Helper data type we use to typecheck GETN.+--+-- It holds all the necessary data to construct a typed GETN+-- instruction once we're done traversing the pair.+data TCGetNHelper (inp :: [T]) where+  TCGetNHelper ::+    forall (ix :: Peano) (pair :: T) (rest :: [T]).+    (SingI (GetN ix pair ': rest), ConstraintGetN ix pair) =>+    PeanoNatural ix -> HST (GetN ix pair ': rest) -> TCGetNHelper (pair : rest)++-- | Helper data type we use to typecheck UPDATEN.+--+-- It holds all the necessary data to construct a typed UPDATEN+-- instruction once we're done traversing the pair.+data TCUpdateNHelper (inp :: [T]) where+  TCUpdateNHelper ::+    forall (ix :: Peano) (val :: T) (pair :: T) (rest :: [T]).+    (SingI (UpdateN ix val pair ': rest), ConstraintUpdateN ix pair) =>+    PeanoNatural ix -> HST (UpdateN ix val pair ': rest) -> TCUpdateNHelper (val : pair : rest)++-- | Helper function to convert a simple throwing typechecking action into a+-- non-throwing one, embedding possible errors into the type checking tree.+workOnInstr+  :: U.ExpandedInstr+  -> TypeCheckInstr (SomeInstr s)+  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)+workOnInstr instr = tcEither+  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr])+  (pure . WellTypedSeq)++-- | Less verbose version of `lift ... typeCheckListNoExcept`.+tcList+  :: (SingI inp)+  => [U.ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+tcList ops stack = lift $ typeCheckListNoExcept ops stack++-- | Function @typeCheckInstr@ converts a single Michelson instruction+-- given in representation from @Morley.Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- As a second argument, @typeCheckInstr@ accepts input stack type representation.+--+-- Type checking algorithm pattern-matches on given instruction, input stack+-- type and constructs strictly typed GADT value, checking necessary type+-- equalities when neccessary.+--+-- If there was no match on a given pair of instruction and input stack,+-- that is interpreted as input of wrong type and type check finishes with+-- error.+typeCheckInstr :: TcInstrHandler+typeCheckInstr uInstr inp = case (uInstr, inp) of+  (U.EXT ext, si) ->+    typeCheckExt typeCheckInstr ext si++  (U.DROP, _ ::& rs) -> workOnInstr uInstr $ pure $ inp :/ DROP ::: rs++  (U.DROP, SNil) -> notEnoughItemsOnStack++  (U.DROPN nTotal, inputHST) -> workOnInstr uInstr $+    go nTotal inputHST <&> \case+      TCDropHelper s out -> inputHST :/ DROPN s ::: out+    where+      go :: forall inp. SingI inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDropHelper inp)+      go = curry \case+        (0, i) -> pure (TCDropHelper Zero i)++        (_, SNil) -> notEnoughItemsOnStack'++        (n, (_ ::& iTail)) -> do+          go (n - 1) iTail <&> \(TCDropHelper s out) -> TCDropHelper (Succ s) out++  (U.DUP vn1, a@(n :: Notes t, d, _vn2) ::& rs) -> workOnInstr uInstr $ do+    Dict <-+      onScopeCheckInstrErr @t uInstr (SomeHST inp) Nothing $+      checkScope @(DupableScope t)+    pure (inp :/ DUP ::: ((n, d, vn1) ::& a ::& rs))++  (U.DUP _vn, SNil) -> notEnoughItemsOnStack++  (U.DUPN vn nTotal, inputHST) -> workOnInstr uInstr $+    go nTotal inputHST <&> \(TCDupNHelper s out) -> inputHST :/ DUPN s ::: out+    where+      go :: forall inp. SingI inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDupNHelper inp)+      go = curry \case+        (_, SNil) -> notEnoughItemsOnStack'++        (0, _) ->+          typeCheckInstrErr' uInstr (SomeHST inp) Nothing (InvalidInstruction uInstr "'DUP n' expects n > 0")++        -- Don't bind whatever variable annotation is here because DUP n doesn't+        -- duplicate variable annotations. This is consistent with tezos-client.+        (1, i@((an :: Notes a, dict, _) ::& _)) -> do+          Dict <-+            onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing $+            checkScope @(DupableScope a)+          pure (TCDupNHelper One ((an, dict, vn) ::& i))++        (n, (b ::& iTail)) ->+          go (n - 1) iTail <&> \(TCDupNHelper s@(Succ _) (a ::& resTail)) ->+            TCDupNHelper (Succ s) (a ::& b ::& resTail)++  (U.SWAP, a ::& b ::& rs) -> workOnInstr uInstr $+    pure (inp :/ SWAP ::: (b ::& a ::& rs))++  (U.SWAP, _) -> notEnoughItemsOnStack++  (U.DIG nTotal, inputHST) -> workOnInstr uInstr $+    go nTotal inputHST <&> \(TCDigHelper s out) -> inputHST :/ DIG s ::: out+    where+      go :: forall inp. SingI inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDigHelper inp)+      go = curry \case+        -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).+        (_, SNil) -> notEnoughItemsOnStack'++        (0, i@(_ ::& _)) -> pure (TCDigHelper Zero i)++        (n, (b ::& iTail)) ->+          go (n - 1) iTail <&> \(TCDigHelper s (a ::& resTail)) ->+            TCDigHelper (Succ s) (a ::& b ::& resTail)++  (U.DUG nTotal, inputHST) -> workOnInstr uInstr $+    go nTotal inputHST <&> \(TCDugHelper s out) -> inputHST :/ DUG s ::: out+    where+      go :: forall inp. SingI inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDugHelper inp)+      go = curry \case+        (0, i@(_ ::& _)) -> pure (TCDugHelper Zero i)++        (n, (a ::& b ::& iTail)) ->+          go (n - 1) (a ::& iTail) <&> \(TCDugHelper s resTail) ->+            TCDugHelper (Succ s) (b ::& resTail)++        -- Two cases:+        -- 1. Input stack is empty.+        -- 2. n > 0 and input stack has exactly 1 item.+        _ -> notEnoughItemsOnStack'++  (U.PUSH vn mt mval, i) -> workOnInstr uInstr $+    withUType mt $ \(nt :: Notes t) -> do+      val <- typeCheckValue @t mval+      proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST i) Nothing+        $ checkScope @(ConstantScope t)+      case proofScope of+        Dict -> withWTPInstr @t $ pure $ i :/ PUSH val ::: ((nt, Dict, vn) ::& i)++  (U.SOME tn vn, (an, Dict, _) ::& rs) -> workOnInstr uInstr $+    pure (inp :/ SOME ::: ((NTOption tn an, Dict, vn) ::& rs))++  (U.SOME _ _, SNil) -> notEnoughItemsOnStack++  (U.NONE tn vn elMt, _) -> workOnInstr uInstr $+    withUType elMt $ \(elNotes :: Notes t) ->+      withWTPInstr @t $+        pure $ inp :/ NONE ::: ((NTOption tn elNotes, Dict, vn) ::& inp)++  (U.UNIT tn vn, _) -> workOnInstr uInstr $+    pure $ inp :/ UNIT ::: ((NTUnit tn, Dict, vn) ::& inp)++  (U.IF_NONE mp mq, (STOption{}, (ons :: Notes ('TOption a)), Dict, ovn) ::&+ rs) -> do+    let (an, avn) = deriveNsOption ons ovn+    withWTPInstr' @a $+      genericIf IF_NONE U.IF_NONE mp mq rs ((an, Dict, avn) ::& rs) inp++  (U.IF_NONE _ _, _ ::& _) ->+    failWithErr $ UnexpectedType $ ("option 'a" :| []) :| []++  (U.IF_NONE _ _, SNil) -> notEnoughItemsOnStack++  (U.PAIR tn vn pfn qfn, (an :: Notes a, _, avn) ::& (bn :: Notes b, _, bvn) ::& rs) -> workOnInstr uInstr $ do+    let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn vn+    withWTPInstr @('TPair a b) $+      pure (inp :/ AnnPAIR tn pfn qfn ::: ((NTPair tn pfn' qfn' avn bvn an bn, Dict, vn') ::& rs))++  (U.PAIR {}, _) -> notEnoughItemsOnStack+  (U.UNPAIR instrVn1 instrVn2 instrFn1 instrFn2, (NTPair _ fn1 fn2 vn1 vn2 n1 n2, Dict, vn) ::& rs) ->+    workOnInstr uInstr $ do+      -- We purposefully ignore the result of `convergeDestrAnns` here.+      -- We're only interested in checking that the instruction's field ann matches the pair's field ann,+      -- we don't need to "unify" them.+      _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn1 instrFn1)+      _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn2 instrFn2)++      let vn1' = deriveSpecialVN instrVn1 fn1 vn vn1+      let vn2' = deriveSpecialVN instrVn2 fn2 vn vn2+      pure $+        inp :/ AnnUNPAIR instrVn1 instrVn2 instrFn1 instrFn2 :::+          ( (n1, Dict, vn1') ::&+            (n2, Dict, vn2') ::&+            rs+          )++  (U.UNPAIR {}, _ ::& _) ->+    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []++  (U.UNPAIR {}, _) -> notEnoughItemsOnStack+  (U.PAIRN varAnn nTotal, _) -> workOnInstr uInstr $ do+    go nTotal inp <&> \case+      TCPairNHelper s out -> inp :/ PAIRN s ::: addVarAnn out+    where+      go :: forall inp. Word -> HST inp -> TypeCheckInstr (TCPairNHelper inp)+      go n hst+        | n < 2 =+            typeCheckInstrErr' uInstr (SomeHST inp) Nothing+              (InvalidInstruction uInstr "'PAIR n' expects n ≥ 2")+        | n == 2 =+            case hst of+              (an :: Notes a, _, _) ::& (bn :: Notes b, _, _) ::& hstTail -> do+                withWTPInstr @('TPair a b) $ do+                  pure $ TCPairNHelper Two $+                    (mkNotes an bn, Dict, U.noAnn) ::& hstTail+              _ -> notEnoughItemsOnStack'+        | otherwise =+            case hst of+              (an :: Notes a, _, _) ::& hstTail@(_ ::& _ ::& _) -> do+                go (n - 1) hstTail >>= \case+                  TCPairNHelper nSing@(Succ (Succ _)) ((bn :: Notes b, _, _) ::& hstTail') -> do+                    withWTPInstr @('TPair a b) $ do+                      pure $ TCPairNHelper (Succ nSing) $+                        (mkNotes an bn, Dict, U.noAnn) ::& hstTail'+              _ -> notEnoughItemsOnStack'++      mkNotes :: forall a b. Notes a -> Notes b -> Notes ('TPair a b)+      mkNotes an bn =+        NTPair U.noAnn+          U.noAnn U.noAnn+          U.noAnn U.noAnn+          an bn++      -- | If a @PAIR n@ instruction has a variable annotation,+      -- the var annotation should be added ONLY to the top-most @pair@ value.+      --+      -- > /* [ nat : nat : nat ] */ ;+      -- > PAIR @aa 3+      -- > /* [ @aa pair nat nat nat ] */ ;+      addVarAnn :: forall a inp. HST (a ': inp) -> HST (a ': inp)+      addVarAnn = \case+        (an, dict, _) ::& hstTail -> (an, dict, varAnn) ::& hstTail++  (U.UNPAIRN _, SNil) -> notEnoughItemsOnStack+  (U.UNPAIRN nTotal, _ ::& _) -> workOnInstr uInstr $ do+    go nTotal inp <&> \case+      TCUnpairNHelper s out ->+        inp :/ UNPAIRN s ::: out+    where+      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCUnpairNHelper (x : xs))+      go n hst+        | n < 2 =+            typeCheckInstrErr' uInstr (SomeHST inp) Nothing+              (InvalidInstruction uInstr "UNPAIR expects an argument of at least 2.")+        | n == 2 =+            case hst of+              (NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes, Dict, _) ::& rest -> do+                pure $ TCUnpairNHelper Two $+                  (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn)+                  ::& (bNotes, Dict, convAnn @FieldTag @VarTag bFieldAnn)+                  ::& rest+              _ -> unexpectedType+        | otherwise =+            case hst of+              (NTPair _ aFieldAnn _ _ _ aNotes bNotes, Dict, _) ::& rest -> do+                go (n - 1) ((bNotes, Dict, U.noAnn) ::& rest) >>= \case+                  TCUnpairNHelper nSing@(Succ (Succ _)) out -> do+                    pure $ TCUnpairNHelper (Succ nSing) $+                      (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn) ::& out+              _ -> unexpectedType++      unexpectedType :: TypeCheckInstr a+      unexpectedType = failWithErr' $ UnexpectedType $ (pairWithElems nTotal :| []) :| []++  (U.CAR vn fn, (STPair{}, NTPair _ pfn _ pvn _ pns _, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do+    -- We purposefully ignore the result of `convergeDestrAnns` here.+    -- We're only interested in checking that the instruction's field ann matches the pair's field ann,+    -- we don't need to "unify" them.+    _ <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeDestrAnns fn pfn)+    let vn' = deriveSpecialVN vn pfn pairVN pvn+    pure $ inp :/ AnnCAR vn fn ::: ((pns, Dict, vn') ::& rs)++  (U.CAR _ _, _ ::& _) ->+    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []++  (U.CAR _ _, SNil) -> notEnoughItemsOnStack++  (U.CDR vn fn, (STPair{}, NTPair _ _ qfn _ qvn _ qns, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do+    -- We purposefully ignore the result of `convergeDestrAnns` here.+    -- We're only interested in checking that the instruction's field ann matches the pair's field ann,+    -- we don't need to "unify" them.+    _ <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeDestrAnns fn qfn)+    let vn' = deriveSpecialVN vn qfn pairVN qvn+    pure $ inp :/ AnnCDR vn fn ::: ((qns, Dict, vn') ::& rs)++  (U.CDR _ _, _ ::& _) ->+    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []++  (U.CDR _ _, SNil) -> notEnoughItemsOnStack++  (U.LEFT tn vn pfn qfn bMt, (an :: Notes l, Dict, avn) ::& rs) ->+    withUType bMt $ \(bn :: Notes r) -> workOnInstr uInstr $ do+      let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn U.noAnn vn+      withWTPInstr @r $ do+        let ns = NTOr tn pfn' qfn' an bn+        pure (inp :/ AnnLEFT tn pfn qfn ::: ((ns, Dict, vn') ::& rs))++  (U.LEFT {}, SNil) -> notEnoughItemsOnStack++  (U.RIGHT tn vn pfn qfn aMt, (bn :: Notes r, Dict, bvn) ::& rs) ->+    withUType aMt $ \(an :: Notes l) -> workOnInstr uInstr $ do+      let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn U.noAnn bvn vn+      withWTPInstr @l $ do+        let ns = NTOr tn pfn' qfn' an bn+        pure (inp :/ AnnRIGHT tn pfn qfn ::: ((ns, Dict, vn') ::& rs))++  (U.RIGHT {}, SNil) -> notEnoughItemsOnStack++  (U.IF_LEFT mp mq, (STOr lt rt, ons, _, ovn) ::&+ rs) -> do+    case deriveNsOr ons ovn of+      (an :: Notes a, bn :: Notes b, avn, bvn) -> withSingI lt $ withSingI rt $+        withWTPInstr' @a $+          withWTPInstr' @b $ do+            let+              ait = (an, Dict, avn) ::& rs+              bit = (bn, Dict, bvn) ::& rs+            genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp++  (U.IF_LEFT _ _, _ ::& _) ->+    failWithErr $ UnexpectedType $ ("or 'a 'b" :| []) :| []++  (U.IF_LEFT _ _, SNil) -> notEnoughItemsOnStack++  (U.NIL tn vn elMt, i) -> workOnInstr uInstr $+    withUType elMt $ \(elNotes :: Notes t) ->+      withWTPInstr @('TList t) $+        pure $ i :/ NIL ::: ((NTList tn elNotes, Dict, vn) ::& i)++  (U.CONS vn, ((an :: Notes a), _, _)+                ::& ((ln :: Notes l), _, _) ::& rs) -> workOnInstr uInstr+    case eqType @('TList a) @l of+      Right Refl -> do+        (n :: Notes t) <- onTypeCheckInstrAnnErr uInstr inp (Just ConsArgument) (converge ln (NTList def an))+        withWTPInstr @t $+          pure $ inp :/ CONS ::: ((n, Dict, vn) ::& rs)+      Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just ConsArgument) m++  (U.CONS _, _) -> notEnoughItemsOnStack++  (U.IF_CONS mp mq, (STList{}, ns, Dict, vn) ::&+ rs) -> do+    case ns of+      NTList _ (an :: Notes t1) -> withWTPInstr' @t1 $ do+        let ait = (an, Dict, vn) ::& (ns, Dict, vn) ::& rs+        genericIf IF_CONS U.IF_CONS mp mq ait rs inp++  (U.IF_CONS _ _, _ ::& _) ->+    failWithErr $ UnexpectedType $ ("list 'a" :| []) :| []++  (U.IF_CONS _ _, SNil)-> notEnoughItemsOnStack++  (U.SIZE vn, (NTList{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn+  (U.SIZE vn, (NTSet{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn+  (U.SIZE vn, (NTMap{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn+  (U.SIZE vn, (NTString{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn+  (U.SIZE vn, (NTBytes{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn+  (U.SIZE _, _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("list 'a" :| []) :|+      [ ("set 'a" :| [])+      , ("map 'k 'v" :| [])+      , ("string" :| [])+      , ("bytes" :| [])+      ]++  (U.SIZE _, SNil) -> notEnoughItemsOnStack++  (U.EMPTY_SET tn vn mv, i) -> workOnInstr uInstr $+    withUType mv $ \(vns :: Notes v) ->+      withWTPInstr @('TSet v) $+        withCompareableCheck (notesSing vns) uInstr inp $ i :/ EMPTY_SET ::: ((STSet sing, NTSet tn vns, Dict, vn) ::&+ i)++  (U.EMPTY_MAP tn vn mk mv, i) -> workOnInstr uInstr $ do+    withUType mv $ \(vns :: Notes v)  ->+      withUType mk $ \(ktn :: Notes k) ->+        withWTPInstr @('TMap k v) $+          withCompareableCheck (notesSing ktn) uInstr inp $ i :/ EMPTY_MAP ::: ((STMap sing sing, NTMap tn ktn vns, Dict, vn) ::&+ i)++  (U.EMPTY_BIG_MAP tn vn mk mv, i) -> workOnInstr uInstr $+    withUType mv $ \(vns :: Notes v)  ->+      withUType mk $ \(ktn :: Notes k) ->+        withWTPInstr @('TBigMap k v) $+          withCompareableCheck (notesSing ktn) uInstr inp $ i :/ EMPTY_BIG_MAP ::: ((STBigMap sing sing, NTBigMap tn ktn vns, Dict, vn) ::&+ i)++  (U.MAP vn mp, (STList l, NTList _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> withSingI l $ do+    withWTPInstr' @t1 $+      mapImpl (U.MAP vn) vns uInstr mp inp+        (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $ (NTList def rn, Dict, vn) ::& hst)++  (U.MAP vn mp, (STMap k v, NTMap _ kns vns, Dict, _vn) ::&+ _) -> withSingI k $ withSingI v $ do+    case NTPair def def def def def kns vns of+      (pns :: Notes ('TPair k v1)) ->+        withWTPInstr' @('TPair k v1) $+          mapImpl (U.MAP vn) pns uInstr mp inp+             (\(rn :: Notes v) hst -> withWTPInstr @('TMap k v) $ pure $ (NTMap def kns rn, Dict, vn) ::& hst)++  (U.MAP _ _, _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("list 'a" :| []) :|+      [ ("map 'k 'v" :| [])+      ]++  (U.MAP _ _, SNil) -> notEnoughItemsOnStack++  (U.ITER is, (STSet (s :: Sing t1), NTSet _ en, _, _) ::&+ _) -> withSingI s $ do+    withWTPInstr' @t1 $+      iterImpl en uInstr is inp++  (U.ITER is, (STList (l :: Sing t1), NTList _ en, _, _) ::&+ _) -> withSingI l $ do+    withWTPInstr' @t1 $+      iterImpl en uInstr is inp++  (U.ITER is, (STMap k v, NTMap _ kns vns, _, _) ::&+ _) -> withSingI k $ withSingI v $ do+    case NTPair def def def def def kns vns of+      (en :: Notes ('TPair a b)) ->+        withWTPInstr' @('TPair a b) $ iterImpl en uInstr is inp++  (U.ITER _, _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("set 'a" :| []) :|+      [ ("list 'a" :| [])+      , ("map 'k 'v" :| [])+      ]++  (U.ITER _, SNil) -> notEnoughItemsOnStack++  (U.MEM varNotes,+   _ ::& (STSet s, NTSet _ notesK, _, _) ::&+ _) -> withSingI s $ workOnInstr uInstr $+    memImpl notesK inp varNotes+  (U.MEM varNotes,+   _ ::& (STMap k v, NTMap _ notesK _, _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $+    memImpl notesK inp varNotes+  (U.MEM varNotes,+   _ ::& (STBigMap k v, NTBigMap _ notesK _, _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $+    memImpl notesK inp varNotes+  (U.MEM _, _ ::& _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("'a" :| ["set 'a"]) :|+      [ ("'k" :| ["map 'k 'v"])+      , ("'k" :| ["big_map 'k 'v"])+      ]++  (U.MEM _, _) -> notEnoughItemsOnStack++  (U.GET varNotes,+   _ ::& (STMap k v, NTMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $+      getImpl notesK inp notesV varNotes+  (U.GET varNotes,+   _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $+      getImpl notesK inp notesV varNotes++  (U.GET _, _ ::& _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("'k" :| ["map 'k 'v"]) :|+      [ ("'k" :| ["big_map 'k 'v"])+      ]++  (U.GET _, _) -> notEnoughItemsOnStack++  (U.GETN _ _, SNil) -> notEnoughItemsOnStack+  (U.GETN getNVarAnn ix0, _ ::& _) -> workOnInstr uInstr $ do+    go ix0 inp <&> \case+      TCGetNHelper s out ->+        inp :/ GETN s ::: out+    where+      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCGetNHelper (x : xs))+      go 0 ((a, Dict, _) ::& rest) =+        pure $ TCGetNHelper Zero ((a, Dict, getNVarAnn) ::& rest)+      go 1 ((NTPair _ _ _ _ _ leftNotes _, Dict, _) ::& rest) =+        pure $ TCGetNHelper One $ (leftNotes, Dict, getNVarAnn) ::& rest+      go ix ((NTPair _ _ _ _ _ _ rightNotes, Dict, _) ::& rest) =+        go (ix - 2) ((rightNotes, Dict, U.noAnn) ::& rest) <&> \(TCGetNHelper ixSing out) ->+          TCGetNHelper (Succ (Succ ixSing)) out+      go _ _ = failWithErr' $ UnexpectedType $ (pairWithNodeIndex ix0 :| []) :| []++  (U.UPDATE varAnn,+   _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn+  (U.UPDATE varAnn,+   _ ::& _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn+  (U.UPDATE varAnn,+   _ ::& _ ::& (STSet s, NTSet _ (notesK :: Notes k), _, _) ::&+ _) ->+    withSingI s $ workOnInstr uInstr $ updImpl notesK inp (NTBool U.noAnn) varAnn++  (U.UPDATE _, _ ::& _ ::& _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("'a" :| ["bool", "set 'a"]) :|+      [ ("'k" :| ["option 'v", "map 'k 'v"])+      , ("'k" :| ["option 'v", "big_map 'k 'v"])+      ]++  (U.UPDATE _, _) -> notEnoughItemsOnStack++  (U.UPDATEN updateNVarAnn ix0, _ ::& _ ::& _) -> workOnInstr uInstr $ do+    go ix0 inp <&> \case+      TCUpdateNHelper s out ->+        inp :/ UPDATEN s ::: out+    where+      go :: forall val pair rest. Word -> HST (val : pair : rest) -> TypeCheckInstr (TCUpdateNHelper (val : pair : rest))+      go 0 ((valNotes, Dict, _) ::& (_, _, _) ::& rest) =+        pure $ TCUpdateNHelper Zero $+          (valNotes, Dict, updateNVarAnn) ::& rest+      go 1 ((valNotes, Dict, _) ::& (NTPair pairTA leftFA rightFA leftVA rightVA _ rightNotes, Dict, _) ::& rest) =+        pure $ TCUpdateNHelper One $+          (NTPair pairTA leftFA rightFA leftVA rightVA valNotes rightNotes, Dict, updateNVarAnn) ::& rest+      go ix (val ::& (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes rightNotes, Dict, _) ::& rest) =+        go (ix - 2) (val ::& (rightNotes, Dict, U.noAnn) ::& rest) <&>+          \(TCUpdateNHelper ixSing ((updatedRightNotes, Dict, _) ::& outRest)) ->+            TCUpdateNHelper (Succ (Succ ixSing)) $+              (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes updatedRightNotes, Dict, updateNVarAnn) ::& outRest+      go _ _ = failWithErr' $ UnexpectedType $ ("'val" :| [pairWithNodeIndex ix0]) :| []+  (U.UPDATEN _ _, _) -> notEnoughItemsOnStack++  (U.GET_AND_UPDATE varAnn,+   _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $+      withWTPInstr @v $+        getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn+  (U.GET_AND_UPDATE varAnn,+   _ ::& _ ::& (STBigMap k v, (NTBigMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->+    withSingI k $ withSingI v $ workOnInstr uInstr $+      withWTPInstr @v $+        getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn+  (U.GET_AND_UPDATE _, _ ::& _ ::& _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("'k" :| ["option 'v", "map 'k 'v"]) :|+      [ ("'k" :| ["option 'v", "big_map 'k 'v"])+      ]+  (U.GET_AND_UPDATE _, _) -> notEnoughItemsOnStack++  (U.IF mp mq, (NTBool{}, _, _) ::& rs) ->+    genericIf IF U.IF mp mq rs rs inp++  (U.IF _ _, _ ::& _) ->+    failWithErr $ UnexpectedType $ ("bool" :| []) :| []++  (U.IF _ _, SNil) -> notEnoughItemsOnStack++  (U.LOOP is, (NTBool{}, _, _) ::& (rs :: HST rs)) -> do+    preserving (tcList is rs) U.LOOP $ \(_ :/ tp) ->+      case tp of+        subI ::: (o :: HST o) -> do+          case eqHST o (sing @'TBool -:& rs) of+            Right Refl -> pure $ inp :/ LOOP subI ::: rs+            Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m+        AnyOutInstr subI ->+          pure $ inp :/ LOOP subI ::: rs++  (U.LOOP _, _ ::& _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("bool" :| []) :| []++  (U.LOOP _, _) -> notEnoughItemsOnStack++  (U.LOOP_LEFT is, (os@STOr{}, ons, Dict, ovn) ::&+ rs) -> do+    case deriveNsOr ons ovn of+      (an :: Notes t, bn :: Notes b, avn, bvn) -> do+        withWTPInstr' @t $ withWTPInstr' @b $ do+          let ait = (an, Dict, avn) ::& rs+          preserving (tcList is ait) U.LOOP_LEFT $ \(_ :/ tp) ->+            case tp of+              subI ::: o -> do+                case (eqHST o (os -:& rs), o) of+                  (Right Refl, ((ons', Dict, ovn') ::& rs')) -> do+                      let (_, bn', _, bvn') = deriveNsOr ons' ovn'+                      br <- onTypeCheckInstrAnnErr uInstr inp+                              (Just Iteration)+                              (convergeHSTEl (bn, Dict, bvn) (bn', Dict, bvn'))+                      pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs')+                  (Left m, _) -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m+              AnyOutInstr subI -> do+                let br = (bn, Dict, bvn)+                pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs)++  (U.LOOP_LEFT _, _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("or 'a 'b" :| []) :| []++  (U.LOOP_LEFT _, _) -> notEnoughItemsOnStack++  (U.LAMBDA vn p1@(AsUType (ins :: Notes t)) p2@(AsUType (ons :: Notes u)) is, i) -> do+    -- further processing is extracted into another function just not to+    -- litter our main typechecking logic+    withWTPInstr' @t $+      withWTPInstr' @u $+        lamImpl (U.LAMBDA vn p1 p2) uInstr is vn ins ons i++  (U.EXEC vn, ((tn :: Notes t1), _, _)+                              ::& ( STLambda v b+                                  , NTLambda _ (t1n :: Notes t1') (t2n :: Notes t2')+                                  , _+                                  , _+                                  )+                              ::&+ rs) -> withSingI v $ withSingI b $ workOnInstr uInstr $ do+    Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)+                  (eqType @t1 @t1')+    (Refl, _) <- errM $ matchTypes tn t1n+    withWTPInstr @t2' $ pure $ inp :/ EXEC ::: ((t2n, Dict, vn) ::& rs)+      where+        errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a+        errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)++  (U.EXEC _, _ ::& _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("'a" :| ["lambda 'a 'b"]) :| []++  (U.EXEC _, _) -> notEnoughItemsOnStack++  (U.APPLY vn, ((_ :: Notes a'), _, _)+                  ::& ( STLambda (STPair lt rt) b+                      , NTLambda vann (NTPair _ _ _ _ _ (_ :: Notes a) (nb :: Notes b)) sc+                      , _+                      , _)+                  ::&+ rs) -> withSingI lt $ withSingI rt $ withSingI b $ workOnInstr uInstr $ do+    case NTLambda vann nb sc of+      (l2n :: Notes ('TLambda t1 t2)) -> withWTPInstr @('TLambda t1 t2) $ do++        proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)+                      (eqType @a' @a)+        proofScope <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just LambdaArgument)+          $ checkScope @(ConstantScope a)+        case (proofArgEq, proofScope) of+          (Refl, Dict) ->+            pure $ inp :/ (APPLY @a) ::: ((l2n, Dict, vn) ::& rs)++  (U.APPLY _, _ ::& _ ::& _) ->+    failWithErr $ UnexpectedType+      $ ("'a" :| ["lambda (pair 'a 'b) 'c"]) :| []++  (U.APPLY _, _) -> notEnoughItemsOnStack++  (U.DIP is, a ::& s) -> do+    typeCheckDipBody U.DIP uInstr is s+      (IllTypedSeq)+      (\subI t -> WellTypedSeq $ inp :/ DIP subI ::: (a ::& t))++  (U.DIP _is, SNil) -> notEnoughItemsOnStack++  (U.DIPN nTotal instructions, inputHST) ->+    go nTotal inputHST <&> \case+      TCDipHelperErr err rest -> IllTypedSeq err rest+      TCDipHelperOk s subI out -> WellTypedSeq $ inputHST :/ DIPN s subI ::: out+    where+      go :: forall inp. SingI inp+        => Word+        -> HST inp+        -> TypeCheckInstrNoExcept (TCDipHelper inp)+      go n curHST = case (n, curHST) of+        (0, _) -> typeCheckDipBody (U.DIPN nTotal) uInstr instructions curHST+          (TCDipHelperErr)+          (TCDipHelperOk Zero)+        (_, SNil) -> do+          pos <- ask+          let err = TCFailedOnInstr uInstr (SomeHST inp) pos Nothing (Just NotEnoughItemsOnStack)+          pure $ TCDipHelperErr err [NonTypedInstr $ U.PrimEx uInstr]+        (_, hstHead ::& hstTail) ->+          go (n - 1) hstTail <&> \case+          TCDipHelperOk s subI out -> TCDipHelperOk (Succ s) subI (hstHead ::& out)+          TCDipHelperErr err rest -> TCDipHelperErr err rest++  (u, v) -> case (u, v) of -- Workaround for not exceeding -fmax-pmcheck-iterations limit+    (U.FAILWITH, ((_ :: Notes a, _, _) ::& _)) -> workOnInstr uInstr $ do+      Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just FailwithArgument)+        $ checkScope @(ConstantScope a)+      pure $ inp :/ AnyOutInstr FAILWITH++    (U.FAILWITH, _) -> notEnoughItemsOnStack++    (U.CAST vn (AsUType (castToNotes :: Notes t)), (en, _, evn) ::& rs) ->+      workOnInstr uInstr $ do+        (Refl, _) <- errM $ matchTypes en castToNotes+        withWTPInstr @t $+          pure $ inp :/ CAST ::: ((castToNotes, Dict, vn `orAnn` evn) ::& rs)+      where+        errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a+        errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just Cast)++    (U.CAST _ _, _) -> notEnoughItemsOnStack++    (U.RENAME vn, (an, Dict, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ RENAME ::: ((an, Dict, vn) ::& rs)++    (U.RENAME _, SNil) -> notEnoughItemsOnStack++    (U.UNPACK tn vn mt, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $+      withUType mt $ \(tns :: Notes tn) -> do+        case NTOption tn tns of+          (ns :: Notes ('TOption t1)) -> withWTPInstr @('TOption t1) $ do+            Dict <- onScopeCheckInstrErr @tn uInstr (SomeHST inp) Nothing+              $ checkScope @(UnpackedValScope tn)+            pure $ inp :/ UNPACK ::: ((ns, Dict, vn) ::& rs)++    (U.UNPACK {}, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []++    (U.UNPACK {}, SNil) -> notEnoughItemsOnStack++    (U.PACK vn, (_ :: Notes a, _, _) ::& rs) -> workOnInstr uInstr $ do+      Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing+        $ checkScope @(PackedValScope a)+      pure $ inp :/ PACK ::: ((starNotes, Dict, vn) ::& rs)++    (U.PACK _, SNil) -> notEnoughItemsOnStack++    (U.CONCAT vn, (NTBytes{}, _, _) ::& (NTBytes{}, _, _) ::& _) ->+      workOnInstr uInstr $ concatImpl inp vn+    (U.CONCAT vn, (NTString{}, _, _) ::& (NTString{}, _, _) ::& _) ->+      workOnInstr uInstr $ concatImpl inp vn+    (U.CONCAT vn, (STList STBytes, _, _, _) ::&+ _) ->+      workOnInstr uInstr $ concatImpl' inp vn+    (U.CONCAT vn, (STList STString, _, _, _) ::&+ _) ->+      workOnInstr uInstr $ concatImpl' inp vn+    (U.CONCAT _, _ ::& _) ->+      failWithErr $ UnexpectedType+        $ ("string" :| ["string"]) :|+        [ ("bytes" :| ["bytes"])+        , ("list string" :| ["list string"])+        , ("list bytes" :| ["list bytes"])+        ]+    (U.CONCAT _, SNil) -> notEnoughItemsOnStack++    (U.SLICE vn, (NTNat{}, _, _) ::&+                 (NTNat{}, _, _) ::&+                 (NTString{}, _, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn+    (U.SLICE vn, (NTNat{}, _, _) ::&+                 (NTNat{}, _, _) ::&+                 (NTBytes{}, _, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn++    (U.SLICE _, _ ::& _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType+        $ ("nat" :| ["nat", "string"]) :|+        [ ("nat" :| ["nat", "bytes"])+        ]+    (U.SLICE _, _) -> notEnoughItemsOnStack++    (U.ISNAT vn', (NTInt{}, _, oldVn) ::& rs) -> workOnInstr uInstr $ do+      let vn = vn' `orAnn` oldVn+      pure $ inp :/ ISNAT ::: ((starNotes, Dict, vn) ::& rs)++    (U.ISNAT _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []++    (U.ISNAT _, SNil)-> notEnoughItemsOnStack++    -- Type checking is already done inside `addImpl`.+    (U.ADD vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $+      addImpl a b inp vn uInstr++    (U.ADD _, _) -> notEnoughItemsOnStack++    (U.SUB vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $+      subImpl a b inp vn uInstr++    (U.SUB _, _) -> notEnoughItemsOnStack++    (U.MUL vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $+      mulImpl a b inp vn uInstr++    (U.MUL _, _) -> notEnoughItemsOnStack++    (U.EDIV vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $+      edivImpl a b inp vn uInstr++    (U.EDIV _, _) -> notEnoughItemsOnStack++    (U.ABS vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImpl @Abs ABS inp vn+    (U.ABS _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []++    (U.ABS _, SNil) -> notEnoughItemsOnStack++    (U.NEG vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Neg NEG inp vn+    (U.NEG vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImpl @Neg NEG inp vn+    (U.NEG vn, (STBls12381Fr, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Neg NEG inp vn+    (U.NEG vn, (STBls12381G1, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Neg NEG inp vn+    (U.NEG vn, (STBls12381G2, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Neg NEG inp vn+    (U.NEG _, _ ::& _) ->+      failWithErr $ UnexpectedType+        $ ("int" :| []) :|+        [ ("nat" :| [])+        , ("bls12_381_fr" :| [])+        , ("bls12_381_g1" :| [])+        , ("bls12_381_g2" :| [])+        ]+    (U.NEG _, SNil) -> notEnoughItemsOnStack++    (U.LSL vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @Lsl LSL inp vn uInstr+    (U.LSL _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []+    (U.LSL _, _) -> notEnoughItemsOnStack++    (U.LSR vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @Lsr LSR inp vn uInstr+    (U.LSR _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []+    (U.LSR _, _) -> notEnoughItemsOnStack++    (U.OR vn, (STBool, _, _, _) ::&++              (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @Or OR inp vn uInstr+    (U.OR vn, (STNat, _, _, _) ::&++              (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @Or OR inp vn uInstr+    (U.OR _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType+        $ ("bool" :| ["bool"]) :|+        [ ("nat" :| ["nat"])+        ]+    (U.OR _, _) -> notEnoughItemsOnStack++    (U.AND vn, (STInt, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @And AND inp vn uInstr+    (U.AND vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @And AND inp vn uInstr+    (U.AND vn, (STBool, _, _, _) ::&++               (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @And AND inp vn uInstr+    (U.AND _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType+        $ ("int" :| ["nat"]) :|+        [ ("nat" :| ["nat"])+        , ("bool" :| ["bool"])+        ]+    (U.AND _, _) -> notEnoughItemsOnStack++    (U.XOR vn, (STBool, _, _, _) ::&++               (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @Xor XOR inp vn uInstr+    (U.XOR vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      arithImpl @Xor XOR inp vn uInstr+    (U.XOR _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType+        $ ("bool" :| ["bool"]) :|+        [ ("nat" :| ["nat"])+        ]+    (U.XOR _, _) -> notEnoughItemsOnStack++    (U.NOT vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImpl @Not NOT inp vn+    (U.NOT vn, (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Not NOT inp vn+    (U.NOT vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Not NOT inp vn+    (U.NOT _, _ ::& _) ->+      failWithErr $ UnexpectedType+        $ ("nat" :| []) :|+        [ ("bool" :| [])+        , ("int" :| [])+        ]+    (U.NOT _, SNil) -> notEnoughItemsOnStack++    (U.COMPARE vn,+          (an :: Notes aT, _, _)+      ::& (bn :: Notes bT, _, _)+      ::& rs+      )+      -> workOnInstr uInstr $ do+      case eqType @aT @bT of+        Right Refl -> do+          void . errConv $ converge an bn+          proofScope <- onScopeCheckInstrErr @aT (U.COMPARE vn) (SomeHST inp) (Just ComparisonArguments)+            $ checkScope @(ComparabilityScope aT)+          case proofScope of+            Dict ->+              pure $ inp :/ COMPARE ::: ((starNotes, Dict, vn) ::& rs)++        Left err -> do+          typeCheckInstrErr' uInstr (SomeHST inp) (Just ComparisonArguments) err+      where+        errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a+        errConv = onTypeCheckInstrAnnErr uInstr inp (Just ComparisonArguments)++    (U.COMPARE _, _) -> notEnoughItemsOnStack++    (U.EQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $+      unaryArithImpl @Eq' EQ inp vn+    (U.EQ _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []+    (U.EQ _, SNil) -> notEnoughItemsOnStack++    (U.NEQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $+      unaryArithImpl @Neq NEQ inp vn+    (U.NEQ _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []+    (U.NEQ _, SNil) -> notEnoughItemsOnStack++    (U.LT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $+      unaryArithImpl @Lt LT inp vn+    (U.LT _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []+    (U.LT _, SNil) -> notEnoughItemsOnStack++    (U.GT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $+      unaryArithImpl @Gt GT inp vn+    (U.GT _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []+    (U.GT _, SNil) -> notEnoughItemsOnStack++    (U.LE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $+      unaryArithImpl @Le LE inp vn+    (U.LE _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []+    (U.LE _, SNil) -> notEnoughItemsOnStack++    (U.GE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $+      unaryArithImpl @Ge GE inp vn+    (U.GE _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("int" :| []) :| []+    (U.GE _, SNil) -> notEnoughItemsOnStack++    (U.INT vn, (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs)+    (U.INT vn, (NTBls12381Fr{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs)+    (U.INT _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("nat" :| []) :| ["bls12_381_fr" :| []]+    (U.INT _, SNil) -> notEnoughItemsOnStack++    (U.SELF vn fn, _) -> workOnInstr uInstr $ do+      mode <- gets tcMode+      case mode of+        TypeCheckValue (value, ty) ->+          tcFailedOnValue value ty "The SELF instruction cannot appear in a lambda." Nothing+        TypeCheckContract (SomeParamType _ notescp) -> do+          let epName = U.epNameFromSelfAnn fn+          MkEntrypointCallRes (argNotes :: Notes arg) epc <-+            mkEntrypointCall epName notescp+              & maybeToRight (EntrypointNotFound epName)+              & onTypeCheckInstrErr uInstr (SomeHST inp) Nothing++          case NTContract U.noAnn argNotes of+                  (ntRes :: Notes ('TContract t1)) ->+                    withWTPInstr @('TContract t1) $+                      pure $ inp :/ SELF @arg (SomeEpc epc) ::: ((ntRes, Dict, vn) ::& inp)+        TypeCheckTest ->+          error "'SELF' appears in test typechecking."+        TypeCheckPack ->+          error "'SELF' appears in packed data."+    (U.CONTRACT vn fn mt, (NTAddress{}, _, _) ::& rs) -> workOnInstr uInstr $+      withUType mt $ \(tns :: Notes t) -> do+        proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter)+          $ checkScope @(ParameterScope t)+        let ns = NTOption def $ NTContract def tns+        epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing+          $ epNameFromRefAnn fn `onFirst` IllegalEntrypoint+        case proofScope of+          Dict ->+            withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs)++    (U.CONTRACT {}, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("address" :| []) :| []+    (U.CONTRACT {}, SNil) -> notEnoughItemsOnStack++    (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _, _)+      ::& (NTMutez{}, _, _)+      ::& (STContract (s :: Sing p), _, _, _) ::&+ rs) -> withSingI s $ workOnInstr uInstr $ do+      proofScope <- onScopeCheckInstrErr @p uInstr (SomeHST inp) (Just ContractParameter)+        $ checkScope @(ParameterScope p)+      case (eqType @p @p', proofScope) of+        (Right Refl, Dict) ->+          pure $ inp :/ TRANSFER_TOKENS ::: ((starNotes, Dict, vn) ::& rs)+        (Left m, _) ->+          typeCheckInstrErr' uInstr (SomeHST inp) (Just ContractParameter) m++    (U.TRANSFER_TOKENS _, _ ::& _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType $ ("'p" :| ["mutez", "contract 'p"]) :| []++    (U.TRANSFER_TOKENS _, _) -> notEnoughItemsOnStack++    (U.SET_DELEGATE vn,+      (STOption STKeyHash, NTOption _ NTKeyHash{}, _, _)+      ::&+ rs) -> workOnInstr uInstr $ do+        pure $ inp :/ SET_DELEGATE ::: ((starNotes, Dict, vn) ::& rs)++    (U.SET_DELEGATE _,  _ ::& _) ->+      failWithErr $ UnexpectedType $ ("option key_hash" :| []) :| []++    (U.SET_DELEGATE _, _) -> notEnoughItemsOnStack++    (U.CREATE_CONTRACT ovn avn contract,+      (STOption STKeyHash, NTOption _ (_ :: Notes ('TKeyHash)), _, _)+      ::&+ (NTMutez{}, _, _)+      ::& (gn :: Notes g, Dict, _) ::& rs) -> workOnInstr uInstr $ do+        (SomeContract+          (Contract+            (contr :: ContractCode p' g')+            paramNotes+            storeNotes+            entriesOrder))+          <- lift $ typeCheckContractImpl contract+        Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage)+          $ eqType @g @g'+        void $ onTypeCheckInstrAnnErr uInstr inp (Just ContractStorage) (converge gn storeNotes)+        pure+          $ inp :/ CREATE_CONTRACT (Contract contr paramNotes storeNotes entriesOrder)+          ::: ((starNotes, Dict, ovn) ::& (starNotes, Dict, avn) ::& rs)++    (U.CREATE_CONTRACT {}, _ ::& _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType $ ("option key_hash" :| ["mutez", "'a"]) :| []++    (U.CREATE_CONTRACT {},  _) -> notEnoughItemsOnStack++    (U.IMPLICIT_ACCOUNT vn, (NTKeyHash{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ IMPLICIT_ACCOUNT ::: ((starNotes, Dict, vn) ::& rs)++    (U.IMPLICIT_ACCOUNT _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("key_hash" :| []) :| []+    (U.IMPLICIT_ACCOUNT _, SNil) -> notEnoughItemsOnStack++    (U.NOW vn, _) -> workOnInstr uInstr $+      pure $ inp :/ NOW ::: ((starNotes, Dict, vn) ::& inp)++    (U.AMOUNT vn, _) -> workOnInstr uInstr $+      pure $ inp :/ AMOUNT ::: ((starNotes, Dict, vn) ::& inp)++    (U.BALANCE vn, _) -> workOnInstr uInstr $+      pure $ inp :/ BALANCE ::: ((starNotes, Dict, vn) ::& inp)++    (U.VOTING_POWER vn, (NTKeyHash{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ VOTING_POWER ::: ((starNotes, Dict, vn) ::& rs)++    (U.TOTAL_VOTING_POWER vn, _) -> workOnInstr uInstr $+      pure $ inp :/ TOTAL_VOTING_POWER ::: ((starNotes, Dict, vn) ::& inp)++    (U.CHECK_SIGNATURE vn,+               (NTKey _, _, _)+               ::& (NTSignature _, _, _) ::& (NTBytes{}, _, _) ::& rs) ->+      workOnInstr uInstr $+        pure $ inp :/ CHECK_SIGNATURE ::: ((starNotes, Dict, vn) ::& rs)++    (U.CHECK_SIGNATURE _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType $ ("key" :| ["signature", "bytes"]) :| []+    (U.CHECK_SIGNATURE _, _) -> notEnoughItemsOnStack++    (U.SHA256 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ SHA256 ::: ((starNotes, Dict, vn) ::& rs)+    (U.SHA256 _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []+    (U.SHA256 _, SNil) -> notEnoughItemsOnStack++    (U.SHA512 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ SHA512 ::: ((starNotes, Dict, vn) ::& rs)+    (U.SHA512 _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []+    (U.SHA512 _, SNil) -> notEnoughItemsOnStack++    (U.BLAKE2B vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ BLAKE2B ::: ((starNotes, Dict, vn) ::& rs)+    (U.BLAKE2B _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []+    (U.BLAKE2B _, SNil) -> notEnoughItemsOnStack++    (U.SHA3 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ SHA3 ::: ((starNotes, Dict, vn) ::& rs)+    (U.SHA3 _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []+    (U.SHA3 _, SNil) -> notEnoughItemsOnStack++    (U.KECCAK vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ KECCAK ::: ((starNotes, Dict, vn) ::& rs)+    (U.KECCAK _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []+    (U.KECCAK _, SNil) -> notEnoughItemsOnStack++    (U.HASH_KEY vn, (NTKey{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ HASH_KEY ::: ((starNotes, Dict, vn) ::& rs)+    (U.HASH_KEY _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("key" :| []) :| []+    (U.HASH_KEY _, SNil) -> notEnoughItemsOnStack++    (U.PAIRING_CHECK vn, (NTList _ (NTPair _ _ _ _ _ (NTBls12381G1 _)+                                                     (NTBls12381G2 _)), _, _) ::& rs) ->+      workOnInstr uInstr $+        pure $ inp :/ PAIRING_CHECK ::: ((starNotes, Dict, vn) ::& rs)+    (U.PAIRING_CHECK _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("list (pair bls12_381_g1 bls12_381_g2)" :| []) :| []+    (U.PAIRING_CHECK _, SNil) -> notEnoughItemsOnStack++    (U.SOURCE vn, _) -> workOnInstr uInstr $+      pure $ inp :/ SOURCE ::: ((starNotes, Dict, vn) ::& inp)++    (U.SENDER vn, _) -> workOnInstr uInstr $+      pure $ inp :/ SENDER ::: ((starNotes, Dict, vn) ::& inp)++    (U.ADDRESS vn, (NTContract{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ ADDRESS ::: ((starNotes, Dict, vn) ::& rs)++    (U.ADDRESS _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("contract 'p" :| []) :| []+    (U.ADDRESS _, SNil) -> notEnoughItemsOnStack++    (U.CHAIN_ID vn, _) -> workOnInstr uInstr $+      pure $ inp :/ CHAIN_ID ::: ((starNotes, Dict, vn) ::& inp)++    (U.LEVEL vn, _) -> workOnInstr uInstr $+      pure $ inp :/ LEVEL ::: ((starNotes, Dict, vn) ::& inp)++    (U.SELF_ADDRESS vn, _) -> workOnInstr uInstr $+      pure $ inp :/ SELF_ADDRESS ::: ((starNotes, Dict, vn) ::& inp)++    (U.NEVER, (NTNever{}, _, _) ::& _) -> workOnInstr uInstr $+      pure $ inp :/ AnyOutInstr NEVER++    (U.TICKET vn, (stVal :: Sing v, _, _, _) ::&+ (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $+      withWTPInstr @v $+      withCompareableCheck stVal uInstr inp $+        inp :/ TICKET ::: ((starNotes, Dict, vn) ::& rs)+    (U.TICKET _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType $ ("a'" :| ["nat"]) :| []+    (U.TICKET _, _) -> notEnoughItemsOnStack++    (U.READ_TICKET vn, ticket@(ntTicket@NTTicket{}, Dict, _) ::& rs) -> workOnInstr uInstr $+      case notesSing ntTicket of+        STTicket{} ->+          pure $ inp :/ READ_TICKET ::: ((starNotes, Dict, vn) ::& ticket ::& rs)+    (U.READ_TICKET _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("ticket 'a" :| []) :| []+    (U.READ_TICKET _, _) -> notEnoughItemsOnStack++    (U.SPLIT_TICKET vn, (NTTicket{}, Dict, _) ::& (NTPair _ _ _ _ _ NTNat{} NTNat{}, _, _) ::& rs) ->+      workOnInstr uInstr $+        pure $ inp :/ SPLIT_TICKET ::: ((starNotes, Dict, vn) ::& rs)+    (U.SPLIT_TICKET _, _ ::& _ ::& _) ->+      failWithErr $ UnexpectedType $ ("pair nat nat" :| ["ticket 'a"]) :| []+    (U.SPLIT_TICKET _, _) -> notEnoughItemsOnStack++    (U.JOIN_TICKETS vn,+       (STPair{}, NTPair _ _ _ _ _ nt1@NTTicket{} nt2@NTTicket{}, Dict, _) ::&+ rs) ->+      workOnInstr uInstr $ do+        (Refl, nt) <-+          onTypeCheckInstrErr uInstr (SomeHST inp) (Just TicketsJoin) $+            matchTypes nt1 nt2+        pure $ inp :/ JOIN_TICKETS ::: ((NTOption U.noAnn nt, Dict, vn) ::& rs)+    (U.JOIN_TICKETS _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("pair (ticket 'a) (ticket 'a)" :| []) :| []+    (U.JOIN_TICKETS _, _) -> notEnoughItemsOnStack++    -- Could not get rid of the catch all clause due to this warning:+    -- @+    -- Pattern match checker exceeded (2000000) iterations in+    -- a case alternative. (Use -fmax-pmcheck-iterations=n+    -- to set the maximum number of iterations to n)+    -- @+    i ->+      error $ "Pattern matches should be exhaustive, but instead got: " <> show i+  where+    withWTPInstr'+      :: forall t inp. SingI t+      => (WellTyped t => TypeCheckInstrNoExcept (TypeCheckedSeq inp))+      -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+    withWTPInstr' = withWTPInstr'_ @t uInstr (SomeHST inp)++    withWTPInstr+      :: forall t a. SingI t => (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a+    withWTPInstr = withWTPInstr_ @t uInstr (SomeHST inp)++    failWithErr :: TCTypeError -> TypeCheckInstrNoExcept (TypeCheckedSeq a)+    failWithErr = workOnInstr uInstr . failWithErr'++    failWithErr' :: TCTypeError -> TypeCheckInstr a+    failWithErr' = typeCheckInstrErr' uInstr (SomeHST inp) Nothing++    notEnoughItemsOnStack :: TypeCheckInstrNoExcept (TypeCheckedSeq a)+    notEnoughItemsOnStack = failWithErr NotEnoughItemsOnStack++    notEnoughItemsOnStack' :: TypeCheckInstr a+    notEnoughItemsOnStack' = failWithErr' NotEnoughItemsOnStack++-- | Helper function for two-branch if where each branch is given a single+-- value.+genericIf+  :: forall bti bfi cond rs .+    (SingI bti, SingI bfi)+  => (forall s'.+        Instr bti s' ->+        Instr bfi s' ->+        Instr (cond ': rs) s'+     )+  -> (forall op. [op] -> [op] -> U.InstrAbstract op)+  -> [U.ExpandedOp]+  -> [U.ExpandedOp]+  -> HST bti+  -> HST bfi+  -> HST (cond ': rs)+  -> TypeCheckInstrNoExcept (TypeCheckedSeq (cond ': rs))+genericIf cons mCons mbt mbf bti bfi i@(_ ::& _) = do+  let cons1 opsT = mCons opsT (map (IllTypedOp . NonTypedInstr) mbf)+  preserving' (tcList mbt bti) cons1 $ \tInstr@(_ :/ pinstr) -> do+    let cons2 opsF = mCons [someInstrToOp tInstr] opsF+    preserving (tcList mbf bfi) cons2 $ \(_ :/ qinstr) -> do+      fmap (i :/) $ case (pinstr, qinstr) of+        (p ::: po, q ::: qo) -> do+          let instr = mCons mbt mbf+          Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just If)+            $ eqHST po qo+          o <- onTypeCheckInstrAnnErr instr i (Just If) (convergeHST po qo)+          pure $ cons p q ::: o+        (AnyOutInstr p, q ::: qo) -> do+          pure $ cons p q ::: qo+        (p ::: po, AnyOutInstr q) -> do+          pure $ cons p q ::: po+        (AnyOutInstr p, AnyOutInstr q) ->+          pure $ AnyOutInstr (cons p q)++mapImpl+  :: forall c rs.+    ( MapOp c+    , WellTyped (MapOpInp c)+    , SingI1 (MapOpRes c)+    )+  => ([TypeCheckedOp] -> TypeCheckedInstr)+  -> Notes (MapOpInp c)+  -> U.ExpandedInstr+  -> [U.ExpandedOp]+  -> HST (c ': rs)+  -> (forall v'. (SingI v') =>+        Notes v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs)))+  -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs))+mapImpl cons vn instr mp i@(_ ::& rs) mkRes = do+  preserving (tcList mp ((vn, Dict, def) ::& rs)) cons $ \(_ :/ subp) ->+    case subp of+      sub ::: subo ->+        case subo of+          (bn :: Notes v', _, _bvn) ::& rs' -> do+            Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration)+              $ eqHST rs rs'+            x <- mkRes bn rs'+            pure $ i :/ withSingI1 @(MapOpRes c) @v' (MAP sub ::: x)+          _ -> typeCheckInstrErr instr (SomeHST i) (Just Iteration)+      AnyOutInstr _ ->+        typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails++iterImpl+  :: forall c rs .+    ( IterOp c+    , WellTyped (IterOpEl c)+    )+  => Notes (IterOpEl c)+  -> U.ExpandedInstr+  -> [U.ExpandedOp]+  -> HST (c ': rs)+  -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs))+iterImpl en instr mp i@((_, _, lvn) ::& rs) = do+  let evn = deriveVN [annQ|elt|] lvn+  let tcAction = case mp of+        [] -> workOnInstr instr+          (typeCheckInstrErr' instr (SomeHST i) (Just Iteration) EmptyCode)+        _ -> typeCheckImpl typeCheckInstr mp ((en, Dict, evn) ::& rs)+  preserving tcAction U.ITER $ \(_ :/ subp) -> case subp of+    subI ::: o -> do+      Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration) $ eqHST o rs+      pure $ i :/ ITER subI ::: o+    AnyOutInstr _ ->+      typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails++lamImpl+  :: forall it ot ts .+    ( WellTyped it, WellTyped ot+    , SingI ts+    )+  => ([TypeCheckedOp] -> TypeCheckedInstr)+  -> U.ExpandedInstr+  -> [U.ExpandedOp]+  -> VarAnn+  -> Notes it+  -> Notes ot+  -> HST ts+  -> TypeCheckInstrNoExcept (TypeCheckedSeq ts)+lamImpl cons instr is vn ins ons i =+  guarding_ instr+    (whenJust (getFirst $ foldMap hasSelf is) $ \selfInstr -> do+      let err = InvalidInstruction selfInstr "SELF instruction cannot be used in a LAMBDA"+      typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) err) $+    preserving (tcList is ((ins, Dict, def) ::& SNil)) cons $ \(_ :/ lamI) -> do+      let lamNotes onsr = NTLambda def ins onsr+      let lamSt onsr = (lamNotes onsr, Dict, vn) ::& i+      fmap (i :/) $ case lamI of+        lam ::: lo -> do+          case eqHST1 @ot lo of+            Right Refl -> do+                let (ons', _, _) ::& SNil = lo+                onsr <- onTypeCheckInstrAnnErr instr i (Just LambdaCode) (converge ons ons')+                pure (LAMBDA (VLam $ RfNormal lam) ::: lamSt onsr)+            Left m -> typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) m+        AnyOutInstr lam ->+          pure (LAMBDA (VLam $ RfAlwaysFails lam) ::: lamSt ons)+  where+    hasSelf :: U.ExpandedOp -> First U.ExpandedInstr+    hasSelf = everything (<>)+      (mkQ (First Nothing)+       (\case+           selfInstr@(U.SELF{} :: U.InstrAbstract U.ExpandedOp) -> First $ Just selfInstr+           _ -> First Nothing+       )+      )++----------------------------------------------------------------------------+-- Helpers for DIP (n) typechecking+----------------------------------------------------------------------------++-- Helper data type we use to typecheck DIPN.+data TCDipHelper inp where+  TCDipHelperOk ::+    forall (n :: Peano) inp out s s'.+    (SingI out, ConstraintDIPN n inp out s s') =>+    PeanoNatural n -> Instr s s' -> HST out -> TCDipHelper inp+  TCDipHelperErr :: TCError -> [IllTypedInstr] -> TCDipHelper inp++typeCheckDipBody+  :: SingI inp+  => ([TypeCheckedOp] -> TypeCheckedInstr)+  -> U.ExpandedInstr+  -> [U.ExpandedOp]+  -> HST inp+  -> (TCError -> [IllTypedInstr] -> r)+  -> (forall out. SingI out => Instr inp out -> HST out -> r)+  -> TypeCheckInstrNoExcept r+typeCheckDipBody cons mainInstr instructions inputHST onErr onOk = do+  listRes <- lift $ typeCheckListNoExcept instructions inputHST+  pos <- ask+  pure $ listRes & tcsEither+    (\tcOps err -> onErr err [SemiTypedInstr $ cons tcOps])+    (\someInstr@(_ :/ iAndOut) -> case iAndOut of+        AnyOutInstr _ ->+        -- This may seem like we throw error because of despair, but in fact,+        -- the reference implementation seems to behave exactly in this way -+        -- if output stack of code block within @DIP@ occurs to be any, an+        -- error "FAILWITH must be at tail position" is raised.+        -- It is not allowed even in `DIP 0`.+          let err = TCFailedOnInstr mainInstr+                                    (SomeHST inputHST)+                                    pos+                                    (Just DipCode)+                                    (Just CodeAlwaysFails)+          in onErr err [SemiTypedInstr $ cons [someInstrToOp someInstr]]+        subI ::: t -> onOk subI t)

+ src/Morley/Michelson/TypeCheck/TypeCheck.hs view

@@ -0,0 +1,280 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.TypeCheck.TypeCheck+  ( TcInstrHandler+  , TcOriginatedContracts+  , TypeCheckEnv(..)+  , TypeCheckOptions(..)+  , TypeCheck+  , TypeCheckNoExcept+  , TypeCheckResult+  , runTypeCheck+  , TypeCheckInstr+  , TypeCheckInstrNoExcept+  , runTypeCheckIsolated+  , runTypeCheckInstrIsolated+  , typeCheckingWith+  , liftNoExcept+  , liftNoExcept'+  , throwingTCError+  , throwingTCError'+  , preserving+  , preserving'+  , guarding+  , guarding_+  , tcEither++  , tcExtFramesL+  , tcModeL+  , TypeCheckMode(..)+  , SomeParamType(..)+  , mkSomeParamType+  , unsafeMkSomeParamType+  ) where+++import Control.Monad.Except (Except, mapExceptT, runExcept, throwError)+import Control.Monad.Reader (mapReaderT)+import Data.Default (Default(..))+import Data.Singletons (Sing)+import Fmt (Buildable, build, pretty)+import qualified Text.Show++import Morley.Michelson.ErrorPos (InstrCallStack)+import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))+import Morley.Michelson.TypeCheck.TypeCheckedSeq+  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), someInstrToOp,+  tcsEither)+import Morley.Michelson.TypeCheck.Types+import Morley.Michelson.Typed (SingI)+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (ContractHash)+import Morley.Util.Lens++type TypeCheck =+  (ReaderT TypeCheckOptions+    (ExceptT TCError+      (State TypeCheckEnv)))++-- | A non-throwing alternative for @TypeCheck@. Mainly meant to be used for+-- construction of a partially typed tree (see @TypeCheckedSeq@).+type TypeCheckNoExcept =+  (ReaderT TypeCheckOptions+    (State TypeCheckEnv))++-- | Monad for performing some typechecking operations with the same options.+--+-- Unlike 'TypeCheck' monad, this does not carry the context of intra-contract+-- or intra-value typechecking.+-- TODO [this MR]: probably come up with a better name? IntraTypeCheck?+type TypeCheckResult =+  (ReaderT TypeCheckOptions+    (Except TCError))++data SomeParamType = forall t. (T.ParameterScope t) =>+  SomeParamType (Sing t) (T.ParamNotes t)++-- | @Show@ instance of @SomeParamType@, mainly used in test.+instance Show SomeParamType where+  show = show . someParamToParameterType++-- | @Eq@ instance of @SomeParamType@, mainly used in test.+instance Eq SomeParamType where+  s1 == s2 = someParamToParameterType s1 == someParamToParameterType s2++-- | @Buildable@ instance of @SomeParamType@, mainly used in test.+instance Buildable SomeParamType where+  build = build . someParamToParameterType++-- | Helper function means to provide a quick way for creating instance+-- of @SomeParamType@ needed in test.+someParamToParameterType :: SomeParamType -> U.ParameterType+someParamToParameterType (SomeParamType s T.UnsafeParamNotes{..}) =+  U.ParameterType (T.AsUTypeExt s pnNotes) pnRootAnn++-- | Construct @SomeParamType@ from @ParameterType@, mainly used in test.+unsafeMkSomeParamType :: HasCallStack => U.ParameterType -> SomeParamType+unsafeMkSomeParamType p =+  case mkSomeParamType p of+    Right sp -> sp+    Left err -> error $ "Illegal type in parameter of env contract: " <> pretty err++mkSomeParamType :: U.ParameterType -> Either TCError SomeParamType+mkSomeParamType (U.ParameterType t ann) =+  T.withUType t $ \(notescp :: T.Notes t) -> do+    case T.checkScope @(T.ParameterScope t) of+      Right T.Dict ->+        case T.mkParamNotes notescp ann of+          Right paramNotes -> Right $ SomeParamType T.sing paramNotes+          Left err ->+            Left $ TCContractError "invalid parameter declaration: " $ Just $ IllegalParamDecl err+      Left err -> Left $ TCContractError ("Parameter type is invalid: " <> pretty err) Nothing++type TcOriginatedContracts = Map ContractHash SomeParamType++-- | Typechecking mode that tells the type checker whether it is typechecking+-- contract code in actual contract, lambda, or test.+data TypeCheckMode+  = TypeCheckValue (U.Value, T.T)+  | TypeCheckContract SomeParamType+  | TypeCheckTest+  | TypeCheckPack++-- | The typechecking state+data TypeCheckEnv = TypeCheckEnv+  { tcExtFrames :: ~TcExtFrames+  , tcMode :: ~TypeCheckMode+  }++data TypeCheckOptions = TypeCheckOptions+  { tcVerbose :: Bool+    -- ^ Whether to add stack type comments after every+    -- instruction a la tezos-client.+  , tcStrict :: Bool+    -- ^ Whether should we behave like in test run or real run+    -- (real run is more strict).+    --+    -- @tezos-client run@'s behaviour can slightly differ from the behaviour+    -- of @tezos-client originate@ and @tezos-client transfer@. For instance,+    -- some values can be "forged" in test run, but not in a real one,+    -- see: Note [Tickets forging].+    --+    -- Set this to @True@ when need to match the behaviour in the network,+    -- and to @False@ if you prefer providing the user with some convenient+    -- features.+  }++instance Default TypeCheckOptions where+  def = TypeCheckOptions{ tcVerbose = False, tcStrict = True }++makeLensesWith postfixLFields ''TypeCheckEnv++runTypeCheck :: TypeCheckMode -> TypeCheck a -> TypeCheckResult a+runTypeCheck mode =+  mapReaderT $ mapExceptT $ evaluatingStateT (TypeCheckEnv [] mode)++-- | Run type checker as if it worked isolated from other world -+-- no access to environment of the current contract is allowed.+--+-- Use this function for test purposes only or for some utilities when+-- environment does not matter. In particular, it is assumed that+-- whatever we typecheck does not depend on the parameter type of the+-- contract which is being typechecked (because there is no contract+-- that we are typechecking).+runTypeCheckIsolated :: TypeCheck a -> TypeCheckResult a+runTypeCheckIsolated = runTypeCheck TypeCheckTest++typeCheckingWith :: TypeCheckOptions -> TypeCheckResult a -> Either TCError a+typeCheckingWith options = runExcept . usingReaderT options++type TypeCheckInstr =+  ReaderT InstrCallStack TypeCheck++type TypeCheckInstrNoExcept =+  ReaderT InstrCallStack TypeCheckNoExcept++-- | Similar to 'runTypeCheckIsolated', but for 'TypeCheckInstr.'+runTypeCheckInstrIsolated :: TypeCheckInstr a -> TypeCheckResult a+runTypeCheckInstrIsolated = runTypeCheckIsolated . flip runReaderT def++liftNoExcept :: TypeCheckInstrNoExcept a -> TypeCheckInstr a+liftNoExcept action = (pure action)+                 <**> (usingReaderT <$> ask)+                 <**> (usingReaderT <$> lift ask)+                 <**> (evaluatingState <$> get)++liftNoExcept' :: TypeCheckNoExcept a -> TypeCheck a+liftNoExcept' action = (pure action)+                  <**> (usingReaderT <$> ask)+                  <**> (evaluatingState <$> get)++throwingTCError+  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp) -> TypeCheckInstr (SomeInstr inp)+throwingTCError action = liftNoExcept action+  >>= tcsEither (const throwError) (pure)++throwingTCError'+  :: TypeCheckNoExcept (TypeCheckedSeq inp) -> TypeCheck (SomeInstr inp)+throwingTCError' action = liftNoExcept' action+  >>= tcsEither (const throwError) (pure)++tcEither+  :: (TCError -> TypeCheckInstrNoExcept a) -- ^ Call this if the action throws+  -> (b -> TypeCheckInstrNoExcept a) -- ^ Call this if it doesn't+  -> TypeCheckInstr b -- ^ The action to perform+  -> TypeCheckInstrNoExcept a -- ^ A non-throwing action+tcEither onErr onOk action = do+  res <- (pure action)+    <**> (usingReaderT <$> ask)+    <**> (usingReaderT <$> lift ask)+    <**> (pure runExceptT)+    <**> (evaluatingState <$> get)+  either onErr onOk res++-- | Perform a throwing action on an acquired instruction. Preserve the acquired+-- result by embedding it into a type checking tree with a specified parent+-- instruction.+preserving+  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp)+  -- ^ Acquiring computation+  -> ([TypeCheckedOp] -> TypeCheckedInstr)+  -- ^ The parent instruction constructor+  -> (SomeInstr inp -> TypeCheckInstr (SomeInstr inp'))+  -- ^ The throwing action+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')+preserving acquire con action = preserving' acquire con+  (\instr -> action instr & tcEither+    (\err -> pure $ IllTypedSeq err [SemiTypedInstr $ con [someInstrToOp instr]])+    (pure . WellTypedSeq))++-- | Perform a non-throwing action on an acquired instruction. Preserve the+-- acquired result even if the action does not succeed. Embed the result into a+-- type checking tree with a specified parent instruction.+preserving'+  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp)+  -- ^ Acquiring computation+  -> ([TypeCheckedOp] -> TypeCheckedInstr)+  -- ^ The parent instruction constructor+  -> (SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp'))+  -- ^ The action+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')+preserving' acquire con action =+  acquire >>= tcsEither+    (\tcOps err -> pure $ IllTypedSeq err [SemiTypedInstr $ con tcOps])+    (action)++-- | Acquire a resource. If successfully, call a follow-up action on it,+-- otherwise embed the error into a type checking tree along with a specified+-- untyped instruction.+guarding+  :: U.ExpandedInstr -- ^ Untyped instruction+  -> TypeCheckInstr a -- ^ Acquiring computation+  -> (a -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)) -- ^ Follow-up action+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+guarding instr cond action = do+  cond & tcEither+    (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr])+    (action)++-- | Same as @guarding@ but doesn't pass an acquired result to a follow-up+-- action.+guarding_+  :: U.ExpandedInstr+  -> TypeCheckInstr a+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)+guarding_ instr cond action = guarding instr cond (const action)++-- pva701: it's really painful to add arguments to TcInstrHandler+-- due to necessity to refactor @typeCheckInstr@.+-- Also functions which are being called from @typeCheckInstr@ would+-- have to be refactored too.+-- Therefore, I am using ReaderT over TypeCheck.+type TcInstrHandler+   = forall inp. (SingI inp, HasCallStack)+      => U.ExpandedInstr+      -> HST inp+      -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)

+ src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs view

@@ -0,0 +1,62 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- This module provides data types for representing partially typed+-- instructions.+module Morley.Michelson.TypeCheck.TypeCheckedOp+  ( TypeCheckedInstr+  , TypeCheckedOp(..)+  , IllTypedInstr(..)+  , someInstrToOp+  ) where++import Data.Singletons (SingI)++import Morley.Michelson.Printer.Util (RenderDoc(..), renderOpsListNoBraces)+import Morley.Michelson.TypeCheck.Types (HST(..), SomeInstr(..), SomeInstrOut(..))+import Morley.Michelson.Typed.Convert (instrToOps)+import Morley.Michelson.Typed.Instr (Instr, castInstr)+import Morley.Michelson.Untyped.Instr (ExpandedOp, InstrAbstract(..))+import Morley.Util.TH (deriveGADTNFData)++-- | Represents a root of a partially typed operation tree.+type TypeCheckedInstr = InstrAbstract TypeCheckedOp++-- | Represents nodes of a partially typed operation tree.+data TypeCheckedOp where+  -- | Constructs well-typed node.+  WellTypedOp :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp+  -- | Constructs ill-typed node which might in turn contain well-typed and+  -- non-typed operations.+  IllTypedOp :: IllTypedInstr -> TypeCheckedOp++instance Eq TypeCheckedOp where+  WellTypedOp i1 == WellTypedOp i2 = castInstr i1 == Just i2+  IllTypedOp i1 == IllTypedOp i2 = i1 == i2+  _ == _ = False++-- | Represents a non-well-typed operation+data IllTypedInstr+  = SemiTypedInstr TypeCheckedInstr -- ^ Constructs a partialy typed operation.+  | NonTypedInstr ExpandedOp  -- ^ Constructs a completely untyped operation.+  deriving stock (Eq, Generic)++deriving anyclass instance NFData TypeCheckedOp => NFData IllTypedInstr++instance RenderDoc TypeCheckedOp where+  renderDoc _ (WellTypedOp instr) = renderOpsListNoBraces False (instrToOps instr)+  renderDoc pn (IllTypedOp (SemiTypedInstr instr)) = renderDoc pn instr+  renderDoc pn (IllTypedOp (NonTypedInstr op)) = renderDoc pn op++-- | Makes a well-typed node out of `SomeInstr`+someInstrToOp :: SomeInstr inp -> TypeCheckedOp+someInstrToOp (hst :/ rest) = case hst of+  SNil -> go rest+  (::&){} -> go rest+  where+    go :: forall inp. SingI inp => SomeInstrOut inp -> TypeCheckedOp+    go (i ::: _) = WellTypedOp i+    go (AnyOutInstr i) = WellTypedOp (i @'[])++$(deriveGADTNFData ''TypeCheckedOp)

+ src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs view

@@ -0,0 +1,51 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | This module provides a data type for representing a partially typed+-- sequence of instructions.+--+-- It is needed to represent the fact that there can only be one well-typed node+-- in a sequence and it is the first one. Also, it serves its role to remove+-- @TCError@ usage from @TypeCheckedOp@.+module Morley.Michelson.TypeCheck.TypeCheckedSeq+  ( TypeCheckedInstr+  , TypeCheckedOp(..)+  , IllTypedInstr(..)+  , TypeCheckedSeq(..)+  , tcsEither+  , seqToOps+  , someInstrToOp+  ) where++import Morley.Michelson.TypeCheck.Error (TCError)+import Morley.Michelson.TypeCheck.TypeCheckedOp+  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), someInstrToOp)+import Morley.Michelson.TypeCheck.Types (SomeInstr(..))++-- | Represents a partiall typed sequence of instructions.+data TypeCheckedSeq inp+  -- | A fully well-typed sequence.+  = WellTypedSeq (SomeInstr inp)+  -- | A well-typed prefix followed by some error and semi-typed instructions.+  | MixedSeq (SomeInstr inp) TCError [IllTypedInstr]+  -- | There is no well-typed prefix, only an error and semi-typed instructions.+  | IllTypedSeq TCError [IllTypedInstr]++seqToOps :: TypeCheckedSeq inp -> [TypeCheckedOp]+seqToOps = \case+  WellTypedSeq instr -> [someInstrToOp instr]+  MixedSeq instr _ tail' -> someInstrToOp instr : map IllTypedOp tail'+  IllTypedSeq _ tail' -> map IllTypedOp tail'++-- | Case analysis for @TypeCheckedSeq@.+tcsEither+  :: ([TypeCheckedOp] -> TCError -> a)+     -- ^ On error, with all already typechecked operations+  -> (SomeInstr inp -> a) -- ^ On well-typed instruction+  -> TypeCheckedSeq inp -- ^ The sequence to dispatch on+  -> a+tcsEither onErr onInstr v = case v of+  WellTypedSeq instr -> onInstr instr+  MixedSeq _ err _ -> onErr (seqToOps v) err+  IllTypedSeq err _ -> onErr (seqToOps v) err

+ src/Morley/Michelson/TypeCheck/Types.hs view

@@ -0,0 +1,301 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.TypeCheck.Types+    ( HST (..)+    , (-:&)+    , pattern (::&+)+    , SomeHST (..)+    , SomeInstrOut (..)+    , SomeInstr (..)+    , BoundVars (..)+    , TcExtFrames+    , NotWellTyped (..)+    , getWTP+    , getWTP'+    , withWTPm+    , unsafeWithWTP+    , mapSomeContract+    , mapSomeInstr+    , mapSomeInstrOut+    , noBoundVars+    ) where++import Data.Constraint (Dict(..))+import qualified Data.Map.Lazy as Map+import Data.Singletons (Sing, SingI(..), fromSing)+import Fmt (Buildable(..), pretty)+import Prelude hiding (EQ, GT, LT)+import Text.PrettyPrint.Leijen.Text hiding (pretty)+import qualified Text.Show+++import Morley.Michelson.Printer.Util+import Morley.Michelson.Typed (Notes(..), SingT(..), SomeContract(..), T(..), notesT, starNotes)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Haskell.Value (WellTyped)+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Untyped (Ty, Var, noAnn)+import Morley.Michelson.Untyped.Annotation (VarAnn)+import Morley.Util.Sing (eqParamSing)++-- | Data type holding type information for stack (Heterogeneous Stack Type).+--+-- This data type is used along with instruction data type @Instr@+-- to carry information about its input and output stack types.+--+-- That is, if there is value @instr :: Instr inp out@, along with this+-- @instr@ one may carry @inpHST :: HST inp@ and @outHST :: HST out@ which will+-- contain whole information about input and output stack types for @instr@.+--+-- Data type @HST@ is very similar to @Data.Vinyl.Rec@,+-- but is specialized for a particular purpose.+-- In particular, definition of @HST (t1 ': t2 ': ... tn ': '[])@ requires+-- constraints @(Typeable t1, Typeable t2, ..., Typeable tn)@ as well as+-- constraints @(Typeable '[ t1 ], Typeable '[ t1, t2 ], ...)@.+-- These applications of @Typeable@ class are required for convenient usage+-- of type encoded by @HST ts@ with some functions from @Data.Typeable@.+--+-- Data type @HST@ (Heterogeneous Stack Type) is a heterogenuous list of tuples.+-- First element of tuple is a structure, holding field and type annotations+-- for a given type.+-- Second element of tuple is an optional variable annotation for the stack+-- element.+-- Additionally constructor keeps 'SingI' constraint for the current type.+data HST (ts :: [T])  where+  SNil :: HST '[]+  (::&) :: (T.SingI x, T.SingI xs)+        => (Notes x, Dict (WellTyped x), VarAnn)+        -> HST xs+        -> HST (x ': xs)++instance NFData (HST ts) where+  rnf (SNil) = ()+  rnf ((a, d, b) ::& hst) = rnf (a, d, b, hst)++instance Show (HST ts) where+  show SNil = "[]"+  show (r ::& rs) = "[ " <> showDo (r ::& rs) <> " ]"+    where+      showDo :: HST (t ': ts_) -> String+      showDo ((notesT -> t, Dict, _vn) ::& (b ::& c)) =+          show t <> ", " <> showDo (b ::& c)+      showDo ((notesT -> t, Dict, _vn) ::& SNil) = show t++instance Buildable (HST ts) where+  build = buildRenderDocExtended++instance RenderDoc (HST ts) where+  renderDoc _ SNil = "[]"+  renderDoc context (r ::& rs) = "[" <+> doRender (r ::& rs) <+> "]"+    where+      doRender :: HST (t ': ts_) -> Doc+      doRender ((notesT -> t, Dict, _vn) ::& (b ::& c)) =+          renderDoc context t <> "," <+> doRender (b ::& c)+      doRender ((notesT -> t, Dict, _vn) ::& SNil) = renderDoc context t+infixr 7 ::&++instance Eq (HST ts) where+  SNil == SNil = True+  (n1, Dict, a1) ::& h1 == (n2, Dict, a2) ::& h2 =+    n1 == n2 && a1 == a2 && h1 == h2++-- | Append a type to 'HST', assuming that notes and annotations+-- for this type are unknown.+(-:&)+  :: (WellTyped x, SingI xs)+  => Sing x+  -> HST xs+  -> HST (x ': xs)+_ -:& hst = (starNotes, Dict, noAnn) ::& hst+infixr 7 -:&++-- | Extended pattern-match - adds @Sing x@ argument.+infixr 7 ::&++pattern (::&+)+  :: ()+  => ( ys ~ (x ': xs)+     , SingI x, SingI xs+     )+  => (Sing x, Notes x, Dict (WellTyped x), VarAnn)+  -> HST xs+  -> HST ys+pattern x ::&+ hst <- ((\(n, d, v) -> (T.notesSing n, n, d, v)) -> x) ::& hst+  where (_, n, d, v) ::&+ hst = (n, d, v) ::& hst++-- | No-argument type wrapper for @HST@ data type.+data SomeHST where+  SomeHST :: SingI ts => HST ts -> SomeHST++deriving stock instance Show SomeHST+instance NFData SomeHST where+  rnf (SomeHST h) = rnf h++instance Eq SomeHST where+  SomeHST hst1 == SomeHST hst2 = hst1 `eqParamSing` hst2++-- | This data type keeps part of type check result - instruction and+-- corresponding output stack.+data SomeInstrOut inp where+  -- | Type-check result with concrete output stack, most common case.+  --+  -- Output stack type is wrapped inside the type and @Typeable@+  -- constraint is provided to allow convenient unwrapping.+  (:::)+    :: SingI out+    => Instr inp out+    -> HST out+    -> SomeInstrOut inp++  -- | Type-check result which matches against arbitrary output stack.+  -- Information about annotations in the output stack is absent.+  --+  -- This case is only possible when the corresponding code terminates+  -- with @FAILWITH@ instruction in all possible executions.+  -- The opposite may be not true though (example: you push always-failing+  -- lambda and immediatelly execute it - stack type is known).+  AnyOutInstr+    :: (forall out. Instr inp out)+    -> SomeInstrOut inp+infix 9 :::++instance Show (ExtInstr inp) => Show (SomeInstrOut inp) where+  show (i ::: out) = show i <> " :: " <> show out+  show (AnyOutInstr i) = show i <> " :: *"++-- | Data type keeping the whole type check result: instruction and+-- type representations of instruction's input and output.+data SomeInstr inp where+  (:/) :: HST inp -> SomeInstrOut inp -> SomeInstr inp+infix 8 :/++mapSomeInstrOut+  :: (forall out. Instr inp out -> Instr inp' out)+  -> SomeInstrOut inp+  -> SomeInstrOut inp'+mapSomeInstrOut f (i ::: out) = f i ::: out+mapSomeInstrOut f (AnyOutInstr i) = AnyOutInstr (f i)++mapSomeInstr+  :: (forall out. Instr inp out -> Instr inp out)+  -> SomeInstr inp+  -> SomeInstr inp+mapSomeInstr f (inp :/ instrAndOut) = inp :/ mapSomeInstrOut f instrAndOut++instance Show (ExtInstr inp) => Show (SomeInstr inp) where+  show (inp :/ out) = show inp <> " -> " <> show out++mapSomeContract ::+  (forall inp out. Instr inp out -> Instr inp out)+  -> SomeContract+  -> SomeContract+mapSomeContract f (SomeContract fc) = SomeContract $ mapContractCode f fc++-- | Set of variables defined in a let-block.+data BoundVars = BoundVars (Map Var Ty) (Maybe SomeHST)++noBoundVars :: BoundVars+noBoundVars = BoundVars Map.empty Nothing++-- | State for type checking @nop@+type TcExtFrames = [BoundVars]++-- | Error type for when a value is not well-typed.+data NotWellTyped = NotWellTyped+  { nwtBadType :: T+  , nwtCause :: T.BadTypeForScope+  }++instance Buildable NotWellTyped where+  build (NotWellTyped t c) =+    "Given type is not well typed because '" <> (build t) <> "' " <> (build c)++-- | Given a type, provide evidence that it is well typed w.r.t to the+--  Michelson rules regarding where comparable types are required.+getWTP :: forall t. (SingI t) => Either NotWellTyped (Dict (WellTyped t))+getWTP = getWTP' sing++-- | Version of 'getWTP' that accepts 'Sing' at term-level.+getWTP' :: Sing t -> Either NotWellTyped (Dict (WellTyped t))+getWTP' = \case+  STKey -> Right Dict+  STUnit -> Right Dict+  STSignature -> Right Dict+  STChainId -> Right Dict+  STOption s -> do+    Dict <- getWTP' s+    pure Dict+  STList s -> do+    Dict <- getWTP' s+    pure Dict+  STSet s -> do+    Dict <- getWTP' s+    Dict <- eitherWellTyped T.BtNotComparable T.getComparableProofS s+    pure Dict+  STOperation -> Right Dict+  STContract s -> do+    Dict <- getWTP' s+    Dict <- eitherWellTyped T.BtIsOperation T.opAbsense s+    pure Dict+  STTicket s -> do+    Dict <- getWTP' s+    Dict <- eitherWellTyped T.BtNotComparable T.getComparableProofS s+    pure Dict+  STPair s1 s2 -> do+    Dict <- getWTP' s1+    Dict <- getWTP' s2+    pure Dict+  STOr s1 s2 -> do+    Dict <- getWTP' s1+    Dict <- getWTP' s2+    pure Dict+  STLambda s1 s2 -> do+    Dict <- getWTP' s1+    Dict <- getWTP' s2+    pure Dict+  STMap s1 s2 -> do+    Dict <- getWTP' s1+    Dict <- getWTP' s2+    Dict <- eitherWellTyped T.BtNotComparable T.getComparableProofS s1+    pure Dict+  STBigMap s1 s2 -> do+    Dict <- getWTP' s1+    Dict <- getWTP' s2+    Dict <- eitherWellTyped T.BtNotComparable T.getComparableProofS s1+    Dict <- eitherWellTyped T.BtIsOperation T.opAbsense s2+    Dict <- eitherWellTyped T.BtHasBigMap T.bigMapAbsense s2+    pure Dict+  STInt -> Right Dict+  STNat -> Right Dict+  STString -> Right Dict+  STBytes -> Right Dict+  STMutez -> Right Dict+  STBool -> Right Dict+  STKeyHash -> Right Dict+  STBls12381Fr -> Right Dict+  STBls12381G1 -> Right Dict+  STBls12381G2 -> Right Dict+  STTimestamp -> Right Dict+  STAddress -> Right Dict+  STNever -> Right Dict+  where+    eitherWellTyped+      :: T.BadTypeForScope+      -> (Sing (ty :: T) -> Maybe a)+      -> Sing (ty :: T)+      -> Either NotWellTyped a+    eitherWellTyped bt sf sng = maybeToRight (NotWellTyped (fromSing sng) bt) $ sf sng++-- | Given a type and an action that requires evidence that the type is well typed,+--  generate the evidence and execute the action, or else fail with an error.+withWTPm :: forall t m a. (MonadFail m, SingI t) => (WellTyped t => m a) -> m a+withWTPm a = case getWTP @t of+  Right Dict -> a+  Left e -> fail (pretty e)++-- | Similar to @withWTPm@ but is meant to be used within tests.+unsafeWithWTP :: forall t a. SingI t => (WellTyped t => a) -> a+unsafeWithWTP fn = case getWTP @t of+  Right Dict -> fn+  Left e -> error $ pretty e

+ src/Morley/Michelson/TypeCheck/Value.hs view

@@ -0,0 +1,384 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.TypeCheck.Value+    ( typeCheckValImpl+    , tcFailedOnValue+    ) where++import Control.Monad.Except (liftEither, throwError)+import Data.Constraint (Dict(..))+import Data.Default (def)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Singletons (Sing, SingI(..), demote, fromSing, withSingI)+import Data.Typeable ((:~:)(..))+import Fmt (pretty)+import Prelude hiding (EQ, GT, LT)++import Morley.Michelson.Text+import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))+import Morley.Michelson.TypeCheck.Helpers+import Morley.Michelson.TypeCheck.TypeCheck+  (SomeParamType(..), TcInstrHandler, TcOriginatedContracts, TypeCheckInstr, TypeCheckOptions(..),+  throwingTCError)+import Morley.Michelson.TypeCheck.Types+import Morley.Michelson.Typed (EpAddress(..), Notes(..), SingT(..), Value'(..), starNotes)+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address(..))+import Morley.Tezos.Core+import Morley.Tezos.Crypto+import qualified Morley.Tezos.Crypto.BLS12381 as BLS+import Morley.Util.Type (onFirst)++tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a+tcFailedOnValue v t msg err = do+  loc <- ask+  throwError $ TCFailedOnValue v t msg loc err++-- | Function @typeCheckValImpl@ converts a single Michelson value+-- given in representation from @Morley.Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- @typeCheckValImpl@ is polymorphic in the expected type of value.+--+-- Type checking algorithm pattern-matches on parse value representation,+-- expected type @t@ and constructs @Val t@ value.+--+-- If there was no match on a given pair of value and expected type,+-- that is interpreted as input of wrong type and type check finishes with+-- error.+--+-- @typeCheckValImpl@ also has a 'Maybe TcOriginatedContracts' argument that+-- should contain the originated contracts when typechecking a parameter and+-- 'Nothing' otherwise.+typeCheckValImpl+  :: forall ty.+     SingI ty+  => Maybe TcOriginatedContracts+  -> TcInstrHandler+  -> U.Value+  -> TypeCheckInstr (T.Value ty)+typeCheckValImpl mOriginatedContracts tcDo uv = doTypeCheckVal (uv, sing @ty)+  where+    doTypeCheckVal :: forall tz. (U.Value, Sing tz) -> TypeCheckInstr (T.Value tz)+    doTypeCheckVal (uvalue, sng) = case (uvalue, sng) of+      (U.ValueInt i, STInt) -> pure $ T.VInt i+      (v@(U.ValueInt i), t@STNat)+        | i >= 0 -> pure $ VNat (fromInteger i)+        | otherwise -> tcFailedOnValue v (fromSing t) "" (Just NegativeNat)+      (v@(U.ValueInt i), t@STMutez) -> case mkMutez i of+        Right m -> pure $ VMutez m+        Left err -> tcFailedOnValue v (fromSing t) err (Just InvalidTimestamp)+      (U.ValueString s, STString) -> pure $ VString s+      (v@(U.ValueString s), t@STAddress) -> case T.parseEpAddress (unMText s) of+        Right addr -> pure $ VAddress addr+        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidAddress err)+      (v@(U.ValueBytes b), t@STAddress) -> case T.parseEpAddressRaw (U.unInternalByteString b) of+        Right addr -> pure $ VAddress addr+        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidAddress err)+      (v@(U.ValueString s), t@STKeyHash) -> case parseKeyHash (unMText s)  of+        Right kHash -> pure $ VKeyHash kHash+        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)+      (v@(U.ValueBytes b), t@STKeyHash) ->+        case parseKeyHashRaw (U.unInternalByteString b) of+          Right kHash -> pure $ VKeyHash kHash+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)+      (U.ValueInt i, STBls12381Fr) ->+        pure $ VBls12381Fr (fromIntegralOverflowing @Integer @Bls12381Fr i)+      (v@(U.ValueBytes b), t@STBls12381Fr) ->+        case BLS.fromMichelsonBytes (U.unInternalByteString b) of+          Right val -> pure $ VBls12381Fr val+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)+      (v@(U.ValueBytes b), t@STBls12381G1) ->+        case BLS.fromMichelsonBytes (U.unInternalByteString b) of+          Right val -> pure $ VBls12381G1 val+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)+      (v@(U.ValueBytes b), t@STBls12381G2) ->+        case BLS.fromMichelsonBytes (U.unInternalByteString b) of+          Right val -> pure $ VBls12381G2 val+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)+      (v@(U.ValueString s), t@STTimestamp) -> case parseTimestamp $ unMText s of+        Just tstamp -> pure $ VTimestamp tstamp+        Nothing -> tcFailedOnValue v (fromSing t) "" (Just InvalidTimestamp)+      (U.ValueInt i, STTimestamp) -> pure $ VTimestamp (timestampFromSeconds i)+      (U.ValueBytes (U.InternalByteString s), STBytes) -> pure $ VBytes s+      (U.ValueTrue, STBool) -> pure $ VBool True+      (U.ValueFalse, STBool) -> pure $ VBool False++      (U.ValueString (parsePublicKey . unMText -> Right s), STKey) ->+        pure $ T.VKey s+      (U.ValueBytes (parsePublicKeyRaw . U.unInternalByteString -> Right s), STKey) ->+        pure $ VKey s++      (U.ValueString (parseSignature . unMText -> Right s), STSignature) ->+        pure $ VSignature s+      (U.ValueBytes (parseSignatureRaw . U.unInternalByteString  -> Right s), STSignature) ->+        pure $ VSignature s++      (U.ValueString (parseChainId . unMText -> Right ci), STChainId) ->+        pure $ VChainId ci+      (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci), STChainId) ->+        pure $ VChainId ci++      (cv@(U.ValueString (T.parseEpAddress . unMText -> Right addr))+        , STContract pc) -> typecheckContractValue cv addr pc+      (cv@(U.ValueBytes (T.parseEpAddressRaw . U.unInternalByteString -> Right addr))+        , STContract pc) -> typecheckContractValue cv addr pc++      (cv, s@(STTicket vt)) -> lift (asks tcStrict) >>= \case+        -- Note [Tickets forging]+        -- Normally, ticket values cannot be constructed manually (i.e. forged)+        -- by design, and the only valid way to make a ticket is calling+        -- @TICKET@ instruction.+        --+        -- However @tezos-client run@ adds an exception, it allows passing a+        -- manually constructed ticket value as parameter or initial storage.+        True ->+          tcFailedOnValue cv (fromSing sng)+            "ticket values cannot be forged in real operations"+            Nothing+        False -> case cv of+          U.ValuePair addrV (U.ValuePair datV amV) -> withComparable vt cv s $ do+            addrValue <- doTypeCheckVal (addrV, STAddress)+            dat <- doTypeCheckVal (datV, vt)+            amountValue <- doTypeCheckVal (amV, STNat)+            case (addrValue, amountValue) of+              (VAddress (EpAddress addr ep), VNat am) -> do+                unless (U.isDefEpName ep) $+                  tcFailedOnValue cv (fromSing sng)+                    "it is pointless to provide an address with entrypoint as a \+                    \ticketer, we do not support that"+                    Nothing+                -- ↑ Tezos allows passing addresses with entrypoint, but it is+                -- not possible to sanely work with them after that anyway,+                -- since @TICKET@ instruction (the only valid way of constructing+                -- tickets in real run) uses @SELF_ADDRESS@ result as ticketer.+                return $ VTicket addr dat am+          _ ->+            tcFailedOnValue cv (fromSing sng)+              "ticket type expects a value of type `(pair address <data> nat)`"+              Nothing++      (U.ValueUnit, STUnit) -> pure $ VUnit+      (U.ValuePair ml mr, STPair lt rt) -> do+        l <- doTypeCheckVal (ml, lt)+        r <- doTypeCheckVal (mr, rt)+        pure $ VPair (l, r)+      (U.ValueLeft ml, STOr lt rt) -> do+        l <- doTypeCheckVal (ml, lt)+        withSingI lt $ withSingI rt $ pure $ VOr (Left l)+      (U.ValueRight mr, STOr lt rt) -> do+        r <- doTypeCheckVal (mr, rt)+        withSingI lt $ withSingI rt $ pure $ VOr (Right r)+      (U.ValueSome mv, STOption op) -> do+        v <- doTypeCheckVal (mv, op)+        withSingI op $ pure $ VOption (Just v)+      (U.ValueNone, STOption op) -> do+        withSingI op $ pure $ VOption Nothing++      (U.ValueNil, STList l) -> withSingI l $+        pure $ T.VList []++      -- If ValueSeq contains at least 2 elements, it can be type checked as a+      -- right combed pair.+      (U.ValueSeq vals@(_ :| (_ : _)), STPair _ _) ->+        doTypeCheckVal (seqToRightCombedPair vals, sng)++      (U.ValueSeq (toList -> mels), STList l) -> do+        els <- typeCheckValsImpl (mels, l)+        withSingI l $ pure $ VList els++      (U.ValueNil, STSet s) -> do+        instrPos <- ask+        case T.getComparableProofS s of+          Just Dict -> withSingI s $ pure (T.VSet S.empty)+          Nothing -> throwError $ TCFailedOnValue uvalue (fromSing s) "Non comparable types are not allowed in Sets"+            instrPos (Just $ UnsupportedTypeForScope (fromSing s) T.BtNotComparable)++      (sq@(U.ValueSeq (toList -> mels)), s@(STSet vt)) -> withComparable vt sq s $ do+        instrPos <- ask++        els <- typeCheckValsImpl (mels, vt)+        elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els+                  `onFirst` \msg -> TCFailedOnValue sq (fromSing vt) msg instrPos Nothing+        withSingI vt $ pure $ VSet elsS++      (v@U.ValueNil, s@(STMap st vt)) ->+        withSingI st $ withSingI vt $ withComparable st v s $ pure $ T.VMap M.empty++      (sq@(U.ValueMap (toList -> mels)), s@(STMap kt vt)) ->+        withComparable kt sq s $ do+          keyOrderedElts <- typeCheckMapVal mels sq kt vt+          withSingI kt $ withSingI vt $+            pure $ VMap (M.fromDistinctAscList keyOrderedElts)++      (v@U.ValueNil, s@(STBigMap st1 st2)) ->+        withSingI st1 $ withSingI st2 $ withComparable st1 v s $ withBigMapAbsence st2 v s $+          pure $ VBigMap Nothing M.empty++      (sq@(U.ValueMap (toList -> mels)), s@(STBigMap kt vt)) ->+        withComparable kt sq s $ withBigMapAbsence vt sq s $ do+          keyOrderedElts <- typeCheckMapVal mels sq kt vt+          withSingI kt $ withSingI vt $+            pure $ VBigMap Nothing (M.fromDistinctAscList keyOrderedElts)++      -- `{ {} }` can be typechecked either as `VLam` or `VList`.+      (U.ValueLambda s, STList l) ->+        case emptyLambdaAsList s of+          Just xs -> doTypeCheckVal (xs, sng)+          Nothing -> tcFailedOnValue uvalue (fromSing l) "" Nothing++      (U.ValueSeq s, STLambda _ _) -> case emptyListAsLambda s of+        Just xs -> doTypeCheckVal (xs, sng)+        Nothing -> tcFailedOnValue uvalue (fromSing sng) "" Nothing++      (v, STLambda (var :: Sing it) (b :: Sing ot)) -> withSingI var $ withSingI b $ do+        mp <- case v of+          U.ValueNil       -> pure []+          U.ValueLambda mp -> pure $ toList mp+          _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing+        _ :/ instr <-+          withWTP @it uvalue $ throwingTCError $+            typeCheckImpl tcDo mp ((starNotes @it, Dict, def) ::& SNil)+        case instr of+          lam ::: (lo :: HST lo) -> withWTP @ot uvalue $ do+            case eqHST1 @ot lo of+              Right Refl -> do+                pure $ VLam (T.RfNormal lam)+              Left m ->+                tcFailedOnValue v (demote @ty)+                        "wrong output type of lambda's value:" (Just m)+          AnyOutInstr lam ->+            pure $ VLam (T.RfAlwaysFails lam)++      (v, t) -> tcFailedOnValue v (fromSing t) "unknown value" Nothing++    seqToRightCombedPair :: (NonEmpty $ U.Value) -> U.Value+    seqToRightCombedPair (x :| [y]) = U.ValuePair x y+    seqToRightCombedPair (x :| xs) = U.ValuePair x $ seqToRightCombedPair (NE.fromList xs)++    -- Converts a lambda containing only empty 'SeqEx's (possibly nested)+    -- to a list of empty lists.+    emptyLambdaAsList :: NonEmpty U.ExpandedOp -> Maybe U.Value+    emptyLambdaAsList ops =+      let+        opToMaybeList :: U.ExpandedOp -> Maybe U.Value+        opToMaybeList = \case+          U.SeqEx []      -> Just U.ValueNil+          U.SeqEx xs      -> U.ValueSeq . NE.fromList <$> traverse opToMaybeList xs+          U.PrimEx {}     -> Nothing+          U.WithSrcEx _ i -> opToMaybeList i+      in+        U.ValueSeq <$> traverse opToMaybeList ops++    -- Converts a list containing only empty lists (possibly nested)+    -- to a lambda of empty 'SeqEx's.+    emptyListAsLambda :: NonEmpty U.Value -> Maybe U.Value+    emptyListAsLambda ops =+      let+        listToMaybeOp :: U.Value -> Maybe U.ExpandedOp+        listToMaybeOp = \case+          U.ValueNil      -> Just $ U.SeqEx []+          U.ValueSeq xs   -> U.SeqEx . toList <$> traverse listToMaybeOp xs+          _               -> Nothing+      in+        U.ValueLambda <$> traverse listToMaybeOp ops++    withWTP+      :: forall t a. SingI t+      => U.Value+      -> (T.WellTyped t => TypeCheckInstr a)+      -> TypeCheckInstr a+    withWTP uvalue fn = case getWTP @t of+      Right Dict -> fn+      Left (NotWellTyped t cause) -> tcFailedOnValue uvalue (demote @ty)+                  ("Value is not well typed: '" <> show t <> "' because it " <> pretty cause) Nothing++    typeCheckValsImpl+      :: ([U.Value], Sing t)+      -> TypeCheckInstr [T.Value t]+    typeCheckValsImpl (mvs, sng) =+      fmap reverse $ foldM (\res mv -> (: res) <$> (doTypeCheckVal (mv, sng))) [] mvs++    -- Typechecks given list of @Elt@s and ensures that its keys are in ascending order.+    --+    -- It return list of pairs (key, value) with keys in ascending order+    -- so it is safe to call @fromDistinctAscList@ on returned list+    typeCheckMapVal+      :: [U.Elt U.ExpandedOp]+      -> U.Value+      -> Sing kt+      -> Sing vt+      -> TypeCheckInstr [(T.Value kt, T.Value vt)]+    typeCheckMapVal mels sq kt vt = withComparable kt sq kt $ do+      instrPos <- ask+      ks <- typeCheckValsImpl (map (\(U.Elt k _) -> k) mels, kt)+      vals <- typeCheckValsImpl (map (\(U.Elt _ v) -> v) mels, vt)+      ksS <- liftEither $ ensureDistinctAsc id ks+            `onFirst` \msg -> TCFailedOnValue sq (fromSing kt) msg instrPos Nothing+      pure $ zip ksS vals++    typecheckContractValue+      :: forall cp tz. (tz ~ 'T.TContract cp)+      => U.Value -> EpAddress -> Sing cp -> TypeCheckInstr (T.Value tz)+    typecheckContractValue cv (EpAddress addr epName) pc = do++      instrPos <- ask+      let ensureTypeMatches :: forall t'. SingI t' => TypeCheckInstr (cp :~: t')+          ensureTypeMatches = liftEither @_ @TypeCheckInstr $+            first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $+              (withSingI pc $ eqType @cp @t')+      let unsupportedType :: T.BadTypeForScope -> TCError+          unsupportedType reason = TCFailedOnValue cv (fromSing pc)+            "Unsupported type in type argument of 'contract' type" instrPos $+              Just $ UnsupportedTypeForScope (fromSing pc) reason+      case addr of+        KeyAddress _ -> do+          Refl <- ensureTypeMatches @'T.TUnit+          pure $ VContract addr T.sepcPrimitive+        ContractAddress ca -> case mOriginatedContracts of+          Nothing -> liftEither . Left $ unsupportedType T.BtHasContract+          Just originatedContracts -> case M.lookup ca originatedContracts of+            Just (SomeParamType (_ :: Sing cp') paramNotes) ->+              case T.mkEntrypointCall epName paramNotes of+                Nothing ->+                  throwError $+                  TCFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $+                  EntrypointNotFound epName+                Just (T.MkEntrypointCallRes (_ :: Notes t') epc) -> do+                  Refl <- ensureTypeMatches @t'+                  pure $ VContract addr (T.SomeEpc epc)+            Nothing ->+              throwError $ TCFailedOnValue cv (demote @ty) "Contract literal unknown"+                instrPos (Just $ UnknownContract addr)++withComparable+  :: forall a (t :: T.T) ty. Sing a+  -> U.Value+  -> Sing t+  -> (T.Comparable a => TypeCheckInstr ty)+  -> TypeCheckInstr ty+withComparable s uv t act = case T.getComparableProofS s of+  Just Dict -> act+  Nothing -> do+    instrPos <- ask+    liftEither . Left $+      TCFailedOnValue uv (fromSing t) "Require a comparable type here" instrPos Nothing++withBigMapAbsence+  :: forall a (t :: T.T) ty. Sing a+  -> U.Value+  -> Sing t+  -> (T.HasNoBigMap a => TypeCheckInstr ty)+  -> TypeCheckInstr ty+withBigMapAbsence s uv t act = case T.bigMapAbsense s of+  Just Dict -> act+  Nothing -> do+    instrPos <- ask+    liftEither . Left $+      TCFailedOnValue uv (fromSing t) "Require a type which doesn't contain `big_map` here"+        instrPos Nothing

+ src/Morley/Michelson/Typed.hs view

@@ -0,0 +1,25 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Typed+  ( module Exports+  ) where++import Morley.Michelson.Typed.Aliases as Exports+import Morley.Michelson.Typed.Annotation as Exports+import Morley.Michelson.Typed.Arith as Exports+import Morley.Michelson.Typed.Convert as Exports+import Morley.Michelson.Typed.Doc as Exports+import Morley.Michelson.Typed.Entrypoints as Exports+import Morley.Michelson.Typed.Existential as Exports+import Morley.Michelson.Typed.Extract as Exports+import Morley.Michelson.Typed.Haskell as Exports+import Morley.Michelson.Typed.Instr as Exports+import Morley.Michelson.Typed.OpSize as Exports+import Morley.Michelson.Typed.Polymorphic as Exports+import Morley.Michelson.Typed.Scope as Exports+import Morley.Michelson.Typed.Sing as Exports+import Morley.Michelson.Typed.T as Exports+import Morley.Michelson.Typed.Util as Exports+import Morley.Michelson.Typed.Value as Exports

+ src/Morley/Michelson/Typed/Aliases.hs view

@@ -0,0 +1,14 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Typed.Aliases+  ( Value+  , Operation+  ) where++import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.Value++type Value = Value' Instr+type Operation = Operation' Instr

+ src/Morley/Michelson/Typed/Annotation.hs view

@@ -0,0 +1,308 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, providing @Notes t@ data type, which holds annotations for a+-- given type @t@.+--+-- Annotation type @Notes t@ is a tree, each leaf is either a star (@*@) or a+-- constructor holding some annotation data for a given type @t@.+-- Star corresponds to the case when given Michelson type contains no+-- annotations.+--+-- This module also provides some+-- utility functions which are used to combine two annotations trees+-- @a@ and @b@ into a new one @c@ in such a way that @c@ can be obtained from+-- both @a@ and @b@ by replacing some @*@ leaves with type or/and field+-- annotations.++module Morley.Michelson.Typed.Annotation+  ( Notes (..)+  , AnnConvergeError(..)+  , converge+  , convergeAnns+  , convergeDestrAnns+  , insertTypeAnn+  , isStar+  , starNotes+  , notesSing+  , notesT+  ) where++import Data.Singletons (Sing, SingI(..), fromSing)+import Fmt (Buildable(..), (+|), (|+))+import Text.PrettyPrint.Leijen.Text (Doc, (<+>))+import qualified Text.Show++import Morley.Michelson.Printer.Util+  (RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens, printDocS)+import Morley.Michelson.Typed.Sing+import Morley.Michelson.Typed.T (T(..))+import Morley.Michelson.Untyped.Annotation+  (Annotation, FieldAnn, TypeAnn, VarAnn, convergeVarAnns, fullAnnSet, noAnn, singleAnnSet,+  unifyAnn, unifyPairFieldAnn)+import Morley.Util.TH+import Morley.Util.Typeable++-- | Data type, holding annotation data for a given Michelson type @t@.+--+-- Each constructor corresponds to exactly one constructor of 'T'+-- and holds all type and field annotations that can be attributed to a+-- Michelson type corresponding to @t@.+data Notes t where+  NTKey       :: TypeAnn -> Notes 'TKey+  NTUnit      :: TypeAnn -> Notes 'TUnit+  NTSignature :: TypeAnn -> Notes 'TSignature+  NTChainId   :: TypeAnn -> Notes 'TChainId+  NTOption    :: TypeAnn -> Notes t -> Notes ('TOption t)+  NTList      :: TypeAnn -> Notes t -> Notes ('TList t)+  NTSet       :: TypeAnn -> Notes t -> Notes ('TSet t)+  NTOperation :: TypeAnn -> Notes 'TOperation+  NTContract  :: TypeAnn -> Notes t -> Notes ('TContract t)+  NTTicket    :: TypeAnn -> Notes t -> Notes ('TTicket t)+  NTPair      :: TypeAnn -> FieldAnn -> FieldAnn+              -> VarAnn -> VarAnn+              -> Notes p -> Notes q -> Notes ('TPair p q)+  NTOr        :: TypeAnn -> FieldAnn -> FieldAnn+              -> Notes p -> Notes q -> Notes ('TOr p q)+  NTLambda    :: TypeAnn -> Notes p -> Notes q -> Notes ('TLambda p q)+  NTMap       :: TypeAnn -> Notes k -> Notes v -> Notes ('TMap k v)+  NTBigMap    :: TypeAnn -> Notes k -> Notes v -> Notes ('TBigMap k v)+  NTInt       :: TypeAnn -> Notes 'TInt+  NTNat       :: TypeAnn -> Notes 'TNat+  NTString    :: TypeAnn -> Notes 'TString+  NTBytes     :: TypeAnn -> Notes 'TBytes+  NTMutez     :: TypeAnn -> Notes 'TMutez+  NTBool      :: TypeAnn -> Notes 'TBool+  NTKeyHash   :: TypeAnn -> Notes 'TKeyHash+  NTBls12381Fr :: TypeAnn -> Notes 'TBls12381Fr+  NTBls12381G1 :: TypeAnn -> Notes 'TBls12381G1+  NTBls12381G2 :: TypeAnn -> Notes 'TBls12381G2+  NTTimestamp :: TypeAnn -> Notes 'TTimestamp+  NTAddress   :: TypeAnn -> Notes 'TAddress+  NTNever     :: TypeAnn -> Notes 'TNever++deriving stock instance Eq (Notes t)+$(deriveGADTNFData ''Notes)+++instance Show (Notes t) where+  show = printDocS True . renderDoc doesntNeedParens++instance Buildable (Notes t) where+  build = buildRenderDoc++instance RenderDoc (Notes t) where+  renderDoc pn n = addParens pn $ case n of+    NTInt ta                -> "NTInt" <+> rendT ta+    NTNat ta                -> "NTNat" <+> rendT ta+    NTString ta             -> "NTString" <+> rendT ta+    NTBytes ta              -> "NTBytes" <+> rendT ta+    NTMutez ta              -> "NTMutez" <+> rendT ta+    NTBool ta               -> "NTBool" <+> rendT ta+    NTKeyHash ta            -> "NTKeyHash" <+> rendT ta+    NTBls12381Fr ta         -> "NTBls12381Fr" <+> rendT ta+    NTBls12381G1 ta         -> "NTBls12381G1" <+> rendT ta+    NTBls12381G2 ta         -> "NTBls12381G2" <+> rendT ta+    NTTimestamp ta          -> "NTTimestamp" <+> rendT ta+    NTAddress ta            -> "NTAddress" <+> rendT ta+    NTKey ta                -> "NTKey" <+> rendT ta+    NTUnit ta               -> "NTUnit" <+> rendT ta+    NTSignature ta          -> "NTSignature" <+> rendT ta+    NTChainId ta            -> "NTChainId" <+> rendT ta+    NTNever ta              -> "NTNever" <+> rendT ta+    NTOption ta nt          -> "NTOption" <+> rendT ta <+> rendN nt+    NTList ta nt            -> "NTList" <+> rendT ta <+> rendN nt+    NTSet ta nt             -> "NTSet" <+> rendT ta <+> rendN nt+    NTOperation ta          -> "NTOperation" <+> rendT ta+    NTContract ta nt        -> "NTContract" <+> rendT ta <+> rendN nt+    NTTicket ta nt          -> "NTTicket" <+> rendT ta <+> rendN nt+    NTPair ta fa1 fa2 va1 va2 np nq -> "NTPair" <+> rendTFV2 ta fa1 fa2 va1 va2 <+> rendN np <+> rendN nq+    NTOr ta fa1 fa2 np nq   -> "NTOr" <+> rendTF2 ta fa1 fa2 <+> rendN np <+> rendN nq+    NTLambda ta np nq       -> "NTLambda" <+> rendT ta <+> rendN np <+> rendN nq+    NTMap ta np nq          -> "NTMap" <+> rendT ta <+> rendN np <+> rendN nq+    NTBigMap ta np nq       -> "NTBigMap" <+> rendT ta <+> rendN np <+> rendN nq+    where+      rendN :: Notes n -> Doc+      rendN = renderDoc needsParens++      rendT :: TypeAnn -> Doc+      rendT = renderDoc doesntNeedParens . singleAnnSet++      rendTF2 :: TypeAnn -> FieldAnn -> FieldAnn -> Doc+      rendTF2 t f1 f2 = renderDoc doesntNeedParens $ fullAnnSet [t] [f1, f2] []++      rendTFV2 :: TypeAnn -> FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> Doc+      rendTFV2 t f1 f2 v1 v2 = renderDoc doesntNeedParens $ fullAnnSet [t] [f1, f2] [v1, v2]++-- | Forget information about annotations, pick singleton with the same type.+--+-- Note: currently we cannot derive 'Sing' from 'Notes' without 'SingI' because+-- for comparable types notes do not remember which exact comparable was used.+notesSing :: SingI t => Notes t -> Sing t+notesSing _ = sing++-- | Get term-level type of notes.+notesT :: SingI t => Notes t -> T+notesT = fromSing . notesSing++-- | In memory of @NStar@ constructor.+--   Generates notes with no annotations.+starNotes :: forall t. SingI t => Notes t+starNotes = starNotes' sing++starNotes' :: Sing t -> Notes t+starNotes' = \case+  STInt -> NTInt noAnn+  STNat -> NTNat noAnn+  STString -> NTString noAnn+  STBytes -> NTBytes noAnn+  STMutez -> NTMutez noAnn+  STBool -> NTBool noAnn+  STKeyHash -> NTKeyHash noAnn+  STBls12381Fr -> NTBls12381Fr noAnn+  STBls12381G1 -> NTBls12381G1 noAnn+  STBls12381G2 -> NTBls12381G2 noAnn+  STTimestamp -> NTTimestamp noAnn+  STAddress -> NTAddress noAnn+  STKey -> NTKey noAnn+  STUnit -> NTUnit noAnn+  STNever -> NTNever noAnn+  STSignature -> NTSignature noAnn+  STChainId -> NTChainId noAnn+  STOperation -> NTOperation noAnn+  STSet t -> NTSet noAnn $ starNotes' t+  STList t -> NTList noAnn $ starNotes' t+  STOption t -> NTOption noAnn $ starNotes' t+  STContract t -> NTContract noAnn $ starNotes' t+  STTicket t -> NTTicket noAnn $ starNotes' t+  STMap t t' -> NTMap noAnn (starNotes' t) (starNotes' t')+  STBigMap t t' -> NTBigMap noAnn (starNotes' t) (starNotes' t')+  STPair t t' ->+    NTPair noAnn noAnn noAnn noAnn noAnn (starNotes' t) (starNotes' t')+  STOr t t' -> NTOr noAnn noAnn noAnn (starNotes' t) (starNotes' t')+  STLambda t t' -> NTLambda noAnn (starNotes' t) (starNotes' t')++-- | Checks if no annotations are present.+isStar :: SingI t => Notes t -> Bool+isStar = (== starNotes)++-- | Combines two annotations trees @a@ and @b@ into a new one @c@+-- in such a way that @c@ can be obtained from both @a@ and @b@ by replacing+-- some empty leaves with type or/and field annotations.+converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t)+converge n1 n2 = case (n1, n2) of+  (NTInt a, NTInt b) -> NTInt <$> convergeAnns a b+  (NTNat a, NTNat b) -> NTNat <$> convergeAnns a b+  (NTString a, NTString b) -> NTString <$> convergeAnns a b+  (NTBytes a, NTBytes b) -> NTBytes <$> convergeAnns a b+  (NTMutez a, NTMutez b) -> NTMutez <$> convergeAnns a b+  (NTBool a, NTBool b) -> NTBool <$> convergeAnns a b+  (NTKeyHash a, NTKeyHash b) -> NTKeyHash <$> convergeAnns a b+  (NTBls12381Fr a, NTBls12381Fr b) -> NTBls12381Fr <$> convergeAnns a b+  (NTBls12381G1 a, NTBls12381G1 b) -> NTBls12381G1 <$> convergeAnns a b+  (NTBls12381G2 a, NTBls12381G2 b) -> NTBls12381G2 <$> convergeAnns a b+  (NTTimestamp a, NTTimestamp b) -> NTTimestamp <$> convergeAnns a b+  (NTAddress a, NTAddress b) -> NTAddress <$> convergeAnns a b+  (NTKey a, NTKey b) -> NTKey <$> convergeAnns a b+  (NTUnit a, NTUnit b) -> NTUnit <$> convergeAnns a b+  (NTNever a, NTNever b) -> NTNever <$> convergeAnns a b+  (NTSignature a, NTSignature b) ->+    NTSignature <$> convergeAnns a b+  (NTChainId a, NTChainId b) ->+    NTChainId <$> convergeAnns a b+  (NTOption a n, NTOption b m) ->+    NTOption <$> convergeAnns a b <*> converge n m+  (NTList a n, NTList b m) ->+    NTList <$> convergeAnns a b <*> converge n m+  (NTSet a n, NTSet b m) ->+    NTSet <$> convergeAnns a b <*> converge n m+  (NTOperation a, NTOperation b) ->+    NTOperation <$> convergeAnns a b+  (NTContract a n, NTContract b m) ->+    NTContract <$> convergeAnns a b <*> converge n m+  (NTTicket a n, NTTicket b m) ->+    NTTicket <$> convergeAnns a b <*> converge n m+  (NTPair a pF qF pV qV pN qN, NTPair b pG qG pW qW pM qM) ->+    NTPair <$> convergeAnns a b+           <*> convergeAnns pF pG <*> convergeAnns qF qG+           <*> pure (convergeVarAnns pV pW) <*> pure (convergeVarAnns qV qW)+           <*> converge pN pM <*> converge qN qM+  (NTOr a pF qF pN qN, NTOr b pG qG pM qM) ->+    NTOr <$> convergeAnns a b <*> convergeAnns pF pG <*> convergeAnns qF qG+         <*> converge pN pM <*> converge qN qM+  (NTLambda a pN qN, NTLambda b pM qM) ->+    NTLambda <$> convergeAnns a b <*> converge pN pM <*> converge qN qM+  (NTMap a kN vN, NTMap b kM vM) ->+    NTMap <$> convergeAnns a b <*> converge kN kM <*> converge vN vM+  (NTBigMap a kN vN, NTBigMap b kM vM) ->+    NTBigMap <$> convergeAnns a b <*> converge kN kM <*> converge vN vM++-- | Insert the provided type annotation into the provided notes.+insertTypeAnn :: forall (b :: T). TypeAnn -> Notes b -> Notes b+insertTypeAnn nt s = case s of+  NTInt _ -> NTInt nt+  NTNat _ -> NTNat nt+  NTString _ -> NTString nt+  NTBytes _ -> NTBytes nt+  NTMutez _ -> NTMutez nt+  NTBool _ -> NTBool nt+  NTKeyHash _ -> NTKeyHash nt+  NTBls12381Fr _ -> NTBls12381Fr nt+  NTBls12381G1 _ -> NTBls12381G1 nt+  NTBls12381G2 _ -> NTBls12381G2 nt+  NTTimestamp _ -> NTTimestamp nt+  NTAddress _ -> NTAddress nt+  NTKey _ -> NTKey nt+  NTUnit _ -> NTUnit nt+  NTSignature _ -> NTSignature nt+  NTOption _ n1  -> NTOption nt n1+  NTList _ n1 -> NTList nt n1+  NTSet _ n1 -> NTSet nt n1+  NTOperation _ -> NTOperation nt+  NTContract _ n1 -> NTContract nt n1+  NTTicket _ n1 -> NTTicket nt n1+  NTPair _ n1 n2 n3 n4 n5 n6 -> NTPair nt n1 n2 n3 n4 n5 n6+  NTOr _ n1 n2 n3 n4 -> NTOr nt n1 n2 n3 n4+  NTLambda _ n1 n2 -> NTLambda nt n1 n2+  NTMap _ n1 n2 -> NTMap nt n1 n2+  NTBigMap _ n1 n2 -> NTBigMap nt n1 n2+  NTChainId _ -> NTChainId nt+  NTNever _ -> NTNever nt++data AnnConvergeError where+  AnnConvergeError+    :: forall (tag :: Type).+       (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)+    => Annotation tag -> Annotation tag -> AnnConvergeError++deriving stock instance Show AnnConvergeError++instance Eq AnnConvergeError where+  AnnConvergeError ann1 ann2 == AnnConvergeError ann1' ann2' =+    (ann1 `eqParam1` ann1') && (ann2 `eqParam1` ann2')++instance Buildable AnnConvergeError where+  build (AnnConvergeError ann1 ann2) =+    "Annotations do not converge: " +| ann1 |+ " /= " +| ann2 |+ ""++convergeAnnsImpl+  :: forall (tag :: Type).+     (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)+  => (Annotation tag -> Annotation tag -> Maybe (Annotation tag))+  -> Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)+convergeAnnsImpl unify a b = maybe (Left $ AnnConvergeError a b) pure $ unify a b++-- | Converge two type or field notes (which may be wildcards).+convergeAnns+  :: forall (tag :: Type).+     (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)+  => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)+convergeAnns = convergeAnnsImpl unifyAnn++-- | Converge two field notes in CAR, CDR or UNPAIR, given that one of them may be a+-- special annotation.+convergeDestrAnns :: FieldAnn -> FieldAnn -> Either AnnConvergeError FieldAnn+convergeDestrAnns = convergeAnnsImpl unifyPairFieldAnn++$(deriveGADTNFData ''AnnConvergeError)

+ src/Morley/Michelson/Typed/Arith.hs view

@@ -0,0 +1,499 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, containing some boilerplate for support of+-- arithmetic operations in Michelson language.++module Morley.Michelson.Typed.Arith+  ( ArithOp (..)+  , UnaryArithOp (..)+  , ToIntArithOp (..)+  , ArithError (..)+  , ShiftArithErrorType (..)+  , MutezArithErrorType (..)+  , Add+  , Sub+  , Mul+  , EDiv+  , Abs+  , Neg+  , Or+  , And+  , Xor+  , Not+  , Lsl+  , Lsr+  , Compare+  , Eq'+  , Neq+  , Lt+  , Gt+  , Le+  , Ge+  , compareOp++  -- * Misc+  , Bls12381MulBadOrder+  ) where++import Data.Bits (complement, shift, (.&.), (.|.))+import Data.Constraint (Dict(..))+import Fmt (Buildable(build))+import qualified Unsafe (fromIntegral)++import Morley.Michelson.Typed.Annotation+  (AnnConvergeError, Notes(..), converge, convergeAnns, starNotes)+import Morley.Michelson.Typed.Polymorphic+import Morley.Michelson.Typed.T (T(..))+import Morley.Michelson.Typed.Value (Comparable, Value'(..))+import Morley.Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds)+import qualified Morley.Tezos.Crypto.BLS12381 as BLS+import Morley.Util.TypeLits++-- | Class for binary arithmetic operation.+--+-- Takes binary operation marker as @op@ parameter,+-- types of left operand @n@ and right operand @m@.+--+-- 'Typeable' constraints in superclass are necessary for error messages.+class (Typeable n, Typeable m) =>+      ArithOp aop (n :: T) (m :: T) where++  -- | Type family @ArithRes@ denotes the type resulting from+  -- computing operation @op@ from operands of types @n@ and @m@.+  --+  -- For instance, adding integer to natural produces integer,+  -- which is reflected in following instance of type family:+  -- @ArithRes Add CNat CInt = CInt@.+  type ArithRes aop n m :: T++  -- | Converge the notes of given operands.+  convergeArith+    :: proxy aop+    -> Notes n+    -> Notes m+    -> Either AnnConvergeError (Notes (ArithRes aop n m))++  -- | Evaluate arithmetic operation on given operands.+  evalOp+    :: proxy aop+    -> Value' instr n+    -> Value' instr m+    -> Either (ArithError (Value' instr n) (Value' instr m)) (Value' instr (ArithRes aop n m))++  -- | An operation can marked as commutative, it does not affect its+  -- runtime behavior, but enables certain optimization in the optimizer.+  -- We conservatively consider operations non-commutative by default.+  --+  -- Note that there is one unusual case: @AND@ works with @int : nat@+  -- but not with @nat : int@. That's how it's specified in Michelson.+  commutativityProof :: Maybe $ Dict (ArithRes aop n m ~ ArithRes aop m n, ArithOp aop m n)+  commutativityProof = Nothing++-- | Denotes the error type occurred in the arithmetic shift operation.+data ShiftArithErrorType+  = LslOverflow+  | LsrUnderflow+  deriving stock (Show, Eq, Ord, Generic)++instance NFData ShiftArithErrorType++-- | Denotes the error type occurred in the arithmetic operation involving mutez.+data MutezArithErrorType+  = AddOverflow+  | MulOverflow+  | SubUnderflow+  deriving stock (Show, Eq, Ord, Generic)++instance NFData MutezArithErrorType++-- | Represents an arithmetic error of the operation.+data ArithError n m+  = MutezArithError MutezArithErrorType n m+  | ShiftArithError ShiftArithErrorType n m+  deriving stock (Show, Eq, Ord, Generic)++instance (NFData n, NFData m) => NFData (ArithError n m)++-- | Class for unary arithmetic operation.+class UnaryArithOp aop (n :: T) where+  type UnaryArithRes aop n :: T+  evalUnaryArithOp :: proxy aop -> Value' instr n -> Value' instr (UnaryArithRes aop n)++-- | Class for conversions to an integer value.+class ToIntArithOp (n :: T) where+  evalToIntOp :: Value' instr n -> Value' instr 'TInt++data Add+data Sub+data Mul+data EDiv+data Abs+data Neg++data Or+data And+data Xor+data Not+data Lsl+data Lsr++data Compare+data Eq'+data Neq+data Lt+data Gt+data Le+data Ge++-- For implementation hints see the reference implementation:+-- (note that you may need to change the branch)+-- https://gitlab.com/metastatedev/tezos/blob/master/src/proto_alpha/lib_protocol/script_ir_translator.ml#L4601++instance ArithOp Add 'TNat 'TInt where+  type ArithRes Add 'TNat 'TInt = 'TInt+  convergeArith _ _ n2 = Right n2+  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i + j)+  commutativityProof = Just Dict+instance ArithOp Add 'TInt 'TNat where+  type ArithRes Add 'TInt 'TNat = 'TInt+  convergeArith _ n1 _ = Right n1+  evalOp _ (VInt i) (VNat j) = Right $ VInt (i + toInteger j)+  commutativityProof = Just Dict+instance ArithOp Add 'TNat 'TNat where+  type ArithRes Add 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i + j)+  commutativityProof = Just Dict+instance ArithOp Add 'TInt 'TInt where+  type ArithRes Add 'TInt 'TInt = 'TInt+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VInt i) (VInt j) = Right $ VInt (i + j)+  commutativityProof = Just Dict+instance ArithOp Add 'TTimestamp 'TInt where+  type ArithRes Add 'TTimestamp 'TInt = 'TTimestamp+  convergeArith _ n1 _ = Right n1+  evalOp _ (VTimestamp i) (VInt j) =+    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i + j+  commutativityProof = Just Dict+instance ArithOp Add 'TInt 'TTimestamp where+  type ArithRes Add 'TInt 'TTimestamp = 'TTimestamp+  convergeArith _ _ n2 = Right n2+  evalOp _ (VInt i) (VTimestamp j) =+    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds j + i+  commutativityProof = Just Dict+instance ArithOp Add 'TMutez 'TMutez where+  type ArithRes Add 'TMutez 'TMutez = 'TMutez+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ n@(VMutez i) m@(VMutez j) = res+    where+      res = maybe (Left $ MutezArithError AddOverflow n m) (Right . VMutez) $ i `addMutez` j+  commutativityProof = Just Dict+instance ArithOp Add 'TBls12381Fr 'TBls12381Fr where+  type ArithRes Add 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBls12381Fr i) (VBls12381Fr j) =+    Right $ VBls12381Fr (BLS.add i j)+  commutativityProof = Just Dict+instance ArithOp Add 'TBls12381G1 'TBls12381G1 where+  type ArithRes Add 'TBls12381G1 'TBls12381G1 = 'TBls12381G1+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBls12381G1 i) (VBls12381G1 j) =+    Right $ VBls12381G1 (BLS.add i j)+  commutativityProof = Just Dict+instance ArithOp Add 'TBls12381G2 'TBls12381G2 where+  type ArithRes Add 'TBls12381G2 'TBls12381G2 = 'TBls12381G2+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBls12381G2 i) (VBls12381G2 j) =+    Right $ VBls12381G2 (BLS.add i j)+  commutativityProof = Just Dict++instance ArithOp Sub 'TNat 'TInt where+  type ArithRes Sub 'TNat 'TInt = 'TInt+  convergeArith _ _ n2 = Right n2+  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i - j)+instance ArithOp Sub 'TInt 'TNat where+  type ArithRes Sub 'TInt 'TNat = 'TInt+  convergeArith _ n1 _ = Right n1+  evalOp _ (VInt i) (VNat j) = Right $ VInt (i - toInteger j)+instance ArithOp Sub 'TNat 'TNat where+  type ArithRes Sub 'TNat 'TNat = 'TInt+  -- | Subtraction between @Nat@ and @Nat@ does not retain annotation.+  convergeArith _ n1 n2 = starNotes <$ converge n1 n2+  evalOp _ (VNat i) (VNat j) = Right $ VInt (toInteger i - toInteger j)+instance ArithOp Sub 'TInt 'TInt where+  type ArithRes Sub 'TInt 'TInt = 'TInt+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VInt i) (VInt j) = Right $ VInt (i - j)+instance ArithOp Sub 'TTimestamp 'TInt where+  type ArithRes Sub 'TTimestamp 'TInt = 'TTimestamp+  convergeArith _ n1 _ = Right n1+  evalOp _ (VTimestamp i) (VInt j) =+    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i - j+instance ArithOp Sub 'TTimestamp 'TTimestamp where+  type ArithRes Sub 'TTimestamp 'TTimestamp = 'TInt+  convergeArith _ (NTTimestamp a) (NTTimestamp b) = NTInt <$> (convergeAnns a b)+  evalOp _ (VTimestamp i) (VTimestamp j) =+    Right $ VInt $ timestampToSeconds i - timestampToSeconds j+instance ArithOp Sub 'TMutez 'TMutez where+  type ArithRes Sub 'TMutez 'TMutez = 'TMutez+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ n@(VMutez i) m@(VMutez j) = res+    where+      res = maybe (Left $ MutezArithError SubUnderflow n m) (Right . VMutez) $ i `subMutez` j++instance ArithOp Mul 'TNat 'TInt where+  type ArithRes Mul 'TNat 'TInt = 'TInt+  convergeArith _ _ n2 = Right n2+  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TInt 'TNat where+  type ArithRes Mul 'TInt 'TNat = 'TInt+  convergeArith _ n1 _ = Right n1+  evalOp _ (VInt i) (VNat j) = Right $ VInt (i * toInteger j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TNat 'TNat where+  type ArithRes Mul 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TInt 'TInt where+  type ArithRes Mul 'TInt 'TInt = 'TInt+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VInt i) (VInt j) = Right $ VInt (i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TNat 'TMutez where+  type ArithRes Mul 'TNat 'TMutez = 'TMutez+  convergeArith _ _ n2 = Right n2+  evalOp _ n@(VNat i) m@(VMutez j) = res+    where+      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ j `mulMutez` i+  commutativityProof = Just Dict+instance ArithOp Mul 'TMutez 'TNat where+  type ArithRes Mul 'TMutez 'TNat = 'TMutez+  convergeArith _ n1 _ = Right n1+  evalOp _ n@(VMutez i) m@(VNat j) = res+    where+      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ i `mulMutez` j+  commutativityProof = Just Dict+instance ArithOp Mul 'TInt 'TBls12381Fr where+  type ArithRes Mul 'TInt 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ (NTInt n1) _ = Right $ (NTBls12381Fr n1)+  evalOp _ (VInt i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegralOverflowing @Integer @BLS.Bls12381Fr i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TNat 'TBls12381Fr where+  type ArithRes Mul 'TNat 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ (NTNat n1) _ = Right (NTBls12381Fr n1)+  evalOp _ (VNat i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegralOverflowing @Natural @BLS.Bls12381Fr i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381Fr 'TInt where+  type ArithRes Mul 'TBls12381Fr 'TInt = 'TBls12381Fr+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381Fr i) (VInt j) = Right $ VBls12381Fr (i * fromIntegralOverflowing @Integer @BLS.Bls12381Fr j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381Fr 'TNat where+  type ArithRes Mul 'TBls12381Fr 'TNat = 'TBls12381Fr+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381Fr i) (VNat j) = Right $ VBls12381Fr (i * fromIntegralOverflowing @Natural @BLS.Bls12381Fr j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381Fr 'TBls12381Fr where+  type ArithRes Mul 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381Fr i) (VBls12381Fr j) = Right $ VBls12381Fr (i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381G1 'TBls12381Fr where+  type ArithRes Mul 'TBls12381G1 'TBls12381Fr = 'TBls12381G1+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381G1 i) (VBls12381Fr j) = Right $ VBls12381G1 (BLS.multiply j i)+  commutativityProof = Nothing+instance ArithOp Mul 'TBls12381G2 'TBls12381Fr where+  type ArithRes Mul 'TBls12381G2 'TBls12381Fr = 'TBls12381G2+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381G2 i) (VBls12381Fr j) = Right $ VBls12381G2 (BLS.multiply j i)+  commutativityProof = Nothing+instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G1 =>+         ArithOp Mul 'TBls12381Fr 'TBls12381G1 where+  type ArithRes Mul 'TBls12381Fr 'TBls12381G1 = 'TBls12381G1+  convergeArith = error "impossible"+  evalOp = error "impossible"+  commutativityProof = error "impossible"+instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G2 =>+         ArithOp Mul 'TBls12381Fr 'TBls12381G2 where+  type ArithRes Mul 'TBls12381Fr 'TBls12381G2 = 'TBls12381G2+  convergeArith = error "impossible"+  evalOp = error "impossible"+  commutativityProof = error "impossible"++instance ArithOp EDiv 'TNat 'TInt where+  type ArithRes EDiv 'TNat 'TInt = 'TOption ('TPair (EDivOpRes 'TNat 'TInt) (EModOpRes 'TNat 'TInt))+  convergeArith _ n1 n2 = convergeEDiv n1 n2+  evalOp _ i j = Right $ evalEDivOp i j+instance ArithOp EDiv 'TInt 'TNat where+  type ArithRes EDiv 'TInt 'TNat = 'TOption ('TPair (EDivOpRes 'TInt 'TNat) (EModOpRes 'TInt 'TNat))+  convergeArith _ n1 n2 = convergeEDiv n1 n2+  evalOp _ i j = Right $ evalEDivOp i j+instance ArithOp EDiv 'TNat 'TNat where+  type ArithRes EDiv 'TNat 'TNat = 'TOption ('TPair (EDivOpRes 'TNat 'TNat) (EModOpRes 'TNat 'TNat))+  convergeArith _ n1 n2 = convergeEDiv n1 n2+  evalOp _ i j = Right $ evalEDivOp i j+instance ArithOp EDiv 'TInt 'TInt where+  type ArithRes EDiv 'TInt 'TInt = 'TOption ('TPair (EDivOpRes 'TInt 'TInt) (EModOpRes 'TInt 'TInt))+  convergeArith _ n1 n2 = convergeEDiv n1 n2+  evalOp _ i j = Right $ evalEDivOp i j+instance ArithOp EDiv 'TMutez 'TMutez where+  type ArithRes EDiv 'TMutez 'TMutez = 'TOption ('TPair (EDivOpRes 'TMutez 'TMutez) (EModOpRes 'TMutez 'TMutez))+  convergeArith _ n1 n2 = convergeEDiv n1 n2+  evalOp _ i j = Right $ evalEDivOp i j+instance ArithOp EDiv 'TMutez 'TNat where+  type ArithRes EDiv 'TMutez 'TNat = 'TOption ('TPair (EDivOpRes 'TMutez 'TNat) (EModOpRes 'TMutez 'TNat))+  convergeArith _ n1 n2 = convergeEDiv n1 n2+  evalOp _ i j = Right $ evalEDivOp i j++type family Bls12381MulBadOrder a1 a2 where+  Bls12381MulBadOrder a1 a2 = TypeError+    ('Text "Multiplication of "+       ':<>: 'ShowType a2 ':<>: 'Text " and "+       ':<>: 'ShowType a1 ':<>: 'Text " works only other way around"+    )++instance UnaryArithOp Abs 'TInt where+  type UnaryArithRes Abs 'TInt = 'TNat+  evalUnaryArithOp _ (VInt i) = VNat (fromInteger $ abs i)++instance UnaryArithOp Neg 'TInt where+  type UnaryArithRes Neg 'TInt = 'TInt+  evalUnaryArithOp _ (VInt i) = VInt (-i)+instance UnaryArithOp Neg 'TNat where+  type UnaryArithRes Neg 'TNat = 'TInt+  evalUnaryArithOp _ (VNat i) = VInt (- fromIntegral i)+instance UnaryArithOp Neg 'TBls12381Fr where+  type UnaryArithRes Neg 'TBls12381Fr = 'TBls12381Fr+  evalUnaryArithOp _ (VBls12381Fr i) = VBls12381Fr (BLS.negate i)+instance UnaryArithOp Neg 'TBls12381G1 where+  type UnaryArithRes Neg 'TBls12381G1 = 'TBls12381G1+  evalUnaryArithOp _ (VBls12381G1 i) = VBls12381G1 (BLS.negate i)+instance UnaryArithOp Neg 'TBls12381G2 where+  type UnaryArithRes Neg 'TBls12381G2 = 'TBls12381G2+  evalUnaryArithOp _ (VBls12381G2 i) = VBls12381G2 (BLS.negate i)++instance ArithOp Or 'TNat 'TNat where+  type ArithRes Or 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i .|. j)+  commutativityProof = Just Dict+instance ArithOp Or 'TBool 'TBool where+  type ArithRes Or 'TBool 'TBool = 'TBool+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBool i) (VBool j) = Right $ VBool (i .|. j)+  commutativityProof = Just Dict++instance ArithOp And 'TInt 'TNat where+  type ArithRes And 'TInt 'TNat = 'TNat+  convergeArith _ _ n2 = Right n2+  evalOp _ (VInt i) (VNat j) = Right $ VNat (fromInteger (i .&. toInteger j))+instance ArithOp And 'TNat 'TNat where+  type ArithRes And 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i .&. j)+  commutativityProof = Just Dict+instance ArithOp And 'TBool 'TBool where+  type ArithRes And 'TBool 'TBool = 'TBool+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBool i) (VBool j) = Right $ VBool (i .&. j)+  commutativityProof = Just Dict++instance ArithOp Xor 'TNat 'TNat where+  type ArithRes Xor 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i `xor` j)+  commutativityProof = Just Dict+instance ArithOp Xor 'TBool 'TBool where+  type ArithRes Xor 'TBool 'TBool = 'TBool+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBool i) (VBool j) = Right $ VBool (i `xor` j)+  commutativityProof = Just Dict++instance ArithOp Lsl 'TNat 'TNat where+  type ArithRes Lsl 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ n@(VNat i) m@(VNat j) =+    if j > 256+    then Left $ ShiftArithError LslOverflow n m+    else Right $ VNat (fromInteger $ shift (toInteger i) (Unsafe.fromIntegral @Natural @Int j))++instance ArithOp Lsr 'TNat 'TNat where+  type ArithRes Lsr 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ n@(VNat i) m@(VNat j) =+    if j > 256+    then Left $ ShiftArithError LsrUnderflow n m+    else Right $ VNat (fromInteger $ shift (toInteger i) (-(Unsafe.fromIntegral @Natural @Int j)))++instance UnaryArithOp Not 'TInt where+  type UnaryArithRes Not 'TInt = 'TInt+  evalUnaryArithOp _ (VInt i) = VInt (complement i)+instance UnaryArithOp Not 'TNat where+  type UnaryArithRes Not 'TNat = 'TInt+  evalUnaryArithOp _ (VNat i) = VInt (complement $ toInteger i)+instance UnaryArithOp Not 'TBool where+  type UnaryArithRes Not 'TBool = 'TBool+  evalUnaryArithOp _ (VBool i) = VBool (not i)++-- | Implementation for @COMPARE@ instruction.+compareOp :: Comparable t => Value' i t -> Value' i t -> Integer+compareOp a b =+  -- If at some point we need to return a number outside of [-1; 1] range,+  -- let's extend 'tcompare' respectively and use it here.+  -- Such situation seems unlikely to happen though, our previous communication+  -- with the Tezos developers shows that even if in Tezos 'COMPARE' returns+  -- something unusual, that is probably a bug.+  toInteger $ fromEnum (compare a b) - 1++instance UnaryArithOp Eq' 'TInt where+  type UnaryArithRes Eq' 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i == 0)++instance UnaryArithOp Neq 'TInt where+  type UnaryArithRes Neq 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i /= 0)+++instance UnaryArithOp Lt 'TInt where+  type UnaryArithRes Lt 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i < 0)++instance UnaryArithOp Gt 'TInt where+  type UnaryArithRes Gt 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i > 0)++instance UnaryArithOp Le 'TInt where+  type UnaryArithRes Le 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i <= 0)++instance UnaryArithOp Ge 'TInt where+  type UnaryArithRes Ge 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i >= 0)++instance ToIntArithOp 'TNat where+  evalToIntOp (VNat i) = VInt (toInteger i)++instance ToIntArithOp 'TBls12381Fr where+  evalToIntOp (VBls12381Fr i) = VInt (toInteger i)++instance Buildable ShiftArithErrorType where+  build = \case+    LslOverflow -> "lsl overflow"+    LsrUnderflow -> "lsr underflow"++instance Buildable MutezArithErrorType where+  build = \case+    AddOverflow -> "add overflow"+    MulOverflow -> "mul overflow"+    SubUnderflow -> "sub underflow"++instance (Show n, Show m) => Buildable (ArithError n m) where+  build (MutezArithError errType n m) = "Mutez "+    <> build errType <> " with " <> show n <> ", " <> show m+  build (ShiftArithError errType n m) =+    build errType <> " with " <> show n <> ", " <> show m

+ src/Morley/Michelson/Typed/Convert.hs view

@@ -0,0 +1,939 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Morley.Michelson.Typed.Convert+  ( convertParamNotes+  , convertContractCode+  , convertContract+  , instrToOps+  , instrToOpsOptimized+  , untypeDemoteT+  , untypeValue+  , untypeValueHashable+  , untypeValueOptimized++  -- Helper for generating documentation+  , sampleTypedValue++  -- * Misc+  , flattenEntrypoints+  ) where++import qualified Data.ByteArray as ByteArray+import Data.Constraint (Dict(..), (\\))+import Data.List.NonEmpty ((<|))+import qualified Data.Map as Map+import Data.Singletons (Sing, demote, withSingI)+import Data.Vinyl (Rec(..))+import Fmt (Buildable(..), Builder, blockListF, fmt, indentF, listF, pretty, unlinesF)+import Text.PrettyPrint.Leijen.Text (Doc)+import qualified Unsafe (fromIntegral)++import Morley.Michelson.Printer.Util+import Morley.Michelson.Text+import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Annotation (Notes(..))+import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Extract (mkUType, mkUType', toUType)+import Morley.Michelson.Typed.Instr as Instr+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.Sing (SingT(..))+import Morley.Michelson.Typed.T (T(..))+import Morley.Michelson.Typed.Value+import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped.Annotation (Annotation(unAnnotation))+import Morley.Tezos.Address (Address(..), ContractHash(..))+import Morley.Tezos.Core+  (ChainId(unChainId), mformatChainId, parseChainId, timestampFromSeconds, timestampToSeconds,+  toMutez, unMutez)+import Morley.Tezos.Crypto+import qualified Morley.Tezos.Crypto.BLS12381 as BLS+import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519+import qualified Morley.Tezos.Crypto.P256 as P256+import qualified Morley.Tezos.Crypto.Secp256k1 as Secp256k1+import Morley.Util.PeanoNatural (fromPeanoNatural)+import Morley.Util.Sing (eqParamSing)++-- | Convert typed parameter annotations to an untyped 'U.ParameterType'.+convertParamNotes :: SingI cp => ParamNotes cp -> U.ParameterType+convertParamNotes (ParamNotes notes rootAnn) =+  U.ParameterType (mkUType notes) rootAnn++-- | Convert typed 'ContractCode' to an untyped t'U.Contract'.+convertContractCode+  :: forall param store . (SingI param, SingI store)+  => ContractCode param store -> U.Contract+convertContractCode contract =+  U.Contract+    { contractParameter = U.ParameterType (untypeDemoteT @param) U.noAnn+    , contractStorage = untypeDemoteT @store+    , contractCode = instrToOps contract+    , entriesOrder = U.canonicalEntriesOrder+    }++-- | Convert typed 'Contract' to an untyped t'U.Contract'.+convertContract :: Contract param store -> U.Contract+convertContract fc@Contract{} =+  let c = convertContractCode (cCode fc)+  in c { U.contractParameter = convertParamNotes (cParamNotes fc)+       , U.contractStorage = mkUType (cStoreNotes fc)+       , U.entriesOrder = cEntriesOrder fc+       }++-- Note: if you change this type, check 'untypeValueImpl' wildcard patterns.+data UntypingOptions+  = Readable+  -- ^ Convert value to human-readable representation+  | Optimized+  -- ^ Convert value to optimized representation+  | Hashable+  -- ^ Like 'Optimized', but without list notation for pairs.+  -- Created to match 'tezos-client hash data' behavior for typed values.+  -- See https://gitlab.com/morley-framework/morley/-/issues/611+  deriving stock (Eq, Show)++-- | Convert a typed value to an untyped human-readable representation+untypeValue :: HasNoOp t => Value' Instr t -> U.Value+untypeValue = untypeValueImpl' Readable++-- | Like 'untypeValueOptimized', but without list notation for pairs.+--+-- Created to match @tezos-client hash data@ behaviour for typed values.+untypeValueHashable :: HasNoOp t => Value' Instr t -> U.Value+untypeValueHashable = untypeValueImpl' Hashable++-- | Convert a typed value to an untyped optimized representation+untypeValueOptimized :: HasNoOp t => Value' Instr t -> U.Value+untypeValueOptimized = untypeValueImpl' Optimized++untypeValueImpl'+  :: HasNoOp t+  => UntypingOptions+  -> Value' Instr t+  -> U.Value+untypeValueImpl' opts val = untypeValueImpl opts (sing \\ valueTypeSanity val) val++-- | Convert a typed t'Morley.Michelson.Typed.Aliases.Value' to an untyped 'Value'.+--+-- For full isomorphism type of the given t'Morley.Michelson.Typed.Aliases.Value' should not contain+-- 'TOperation' - a compile error will be raised otherwise.+-- You can analyse its presence with 'checkOpPresence' function.+untypeValueImpl+  :: HasNoOp t+  => UntypingOptions+  -> Sing t+  -> Value' Instr t+  -> U.Value+untypeValueImpl opts sng val = case (val, sng) of+  (VInt i, _) -> U.ValueInt i+  (VNat i, _) -> U.ValueInt $ toInteger i+  (VString s, _) -> U.ValueString s+  (VBytes b, _) -> U.ValueBytes $ U.InternalByteString b+  (VMutez m, _) -> U.ValueInt $ toInteger $ unMutez m+  (VBool True, _) -> U.ValueTrue+  (VBool False, _) -> U.ValueFalse+  (VKeyHash h, _) ->+    case opts of+      Readable  -> U.ValueString $ mformatKeyHash h+      _         -> U.ValueBytes $ U.InternalByteString $ keyHashToBytes h+  (VBls12381Fr v, _) ->+    case opts of+      Readable  -> U.ValueInt $ toInteger v+      _         -> U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v+  (VBls12381G1 v, _) ->+    U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v+  (VBls12381G2 v, _) ->+    U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v+  (VTimestamp t, _) ->+    case opts of+      Readable   -> U.ValueString . unsafeMkMText $ pretty t+      _          -> U.ValueInt $ timestampToSeconds t+  (VAddress a, _) ->+    case opts of+      Readable  -> U.ValueString $ mformatEpAddress a+      _         -> U.ValueBytes . U.InternalByteString  $ encodeEpAddress a+  (VKey b, _) ->+    case opts of+      Readable  -> U.ValueString $ mformatPublicKey b+      _         -> U.ValueBytes . U.InternalByteString $ keyToBytes b+  (VUnit, _) ->+    U.ValueUnit+  (VSignature b, _) ->+    case opts of+      Readable  -> U.ValueString $ mformatSignature b+      _         -> U.ValueBytes . U.InternalByteString $ signatureToBytes b+  (VChainId b, _) ->+    case opts of+      Readable  -> U.ValueString $ mformatChainId b+      _         ->+        U.ValueBytes . U.InternalByteString $ ByteArray.convert (unChainId b)+  (VOption (Just x), STOption op) ->+    U.ValueSome (untypeValueImpl opts op x)+  (VOption Nothing, STOption _) ->+    U.ValueNone+  (VList l, STList lt) ->+    vList U.ValueSeq $ map (untypeValueImpl opts lt) l+  (VSet s, STSet st) ->+    case checkOpPresence st of+      OpAbsent -> vList U.ValueSeq $ map (untypeValueImpl opts st) $ toList s+  (VContract addr sepc, _) ->+    case opts of+      Readable  ->+        U.ValueString . mformatEpAddress $ EpAddress addr (sepcName sepc)+      _         -> U.ValueBytes . U.InternalByteString . encodeEpAddress $+        EpAddress addr (sepcName sepc)+  (VTicket s v a, STTicket vt) ->+    case valueTypeSanity v of+      Dict ->+        let us = untypeValueImpl opts STAddress $ VAddress (EpAddress s DefEpName)+            uv = untypeValueImpl opts vt v+            ua = untypeValueImpl opts STNat $ VNat a+        in case opts of+          Optimized -> U.ValueSeq $ us :| [uv, ua]+          _         -> U.ValuePair us (U.ValuePair uv ua)+  p@(VPair (l, r), STPair lt rt) ->+    case checkOpPresence lt of+      OpAbsent -> case opts of+        Optimized -> U.ValueSeq $ pairToSeq p+        _         -> U.ValuePair (untypeValueImpl opts lt l) (untypeValueImpl opts rt r)++  (VOr (Left x), STOr lt _) ->+    case checkOpPresence lt of+      OpAbsent -> U.ValueLeft (untypeValueImpl opts lt x)++  (VOr (Right x), STOr lt rt) ->+    case checkOpPresence lt of+      OpAbsent -> U.ValueRight (untypeValueImpl opts rt x)++  (VLam (rfAnyInstr -> ops :: Instr '[inp] '[out]), _) ->+    vList U.ValueLambda $ instrToOpsImpl opts ops++  (VMap m, STMap kt vt) ->+    case (checkOpPresence kt, checkOpPresence vt) of+      (OpAbsent, OpAbsent) ->+        vList U.ValueMap $ Map.toList m <&> \(k, v) ->+        U.Elt (untypeValueImpl opts kt k) (untypeValueImpl opts vt v)++  (VBigMap _ m, STBigMap kt vt) ->+    case (checkOpPresence kt, checkOpPresence vt) of+      (OpAbsent, OpAbsent) ->+        vList U.ValueMap $ Map.toList m <&> \(k, v) ->+        U.Elt (untypeValueImpl opts kt k) (untypeValueImpl opts vt v)+  where+    vList ctor = maybe U.ValueNil ctor . nonEmpty++    pairToSeq :: HasNoOp ty+              => (Value ty, Sing ty)+              -> NonEmpty U.Value+    pairToSeq = \case+      (VPair (a, b), STPair l r) -> case checkOpPresence l of+        OpAbsent -> untypeValueImpl opts l a <| pairToSeq (b, r)+      (v, vt) -> untypeValueImpl opts vt v :| []++    keyHashToBytes :: KeyHash -> ByteString+    keyHashToBytes kh = (<> (khBytes kh)) $+      case khTag kh of+        KeyHashEd25519 -> "\x00"+        KeyHashSecp256k1 -> "\x01"+        KeyHashP256 -> "\x02"++    keyToBytes :: PublicKey -> ByteString+    keyToBytes = \case+      PublicKeyEd25519 pk -> "\x00" <> Ed25519.publicKeyToBytes pk+      PublicKeySecp256k1 pk -> "\x01" <> Secp256k1.publicKeyToBytes pk+      PublicKeyP256 pk -> "\x02" <> P256.publicKeyToBytes pk++    encodeEpAddress :: EpAddress -> ByteString+    encodeEpAddress (EpAddress addr epName) =+      encodeAddress addr <> encodeEpName epName++    encodeAddress :: Address -> ByteString+    encodeAddress = \case+      KeyAddress keyHash ->+        "\x00" <> keyHashToBytes keyHash+      ContractAddress (ContractHash address) ->+        "\x01" <> address <> "\x00"++    encodeEpName :: EpName -> ByteString+    encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn . canonicalize+      where+        canonicalize :: EpName -> EpName+        canonicalize (UnsafeEpName "default") = DefEpName+        canonicalize epName                   = epName++-- | Convert a Haskell type-level type tag into an+-- untyped value representation.+--+-- This function is intended to be used with @TypeApplications@.+untypeDemoteT :: forall (t :: T). SingI t => U.Ty+untypeDemoteT = toUType $ demote @t++-- | Convert Haskell-typed 'Instr' to a list of optimized untyped operations+instrToOpsOptimized :: HasCallStack => Instr inp out -> [U.ExpandedOp]+instrToOpsOptimized = instrToOpsImpl Optimized++-- | Convert Haskell-typed 'Instr' to a list of human-readable untyped operations+instrToOps :: HasCallStack => Instr inp out -> [U.ExpandedOp]+instrToOps = instrToOpsImpl Readable++instrToOpsImpl :: HasCallStack+               => UntypingOptions+               -> Instr inp out+               -> [U.ExpandedOp]+instrToOpsImpl opts = \case+  Nop -> []+  Seq i1 i2 -> instrToOpsImpl opts i1 <> instrToOpsImpl opts i2+  Nested sq -> one $ U.SeqEx $ instrToOps sq+  DocGroup _ sq -> instrToOpsImpl opts sq+  Fn t sfn i -> [U.PrimEx . U.EXT . U.FN t sfn $ instrToOps i]+  Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext+  FrameInstr _ i -> instrToOpsImpl opts i+  -- TODO [#283] After representation of locations is polished,+  -- this place should be updated to pass it from typed to untyped ASTs.+  WithLoc _ i -> instrToOpsImpl opts i+  Meta _ i -> instrToOpsImpl opts i+  InstrWithVarAnns _ i -> instrToOpsImpl opts i+  InstrWithNotes proxy n i -> case i of+    Nop -> instrToOpsImpl opts i+    Seq _ _ -> instrToOpsImpl opts i+    Nested _ -> instrToOpsImpl opts i+    DocGroup _ _ -> instrToOpsImpl opts i+    Ext _ -> instrToOpsImpl opts i+    WithLoc _ i0 -> instrToOpsImpl opts (InstrWithNotes proxy n i0)+    InstrWithNotes {} -> instrToOpsImpl opts i+    -- For inner instruction, filter out values that we don't want to apply+    -- annotations to and delegate it's conversion to this function itself.+    -- If none of the above, convert a single instruction and copy annotations+    -- to it.+    InstrWithVarNotes n0 (InstrWithVarAnns _ i0) ->+      instrToOpsImpl opts $ InstrWithNotes proxy n $ InstrWithVarNotes n0 i0+    InstrWithVarNotes n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n n0]+    InstrWithVarAnns _ _ -> instrToOpsImpl opts i+    _ -> [U.PrimEx $ handleInstrAnnotate i n]+  InstrWithVarNotes n i -> case i of+    Nop -> instrToOpsImpl opts i+    Seq _ _ -> instrToOpsImpl opts i+    Nested _ -> instrToOpsImpl opts i+    DocGroup _ _ -> instrToOpsImpl opts i+    Ext _ -> instrToOpsImpl opts i+    WithLoc _ i0 -> instrToOpsImpl opts (InstrWithVarNotes n i0)+    InstrWithNotes p0 n0 (InstrWithVarAnns _ i0) ->+      instrToOpsImpl opts $ InstrWithNotes p0 n0 $ InstrWithVarNotes n i0+    InstrWithNotes _ n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n0 n]+    InstrWithVarNotes _ _ -> instrToOpsImpl opts i+    InstrWithVarAnns _ i0 -> instrToOpsImpl opts $ InstrWithVarNotes n i0+    _ -> [U.PrimEx $ handleInstrVarNotes i n]+  i -> [U.PrimEx $ handleInstr i]+  where+    handleInstrAnnotateWithVarNotes+      :: forall inp' out' topElems+       . (HasCallStack, Each '[SingI] topElems)+      => Instr inp' out'+      -> Rec Notes topElems+      -> NonEmpty U.VarAnn+      -> U.ExpandedInstr+    handleInstrAnnotateWithVarNotes instr notes varAnns =+      addVarNotes (addInstrNote (handleInstr instr) notes) varAnns++    handleInstrAnnotate+      :: forall inp' out' topElems.+         (HasCallStack, Each '[SingI] topElems)+      => Instr inp' out' -> Rec Notes topElems -> U.ExpandedInstr+    handleInstrAnnotate ins' notes =+      addInstrNote (handleInstr ins') notes++    addInstrNote+      :: forall topElems. (Each '[SingI] topElems, HasCallStack)+      => U.ExpandedInstr -> Rec Notes topElems -> U.ExpandedInstr+    addInstrNote instr notes =+      case (instr, notes) of+        (U.PUSH va _ v, notes' :& _) -> U.PUSH va (mkUType notes') v+        (U.SOME _ va, NTOption ta _ :& _) -> U.SOME ta va+        (U.NONE _ va _, (NTOption ta nt :: Notes t) :& _) ->+          case sing @t of+            STOption t -> U.NONE ta va $ mkUType' (t, nt)+        (U.UNIT _ va, NTUnit ta :& _) -> U.UNIT ta va+        (U.PAIRN va n, _) -> U.PAIRN va n+        (U.LEFT ta va fa1 fa2 _, (NTOr _ _ _ _ n2 :: Notes t) :& _) ->+          case sing @t of+            STOr _ rt ->+              U.LEFT ta va fa1 fa2 $ mkUType' (rt, n2)+        (U.RIGHT ta va fa1 fa2 _, (NTOr _ _ _ n1 _ :: Notes t) :& _) ->+          case sing @t of+            STOr lt _ ->+              U.RIGHT ta va fa1 fa2 $ mkUType' (lt, n1)+        (U.NIL _ va _, (NTList ta n :: Notes t) :& _) ->+          case sing @t of+            STList l -> U.NIL ta va $ mkUType' (l, n)+        (U.EMPTY_SET _ va _, (NTSet ta1 n :: Notes t) :& _) ->+          case sing @t of+            STSet s -> U.EMPTY_SET ta1 va $ mkUType' (s, n)+        (U.EMPTY_MAP _ va _ _, (NTMap ta1 k n :: Notes t) :& _) ->+          case sing @t of+            STMap kt vt -> U.EMPTY_MAP ta1 va (mkUType' (kt, k)) (mkUType' (vt, n))+        (U.EMPTY_BIG_MAP _ va _ _, (NTBigMap ta1 k n :: Notes t) :& _) ->+          case sing @t of+            STBigMap kt vt -> U.EMPTY_BIG_MAP ta1 va (mkUType' (kt, k)) (mkUType' (vt, n))+        (U.LAMBDA va _ _ ops, (NTLambda _ n1 n2 :: Notes t) :& _) ->+          case sing @t of+            STLambda v b -> U.LAMBDA va (mkUType' (v, n1)) (mkUType' (b, n2)) ops+        (U.CAST va _, n :& _) -> U.CAST va (mkUType n)+        (U.UNPACK _ va _, (NTOption ta nt :: Notes t) :& _) ->+          case sing @t of+            STOption op -> U.UNPACK ta va (mkUType' (op, nt))+        (U.CONTRACT va fa _, (NTOption _ (NTContract _ nt :: Notes t) :: Notes t2) :& _) ->+          case sing @t2 of+            STOption (STContract c) -> U.CONTRACT va fa (mkUType' (c, nt))+        (U.CONTRACT va fa t, NTOption _ _ :& _) -> U.CONTRACT va fa t+        (U.CAR {}, _) -> instr+        (U.CDR {}, _) -> instr+        (U.PAIR {}, _) -> instr+        (U.UNPAIR {}, _) -> instr+        (U.APPLY {}, _) -> instr+        (U.CHAIN_ID {}, _) -> instr+        (U.EXT _, _) -> instr+        (U.DROP, _) -> instr+        (U.DROPN _, _) -> instr+        (U.DUP _, _) -> instr+        (U.DUPN _ _, _) -> instr+        (U.SWAP, _) -> instr+        (U.DIG {}, _) -> instr+        (U.DUG {}, _) -> instr+        (U.IF_NONE _ _, _) -> instr+        (U.CONS _, _) -> instr+        (U.IF_LEFT _ _, _) -> instr+        (U.IF_CONS _ _, _) -> instr+        (U.SIZE _, _) -> instr+        (U.MAP _ _, _) -> instr+        (U.ITER _, _) -> instr+        (U.MEM _, _) -> instr+        (U.GET _, _) -> instr+        (U.GETN _ _, _) -> instr+        (U.UPDATE _, _) -> instr+        (U.UPDATEN _ _, _) -> instr+        (U.GET_AND_UPDATE _, _) -> instr+        (U.IF _ _, _) -> instr+        (U.LOOP _, _) -> instr+        (U.LOOP_LEFT _, _) -> instr+        (U.EXEC _, _) -> instr+        (U.DIP _, _) -> instr+        (U.DIPN {}, _) -> instr+        (U.FAILWITH, _) -> instr+        (U.RENAME _, _) -> instr+        (U.PACK _, _) -> instr+        (U.CONCAT _, _) -> instr+        (U.SLICE _, _) -> instr+        (U.ISNAT _, _) -> instr+        (U.ADD _, _) -> instr+        (U.SUB _, _) -> instr+        (U.MUL _, _) -> instr+        (U.EDIV _, _) -> instr+        (U.ABS _, _) -> instr+        (U.NEG _, _) -> instr+        (U.LSL _, _) -> instr+        (U.LSR _, _) -> instr+        (U.OR _, _) -> instr+        (U.AND _, _) -> instr+        (U.XOR _, _) -> instr+        (U.NOT _, _) -> instr+        (U.COMPARE _, _) -> instr+        (U.EQ _, _) -> instr+        (U.NEQ _, _) -> instr+        (U.LT _, _) -> instr+        (U.GT _, _) -> instr+        (U.LE _, _) -> instr+        (U.GE _, _) -> instr+        (U.INT _, _) -> instr+        (U.SELF _ _, _) -> instr+        (U.TRANSFER_TOKENS _, _) -> instr+        (U.SET_DELEGATE _, _) -> instr+        (U.CREATE_CONTRACT {}, _) -> instr+        (U.IMPLICIT_ACCOUNT _, _) -> instr+        (U.NOW _, _) -> instr+        (U.LEVEL _, _) -> instr+        (U.AMOUNT _, _) -> instr+        (U.BALANCE _, _) -> instr+        (U.VOTING_POWER _, _) -> instr+        (U.TOTAL_VOTING_POWER _, _) -> instr+        (U.CHECK_SIGNATURE _, _) -> instr+        (U.SHA256 _, _) -> instr+        (U.SHA512 _, _) -> instr+        (U.BLAKE2B _, _) -> instr+        (U.SHA3 _, _) -> instr+        (U.KECCAK _, _) -> instr+        (U.HASH_KEY _, _) -> instr+        (U.SOURCE _, _) -> instr+        (U.SENDER _, _) -> instr+        (U.ADDRESS _, _) -> instr+        (U.SELF_ADDRESS _, _) -> instr+        (U.NEVER, _) -> instr+        (U.TICKET _, _) -> instr+        (U.READ_TICKET _, _) -> instr+        (U.SPLIT_TICKET _, _) -> instr+        (U.JOIN_TICKETS _, _) -> instr+        _ -> error $ pretty $ unlinesF+          [ "addInstrNote: Unexpected instruction/annotation combination"+          , "Instruction:"+          , indentF 2 $ build instr+          , "Annotations:"+          , indentF 2 $ blockListF $ buildNotes notes+          ]+          where+            buildNotes :: Rec Notes ts -> [Builder]+            buildNotes = \case+              RNil -> []+              n :& ns -> build n : buildNotes ns++    handleInstrVarNotes :: forall inp' out' . HasCallStack+      => Instr inp' out' -> NonEmpty U.VarAnn -> U.ExpandedInstr+    handleInstrVarNotes ins' varAnns =+      let x = handleInstr ins' in addVarNotes x varAnns++    addVarNotes+      :: HasCallStack+      => U.ExpandedInstr -> NonEmpty U.VarAnn -> U.ExpandedInstr+    addVarNotes ins varNotes = case varNotes of+      va1 :| [va2] -> case ins of+        U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va1 va2 c+        _ -> error $+          "addVarNotes: Cannot add two var annotations to instr: " <> show ins+      va :| [] -> case ins of+        U.DUP _ -> U.DUP va+        U.DUPN _ s -> U.DUPN va s+        U.PUSH _ t v -> U.PUSH va t v+        U.SOME ta _ -> U.SOME ta va+        U.NONE ta _ t -> U.NONE ta va t+        U.UNIT ta _ -> U.UNIT ta va+        U.PAIR ta _ fa1 fa2 -> U.PAIR ta va fa1 fa2+        U.PAIRN _ n -> U.PAIRN va n+        U.LEFT ta _ fa1 fa2 t -> U.LEFT ta va fa1 fa2 t+        U.RIGHT ta _ fa1 fa2 t -> U.RIGHT ta va fa1 fa2 t+        U.NIL ta _ t -> U.NIL ta va t+        U.CONS _ -> U.CONS va+        U.SIZE _ -> U.SIZE va+        U.EMPTY_SET ta _ c -> U.EMPTY_SET ta va c+        U.EMPTY_MAP ta _ c t -> U.EMPTY_MAP ta va c t+        U.EMPTY_BIG_MAP ta _ c t -> U.EMPTY_BIG_MAP ta va c t+        U.MAP _ ops -> U.MAP va ops+        U.MEM _ -> U.MEM va+        U.GET _ -> U.GET va+        U.GETN _ n -> U.GETN va n+        U.UPDATE _ -> U.UPDATE va+        U.UPDATEN _ n -> U.UPDATEN va n+        U.GET_AND_UPDATE _ -> U.GET_AND_UPDATE va+        U.LAMBDA _ t1 t2 ops -> U.LAMBDA va t1 t2 ops+        U.EXEC _ -> U.EXEC va+        U.APPLY _ -> U.APPLY va+        U.CAST _ t -> U.CAST va t+        U.RENAME _ -> U.RENAME va+        U.PACK _ -> U.PACK va+        U.UNPACK ta _ t -> U.UNPACK ta va t+        U.CONCAT _ -> U.CONCAT va+        U.SLICE _ -> U.SLICE va+        U.ISNAT _ -> U.ISNAT va+        U.ADD _ -> U.ADD va+        U.SUB _ -> U.SUB va+        U.MUL _ -> U.MUL va+        U.EDIV _ -> U.EDIV va+        U.ABS _ -> U.ABS va+        U.NEG _ -> U.NEG va+        U.LSL _ -> U.LSL va+        U.LSR _ -> U.LSR va+        U.OR _ -> U.OR va+        U.AND _ -> U.AND va+        U.XOR _ -> U.XOR va+        U.NOT _ -> U.NOT va+        U.COMPARE _ -> U.COMPARE va+        U.EQ _ -> U.EQ va+        U.NEQ _ -> U.NEQ va+        U.LT _ -> U.LT va+        U.GT _ -> U.GT va+        U.LE _ -> U.LE va+        U.GE _ -> U.GE va+        U.INT _ -> U.INT va+        U.SELF _ fa -> U.SELF va fa+        U.CONTRACT _ fa t -> U.CONTRACT va fa t+        U.TRANSFER_TOKENS _ -> U.TRANSFER_TOKENS va+        U.SET_DELEGATE _ -> U.SET_DELEGATE va+        U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va U.noAnn c+        U.IMPLICIT_ACCOUNT _ -> U.IMPLICIT_ACCOUNT va+        U.NOW _ -> U.NOW va+        U.AMOUNT _ -> U.AMOUNT va+        U.BALANCE _ -> U.BALANCE va+        U.VOTING_POWER _ -> U.VOTING_POWER va+        U.TOTAL_VOTING_POWER _ -> U.TOTAL_VOTING_POWER va+        U.CHECK_SIGNATURE _ -> U.CHECK_SIGNATURE va+        U.SHA256 _ -> U.SHA256 va+        U.SHA512 _ -> U.SHA512 va+        U.BLAKE2B _ -> U.BLAKE2B va+        U.SHA3 _ -> U.SHA3 va+        U.KECCAK _ -> U.KECCAK va+        U.HASH_KEY _ -> U.HASH_KEY va+        U.SOURCE _ -> U.SOURCE va+        U.SENDER _ -> U.SENDER va+        U.ADDRESS _ -> U.ADDRESS va+        U.CHAIN_ID _ -> U.CHAIN_ID va+        U.LEVEL _ -> U.LEVEL va+        U.SELF_ADDRESS _ -> U.SELF_ADDRESS va+        U.TICKET _ -> U.TICKET va+        U.READ_TICKET _ -> U.READ_TICKET va+        U.SPLIT_TICKET _ -> U.SPLIT_TICKET va+        U.JOIN_TICKETS _ -> U.JOIN_TICKETS va+        _ -> error $+          "addVarNotes: Cannot add single var annotation to instr: " <> (show ins) <> " with " <> show va+      _ -> error $+        "addVarNotes: Trying to add more than two var annotations to instr: " <> (show ins)++    handleInstr :: Instr inp out -> U.ExpandedInstr+    handleInstr = \case+      (WithLoc _ _) -> error "impossible"+      Meta _ _ -> error "impossible"+      InstrWithNotes {} -> error "impossible"+      (InstrWithVarNotes _ _) -> error "impossible"+      (InstrWithVarAnns _ _) -> error "impossible"+      (FrameInstr _ _) -> error "impossible"+      (Seq _ _) -> error "impossible"+      Nop -> error "impossible"+      (Ext _) -> error "impossible"+      (Nested _) -> error "impossible"+      DocGroup{} -> error "impossible"+      Fn t sfn i -> U.EXT . U.FN t sfn $ instrToOpsImpl opts i+      DROP -> U.DROP+      (DROPN s) -> U.DROPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)+      DUP -> U.DUP U.noAnn+      (DUPN s) -> U.DUPN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)+      SWAP -> U.SWAP+      (DIG s) -> U.DIG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)+      (DUG s) -> U.DUG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)+      i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i ->+        let value = untypeValueImpl opts (sing @t) val+        in U.PUSH U.noAnn (untypeDemoteT @t) value+      i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i ->+        U.NONE U.noAnn U.noAnn (untypeDemoteT @a)+      SOME -> U.SOME U.noAnn U.noAnn+      UNIT -> U.UNIT U.noAnn U.noAnn+      (IF_NONE i1 i2) -> U.IF_NONE (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)++      -- `AnnUNPAIR` accepts special var anns, so it carries them inside its constructor,+      -- so we can use them here to re-construct an untyped `U.UNPAIR`.+      -- `AnnPAIR`, on the other hand, doesn't accept special var anns, so the var anns+      -- are carried in the `InstrWithVarNotes` meta-instruction instead.+      --+      -- See: Note [Annotations - Exceptional scenarios] in `Morley.Michelson.Typed.Instr`+      --+      -- TODO [#580]+      AnnPAIR tn fn1 fn2 -> U.PAIR tn U.noAnn fn1 fn2+      AnnUNPAIR vn1 vn2 fn1 fn2 -> U.UNPAIR vn1 vn2 fn1 fn2++      PAIRN n -> U.PAIRN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)+      UNPAIRN n -> U.UNPAIRN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)+      (AnnCAR vn fn) -> U.CAR vn fn+      (AnnCDR vn fn) -> U.CDR vn fn+      i@(AnnLEFT tn fn1 fn2) | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->+        U.LEFT tn U.noAnn fn1 fn2 (untypeDemoteT @b)+      i@(AnnRIGHT tn fn1 fn2) | _ :: Instr (b ': s) ('TOr a b ': s) <- i ->+        U.RIGHT tn U.noAnn fn1 fn2 (untypeDemoteT @a)+      (IF_LEFT i1 i2) -> U.IF_LEFT (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)+      i@NIL | _ :: Instr s ('TList p ': s) <- i ->+        U.NIL U.noAnn U.noAnn (untypeDemoteT @p)+      CONS -> U.CONS U.noAnn+      (IF_CONS i1 i2) -> U.IF_CONS (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)+      SIZE -> U.SIZE U.noAnn+      i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i ->+        U.EMPTY_SET U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @e) U.noAnn)+      i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i ->+        U.EMPTY_MAP U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @a) U.noAnn)+          (untypeDemoteT @b)+      i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i ->+        U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @a) U.noAnn)+          (untypeDemoteT @b)+      (MAP op) -> U.MAP U.noAnn $ instrToOpsImpl opts op+      (ITER op) -> U.ITER $ instrToOpsImpl opts op+      MEM -> U.MEM U.noAnn+      GET -> U.GET U.noAnn+      GETN n -> U.GETN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)+      UPDATE -> U.UPDATE U.noAnn+      UPDATEN n -> U.UPDATEN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)+      GET_AND_UPDATE -> U.GET_AND_UPDATE U.noAnn+      (IF op1 op2) -> U.IF (instrToOpsImpl opts op1) (instrToOpsImpl opts op2)+      (LOOP op) -> U.LOOP (instrToOpsImpl opts op)+      (LOOP_LEFT op) -> U.LOOP_LEFT (instrToOpsImpl opts op)+      i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i ->+        U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOpsImpl opts $ rfAnyInstr l)+      EXEC -> U.EXEC U.noAnn+      APPLY -> U.APPLY U.noAnn+      (DIP op) -> U.DIP (instrToOpsImpl opts op)+      (DIPN s op) ->+        U.DIPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) (instrToOpsImpl opts op)+      FAILWITH -> U.FAILWITH+      i@CAST | _ :: Instr (a ': s) (a ': s) <- i ->+        U.CAST U.noAnn (untypeDemoteT @a)+      RENAME -> U.RENAME U.noAnn+      PACK -> U.PACK U.noAnn+      i@UNPACK+        | _ :: Instr ('TBytes ': s) ('TOption a ': s) <- i ->+            U.UNPACK U.noAnn U.noAnn (untypeDemoteT @a)+      CONCAT -> U.CONCAT U.noAnn+      CONCAT' -> U.CONCAT U.noAnn+      SLICE -> U.SLICE U.noAnn+      ISNAT -> U.ISNAT U.noAnn+      ADD -> U.ADD U.noAnn+      SUB -> U.SUB U.noAnn+      MUL -> U.MUL U.noAnn+      EDIV -> U.EDIV U.noAnn+      ABS -> U.ABS U.noAnn+      NEG -> U.NEG U.noAnn+      LSL -> U.LSL U.noAnn+      LSR -> U.LSR U.noAnn+      OR -> U.OR U.noAnn+      AND -> U.AND U.noAnn+      XOR -> U.XOR U.noAnn+      NOT -> U.NOT U.noAnn+      COMPARE -> U.COMPARE U.noAnn+      Instr.EQ -> U.EQ U.noAnn+      NEQ -> U.NEQ U.noAnn+      Instr.LT -> U.LT U.noAnn+      Instr.GT -> U.GT U.noAnn+      LE -> U.LE U.noAnn+      GE -> U.GE U.noAnn+      INT -> U.INT U.noAnn+      SELF sepc ->+        U.SELF U.noAnn (epNameToRefAnn $ sepcName sepc)+      i@(CONTRACT nt epName)+        | _ :: Instr ('TAddress ': s) ('TOption ('TContract p) ': s) <- i ->+            let fa = epNameToRefAnn epName+            in U.CONTRACT U.noAnn fa (mkUType nt)+      TRANSFER_TOKENS -> U.TRANSFER_TOKENS U.noAnn+      SET_DELEGATE -> U.SET_DELEGATE U.noAnn+      i@(CREATE_CONTRACT contract)+        | _ :: Instr+            (  'TOption ('TKeyHash)+            ': 'TMutez+            ': g+            ': s)+            ('TOperation ': 'TAddress ': s) <- i ->+          U.CREATE_CONTRACT U.noAnn U.noAnn (convertContract contract)+      IMPLICIT_ACCOUNT -> U.IMPLICIT_ACCOUNT U.noAnn+      NOW -> U.NOW U.noAnn+      AMOUNT -> U.AMOUNT U.noAnn+      BALANCE -> U.BALANCE U.noAnn+      VOTING_POWER -> U.VOTING_POWER U.noAnn+      TOTAL_VOTING_POWER -> U.TOTAL_VOTING_POWER U.noAnn+      CHECK_SIGNATURE -> U.CHECK_SIGNATURE U.noAnn+      SHA256 -> U.SHA256 U.noAnn+      SHA512 -> U.SHA512 U.noAnn+      BLAKE2B -> U.BLAKE2B U.noAnn+      SHA3 -> U.SHA3 U.noAnn+      KECCAK -> U.KECCAK U.noAnn+      HASH_KEY -> U.HASH_KEY U.noAnn+      PAIRING_CHECK -> U.PAIRING_CHECK U.noAnn+      SOURCE -> U.SOURCE U.noAnn+      SENDER -> U.SENDER U.noAnn+      ADDRESS -> U.ADDRESS U.noAnn+      CHAIN_ID -> U.CHAIN_ID U.noAnn+      LEVEL -> U.LEVEL U.noAnn+      SELF_ADDRESS -> U.SELF_ADDRESS U.noAnn+      NEVER -> U.NEVER+      TICKET -> U.TICKET U.noAnn+      READ_TICKET -> U.READ_TICKET U.noAnn+      SPLIT_TICKET -> U.SPLIT_TICKET U.noAnn+      JOIN_TICKETS -> U.JOIN_TICKETS U.noAnn++untypeStackRef :: StackRef s -> U.StackRef+untypeStackRef (StackRef n) = U.StackRef (fromPeanoNatural n)++untypePrintComment :: PrintComment s -> U.PrintComment+untypePrintComment (PrintComment pc) = U.PrintComment $ map (second untypeStackRef) pc++extInstrToOps :: ExtInstr s -> [U.ExtInstrAbstract U.ExpandedOp]+extInstrToOps = \case+  PRINT pc -> one $ U.UPRINT (untypePrintComment pc)+  TEST_ASSERT (TestAssert nm pc i) ->+    one $ U.UTEST_ASSERT $+    U.TestAssert nm (untypePrintComment pc) (instrToOps i)+  DOC_ITEM{} -> []+  COMMENT_ITEM tp ->+    case tp of+      FunctionStarts name -> one $ U.UCOMMENT $ name <> " [user func starts]"+      FunctionEnds name -> one $ U.UCOMMENT $ name <> " [user func ends]"+      StatementStarts name -> one $ U.UCOMMENT $ name <> " [user stmt starts]"+      StatementEnds name -> one $ U.UCOMMENT $ name <> " [user stmt ends]"+      JustComment com -> one $ U.UCOMMENT com+      StackTypeComment (Just stack) -> one $ U.UCOMMENT $ pretty (listF stack)+      StackTypeComment Nothing -> one $ U.UCOMMENT $ fmt "any stack type"+  STACKTYPE s -> one $ U.STACKTYPE s++eqInstrExt :: Instr i1 o1 -> Instr i2 o2 -> Bool+eqInstrExt i1 i2 = instrToOps i1 == instrToOps i2++-- It's an orphan instance, but it's better than checking all cases manually.+-- We can also move this convertion to the place where `Instr` is defined,+-- but then there will be a very large module (as we'll have to move a lot of+-- stuff as well).+instance Eq (Instr inp out) where+  (==) = eqInstrExt++instance SingI s => Eq (TestAssert s) where+  TestAssert   name1 pattern1 instr1+    ==+    TestAssert name2 pattern2 instr2+    = and+    [ name1 == name2+    , pattern1 `eqParamSing` pattern2+    , instr1 `eqInstrExt` instr2+    ]++instance HasNoOp t => RenderDoc (Value' Instr t) where+  renderDoc pn = renderDoc pn . untypeValue++instance Buildable (Value' Instr t) where+  build val = printDocB True $ let tv = withValueTypeSanity val sing+    in renderDocSing doesntNeedParens (checkOpPresence tv) (val, tv)++instance Buildable (Instr inp out) where+  build = buildRenderDocExtended++instance RenderDoc (Instr inp out) where+  renderDoc context = renderDocList context . instrToOps++-- | Generate a value used for generating examples in documentation.+--+-- Since not for all types it is possible to produce a sensible example,+-- the result is optional. E.g. for operations, @never@, not proper+-- types like @contract operation@ we return 'Nothing'.+sampleTypedValue :: Sing t -> Maybe (Value t)+sampleTypedValue = \case+    STInt              -> Just $ VInt -1+    STNat              -> Just $ VNat 0+    STString           -> Just $ VString [mt|hello|]+    STMutez            -> Just $ VMutez (toMutez 100)+    STBool             -> Just $ VBool True+    STKey              -> Just $ VKey samplePublicKey+    STKeyHash          -> Just $ VKeyHash $ hashKey samplePublicKey+    STBls12381Fr       -> Just $ VBls12381Fr 1+    STBls12381G1       -> Just $ VBls12381G1 BLS.g1One+    STBls12381G2       -> Just $ VBls12381G2 BLS.g2One+    STTimestamp        -> Just $ VTimestamp $ timestampFromSeconds 1564142952+    STBytes            -> Just $ VBytes "\10"+    STAddress          -> Just $ VAddress $ sampleAddress+    STUnit             -> Just $ VUnit+    STSignature        -> Just $ VSignature $ sampleSignature+    STChainId          -> Just $ VChainId sampleChainId+    STOperation        -> Nothing+    STNever            -> Nothing+    STOption t ->+      withSingI t $ VOption . Just <$> sampleTypedValue t+    STList t ->+      withSingI t $ VList . one <$> sampleTypedValue t+    STSet t -> withSingI t $ do+      Dict <- comparabilityPresence t+      VSet . one <$> sampleTypedValue t+    STContract t -> withSingI t $ do+      Dict <- opAbsense t+      Dict <- nestedBigMapsAbsense t+      pure . VContract (eaAddress sampleAddress) $ SomeEpc unsafeEpcCallRoot+    STTicket t -> withSingI t $ do+      cmpProof <- comparabilityPresence t+      dat <- sampleTypedValue t+      VNat amount <- sampleTypedValue STNat+      case cmpProof of+        Dict -> return $ VTicket (eaAddress sampleAddress) dat amount+    STPair t1 t2 -> withSingI t1 $ withSingI t2 $ do+      val1 <- sampleTypedValue t1+      val2 <- sampleTypedValue t2+      pure $ VPair (val1, val2)+    STOr tl tr -> withSingI tl $ withSingI tr $ asum+      [ VOr . Left <$> sampleTypedValue tl+      , VOr . Right <$> sampleTypedValue tr+      ]+    STMap t1 t2 -> withSingI t1 $ withSingI t2 $ do+      val1 <- sampleTypedValue t1+      val2 <- sampleTypedValue t2+      case checkComparability t1 of+        CanBeCompared -> pure $ VMap $ Map.fromList [(val1, val2)]+        CannotBeCompared -> Nothing+    STBigMap t1 t2 -> withSingI t1 $ withSingI t2 $ do+      val1 <- sampleTypedValue t1+      val2 <- sampleTypedValue t2+      case (checkComparability t1, bigMapAbsense t2) of+        (CanBeCompared, Just Dict) -> pure $ VBigMap Nothing $ Map.fromList [(val1, val2)]+        _                          -> Nothing+    STLambda v (t2 :: Sing t2) -> withSingI v $ withSingI t2 $+      case checkScope @(ConstantScope t2) of+        Right Dict -> do+          val <- sampleTypedValue t2+          pure $ VLam $ RfNormal (DROP `Seq` PUSH val)+        _ -> pure $ VLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH)+    where+      sampleAddress = unsafeParseEpAddress "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"+      samplePublicKey = fromRight (error "impossible") $ parsePublicKey+        "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"+      sampleSignature = fromRight (error "impossible") $ parseSignature+        "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"+      sampleChainId = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t"++-- Misc+----------------------------------------------------------------------------++-- | Flatten a provided list of notes to a map of its entrypoints and its+-- corresponding utype. Please refer to 'U.mkEntrypointsMap' in regards to how+-- duplicate entrypoints are handled.+flattenEntrypoints :: SingI t => ParamNotes t -> Map EpName U.Ty+flattenEntrypoints = U.mkEntrypointsMap . convertParamNotes++-------------------------------------------------------------------------------+-- Rendering helpers+-------------------------------------------------------------------------------++-- | An extended version of renderDoc for typed values that handles VOp+-- accepts explicit singleton+renderDocSing :: RenderContext -> OpPresence t -> (Value' Instr t, Sing t) -> Doc+renderDocSing pn = \case+  OpAbsent -> renderDoc pn . untypeValue . fst+  OpPresent -> \case+    (VOp op, _) -> renderAnyBuildable op+    -- other cases try to mimic instance RenderDoc U.Value, see "Michelson.Untyped.Value"+    (VOption Nothing, _) -> U.renderNone+    (VOption (Just x), STOption tx) -> U.renderSome pn $ \ctx -> renderDocSing ctx OpPresent (x, tx)+    (VList xs, STList txs) -> renderList OpPresent txs xs+    (VSet ss, STSet tss) -> renderList OpPresent tss $ toList ss+    (VTicket s v a, STTicket tv) -> renderDocSing+      needsParens+      OpPresent+      (VPair (VAddress (EpAddress s DefEpName), VPair (v, VNat a))+        , STPair STAddress (STPair tv STNat))+    val@(VPair (_, (VPair (_, _))), _) ->+      U.renderValuesList id $ renderLinearizedRightCombValuePair val+    (VPair (l, r), STPair tl tr) -> U.renderPair pn (render tl l) (render tr r)+    (VOr (Left l), STOr tl _) -> U.renderLeft pn $ render tl l+    (VOr (Right r), STOr _ tr) -> U.renderRight pn $ render tr r+    (VMap m, STMap tk tv) -> renderMap (tk, tv, checkOpPresence tk, checkOpPresence tv) m+    (VBigMap _ m, STBigMap tk tv) -> renderMap (tk, tv, checkOpPresence tk, checkOpPresence tv) m+  where render sg v ctx = renderDocSing ctx (checkOpPresence sg) (v, sg)++renderList :: OpPresence t -> Sing t -> [Value' Instr t] -> Doc+renderList osg sg = renderList' $ renderDocSing doesntNeedParens osg . (, sg)++renderMap :: (Sing tk, Sing tv, OpPresence tk, OpPresence tv)+          -> Map (Value' Instr tk) (Value' Instr tv) -> Doc+renderMap ctx = renderList' (renderElt ctx) . Map.toList++renderList' :: (a -> Doc) -> [a] -> Doc+renderList' f = maybe "{ }" (U.renderValuesList f) . nonEmpty++renderElt :: (Sing tk, Sing tv, OpPresence tk, OpPresence tv)+          -> (Value' Instr tk, Value' Instr tv) -> Doc+renderElt (tk, tv, otk, otv) (k, v) =+  U.renderElt' (render otk k tk) (render otv v tv)+  where render o x tx ctx = renderDocSing ctx o (x, tx)++-- | Mimics U.linearizeRightCombValuePair, but for typed values;+-- however, unlike U.linearizeRightCombValuePair renders values on-the-fly.+renderLinearizedRightCombValuePair :: (Value' Instr t, Sing t) -> NonEmpty Doc+renderLinearizedRightCombValuePair = \case+  (VPair (l, r), STPair tl tr) -> renderDocSing doesntNeedParens (checkOpPresence tl) (l, tl)+                               <| renderLinearizedRightCombValuePair (r, tr)+  val@(_, tv)                  -> renderDocSing doesntNeedParens (checkOpPresence tv) val :| []

+ src/Morley/Michelson/Typed/Doc.hs view

@@ -0,0 +1,157 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Extracting documentation from instructions set.+module Morley.Michelson.Typed.Doc+  ( buildInstrDoc+  , buildInstrDocWithGitRev+  , modifyInstrDoc+  , modifyInstrAllDoc+  , cutInstrNonDoc+  , docInstr+  ) where++import Control.Lens (at)+import Data.Default (def)+import Data.Typeable (cast)+import Prelude hiding (Ordering(..))++import Morley.Michelson.Doc+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.Util++someDefinitionDocItemToContractDoc :: SomeDocDefinitionItem -> State ContractDoc ()+someDefinitionDocItemToContractDoc sdi@(SomeDocDefinitionItem di) =+  modify $ flip mappend+    mempty+    { cdContents = mempty+    , cdDefinitions = docItemToBlock di+    , cdDefinitionsSet = one sdi+    , cdDefinitionIds = one $ case docItemRef di of+        DocItemRef docItemId -> docItemId+    }++someDocItemToContractDoc :: SomeDocItem -> State ContractDoc ()+someDocItemToContractDoc (SomeDocItem di) = do+  () <- case docItemRef di of+    DocItemNoRef ->+      modify (<> mempty{ cdContents = docItemToBlock di })+    DocItemRefInlined{} ->+      modify (<> mempty{ cdContents = docItemToBlock di })+    DocItemRef{} ->+      someDefinitionDocItemToContractDoc (SomeDocDefinitionItem di)+  forM_ @_ @_ @() (docItemDependencies di) $ \(SomeDocDefinitionItem dep) ->+    case docItemRef dep of+      DocItemRef{} -> do+        -- Taking special treatment for possible cyclic dependencies.+        isPresent <- use $ cdDefinitionsSetL . at (SomeDocDefinitionItem dep)+        case isPresent of+          Just () -> pass+          Nothing -> someDocItemToContractDoc (SomeDocItem dep)++-- | Put a document item.+docInstr :: DocItem di => di -> Instr s s+docInstr = Ext . DOC_ITEM . SomeDocItem++-- | Assemble contract documentation with the revision of the contract.+{-# DEPRECATED buildInstrDocWithGitRev+    "Use `buildDoc . attachDocCommons gitRev` instead."+#-}+buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc+buildInstrDocWithGitRev gitRev contract =+  let toc = DToc $ contractDocToToc $ buildInstrDoc contract+      c = pure contract+            >>= attachGitInfo gitRev+            >>= attachToc toc+  in buildDoc c++-- | Assemble contract documentation.+{-# DEPRECATED buildInstrDoc "Use 'buildDoc' instead." #-}+buildInstrDoc :: Instr inp out -> ContractDoc+buildInstrDoc = dfsFoldInstr dfsSettings $ \case+  Ext ext -> case ext of+    DOC_ITEM sdi ->+      execState (someDocItemToContractDoc sdi) mempty+    _ -> mempty+  _ -> mempty+  where+  dfsSettings :: DfsSettings ContractDoc+  dfsSettings = def+    { dsCtorEffectsApp = CtorEffectsApp+        { ceaName = "Building DocGroup"+        , ceaApplyEffects = \resChildren _ -> \case+            i@(DocGroup grouping _) ->+              (i, docGroupContent grouping resChildren)+            i -> (i, resChildren)+        }+    }++-- | Modify all documentation items recursively.+{-# DEPRECATED modifyInstrAllDoc "Use 'modifyDocEntirely' instead." #-}+modifyInstrAllDoc+  :: (SomeDocItem -> SomeDocItem)+  -> Instr inp out+  -> Instr inp out+modifyInstrAllDoc mapper = dfsModifyInstr def $ \case+  Ext ext -> Ext $+    case ext of+      DOC_ITEM sdi -> DOC_ITEM (mapper sdi)+      i -> i+  i -> i++-- | Recursevly traverse an instruction and modify documentation items+-- matching given type.+--+-- If mapper returns 'Nothing', doc item will remain unmodified.+{-# DEPRECATED modifyInstrDoc "Use 'modifyDoc' instead." #-}+modifyInstrDoc+  :: (DocItem i1, DocItem i2)+  => (i1 -> Maybe i2)+  -> Instr inp out+  -> Instr inp out+modifyInstrDoc mapper = modifyInstrAllDoc untypedMapper+  where+  untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do+    di' <- cast di+    newDi <- mapper di'+    return (SomeDocItem newDi)++instance ContainsDoc (Instr inp out) where+  buildDocUnfinalized = buildInstrDoc++instance ContainsUpdateableDoc (Instr inp out) where+  modifyDocEntirely = modifyInstrAllDoc++instance ContainsDoc (Contract cp st) where+  buildDocUnfinalized = buildDocUnfinalized . cCode++instance ContainsUpdateableDoc (Contract cp st) where+  modifyDocEntirely how contract =+    contract{ cCode = modifyInstrAllDoc how (cCode contract) }++-- | Leave only instructions related to documentation.+--+-- Generated documentation for resulting instruction remains the same, but+-- semantics of instruction itself gets lost.+-- We have to pass optimizer here as an argument to avoid cyclic dependencies.+cutInstrNonDoc :: (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr s s+cutInstrNonDoc optimize = optimize . dfsFoldInstr dfsSettings step+  where+  dfsSettings :: DfsSettings (Instr s s)+  dfsSettings = def+    { dsCtorEffectsApp = CtorEffectsApp+        { ceaName = "Wrap into DocGroup"+        , ceaApplyEffects = \resChildren _ -> \case+            i@(DocGroup g _) -> (i, DocGroup g resChildren)+            i -> (i, resChildren)+        }+    }+  step :: Instr inp out -> Instr s s+  step = \case+    Ext ext -> case ext of+      DOC_ITEM di -> Ext $ DOC_ITEM di+      _ -> Nop+    _ -> Nop

+ src/Morley/Michelson/Typed/Entrypoints.hs view

@@ -0,0 +1,500 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities for lightweight entrypoints support.+module Morley.Michelson.Typed.Entrypoints+  ( EpAddress (..)+  , ParseEpAddressError (..)+  , formatEpAddress+  , mformatEpAddress+  , parseEpAddress+  , unsafeParseEpAddress+  , parseEpAddressRaw+  , unsafeParseEpAddressRaw+  , ParamNotes (..)+  , pattern ParamNotes+  , starParamNotes+  , ArmCoord (..)+  , ArmCoords+  , ParamEpError (..)+  , mkParamNotes++  , EpLiftSequence (..)+  , EntrypointCallT (..)+  , epcPrimitive+  , unsafeEpcCallRoot+  , SomeEntrypointCallT (..)+  , unsafeSepcCallRoot+  , sepcPrimitive+  , sepcName+  , ForbidOr+  , MkEntrypointCallRes (..)+  , mkEntrypointCall++  , tyImplicitAccountParam++    -- * Re-exports+  , EpName (..)+  , pattern DefEpName+  , epNameFromParamAnn+  , epNameToParamAnn+  , epNameFromRefAnn+  , epNameToRefAnn+  , EpNameFromRefAnnError (..)+  ) where++import Control.Monad.Except (throwError)+import qualified Data.ByteString as BS+import Data.Constraint (Dict(..))+import qualified Data.List.NonEmpty as NE+import Data.Singletons (withSingI)+import qualified Data.Text as T+import Fmt (Buildable(..), hexF, pretty, (+|), (|+))+import Text.PrettyPrint.Leijen.Text (int, punctuate, squotes, textStrict, (<+>))++import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)+import Morley.Michelson.Text+import Morley.Michelson.Typed.Annotation+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.Sing+import Morley.Michelson.Typed.T+import Morley.Michelson.Untyped.Annotation+import Morley.Michelson.Untyped.Entrypoints+import Morley.Tezos.Address+import Morley.Tezos.Crypto (keyHashLengthBytes)+import Morley.Util.TH+import Morley.Util.TypeLits+import Morley.Util.Typeable++----------------------------------------------------------------------------+-- Primitives+----------------------------------------------------------------------------+--+-- EpAddress+----------------------------------------------------------------------------++-- | Address with optional entrypoint name attached to it.+-- TODO: come up with better name?+data EpAddress = EpAddress+  { eaAddress :: Address+    -- ^ Address itself+  , eaEntrypoint :: EpName+    -- ^ Entrypoint name (might be empty)+  } deriving stock (Show, Eq, Ord, Generic)++instance Buildable EpAddress where+  build = build . formatEpAddress++instance NFData EpAddress++formatEpAddress :: EpAddress -> Text+formatEpAddress (EpAddress addr ep)+  | isDefEpName ep = formatAddress addr+  | otherwise = formatAddress addr <> "%" <> pretty ep++mformatEpAddress :: EpAddress -> MText+mformatEpAddress ea =+  let t = formatEpAddress ea+     -- Should be safe because set of characters allowed in annotations+     -- (and thus in 'EpName') is subset of characters allowed in Michelson strings.+  in unsafeMkMText t++data ParseEpAddressError+  = ParseEpAddressBadAddress ParseAddressError+  | ParseEpAddressRawBadAddress ParseAddressRawError+  | ParseEpAddressBadEntryopint ByteString UnicodeException+  | ParseEpAddressBadRefAnn Text+  | ParseEpAddressRefAnnError EpNameFromRefAnnError+  | ParseEpAddressInvalidLength Int+  deriving stock (Show, Eq, Generic)++instance NFData ParseEpAddressError++instance Buildable ParseEpAddressError where+  build = buildRenderDoc++instance RenderDoc ParseEpAddressError where+  renderDoc context = \case+    ParseEpAddressBadAddress err -> renderDoc context err+    ParseEpAddressRawBadAddress err -> renderDoc context err+    ParseEpAddressBadEntryopint addr exception ->+      "Invalid entrypoint given for raw adddress" <+> (renderAnyBuildable $ hexF addr)<>+      " and failed with" <+> (textStrict (show @Text exception))+    ParseEpAddressBadRefAnn txt -> "Invalid reference annotation:" <+> (textStrict txt)+    ParseEpAddressRefAnnError err -> renderDoc context err+    ParseEpAddressInvalidLength len ->+      "Given raw entrypoint address has invalid length:" <+> int len++-- | Parse an address which can be suffixed with entrypoint name+-- (e.g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU%entrypoint").+parseEpAddress :: Text -> Either ParseEpAddressError EpAddress+parseEpAddress txt =+  let (addrTxt, mannotTxt) = T.breakOn "%" txt+  in case mannotTxt of+    "" -> do+      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt+      return $ EpAddress addr DefEpName+    annotTxt' -> do+      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt+      annot <- first ParseEpAddressBadRefAnn $ case T.stripPrefix "%" annotTxt' of+        Nothing -> error "impossible"+        Just a -> mkAnnotation a+      epName <- first ParseEpAddressRefAnnError $ epNameFromRefAnn annot+      return $ EpAddress addr epName++unsafeParseEpAddress :: HasCallStack => Text -> EpAddress+unsafeParseEpAddress = either (error . pretty) id . parseEpAddress++-- | Parses byte representation of entrypoint address.+--+-- For every address+--+-- @+-- KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo%bar+-- @+--+-- we get the following byte representation+--+-- @+-- 01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f25626172+-- \________________________________________/\/\____/\/\____/+--               address                     %   ep1  % ep2+-- @+--+parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress+parseEpAddressRaw raw = do+  let (bytes, eps) = BS.splitAt (keyHashLengthBytes + 2) raw+  eaAddress <- first ParseEpAddressRawBadAddress $ parseAddressRaw bytes+  decodedEntrypoint <- first (ParseEpAddressBadEntryopint raw) $ decodeUtf8' eps+  decodedAnnotation <- first ParseEpAddressBadRefAnn $ mkAnnotation decodedEntrypoint+  eaEntrypoint <- first ParseEpAddressRefAnnError $ epNameFromRefAnn decodedAnnotation+  pure $ EpAddress {..}++unsafeParseEpAddressRaw :: ByteString -> EpAddress+unsafeParseEpAddressRaw = either (error . pretty) id . parseEpAddressRaw++-- ParamNotes+----------------------------------------------------------------------------++-- | Annotations for contract parameter declaration.+--+-- Following the Michelson specification, this type has the following invariants:+-- 1. No entrypoint name is duplicated.+-- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable.+data ParamNotes (t :: T) = UnsafeParamNotes+  { pnNotes   :: Notes t+  , pnRootAnn :: RootAnn+  } deriving stock (Show, Eq, Generic)+    deriving anyclass (NFData)++pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t+pattern ParamNotes t f <- UnsafeParamNotes t f+{-# COMPLETE ParamNotes #-}++-- | Parameter without annotations.+starParamNotes :: SingI t => ParamNotes t+starParamNotes = UnsafeParamNotes starNotes noAnn++-- | Coordinates of "arm" in Or tree, used solely in error messages.+type ArmCoords = [ArmCoord]+data ArmCoord = AcLeft | AcRight+  deriving stock (Show, Eq, Generic)++instance NFData ArmCoord++instance Buildable ArmCoord where+  build = buildRenderDoc++instance RenderDoc ArmCoord where+  renderDoc _ = \case+    AcLeft -> "left"+    AcRight -> "right"+++-- | Errors specific to parameter type declaration (entrypoints).+data ParamEpError+  = ParamEpDuplicatedNames (NonEmpty EpName)+  | ParamEpUncallableArm ArmCoords+  deriving stock (Show, Eq, Generic)++instance NFData ParamEpError++instance Buildable ParamEpError where+  build = buildRenderDoc++instance RenderDoc ParamEpError where+  renderDoc context = \case+    ParamEpDuplicatedNames names -> mconcat+      [ "Duplicated entrypoint names: "+      , mconcat $ punctuate ", " . map (squotes . renderAnyBuildable) $ toList names+      ]+    ParamEpUncallableArm arm -> mconcat+      [ "Due to presence of 'default' entrypoint, one of contract \"arms\" \+        \cannot be called: \""+      , mconcat . intersperse " - " $ map (renderDoc context) arm+      , "\""+      , if length arm > 1 then " (in top-to-bottom order)" else ""+      ]++-- | Check whether given notes are valid parameter notes.+verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()+verifyParamNotes notes ra = do+  let allEps = appEndo (gatherEntrypoints notes) []+      duplicatedEps+        = mapMaybe (safeHead . tail)+        . NE.group+        . sort+        $ maybe allEps (: allEps) (epNameFromParamAnn ra)++  whenJust (nonEmpty duplicatedEps) $ \dups ->+    throwError $ ParamEpDuplicatedNames dups++  -- In case contract have explicit root entrypoint, we assume that everything is+  -- callable.+  when (ra == noAnn) $ void+    $ first ParamEpUncallableArm+    $ ensureAllCallable notes+  where+    gatherEntrypoints :: Notes t -> Endo [EpName]+    gatherEntrypoints = \case+      NTOr _ fn1 fn2 l r -> mconcat+        [ Endo $ maybe id (:) (epNameFromParamAnn fn1)+        , Endo $ maybe id (:) (epNameFromParamAnn fn2)+        , gatherEntrypoints l+        , gatherEntrypoints r+        ]+      _ -> mempty++    -- Here we can assume that there is no more than one @default@ entrypoint,+    -- because duplications check occurs earlier.+    --+    -- In case when multiple entrypoints are uncallable, the reference+    -- implementation prefers displaying (in error message) arms which are+    -- closer to the root, but here we don't do this because that would be+    -- some more complex to implement and not sure how much does it worth that.+    ensureAllCallable :: Notes t -> Either ArmCoords Bool+    ensureAllCallable = \case+      NTOr _ fnL fnR l r -> do+        let epNameL = epNameFromParamAnn fnL+        let epNameR = epNameFromParamAnn fnR+        haveDefLL <- first (AcLeft  :) $ ensureAllCallable l+        haveDefRR <- first (AcRight :) $ ensureAllCallable r++        let haveDefL = or [haveDefLL, maybe False isDefEpName epNameL]+        let haveDefR = or [haveDefRR, maybe False isDefEpName epNameR]++        when haveDefL $ first (AcRight :) $ checkAllEpsNamed epNameR r+        when haveDefR $ first (AcLeft  :) $ checkAllEpsNamed epNameL l++        return $ or [haveDefL, haveDefR]++      _ -> return False++    checkAllEpsNamed :: Maybe EpName -> Notes t -> Either ArmCoords ()+    checkAllEpsNamed epNameRoot+      | isJust epNameRoot = \_ -> pass+      | otherwise = \case+          NTOr _ fnL fnR l r -> do+            let epNameL = epNameFromParamAnn fnL+                epNameR = epNameFromParamAnn fnR++            first (AcLeft  :) $ checkAllEpsNamed epNameL l+            first (AcRight :) $ checkAllEpsNamed epNameR r++          _ -> throwError []++-- | Construct t'ParamNotes' performing all necessary checks.+mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)+mkParamNotes nt fa = verifyParamNotes nt fa $> UnsafeParamNotes nt fa++----------------------------------------------------------------------------+-- Entrypoint logic+----------------------------------------------------------------------------++-- | Describes how to construct full contract parameter from given entrypoint+-- argument.+--+-- This could be just wrapper over @Value arg -> Value param@, but we cannot+-- use @Value@ type in this module easily.+data EpLiftSequence (arg :: T) (param :: T) where+  EplArgHere :: EpLiftSequence arg arg+  EplWrapLeft+    :: (SingI subparam, SingI r)+    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)+  EplWrapRight+    :: (SingI l, SingI subparam)+    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)++deriving stock instance Eq (EpLiftSequence arg param)+deriving stock instance Show (EpLiftSequence arg param)++$(deriveGADTNFData ''EpLiftSequence)++instance Buildable (EpLiftSequence arg param) where+  build = \case+    EplArgHere -> "×"+    EplWrapLeft es -> "Left (" <> build es <> ")"+    EplWrapRight es -> "Right (" <> build es <> ")"++-- | Reference for calling a specific entrypoint of type @arg@.+data EntrypointCallT (param :: T) (arg :: T) =+  ParameterScope arg => EntrypointCall+  { epcName :: EpName+    -- ^ Name of entrypoint.+  , epcParamProxy :: Proxy param+    -- ^ Proxy of parameter, to make parameter type more easily fetchable.+  , epcLiftSequence :: EpLiftSequence arg param+    -- ^ How to call this entrypoint in the corresponding contract.+  }++deriving stock instance Eq (EntrypointCallT param arg)+deriving stock instance Show (EntrypointCallT param arg)+instance NFData (EntrypointCallT param arg) where+  rnf (EntrypointCall name Proxy s) = rnf (name, s)++instance Buildable (EntrypointCallT param arg) where+  build EntrypointCall{..} =+    "Call " +| epcName |+ ": " +| epcLiftSequence |+ ""++-- | Construct 'EntrypointCallT' which calls no entrypoint and assumes that+-- there is no explicit "default" one.+--+-- Validity of such operation is not ensured.+unsafeEpcCallRoot :: ParameterScope param => EntrypointCallT param param+unsafeEpcCallRoot = EntrypointCall+  { epcName = DefEpName+  , epcParamProxy = Proxy+  , epcLiftSequence = EplArgHere+  }++-- | Call parameter which has no entrypoints, always safe.+epcPrimitive+  :: forall p.+     (ParameterScope p, ForbidOr p)+  => EntrypointCallT p p+epcPrimitive = unsafeEpcCallRoot+  where+  _requireNoOr = Dict @(ForbidOr p)++type family ForbidOr (t :: T) :: Constraint where+  ForbidOr ('TOr l r) =+    TypeError+    ('Text "Cannot apply to sum type parameter " ':<>: 'ShowType ('TOr l r))+  ForbidOr _ = ()++-- | 'EntrypointCallT' with hidden parameter type.+--+-- This requires argument to satisfy 'ParameterScope' constraint.+-- Strictly speaking, entrypoint argument may one day start having different+-- set of constraints comparing to ones applied to parameter, but this seems+-- unlikely.+data SomeEntrypointCallT (arg :: T) =+  forall param. (ParameterScope param) =>+  SomeEpc (EntrypointCallT param arg)++instance Eq (SomeEntrypointCallT arg) where+  SomeEpc epc1 == SomeEpc epc2 = isJust @() $ do+    Refl <- eqP (epcParamProxy epc1) (epcParamProxy epc2)+    guard (epc1 == epc2)++deriving stock instance Show (SomeEntrypointCallT arg)+instance NFData (SomeEntrypointCallT arg) where+  rnf (SomeEpc epc) = rnf epc++instance Buildable (SomeEntrypointCallT arg) where+  build (SomeEpc epc) = build epc++-- | Construct 'SomeEntrypointCallT' which calls no entrypoint and assumes that+-- there is no explicit "default" one.+--+-- Validity of such operation is not ensured.+unsafeSepcCallRoot :: ParameterScope param => SomeEntrypointCallT param+unsafeSepcCallRoot = SomeEpc unsafeEpcCallRoot++-- | Call parameter which has no entrypoints, always safe.+sepcPrimitive+  :: forall t.+     (ParameterScope t, ForbidOr t)+  => SomeEntrypointCallT t+sepcPrimitive = SomeEpc epcPrimitive++sepcName :: SomeEntrypointCallT arg -> EpName+sepcName (SomeEpc epc) = epcName epc++-- | Build 'EpLiftSequence'.+--+-- Here we accept entrypoint name and type information for the parameter+-- of target contract.+--+-- Returns 'Nothing' if entrypoint is not found.+-- Does not treat default entrypoints specially.+withEpLiftSequence+  :: forall param r.+     (ParameterScope param)+  => EpName+  -> Notes param+  -> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r)+  -> Maybe r+withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont =+  case (sing @param, param) of+    (STOr lSing rSing, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->+      withSingI lSing $+      withSingI rSing $+      case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of+        (OpAbsent, NestedBigMapsAbsent) -> asum+          [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)+          , guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere)+          , withEpLiftSequence epName lNotes (cont . fmap @((,) _) EplWrapLeft)+          , withEpLiftSequence epName rNotes (cont . fmap @((,) _) EplWrapRight)+          ]+    _ -> Nothing++-- Helper datatype for 'mkEntrypointCall'.+data MkEntrypointCallRes param where+  MkEntrypointCallRes+    :: ParameterScope arg+    => Notes arg+    -> EntrypointCallT param arg+    -> MkEntrypointCallRes param++-- | Build 'EntrypointCallT'.+--+-- Here we accept entrypoint name and type information for the parameter+-- of target contract.+--+-- Returns 'Nothing' if entrypoint is not found.+mkEntrypointCall+  :: (ParameterScope param)+  => EpName+  -> ParamNotes param+  -> Maybe (MkEntrypointCallRes param)+mkEntrypointCall epName (ParamNotes paramNotes root) =+  asum+  [ do+      epName' <- epNameFromParamAnn root+      guard (epName == epName')+      return $ MkEntrypointCallRes+        paramNotes+        EntrypointCall+          { epcName = epName+          , epcParamProxy = Proxy+          , epcLiftSequence = EplArgHere+          }+  , withEpLiftSequence epName paramNotes $ \(argInfo, liftSeq) ->+      MkEntrypointCallRes argInfo $ EntrypointCall+        { epcName = epName+        , epcParamProxy = Proxy+        , epcLiftSequence = liftSeq+        }+  , guard (isDefEpName epName) $>+      MkEntrypointCallRes paramNotes EntrypointCall+        { epcName = epName+        , epcParamProxy = Proxy+        , epcLiftSequence = EplArgHere+        }+  ]++-- | @parameter@ type of implicit account.+tyImplicitAccountParam :: ParamNotes 'TUnit+tyImplicitAccountParam = UnsafeParamNotes starNotes noAnn

+ src/Morley/Michelson/Typed/Existential.hs view

@@ -0,0 +1,83 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Typed.Existential+  ( SomeConstant (..)+  , SomeConstrainedValue (..)+  , SomeContract (..)+  , SomeContractAndStorage (..)+  , SomeIsoValue (..)+  , SomeValue (..)+  , SomeStorage(..)+  ) where++import Fmt (Buildable(..))++import Morley.Michelson.Printer.Util (RenderDoc(..))+import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Convert ()+import Morley.Michelson.Typed.Haskell.Value (KnownIsoT)+import Morley.Michelson.Typed.Instr (Contract(..))+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.T (T(..))+import Morley.Util.Sing (eqParamSing)++data SomeConstrainedValue (c :: T -> Constraint) where+  SomeConstrainedValue+    :: forall (t :: T) (c :: T -> Constraint)+    . (c t)+    => Value t+    -> SomeConstrainedValue c++deriving stock instance Show (SomeConstrainedValue c)++-- TODO+-- @gromak: perhaps we should implement `SomeValue` in terms of+-- `SomeConstrainedValue`, but it will require changing quite a lot of code,+-- so it is postponed.++data SomeValue where+  SomeValue :: SingI t => Value t -> SomeValue++deriving stock instance Show SomeValue++instance Eq SomeValue where+  SomeValue v1 == SomeValue v2 = v1 `eqParamSing` v2++data SomeConstant where+  SomeConstant :: (ConstantScope t, SingI t) => Value t -> SomeConstant++instance Buildable SomeConstant where+  build (SomeConstant v) = build v++instance RenderDoc SomeConstant where+  renderDoc pn (SomeConstant v) = renderDoc pn v++-- | Hides some Haskell value put in line with Michelson 'Value'.+data SomeIsoValue where+  SomeIsoValue :: (KnownIsoT a) => a -> SomeIsoValue++data SomeContract where+  SomeContract :: Contract cp st -> SomeContract++instance NFData SomeContract where+  rnf (SomeContract c) = rnf c++deriving stock instance Show SomeContract++-- | Represents a typed contract & a storage value of the type expected by the contract.+data SomeContractAndStorage where+  SomeContractAndStorage+    :: forall cp st.+       (StorageScope st, ParameterScope cp)+       => Contract cp st+       -> Value st+       -> SomeContractAndStorage++deriving stock instance Show SomeContractAndStorage++data SomeStorage where+  SomeStorage :: forall st. StorageScope st => Value st -> SomeStorage++deriving stock instance Show SomeStorage

+ src/Morley/Michelson/Typed/Extract.hs view

@@ -0,0 +1,223 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, containing functions to convert @Morley.Michelson.Untyped.Ty@ to+-- @Morley.Michelson.Typed.T.T@ Michelson type representation (type stripped off all+-- annotations) and to @Morley.Michelson.Typed.Annotation.Notes@ value (which contains+-- field and type annotations for a given Michelson type).+--+-- I.e. @Morley.Michelson.Untyped.Ty@ is split to value @t :: T@ and value of type+-- @Notes t@ for which @t@ is a type representation of value @t@.+module Morley.Michelson.Typed.Extract+  ( fromUType+  , mkUType+  , mkUType'+  , toUType+  , withUType++  , pattern AsUType+  , pattern AsUTypeExt+  ) where++import Data.Singletons (Sing, SingI, fromSing)++import Morley.Michelson.Typed.Annotation (Notes(..), notesSing)+import Morley.Michelson.Typed.Sing (SingT(..))+import Morley.Michelson.Typed.T (T(..), toUType)+import qualified Morley.Michelson.Untyped as Un++{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}++fromUType :: Un.Ty -> T+fromUType ut = withUType ut (fromSing . notesSing)++mkUType :: SingI x => Notes x -> Un.Ty+mkUType notes = mkUType' (notesSing notes, notes)++mkUType' :: (Sing x, Notes x) -> Un.Ty+mkUType' = \case+  (STInt, NTInt tn)               -> Un.Ty Un.TInt tn+  (STNat, NTNat tn)               -> Un.Ty Un.TNat tn+  (STString, NTString tn)         -> Un.Ty Un.TString tn+  (STBytes, NTBytes tn)           -> Un.Ty Un.TBytes tn+  (STMutez, NTMutez tn)           -> Un.Ty Un.TMutez tn+  (STBool, NTBool tn)             -> Un.Ty Un.TBool tn+  (STKeyHash, NTKeyHash tn)       -> Un.Ty Un.TKeyHash tn+  (STBls12381Fr, NTBls12381Fr tn) -> Un.Ty Un.TBls12381Fr tn+  (STBls12381G1, NTBls12381G1 tn) -> Un.Ty Un.TBls12381G1 tn+  (STBls12381G2, NTBls12381G2 tn) -> Un.Ty Un.TBls12381G2 tn+  (STTimestamp, NTTimestamp tn)   -> Un.Ty Un.TTimestamp tn+  (STAddress, NTAddress tn)       -> Un.Ty Un.TAddress tn+  (STKey, NTKey tn)               -> Un.Ty Un.TKey tn+  (STUnit, NTUnit tn)             -> Un.Ty Un.TUnit tn+  (STSignature, NTSignature tn)   -> Un.Ty Un.TSignature tn+  (STChainId, NTChainId tn)       -> Un.Ty Un.TChainId tn+  (STOption t, NTOption tn n)     -> Un.Ty (Un.TOption $ mkUType' (t, n)) tn+  (STList t, NTList tn n)         -> Un.Ty (Un.TList $ mkUType' (t, n)) tn+  (STSet t, NTSet tn n)           -> Un.Ty (Un.TSet $ mkUType' (t, n)) tn+  (STOperation, NTOperation tn)   -> Un.Ty Un.TOperation tn+  (STNever, NTNever tn)           -> Un.Ty Un.TNever tn+  (STContract t, NTContract tn n) ->+    Un.Ty (Un.TContract $ mkUType' (t, n)) tn+  (STTicket t, NTTicket tn n) ->+      Un.Ty (Un.TTicket $ mkUType' (t, n)) tn+  (STPair t t', NTPair tn fl fr vl vr nl nr) ->+    Un.Ty+    (Un.TPair fl fr vl vr+    (mkUType' (t, nl))+    (mkUType' (t', nr)))+    tn+  (STOr t t', NTOr tn fl fr nl nr) ->+    Un.Ty+    (Un.TOr fl fr+    (mkUType' (t, nl))+    (mkUType' (t', nr)))+    tn+  (STLambda t t', NTLambda tn np nq) ->+    Un.Ty+    (Un.TLambda+    (mkUType' (t, np))+    (mkUType' (t', nq)))+    tn+  (STMap t t', NTMap tn nk nv) ->+    Un.Ty+    (Un.TMap+    (mkUType' (t, nk))+    (mkUType' (t', nv)))+    tn+  (STBigMap t t', NTBigMap tn nk nv) ->+    Un.Ty+    (Un.TBigMap+    (mkUType' (t, nk))+    (mkUType' (t', nv)))+    tn++-- | Convert 'Un.Ty' to the isomorphic set of information from typed world.+withUType+  :: Un.Ty+  -> (forall t. SingI t => Notes t -> r)+  -> r+withUType (Un.Ty ut tn) cont = case ut of++  Un.TInt ->+    cont (NTInt tn)++  Un.TNat ->+    cont (NTNat tn)++  Un.TString ->+    cont (NTString tn)++  Un.TBytes ->+    cont (NTBytes tn)++  Un.TMutez ->+    cont (NTMutez tn)++  Un.TBool ->+    cont (NTBool tn)++  Un.TKeyHash ->+    cont (NTKeyHash tn)++  Un.TBls12381Fr ->+    cont (NTBls12381Fr tn)++  Un.TBls12381G1 ->+    cont (NTBls12381G1 tn)++  Un.TBls12381G2 ->+    cont (NTBls12381G2 tn)++  Un.TTimestamp ->+    cont (NTTimestamp tn)++  Un.TAddress ->+    cont (NTAddress tn)++  Un.TKey ->+    cont (NTKey tn)++  Un.TUnit ->+    cont (NTUnit tn)++  Un.TSignature ->+    cont (NTSignature tn)++  Un.TChainId ->+    cont (NTChainId tn)++  Un.TNever ->+    cont (NTNever tn)++  Un.TOption internalT -> withUType internalT $+    \(notesInternalT :: Notes internalT) ->+      cont (NTOption tn notesInternalT)++  Un.TList listT -> withUType listT $+    \(notesListT :: Notes listT) ->+      cont (NTList tn notesListT)++  Un.TSet setT -> withUType setT $+    \(notesSetT :: Notes setT) ->+      cont (NTSet tn notesSetT)++  Un.TOperation ->+    cont (NTOperation tn)++  Un.TContract contractT -> withUType contractT $+    \(notesContractT :: Notes contractT) ->+      cont (NTContract tn notesContractT)++  Un.TTicket ticketT -> withUType ticketT $+    \(notesTicketT :: Notes ticketT) ->+      cont (NTTicket tn notesTicketT)++  Un.TPair la ra lv rv lt rt ->+    withUType lt $ \ln ->+      withUType rt $ \rn ->+        cont (NTPair tn la ra lv rv ln rn)++  Un.TOr la ra lt rt ->+    withUType lt $ \ln ->+      withUType rt $ \rn ->+        cont (NTOr tn la ra ln rn)++  Un.TLambda lt rt ->+    withUType lt $ \ln ->+      withUType rt $ \rn ->+        cont (NTLambda tn ln rn)++  Un.TMap keyT valT ->+    withUType keyT $ \keyN ->+      withUType valT $ \valN ->+        cont @('TMap _ _) (NTMap tn keyN valN)++  Un.TBigMap keyT valT ->+    withUType keyT $ \keyN ->+      withUType valT $ \valN ->+        cont @('TBigMap _ _) (NTBigMap tn keyN valN)++-- Helper datatype for 'AsUType'.+data SomeTypedInfo = forall t. SingI t => SomeTypedInfo (Notes t)++-- | Transparently represent untyped 'Un.Ty' as wrapper over @Notes t@+-- from typed world with @SingI t@ constraint.+--+-- As expression this carries logic of 'mkUType', and as pattern it performs+-- 'withUType' but may make code a bit cleaner.+--+-- Note about constraints: pattern signatures usually require two constraints -+-- one they require and another one which they provide. In our case we require+-- nothing (thus first constraint is @()@) and provide some knowledge about @t@.+pattern AsUType :: () => (SingI t) => Notes t -> Un.Ty+pattern AsUType notes <- ((\ut -> withUType ut SomeTypedInfo) -> SomeTypedInfo notes)+  where AsUType notes = mkUType notes+{-# COMPLETE AsUType #-}++-- | Similar to 'AsUType', but also gives 'Sing' for given type.+pattern AsUTypeExt :: () => (SingI t) => Sing t -> Notes t -> Un.Ty+pattern AsUTypeExt sng notes <- AsUType notes@(notesSing -> sng)+  where AsUTypeExt _ notes = AsUType notes+{-# COMPLETE AsUTypeExt #-}

+ src/Morley/Michelson/Typed/Haskell.hs view

@@ -0,0 +1,15 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Haskell-Michelson conversions.+module Morley.Michelson.Typed.Haskell+  ( module Exports+  ) where++import Morley.Michelson.Typed.Haskell.Compatibility as Exports+import Morley.Michelson.Typed.Haskell.Doc as Exports+import Morley.Michelson.Typed.Haskell.Instr as Exports+import Morley.Michelson.Typed.Haskell.LooseSum as Exports+import Morley.Michelson.Typed.Haskell.Value as Exports hiding (BigMap(..), GIsoValue(..))+import Morley.Michelson.Typed.Haskell.Value as Exports (BigMap)

+ src/Morley/Michelson/Typed/Haskell/Compatibility.hs view

@@ -0,0 +1,53 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Compatibility of Haskell values representation in Michelson.+module Morley.Michelson.Typed.Haskell.Compatibility+  ( ligoLayout+  , ligoCombLayout+  ) where++import Morley.Util.CustomGeneric++-- | Default layout in LIGO.+--+-- To be used with 'customGeneric', see this method for more info.+--+-- This is similar to 'leftBalanced', but+--+-- * fields are sorted alphabetically;+-- * always puts as large complete binary subtrees as possible at left.+ligoLayout :: GenericStrategy+ligoLayout =+  reorderingData forbidUnnamedFields alphabetically $+    fromDepthsStrategy ligoDepths+  where+    ligoDepths n =+      case fmap last . nonEmpty $ takeWhile (\(_, p) -> p <= n) powersOfTwo of+        Nothing -> []+        Just (depth, power) ->+          let leftSub = replicate power depth+              rightSub = ligoDepths (n - power)+          in if null rightSub then leftSub else map succ $ leftSub ++ rightSub++    powersOfTwo = [0..] <&> \i -> (i, 2 ^ i)++-- | Comb layout in LIGO (@ [\@layout:comb] @).+--+-- To be used with 'customGeneric'.+--+-- Note: to make comb layout work for sum types, make sure that in LIGO+-- all the constructors are preceded by the bar symbol in your type declaration:+--+-- @+-- type my_type =+--   [@layout:comb]+--   | Ctor1 of nat  ← bar symbol _must_ be here+--   | Ctor2 of int+--   ...+-- @+--+-- Though the situation may change: https://gitlab.com/ligolang/ligo/-/issues/1104.+ligoCombLayout :: GenericStrategy+ligoCombLayout = rightComb

+ src/Morley/Michelson/Typed/Haskell/Doc.hs view

@@ -0,0 +1,964 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- Dunno why it triggers+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Documentation of types appearing in contracts.+module Morley.Michelson.Typed.Haskell.Doc+  ( ADTRep+  , ConstructorRep (..)+  , crNameL, crDescriptionL, crFieldsL+  , FieldRep (..)+  , frNameL, frDescriptionL, frTypeRepL+  , WithinParens (..)+  , TypeHasDoc (..)+  , TypeDocHaskellRep+  , TypeDocMichelsonRep+  , FieldDescriptions+  , PolyTypeHasDocC+  , SomeTypeWithDoc (..)++  , HaveCommonTypeCtor+  , IsHomomorphic+  , genericTypeDocDependencies+  , customTypeDocMdReference+  , customTypeDocMdReference'+  , homomorphicTypeDocMdReference+  , poly1TypeDocMdReference+  , poly2TypeDocMdReference+  , homomorphicTypeDocHaskellRep+  , concreteTypeDocHaskellRep+  , unsafeConcreteTypeDocHaskellRep+  , haskellAddNewtypeField+  , haskellRepNoFields+  , haskellRepStripFieldPrefix+  , homomorphicTypeDocMichelsonRep+  , concreteTypeDocMichelsonRep+  , unsafeConcreteTypeDocMichelsonRep++  , DType (..)+  , DStorageType (..)+  , dStorage+  , GTypeHasDoc+  , GProductHasDoc+  , dTypeDep+  , dTypeDepP+  , buildADTRep+  , applyWithinParens+  , buildTypeWithinParens+  ) where++import Control.Lens (_Just, each, to)+import Data.Char (isLower, isUpper, toLower)+import Data.List (lookup)+import Data.Singletons (SingI, demote)+import qualified Data.Text as T+import Data.Typeable (typeRep, typeRepArgs)+import Fmt (Buildable, build, (+|), (|+))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal)+import qualified Text.Show+import Type.Showtype (Showtype(..))++import Morley.Michelson.Doc+import Morley.Michelson.Text+import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Haskell.ValidateDescription+import Morley.Michelson.Typed.Haskell.Value+import Morley.Michelson.Typed.T+import Morley.Tezos.Address+import Morley.Tezos.Core+import Morley.Tezos.Crypto+import Morley.Util.Generic+import Morley.Util.Lens+import Morley.Util.Markdown+import Morley.Util.Named+import Morley.Util.Typeable++-- | Stands for representation of some Haskell ADT corresponding to+-- Michelson value. Type parameter @a@ is what you put in place of+-- each field of the datatype, e.g. information about field type.+--+-- This representation also includes descriptions of constructors and fields.+type ADTRep a = [ConstructorRep a]++-- | Representation of a constructor with an optional description.+data ConstructorRep a = ConstructorRep+  { crName :: Text+  , crDescription :: Maybe Text+  , crFields :: [FieldRep a]+  }++-- | Representation of a field with an optional description.+data FieldRep a = FieldRep+  { frName :: Maybe Text+  , frDescription :: Maybe Text+  , frTypeRep :: a+  }++makeLensesWith postfixLFields ''ConstructorRep+makeLensesWith postfixLFields ''FieldRep++-- | Show given 'ADTRep' in a neat way.+buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown+buildADTRep buildField = \case+  [] -> mdItalic "no values"+  [ctor@ConstructorRep{..}] -> renderProduct (WithinParens False) ctor crFields+  ps -> (mappend (mdItalic "one of" <> " \n")) $+        foldMap+        (toListItem . renderNamedProduct (WithinParens True)) (toList ps)+  where+    toListItem item = "+ " <> item <> "\n"++    renderNamedProduct :: WithinParens -> ConstructorRep a -> Markdown+    renderNamedProduct wp ctor@ConstructorRep{..} =+      mdBold (build crName) <>+      if hasFieldNames+         then maybe "" (\d -> ": " <> build d <> " ") crDescription <>+              renderProduct wp ctor crFields+         else renderProduct wp ctor crFields <>+              maybe "" (\d -> ": " <> build d) crDescription+      where+        hasFieldNames = any (isJust . frName) crFields++    renderProduct :: WithinParens -> ConstructorRep a -> [FieldRep a] -> Markdown+    renderProduct wp ctor = \case+      [] -> "()"+      [t@FieldRep{ frDescription = Nothing }]+        | Nothing <- crDescription ctor -> renderNamedField wp t+      ts -> mconcat $ map (("\n  * " <>) . renderNamedField wp) ts++    renderNamedField :: WithinParens -> FieldRep a -> Markdown+    renderNamedField wp FieldRep{..} = mconcat+      [ maybe "" buildFieldName frName+      , buildField wp frTypeRep+      , maybe "" (mappend "    " . mappend "\n" . build) frDescription+      ]++-- | Map field names in a 'ADTRep', with the possibility to remove some names by+-- mapping them to 'Nothing'.+mapADTRepFields :: (Maybe Text -> Maybe Text) -> ADTRep a -> ADTRep a+mapADTRepFields = over $ each . crFieldsL . each . frNameL++-- | How field names should be displayed.+--+-- Result of this function call should appear right before rendered type+-- of that field.+buildFieldName :: Text -> Markdown+buildFieldName name = mdItalic (mdBold (build name)) |+ " :"++-- | Whether given text should be rendered grouped in parentheses+-- (if they make sense).+newtype WithinParens = WithinParens Bool++applyWithinParens :: WithinParens -> Markdown -> Markdown+applyWithinParens (WithinParens wp) txt+  | wp = "(" <> txt <> ")"+  | otherwise = txt++-- | Show type, wrapping into parentheses if necessary.+buildTypeWithinParens :: forall a. Typeable a => WithinParens -> Markdown+buildTypeWithinParens wp =+  let rep = typeRep (Proxy @a)+      wrap = if null (typeRepArgs rep) then id else applyWithinParens wp+  in wrap $ build @Text $ show rep++-- | Description for a Haskell type appearing in documentation.+class ( Typeable a+      , SingI (TypeDocFieldDescriptions a)+      , FieldDescriptionsValid (TypeDocFieldDescriptions a) a+      ) => TypeHasDoc a where+  -- | Name of type as it appears in definitions section.+  --+  -- Each type must have its own unique name because it will be used+  -- in identifier for references.+  --+  -- Default definition derives name from Generics.+  -- If it does not fit, consider defining this function manually.+  -- (We tried using "Data.Data" for this, but it produces names including+  -- module names which is not do we want).+  typeDocName :: Proxy a -> Text+  default typeDocName+    :: (Generic a, KnownSymbol (GenericTypeName a))+    => Proxy a -> Text+  typeDocName _ = toText $ symbolVal (Proxy @(GenericTypeName a))++  -- | Explanation of a type. Markdown formatting is allowed.+  typeDocMdDescription :: Markdown++  -- | How reference to this type is rendered, in Markdown.+  --+  -- Examples:+  --+  -- * @\[Integer](\#type-integer)@,+  -- * @\[Maybe](\#type-Maybe) \[()](\#type-unit)@.+  --+  -- Consider using one of the following functions as default implementation;+  -- which one to use depends on number of type arguments in your type:+  --+  -- * 'homomorphicTypeDocMdReference'+  -- * 'poly1TypeDocMdReference'+  -- * 'poly2TypeDocMdReference'+  --+  -- If none of them fits your purposes precisely, consider using+  -- 'customTypeDocMdReference'.+  typeDocMdReference :: Proxy a -> WithinParens -> Markdown+  default typeDocMdReference+    :: (Typeable a, IsHomomorphic a)+    => Proxy a -> WithinParens -> Markdown+  typeDocMdReference = homomorphicTypeDocMdReference++  -- | All types which this type directly contains.+  --+  -- Used in automatic types discovery.+  typeDocDependencies :: Proxy a -> [SomeDocDefinitionItem]+  default typeDocDependencies+    :: (Generic a, GTypeHasDoc (G.Rep a))+    => Proxy a -> [SomeDocDefinitionItem]+  typeDocDependencies = genericTypeDocDependencies++  -- | For complex types - their immediate Haskell representation.+  --+  -- For primitive types set this to 'Nothing'.+  --+  -- For homomorphic types use 'homomorphicTypeDocHaskellRep' implementation.+  --+  -- For polymorhpic types consider using 'concreteTypeDocHaskellRep' as implementation.+  --+  -- Modifier 'haskellRepNoFields' can be used to hide names of fields,+  -- beneficial for newtypes.+  --+  -- Another modifier called 'haskellRepStripFieldPrefix' can be used for datatypes+  -- to leave only meaningful part of name in every field.+  typeDocHaskellRep :: TypeDocHaskellRep a+  default typeDocHaskellRep+    :: (Generic a, GTypeHasDoc (G.Rep a), IsHomomorphic a)+    => TypeDocHaskellRep a+  typeDocHaskellRep = haskellRepStripFieldPrefix homomorphicTypeDocHaskellRep++  -- | Description of constructors and fields of @a@.+  --+  -- See 'FieldDescriptions' documentation for an example of usage.+  --+  -- Descriptions will be checked at compile time to make sure that only existing constructors+  -- and fields are referenced.+  --+  -- For that check to work @instance Generic a@ is required whenever @TypeDocFieldDescriptions@+  -- is not empty.+  --+  -- For implementation of the check see 'FieldDescriptionsValid' type family.+  type TypeDocFieldDescriptions a :: FieldDescriptions+  type TypeDocFieldDescriptions _ = '[]++  -- | Final michelson representation of a type.+  --+  -- For homomorphic types use 'homomorphicTypeDocMichelsonRep' implementation.+  --+  -- For polymorhpic types consider using 'concreteTypeDocMichelsonRep' as implementation.+  typeDocMichelsonRep :: TypeDocMichelsonRep a+  default typeDocMichelsonRep+    :: (KnownIsoT a, IsHomomorphic a)+    => TypeDocMichelsonRep a+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++-- | Signature of 'typeDocHaskellRep' function.+--+-- A value of 'FieldDescriptionsV' is provided by the library to make sure that+-- instances won't replace it with an unchecked value.+--+-- When value is 'Just', it contains types which this type is built from.+--+-- First element of provided pair may contain name a concrete type which has+-- the same type constructor as @a@ (or just @a@ for homomorphic types), and+-- the second element of the pair - its unfolding in Haskell.+--+-- For example, for some @newtype MyNewtype = MyNewtype (Integer, Natural)@+-- we would not specify the first element in the pair because @MyNewtype@ is+-- already a concrete type, and second element would contain @(Integer, Natural)@.+-- For polymorhpic types like @newtype MyPolyNewtype a = MyPolyNewtype (Text, a)@,+-- we want to describe its representation on some example of @a@, because+-- working with type variables is too non-trivial; so the first element of+-- the pair may be e.g. @"MyPolyNewType Integer"@, and the second one shows+-- that it unfolds to @(Text, Integer)@.+--+-- When rendered, values of this type look like:+--+-- * @(Integer, Natural)@ - for homomorphic type.+-- * @MyError Integer = (Text, Integer)@ - concrete sample for polymorhpic type.+type TypeDocHaskellRep a =+  Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)++-- | Signature of 'typeDocMichelsonRep' function.+--+-- As in 'TypeDocHaskellRep', set the first element of the pair to 'Nothing'+-- for primitive types, otherwise it stands as some instantiation of a type,+-- and its Michelson representation is given in the second element of the pair.+--+-- Examples of rendered representation:+--+-- * @pair int nat@ - for homomorphic type.+-- * @MyError Integer = pair string int@ - concrete sample for polymorhpic type.+type TypeDocMichelsonRep a =+  Proxy a -> (Maybe DocTypeRepLHS, T)++-- | Data hides some type implementing 'TypeHasDoc'.+data SomeTypeWithDoc where+  SomeTypeWithDoc :: TypeHasDoc td => Proxy td -> SomeTypeWithDoc++-- | When rendering type's inner representation, this stands for name of+--+-- Having this makes sense for polymorhpic types, when you want to render+-- representation of some concrete instantiation of that type.+newtype DocTypeRepLHS = DocTypeRepLHS Text+  deriving newtype (IsString, Buildable)++-- | Doc element with description of a type.+data DType where+  DType :: TypeHasDoc a => Proxy a -> DType++instance Show DType where+  show (DType a) = show $ typeRep a++instance Eq DType where+  DType a1 == DType a2 = a1 `eqExt` a2+instance Ord DType where+  DType a1 `compare` DType a2 = a1 `compareExt` a2++instance DocItem DType where+  type DocItemPlacement DType = 'DocItemInDefinitions+  type DocItemReferenced DType = 'True+  docItemPos = 5000++  docItemSectionName = Just "Types"++  docItemRef (DType a) = DocItemRef $+    DocItemId ("types-" <> typeDocName a)++  docItemDependencies (DType (ap' :: Proxy a)) =+    typeDocDependencies ap'++  docItemToMarkdown lvl (DType (ap' :: Proxy a)) =+    mconcat . catMaybes $+    [ Just mdSeparator+    , Just $ mdHeader lvl (mdTicked . build $ typeDocName ap')+    , Just $ typeDocMdDescription @a |+ "\n\n"+    , typeDocHaskellRep ap' (demote @(TypeDocFieldDescriptions a)) <&> \(mlhs, rep) ->+        let+          -- Without this signature type inference trips.+          buildField :: WithinParens -> SomeTypeWithDoc -> Markdown+          buildField wp (SomeTypeWithDoc di) =+            typeDocMdReference di wp+          renderedRep =+             buildADTRep buildField rep+          rendered = case mlhs of+            Nothing ->+              mdSubsection "Structure" renderedRep+            Just lhs ->+              mdSubsection "Structure (example)" $+                mdTicked (build lhs) <> " = " <> renderedRep+        in rendered <> "\n\n"+    , Just $+        let (mlhs, rep) = typeDocMichelsonRep ap'+            renderedRep = mdTicked (build rep)+            rendered = case mlhs of+              Nothing -> mdSubsection "Final Michelson representation"+                         renderedRep+              Just lhs -> mdSubsection "Final Michelson representation (example)" $+                          mdTicked (build lhs) <> " = " <> renderedRep+        in rendered <> "\n\n"+    ]++  docItemToToc lvl d@(DType ap') =+    mdTocFromRef lvl (build $ typeDocName ap') d++-- | Create a 'DType' in form suitable for putting to 'typeDocDependencies'.+dTypeDep :: forall (t :: Type). TypeHasDoc t => SomeDocDefinitionItem+dTypeDep = SomeDocDefinitionItem (DType (Proxy @t))++-- | Proxy version of 'dTypeDep'.+dTypeDepP+  :: forall (t :: Type).+      TypeHasDoc t+  => Proxy t -> SomeDocDefinitionItem+dTypeDepP _ = dTypeDep @t++-- | Doc element with description of contract storage type.+newtype DStorageType = DStorageType DType+  deriving stock (Generic, Eq, Ord)++-- | Shortcut for 'DStorageType'.+dStorage :: forall store. TypeHasDoc store => DStorageType+dStorage = DStorageType $ DType (Proxy @store)++instance DocItem DStorageType where+  type DocItemPlacement DStorageType = 'DocItemInlined+  type DocItemReferenced DStorageType = 'True++  docItemRef (DStorageType (DType a)) = DocItemRefInlined $+    DocItemId ("storage-" <> typeDocName a)+  docItemPos = 835+  docItemSectionName = Just "Storage"+  docItemToMarkdown lvl (DStorageType t) = docItemToMarkdown lvl t+  docItemToToc lvl d@(DStorageType (DType a)) =+    mdTocFromRef lvl (build $ typeDocName a) d+  docItemDependencies (DStorageType t) = docItemDependencies t++-- Default implementations+----------------------------------------------------------------------------++-- | Require two types to be built from the same type constructor.+--+-- E.g. @HaveCommonTypeCtor (Maybe Integer) (Maybe Natural)@ is defined,+-- while @HaveCmmonTypeCtor (Maybe Integer) [Integer]@ is not.+class HaveCommonTypeCtor a b+instance HaveCommonTypeCtor ac bc => HaveCommonTypeCtor (ac a) (bc b)+instance HaveCommonTypeCtor a a++-- | Require this type to be homomorphic.+class IsHomomorphic a where+instance TypeError ('Text "Type is not homomorphic: " ':<>: 'ShowType (a b)) =>+         IsHomomorphic (a b)+instance {-# OVERLAPPABLE #-} IsHomomorphic a++-- | Render a reference to a type which consists of type constructor+-- (you have to provide name of this type constructor and documentation+-- for the whole type) and zero or more type arguments.+customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown+customTypeDocMdReference tyInfo typeArgsDoc =+  customTypeDocMdReference'+    tyInfo+    (typeArgsDoc <&> \(DType di) -> typeDocMdReference di)++-- | More generic version of 'customTypeDocMdReference', it accepts+-- arguments not as types with doc, but printers for them.+customTypeDocMdReference'+  :: (Text, DType)+  -> [WithinParens -> Markdown]+  -> WithinParens+  -> Markdown+customTypeDocMdReference' (typeCtorName, tyDoc) typeArgsPrinters wp =+  let DocItemRef ctorDocItemId = docItemRef tyDoc+  in applyWithinParens wpSmart $+     mconcat . intersperse " " $+      ( mdLocalRef (mdTicked $ build typeCtorName) ctorDocItemId+      : (typeArgsPrinters <&> \printer -> printer (WithinParens True))+      )+    where+      -- If we are rendering an atomic thing, there is no need in parentheses+      -- around it+      wpSmart =+        let WithinParens wp' = wp+        in WithinParens (wp' && not (null typeArgsPrinters))++-- | Derive 'typeDocMdReference', for homomorphic types only.+homomorphicTypeDocMdReference+  :: forall (t :: Type).+     (Typeable t, TypeHasDoc t, IsHomomorphic t)+  => Proxy t -> WithinParens -> Markdown+homomorphicTypeDocMdReference tp _ =+  customTypeDocMdReference+    (typeDocName tp, DType tp)+    []+    (WithinParens False)++-- | Derive 'typeDocMdReference', for polymorphic type with one+-- type argument, like @Maybe Integer@.+poly1TypeDocMdReference+  :: forall t (r :: Type) (a :: Type).+      (r ~ t a, Typeable t, Each '[TypeHasDoc] [r, a], IsHomomorphic t)+  => Proxy r -> WithinParens -> Markdown+poly1TypeDocMdReference tp =+  customTypeDocMdReference+    (toText $ showtype (Proxy @t), DType tp)+    [DType (Proxy @a)]++-- | Derive 'typeDocMdReference', for polymorphic type with two+-- type arguments, like @Lambda Integer Natural@.+poly2TypeDocMdReference+  :: forall t (r :: Type) (a :: Type) (b :: Type).+      (r ~ t a b, Typeable t, Each '[TypeHasDoc] [r, a, b], IsHomomorphic t)+  => Proxy r -> WithinParens -> Markdown+poly2TypeDocMdReference tp =+  customTypeDocMdReference+    (toText $ showtype (Proxy @t), DType tp)+    [ DType (Proxy @a)+    , DType (Proxy @b)+    ]++-- | Implement 'typeDocDependencies' via getting all immediate fields+-- of a datatype.+--+-- Note: this will not include phantom types, I'm not sure yet how this+-- scenario should be handled (@martoon).+genericTypeDocDependencies+  :: forall a.+      (Generic a, GTypeHasDoc (G.Rep a))+  => Proxy a -> [SomeDocDefinitionItem]+genericTypeDocDependencies _ = do+  ConstructorRep{..} <- toList $ gTypeDocHaskellRep @(G.Rep a) []+  FieldRep{..} <- crFields+  SomeTypeWithDoc ty <- pure frTypeRep+  return (dTypeDepP ty)++-- | Implement 'typeDocHaskellRep' for a homomorphic type.+--+-- Note that it does not require your type to be of 'IsHomomorphic' instance,+-- which can be useful for some polymorhpic types which, for documentation+-- purposes, we want to consider homomorphic.+--+-- Example: 'Operation' is in fact polymorhpic, but we don't want this fact to+-- be reflected in the documentation.+homomorphicTypeDocHaskellRep+  :: forall a.+     (Generic a, GTypeHasDoc (G.Rep a))+  => TypeDocHaskellRep a+homomorphicTypeDocHaskellRep _ descr = Just+  ( Nothing+  , gTypeDocHaskellRep @(G.Rep a) descr+  )++-- | Implement 'typeDocHaskellRep' on example of given concrete type.+--+-- This is a best effort attempt to implement 'typeDocHaskellRep' for polymorhpic+-- types, as soon as there is no simple way to preserve type variables when+-- automatically deriving Haskell representation of a type.+concreteTypeDocHaskellRep+  :: forall a b.+     ( Typeable a, GenericIsoValue a, GTypeHasDoc (G.Rep a)+     , HaveCommonTypeCtor b a+     )+  => TypeDocHaskellRep b+concreteTypeDocHaskellRep = unsafeConcreteTypeDocHaskellRep @a++-- | Version of 'concreteTypeDocHaskellRep' which does not ensure+-- whether the type for which representation is built is any similar to+-- the original type which you implement a 'TypeHasDoc' instance for.+unsafeConcreteTypeDocHaskellRep+  :: forall a b.+     ( Typeable a, GenericIsoValue a, GTypeHasDoc (G.Rep a)+     )+  => TypeDocHaskellRep b+unsafeConcreteTypeDocHaskellRep _ descr = Just+  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)+    -- ↑ this also shows kinds when poly-kinded type arguments are present,+    -- but there seems to be no simple way to deal with this.+  , gTypeDocHaskellRep @(G.Rep a) descr+  )++-- | Erase fields from Haskell datatype representation.+--+-- Use this when rendering fields names is undesired.+haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a+haskellRepNoFields mkRep =+  \p descr -> second (mapADTRepFields (const Nothing)) <$> mkRep p descr++-- | Add field name for @newtype@.+--+-- Since @newtype@ field is automatically erased. Use this function+-- to add the desired field name.+haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a+haskellAddNewtypeField fieldName mkRep =+  \p descr -> second (mapADTRepFields (const (Just fieldName))) <$> mkRep p descr++-- | Cut fields prefixes which we use according to the style guide.+--+-- E.g. @cmMyField@ field will be transformed to @myField@.+haskellRepStripFieldPrefix+  :: HasCallStack+  => TypeDocHaskellRep a -> TypeDocHaskellRep a+haskellRepStripFieldPrefix mkRep =+  \p descr -> second (mapADTRepFields (fmap stripPrefix)) <$> mkRep p descr+  where+    stripPrefix fieldName =+      case T.uncons $ T.dropWhile isLower fieldName of+        Nothing -> error $ "Field '" <> fieldName <> "' has no prefix"+        Just (c, cs) ->+          -- For fields like @ciUSPosition@ we should not lead the first letter+          -- to lower case like @uSPosition@.+          let isAbbreviation = case T.uncons cs of+                Just (c2, _)+                  | isUpper c2 -> True+                  | otherwise -> False+                Nothing -> False+          in T.cons (if isAbbreviation then c else toLower c) cs++-- | Implement 'typeDocMichelsonRep' for homomorphic type.+homomorphicTypeDocMichelsonRep+  :: forall a.+     KnownIsoT a+  => TypeDocMichelsonRep a+homomorphicTypeDocMichelsonRep _ =+  ( Nothing+  , demote @(ToT a)+  )++-- | Implement 'typeDocMichelsonRep' on example of given concrete type.+--+-- This function exists for the same reason as 'concreteTypeDocHaskellRep'.+concreteTypeDocMichelsonRep+  :: forall a b.+     (Typeable a, KnownIsoT a, HaveCommonTypeCtor b a)+  => TypeDocMichelsonRep b+concreteTypeDocMichelsonRep _ =+  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)+  , demote @(ToT a)+  )++-- | Version of 'unsafeConcreteTypeDocHaskellRep' which does not ensure+-- whether the type for which representation is built is any similar to+-- the original type which you implement a 'TypeHasDoc' instance for.+unsafeConcreteTypeDocMichelsonRep+  :: forall a b.+     (Typeable a, KnownIsoT a)+  => TypeDocMichelsonRep b+unsafeConcreteTypeDocMichelsonRep _ =+  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)+  , demote @(ToT a)+  )++-- | Generic traversal for automatic deriving of some methods in 'TypeHasDoc'.+class GTypeHasDoc (x :: Type -> Type) where+  gTypeDocHaskellRep :: FieldDescriptionsV -> ADTRep SomeTypeWithDoc++instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'False) x) where+  gTypeDocHaskellRep = gTypeDocHaskellRep @x++instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'True) x) where+  gTypeDocHaskellRep descr =+    mapADTRepFields (const Nothing) $ gTypeDocHaskellRep @x descr++instance (GTypeHasDoc x, GTypeHasDoc y) => GTypeHasDoc (x :+: y) where+  gTypeDocHaskellRep descr = gTypeDocHaskellRep @x descr <> gTypeDocHaskellRep @y descr++instance (GProductHasDoc x, KnownSymbol ctor) =>+         GTypeHasDoc (G.C1 ('G.MetaCons ctor _1 _2) x) where+  gTypeDocHaskellRep descr = one $ ConstructorRep+    { crName = conName+    , crDescription = descr ^? to (lookup conName) . _Just . _1 . _Just+    , crFields = gProductDocHaskellRep @x $ descr ^. to (lookup conName) . _Just . _2+    }+    where+      conName = toText $ symbolVal (Proxy @ctor)++instance GTypeHasDoc G.V1 where+  gTypeDocHaskellRep _ = []++-- | Product type traversal for 'TypeHasDoc'.+class GProductHasDoc (x :: Type -> Type) where+  gProductDocHaskellRep :: [(Text, Text)] -> [FieldRep SomeTypeWithDoc]++instance (GProductHasDoc x, GProductHasDoc y) => GProductHasDoc (x :*: y) where+  gProductDocHaskellRep descr = gProductDocHaskellRep @x descr <> gProductDocHaskellRep @y descr++instance TypeHasDoc a =>+         GProductHasDoc (G.S1 ('G.MetaSel 'Nothing _1 _2 _3) (G.Rec0 a)) where+  gProductDocHaskellRep _ = one $ FieldRep+    { frName = Nothing+    , frDescription = Nothing+    , frTypeRep = SomeTypeWithDoc (Proxy @a)+    }++instance (TypeHasDoc a, KnownSymbol field) =>+         GProductHasDoc (G.S1 ('G.MetaSel ('Just field) _1 _2 _3) (G.Rec0 a)) where+  gProductDocHaskellRep descr = one $ FieldRep+    { frName = Just fieldName+    , frDescription = descr ^? to (lookup fieldName) . _Just+    , frTypeRep = SomeTypeWithDoc (Proxy @a)+    }+    where+      fieldName = toText (symbolVal $ Proxy @field)++instance GProductHasDoc G.U1 where+  gProductDocHaskellRep = mempty++-- Instances+----------------------------------------------------------------------------++-- | Constraint, required when deriving 'TypeHasDoc' for polymorphic type+-- with the least possible number of methods defined manually.+type PolyTypeHasDocC ts = Each '[TypeHasDoc] ts++-- | Version of 'PolyTypeHasDocC' for comparable types.+type PolyCTypeHasDocC ts = Each '[TypeHasDoc] ts++instance TypeHasDoc Integer where+  typeDocName _ = "Integer"+  typeDocMdDescription = "Signed number."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc Natural where+  typeDocName _ = "Natural"+  typeDocMdDescription = "Unsigned number."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc MText where+  typeDocName _ = "Text"+  typeDocMdReference p = customTypeDocMdReference ("Text", DType p) []+  typeDocMdDescription =+    "Michelson string.\n\n\+    \This has to contain only ASCII characters with codes from [32; 126] range; \+    \additionally, newline feed character is allowed."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc Bool where+  typeDocName _ = "Bool"+  typeDocMdDescription = "Bool primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc ByteString where+  typeDocName _ = "ByteString"+  typeDocMdDescription = "Bytes primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc Mutez where+  typeDocName _ = "Mutez"+  typeDocMdDescription = "Mutez primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc KeyHash where+  typeDocName _ = "KeyHash"+  typeDocMdDescription = "KeyHash primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc Timestamp where+  typeDocName _ = "Timestamp"+  typeDocMdDescription = "Timestamp primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc Address where+  typeDocName _ = "Address"+  typeDocMdDescription = [md|+    Address primitive.++    Unlike Michelson's `address`, it is assumed not to contain an entrypoint name,+    even if it refers to a contract; this won't be checked, so passing an entrypoint+    name may result in unexpected errors.+    |]+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc EpAddress where+  typeDocName _ = "EntrypointAddress"+  typeDocMdDescription = [md|+    Address primitive.++    This exactly matches the Michelson's `address`, and can refer to a specific entrypoint.+    |]+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc PublicKey where+  typeDocName _ = "PublicKey"+  typeDocMdDescription = "PublicKey primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc Signature where+  typeDocName _ = "Signature"+  typeDocMdDescription = "Signature primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc ChainId where+  typeDocName _ = "ChainId"+  typeDocMdDescription = "Identifier of the current chain."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing++instance TypeHasDoc () where+  typeDocName _ = "()"+  typeDocMdDescription = "Unit primitive."+  typeDocDependencies _ = []++instance PolyTypeHasDocC '[a] => TypeHasDoc [a] where+  typeDocName _ = "List"+  typeDocMdDescription = "List primitive."+  typeDocMdReference _ =+    -- poly1TypeDocMdReference would produce text like @[] Integer@, we want+    -- to replace this @[]@ with @List@.+    customTypeDocMdReference ("List", DType (Proxy @[a])) [DType (Proxy @a)]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @[Integer]++instance PolyTypeHasDocC '[a] => TypeHasDoc (Maybe a) where+  typeDocMdDescription = "Option primitive."+  typeDocMdReference = poly1TypeDocMdReference+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Maybe Integer)++instance PolyTypeHasDocC [l, r] => TypeHasDoc (Either l r) where+  typeDocMdDescription = "Or primitive."+  typeDocMdReference = poly2TypeDocMdReference+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Either Integer Natural)++instance PolyTypeHasDocC [a, b] => TypeHasDoc (a, b) where+  typeDocName _ = "(a, b)"+  typeDocMdReference _ = tupleTypeDocReference+    [ typeDocMdReference (Proxy @a) (WithinParens False)+    , typeDocMdReference (Proxy @b) (WithinParens False)+    ]+  typeDocMdDescription = "Pair primitive."+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Integer, Natural)++instance PolyCTypeHasDocC '[a] => TypeHasDoc (Set a) where+  typeDocName _ = "Set"+  typeDocMdReference = poly1TypeDocMdReference+  typeDocMdDescription = "Set primitive."+  typeDocDependencies _ = [dTypeDep @a]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Set Integer)++instance TypeHasDoc Operation where+  typeDocName _ = "Operation"+  typeDocMdReference tp = customTypeDocMdReference ("Operation", DType tp) []+  typeDocMdDescription = "Operation primitive."+  typeDocDependencies _ = []+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++instance PolyTypeHasDocC '[cp] => TypeHasDoc (ContractRef cp) where+  typeDocName _ = "Contract"+  typeDocMdReference = poly1TypeDocMdReference+  typeDocMdDescription = "Contract primitive with given type of parameter."+  typeDocDependencies _ = [dTypeDep @cp, dTypeDep @Integer]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(ContractRef Integer)++instance PolyTypeHasDocC '[a] => TypeHasDoc (Ticket a) where+  typeDocName _ = "Ticket"+  typeDocMdReference = poly1TypeDocMdReference+  typeDocMdDescription = "Ticket primitive."+  typeDocDependencies _ = [dTypeDep @a, dTypeDep @MText]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Ticket MText)++instance (PolyCTypeHasDocC '[k], PolyTypeHasDocC '[v], Ord k) =>+         TypeHasDoc (Map k v) where+  typeDocName _ = "Map"+  typeDocMdReference = poly2TypeDocMdReference+  typeDocMdDescription = "Map primitive."+  typeDocDependencies _ =+    [dTypeDep @k, dTypeDep @v]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Map Integer Natural)++instance (PolyCTypeHasDocC '[k], PolyTypeHasDocC '[v], Ord k) =>+         TypeHasDoc (BigMap k v) where+  typeDocName _ = "BigMap"+  typeDocMdReference = poly2TypeDocMdReference+  typeDocMdDescription = "BigMap primitive."+  typeDocDependencies _ =+    [dTypeDep @k, dTypeDep @v]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(BigMap Integer Natural)+++tupleTypeDocReference :: [Markdown] -> WithinParens -> Markdown+tupleTypeDocReference vs _ = "(" +| mconcat (intersperse ", " $ map build vs) |+ ")"++instance PolyTypeHasDocC [a, b, c] => TypeHasDoc (a, b, c) where+  typeDocName _ = "(a, b, c)"+  typeDocMdReference _ = tupleTypeDocReference+    [ typeDocMdReference (Proxy @a) (WithinParens False)+    , typeDocMdReference (Proxy @b) (WithinParens False)+    , typeDocMdReference (Proxy @c) (WithinParens False)+    ]+  typeDocMdDescription = "Tuple of size 3."+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Integer, Natural, MText)++instance PolyTypeHasDocC [a, b, c, d] => TypeHasDoc (a, b, c, d) where+  typeDocName _ = "(a, b, c, d)"+  typeDocMdReference _ = tupleTypeDocReference+    [ typeDocMdReference (Proxy @a) (WithinParens False)+    , typeDocMdReference (Proxy @b) (WithinParens False)+    , typeDocMdReference (Proxy @c) (WithinParens False)+    , typeDocMdReference (Proxy @d) (WithinParens False)+    ]+  typeDocMdDescription = "Tuple of size 4."+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep =+    -- Starting from tuple of size 4 the exact types should not matter to a reader,+    -- rather the resulting pairs tree.+    concreteTypeDocMichelsonRep @((), (), (), ())++instance PolyTypeHasDocC [a, b, c, d, e] => TypeHasDoc (a, b, c, d, e) where+  typeDocName _ = "(a, b, c, d, e)"+  typeDocMdDescription = "Tuple of size 5."+  typeDocMdReference _ = tupleTypeDocReference+    [ typeDocMdReference (Proxy @a) (WithinParens False)+    , typeDocMdReference (Proxy @b) (WithinParens False)+    , typeDocMdReference (Proxy @c) (WithinParens False)+    , typeDocMdReference (Proxy @d) (WithinParens False)+    , typeDocMdReference (Proxy @e) (WithinParens False)+    ]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep =+    concreteTypeDocMichelsonRep @((), (), (), (), ())++instance PolyTypeHasDocC [a, b, c, d, e, f] => TypeHasDoc (a, b, c, d, e, f) where+  typeDocName _ = "(a, b, c, d, e, f)"+  typeDocMdReference _ = tupleTypeDocReference+    [ typeDocMdReference (Proxy @a) (WithinParens False)+    , typeDocMdReference (Proxy @b) (WithinParens False)+    , typeDocMdReference (Proxy @c) (WithinParens False)+    , typeDocMdReference (Proxy @d) (WithinParens False)+    , typeDocMdReference (Proxy @e) (WithinParens False)+    , typeDocMdReference (Proxy @f) (WithinParens False)+    ]+  typeDocMdDescription = "Tuple of size 6."+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep =+    concreteTypeDocMichelsonRep @((), (), (), (), (), ())++instance PolyTypeHasDocC [a, b, c, d, e, f, g] => TypeHasDoc (a, b, c, d, e, f, g) where+  typeDocName _ = "(a, b, c, d, e, f, g)"+  typeDocMdReference _ = tupleTypeDocReference+    [ typeDocMdReference (Proxy @a) (WithinParens False)+    , typeDocMdReference (Proxy @b) (WithinParens False)+    , typeDocMdReference (Proxy @c) (WithinParens False)+    , typeDocMdReference (Proxy @d) (WithinParens False)+    , typeDocMdReference (Proxy @e) (WithinParens False)+    , typeDocMdReference (Proxy @f) (WithinParens False)+    , typeDocMdReference (Proxy @g) (WithinParens False)+    ]+  typeDocMdDescription = "Tuple of size 7."+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep =+    concreteTypeDocMichelsonRep @((), (), (), (), (), (), ())+++instance ( TypeHasDoc (ApplyNamedFunctor f a)+         , KnownSymbol n+         , KnownIsoT (ApplyNamedFunctor f Integer)+         , Typeable f, Typeable a+         ) =>+         TypeHasDoc (NamedF f a n) where+  typeDocName _ = "Named entry"+  typeDocMdReference _ wp =+    applyWithinParens wp $+    buildFieldName (toText (symbolVal $ Proxy @n)) +| " " +|+    typeDocMdReference (Proxy @(ApplyNamedFunctor f a)) (WithinParens False) |+ ""+  typeDocDependencies _ =+    [ dTypeDep @(ApplyNamedFunctor f a)+    , dTypeDep @Integer+    ]+  typeDocHaskellRep _ _ = Nothing+  typeDocMichelsonRep _ = (Just "number: Integer", demote @(ToT (ApplyNamedFunctor f Integer)))+  typeDocMdDescription =+    "Some entries have names for clarity.\n\n\+    \In resulting Michelson names may be mapped to annotations."

+ src/Morley/Michelson/Typed/Haskell/Instr.hs view

@@ -0,0 +1,10 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Typed.Haskell.Instr+  ( module Exports+  ) where++import Morley.Michelson.Typed.Haskell.Instr.Product as Exports+import Morley.Michelson.Typed.Haskell.Instr.Sum as Exports

+ src/Morley/Michelson/Typed/Haskell/Instr/Helpers.hs view

@@ -0,0 +1,23 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Helpers used for product and sum type representations+module Morley.Michelson.Typed.Haskell.Instr.Helpers+  ( Branch (..)+  , Path+  ) where++-- | Which branch to choose in generic tree representation: left,+-- straight or right. 'S' is used when there is one constructor with+-- one field (something newtype-like).+--+-- The reason why we need 'S' can be explained by this example:+-- data A = A1 B | A2 Integer+-- data B = B Bool+-- Now we may search for A1 constructor or B constructor. Without 'S' in+-- both cases path will be the same ([L]).+data Branch = L | S | R++-- | Path to a leaf (some field or constructor) in generic tree representation.+type Path = [Branch]

+ src/Morley/Michelson/Typed/Haskell/Instr/Product.hs view

@@ -0,0 +1,423 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE InstanceSigs #-}++-- | Instructions working on product types derived from Haskell ones.+module Morley.Michelson.Typed.Haskell.Instr.Product+  ( InstrGetFieldC+  , InstrSetFieldC+  , InstrConstructC+  , instrToField+  , instrSetField+  , instrConstruct+  , instrConstructStack+  , instrDeconstruct+  , InstrDeconstructC++  , GetFieldType+  , GLookupNamed+  , ConstructorFieldTypes+  , ConstructorFieldNames+  , FieldConstructor (..)+  , CastFieldConstructors (..)+  ) where++import Data.Vinyl.Core (Rec(..))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)++import Morley.Michelson.Text+import Morley.Michelson.Typed.Haskell.Instr.Helpers+import Morley.Michelson.Typed.Haskell.Value+import Morley.Michelson.Typed.Instr+import Morley.Util.Label (Label)+import Morley.Util.Named+import Morley.Util.Type++-- Fields lookup (helper)+----------------------------------------------------------------------------++-- | Result of field lookup - its type and path to it in+-- the tree.+data LookupNamedResult = LNR Type Path++type family LnrFieldType (lnr :: LookupNamedResult) where+  LnrFieldType ('LNR f _) = f+type family LnrBranch (lnr :: LookupNamedResult) :: Path where+  LnrBranch ('LNR _ p) = p++-- | Find field of some product type by its name.+--+-- Name might be either field record name, or one in 'NamedF' if+-- field is wrapped using 'Named.(:!)' or 'Named.(:?)'.+type GetNamed name a = LNRequireFound name a (GLookupNamed name (G.Rep a))++-- | Force result of 'GLookupNamed' to be 'Just'+type family LNRequireFound+  (name :: Symbol)+  (a :: Type)+  (mf :: Maybe LookupNamedResult)+    :: LookupNamedResult where+  LNRequireFound _ _ ('Just lnr) = lnr+  LNRequireFound name a 'Nothing = TypeError+    ('Text "Datatype " ':<>: 'ShowType a ':<>:+     'Text " has no field " ':<>: 'ShowType name)++type family GLookupNamed (name :: Symbol) (x :: Type -> Type)+          :: Maybe LookupNamedResult where+  GLookupNamed name (G.D1 _ x) = GLookupNamed name x+  GLookupNamed name (G.C1 _ x) = GLookupNamed name x++  GLookupNamed name (G.S1 ('G.MetaSel ('Just recName) _ _ _) (G.Rec0 a)) =+    If (name == recName)+      ('Just $ 'LNR a '[])+      'Nothing+  GLookupNamed name (G.S1 _ (G.Rec0 (NamedF f a fieldName))) =+    If (name == fieldName)+      ('Just $ 'LNR (NamedInner (NamedF f a fieldName)) '[])+      'Nothing+  GLookupNamed _ (G.S1 _ _) = 'Nothing+  GLookupNamed name (x :*: y) =+    LNMergeFound name (GLookupNamed name x) (GLookupNamed name y)+  GLookupNamed name (_ :+: _) = TypeError+    ('Text "Cannot seek for a field " ':<>: 'ShowType name ':<>:+     'Text " in sum type")+  GLookupNamed _ G.U1 = 'Nothing+  GLookupNamed _ G.V1 = TypeError+    ('Text "Cannot access fields of void-like type")++type family LNMergeFound+  (name :: Symbol)+  (f1 :: Maybe LookupNamedResult)+  (f2 :: Maybe LookupNamedResult)+    :: Maybe LookupNamedResult where+  LNMergeFound _ 'Nothing 'Nothing = 'Nothing+  LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p)+  LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p)+  LNMergeFound name ('Just _) ('Just _) = TypeError+    ('Text "Ambigous reference to datatype field: " ':<>: 'ShowType name)++-- | Get type of field by datatype it is contained in and field name.+type GetFieldType dt name = LnrFieldType (GetNamed name dt)++----------------------------------------------------------------------------+-- Value accessing instruction+----------------------------------------------------------------------------++-- | Make an instruction which accesses given field of the given datatype.+instrToField+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> Instr (ToT dt ': st) (ToT (GetFieldType dt name) ': st)+instrToField _ =+  gInstrToField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))+    @(GetFieldType dt name)++-- | Constraint for 'instrToField'.+type InstrGetFieldC dt name =+  ( GenericIsoValue dt+  , GInstrGet name (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (LnrFieldType (GetNamed name dt))+  )++{- Note about bulkiness of `instrToField` type signature:++Read this only if you are going to modify the signature qualitatively.++It may seem that you can replace 'LnrBranch' and 'LnrFieldType' getters since+their result is already assigned to a type variable, but if you do so,+on attempt to access non-existing field GHC will prompt you a couple of huge+"cannot deduce type" errors along with desired "field is not present".+To make error messages clearer we prevent GHC from deducing 'GInstrAccess' when+no field is found via using those getters.+-}++-- | Generic traversal for 'instrToField'.+class GIsoValue x =>+  GInstrGet+    (name :: Symbol)+    (x :: Type -> Type)+    (path :: Path)+    (fieldTy :: Type) where+  gInstrToField+    :: GIsoValue x+    => Instr (GValueType x ': s) (ToT fieldTy ': s)++instance GInstrGet name x path f => GInstrGet name (G.M1 t i x) path f where+  gInstrToField = gInstrToField @name @x @path @f++instance (IsoValue f, ToT f ~ ToT f') =>+         GInstrGet name (G.Rec0 f) '[] f' where+  gInstrToField = Nop++instance (GInstrGet name x path f, GIsoValue y) => GInstrGet name (x :*: y) ('L ': path) f where+  gInstrToField = CAR `Seq` gInstrToField @name @x @path @f++instance (GInstrGet name y path f, GIsoValue x) => GInstrGet name (x :*: y) ('R ': path) f where+  gInstrToField = CDR `Seq` gInstrToField @name @y @path @f++-- Examples+----------------------------------------------------------------------------++type MyType1 = ("int" :! Integer, "bytes" :! ByteString, "bytes2" :? ByteString)++_getIntInstr1 :: Instr (ToT MyType1 ': s) (ToT Integer ': s)+_getIntInstr1 = instrToField @MyType1 #int++_getTextInstr1 :: Instr (ToT MyType1 ': s) (ToT (Maybe ByteString) ': s)+_getTextInstr1 = instrToField @MyType1 #bytes2++data MyType2 = MyType2+  { getInt :: Integer+  , getText :: MText+  , getUnit :: ()+  , getMyType1 :: MyType1+  } deriving stock (Generic)+    deriving anyclass (IsoValue)++_getIntInstr2 :: Instr (ToT MyType2 ': s) (ToT () ': s)+_getIntInstr2 = instrToField @MyType2 #getUnit++_getIntInstr2' :: Instr (ToT MyType2 ': s) (ToT Integer ': s)+_getIntInstr2' =+  instrToField @MyType2 #getMyType1 `Seq` instrToField @MyType1 #int++----------------------------------------------------------------------------+-- Value modification instruction+----------------------------------------------------------------------------++-- | For given complex type @dt@ and its field @fieldTy@ update the field value.+instrSetField+  :: forall dt name st.+     InstrSetFieldC dt name+  => Label name -> Instr (ToT (GetFieldType dt name) ': ToT dt ': st) (ToT dt ': st)+instrSetField _ =+  gInstrSetField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))+    @(GetFieldType dt name)++-- | Constraint for 'instrSetField'.+type InstrSetFieldC dt name =+  ( GenericIsoValue dt+  , GInstrSetField name (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (LnrFieldType (GetNamed name dt))+  )++-- | Generic traversal for 'instrSetField'.+class GIsoValue x =>+  GInstrSetField+    (name :: Symbol)+    (x :: Type -> Type)+    (path :: Path)+    (fieldTy :: Type) where+  gInstrSetField+    :: Instr (ToT fieldTy ': GValueType x ': s) (GValueType x ': s)++instance GInstrSetField name x path f => GInstrSetField name (G.M1 t i x) path f where+  gInstrSetField = gInstrSetField @name @x @path @f++instance (IsoValue f, ToT f ~ ToT f') =>+         GInstrSetField name (G.Rec0 f) '[] f' where+  gInstrSetField = DIP DROP++instance (GInstrSetField name x path f, GIsoValue y) => GInstrSetField name (x :*: y) ('L ': path) f where+  gInstrSetField =+    DIP UNPAIR `Seq`+    gInstrSetField @name @x @path @f `Seq`+    PAIR++instance (GInstrSetField name y path f, GIsoValue x) => GInstrSetField name (x :*: y) ('R ': path) f where+  gInstrSetField =+    DIP (UNPAIR `Seq` SWAP) `Seq`+    gInstrSetField @name @y @path @f `Seq`+    SWAP `Seq` PAIR++-- Examples+----------------------------------------------------------------------------++_setIntInstr1 :: Instr (ToT Integer ': ToT MyType2 ': s) (ToT MyType2 ': s)+_setIntInstr1 = instrSetField @MyType2 #getInt++----------------------------------------------------------------------------+-- Value construction instruction+----------------------------------------------------------------------------++-- | Way to construct one of the fields in a complex datatype.+newtype FieldConstructor (st :: [k]) (field :: Type) =+  FieldConstructor (Instr (ToTs' st) (ToT field ': ToTs' st))++-- | Ability to pass list of fields with the same ToTs.+-- It may be useful if you don't want to work with NamedF in ConstructorFieldTypes.+class ToTs xs ~ ToTs ys => CastFieldConstructors xs ys where+  castFieldConstructorsImpl :: Rec (FieldConstructor st) xs -> Rec (FieldConstructor st) ys++instance CastFieldConstructors '[] '[] where+  castFieldConstructorsImpl RNil = RNil++instance (CastFieldConstructors xs ys, ToTs xs ~ ToTs ys, ToT x ~ ToT y)+    => CastFieldConstructors (x ': xs) (y ': ys) where+  castFieldConstructorsImpl (FieldConstructor fctr :& xs) =+    FieldConstructor fctr :& (castFieldConstructorsImpl @xs @ys xs)++-- | For given complex type @dt@ and its field @fieldTy@ update the field value.+instrConstruct+  :: forall dt st. InstrConstructC dt+  => Rec (FieldConstructor st) (ConstructorFieldTypes dt)+  -> Instr st (ToT dt ': st)+instrConstruct = gInstrConstruct @(G.Rep dt)++instrConstructStack+  :: forall dt stack st .+  ( InstrConstructC dt+  , stack ~ ToTs (ConstructorFieldTypes dt)+  , KnownList stack+  )+  => Instr (stack ++ st) (ToT dt ': st)+instrConstructStack =+  FrameInstr (Proxy @st) (gInstrConstructStack @(G.Rep dt))++-- | Types of all fields in a datatype.+type ConstructorFieldTypes dt = GFieldTypes (G.Rep dt)++-- | Names of all fields in a datatype.+type ConstructorFieldNames dt = GFieldNames (G.Rep dt)++-- | Constraint for 'instrConstruct' and 'gInstrConstructStack'.+type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (G.Rep dt))++-- | Retrieve field names of a constructor.+type family GFieldNames x :: [Symbol] where+  GFieldNames (G.D1 _ x) = GFieldNames x+  GFieldNames (G.C1 _ x) = GFieldNames x+  GFieldNames (x :*: y) = GFieldNames x ++ GFieldNames y+  GFieldNames (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) _) = '[fieldName]+  GFieldNames (G.S1 _ (G.Rec0 (NamedF _ _ fieldName))) = '[fieldName]++  GFieldNames (G.S1 ('G.MetaSel _ _ _ _) _) = TypeError ('Text "All fields have to be named")+  GFieldNames (_ :+: _) = TypeError ('Text "Cannot get field names of sum type")+  GFieldNames G.V1 = TypeError ('Text "Must be at least one constructor")++-- | Generic traversal for 'instrConstruct'.+class GIsoValue x => GInstrConstruct (x :: Type -> Type) where+  type GFieldTypes x :: [Type]+  gInstrConstruct :: Rec (FieldConstructor st) (GFieldTypes x) -> Instr st (GValueType x ': st)+  gInstrConstructStack :: Instr (ToTs (GFieldTypes x)) '[GValueType x]++instance GInstrConstruct x => GInstrConstruct (G.M1 t i x) where+  type GFieldTypes (G.M1 t i x) = GFieldTypes x+  gInstrConstruct = gInstrConstruct @x+  gInstrConstructStack = gInstrConstructStack @x++instance ( GInstrConstruct x, GInstrConstruct y+         , RSplit (GFieldTypes x) (GFieldTypes y)+         , KnownList (ToTs (GFieldTypes x)), KnownList (ToTs (GFieldTypes y))+         , ToTs (GFieldTypes x) ++ ToTs (GFieldTypes y) ~ ToTs (GFieldTypes x ++ GFieldTypes y)+         ) => GInstrConstruct (x :*: y) where+  type GFieldTypes (x :*: y) = GFieldTypes x ++ GFieldTypes y+  gInstrConstruct fs =+    let (lfs, rfs) = rsplit fs+        linstr = gInstrConstruct @x lfs+        rinstr = gInstrConstruct @y rfs+    in linstr `Seq` DIP rinstr `Seq` PAIR++  gInstrConstructStack =+    let linstr = gInstrConstructStack @x+        rinstr = gInstrConstructStack @y+    in FrameInstr (Proxy @(ToTs (GFieldTypes y))) linstr `Seq` DIP rinstr `Seq` PAIR++instance GInstrConstruct G.U1 where+  type GFieldTypes G.U1 = '[]+  gInstrConstruct RNil = UNIT+  gInstrConstructStack = UNIT++instance ( TypeError ('Text "Cannot construct sum type")+         , GIsoValue x, GIsoValue y+         ) => GInstrConstruct (x :+: y) where+  type GFieldTypes (x :+: y) = '[]+  gInstrConstruct = error "impossible"+  gInstrConstructStack = error "impossible"++instance ( TypeError ('Text "Cannot construct void-like type")+         ) => GInstrConstruct G.V1 where+  type GFieldTypes G.V1 = '[]+  gInstrConstruct = error "impossible"+  gInstrConstructStack = error "impossible"++instance IsoValue a => GInstrConstruct (G.Rec0 a) where+  type GFieldTypes (G.Rec0 a) = '[a]+  gInstrConstruct (FieldConstructor i :& RNil) = i+  gInstrConstructStack = Nop++-- Examples+----------------------------------------------------------------------------++_constructInstr1 :: Instr (ToT MyType1 ': s) (ToT MyType2 ': ToT MyType1 ': s)+_constructInstr1 =+  instrConstruct @MyType2 $+    FieldConstructor (PUSH (toVal @Integer 5)) :&+    FieldConstructor (PUSH (toVal @MText [mt||])) :&+    FieldConstructor UNIT :&+    FieldConstructor DUP :&+    RNil++_constructInstr2 :: Instr s (ToT MyType1 ': s)+_constructInstr2 =+  instrConstruct @MyType1 $+    FieldConstructor (PUSH (toVal @Integer 5)) :&+    FieldConstructor (PUSH (toVal @ByteString "bytestring1")) :&+    FieldConstructor (PUSH (toVal @(Maybe ByteString) (Just "bytestring2"))) :&+    RNil++----------------------------------------------------------------------------+-- Value deconstruction+----------------------------------------------------------------------------++-- | Constraint for 'instrConstruct'.+type InstrDeconstructC dt = (GenericIsoValue dt, GInstrDeconstruct (G.Rep dt))++-- | For given complex type @dt@ deconstruct it to its field types.+instrDeconstruct+  :: forall dt stack st .+  (InstrDeconstructC dt+  , stack ~ ToTs (ConstructorFieldTypes dt)+  , KnownList stack+  )+  => Instr (ToT dt ': st) (stack ++ st)+instrDeconstruct = FrameInstr (Proxy @st) $ gInstrDeconstruct @(G.Rep dt)++-- | Generic traversal for 'instrDeconstruct'.+class GIsoValue x => GInstrDeconstruct (x :: Type -> Type) where+  gInstrDeconstruct :: Instr '[GValueType x] (ToTs (GFieldTypes x))++instance GInstrDeconstruct x => GInstrDeconstruct (G.M1 t i x) where+  gInstrDeconstruct = gInstrDeconstruct @x++instance ( GInstrDeconstruct x, GInstrDeconstruct y+         , t ~ (x :*: y)+         , KnownList (ToTs (GFieldTypes x)), KnownList (ToTs (GFieldTypes y))+         , ToTs (GFieldTypes x) ++ ToTs (GFieldTypes y) ~ ToTs (GFieldTypes x ++ GFieldTypes y)+         ) => GInstrDeconstruct (x :*: y) where+  gInstrDeconstruct =+    let linstr = gInstrDeconstruct @x+        rinstr = gInstrDeconstruct @y+    in UNPAIR `Seq` DIP rinstr `Seq` FrameInstr (Proxy @(ToTs (GFieldTypes y))) linstr++instance GInstrDeconstruct G.U1 where+  gInstrDeconstruct = DROP++instance ( TypeError ('Text "Cannot deconstruct sum type")+         , GIsoValue x, GIsoValue y+         ) => GInstrDeconstruct (x :+: y) where+  gInstrDeconstruct = error "impossible"++instance ( TypeError ('Text "Cannot deconstruct void-like type")+         ) => GInstrDeconstruct G.V1 where+  gInstrDeconstruct = error "impossible"++instance IsoValue a => GInstrDeconstruct (G.Rec0 a) where+  gInstrDeconstruct = Nop

+ src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs view

@@ -0,0 +1,719 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Instructions working on sum types derived from Haskell ones.+module Morley.Michelson.Typed.Haskell.Instr.Sum+  ( InstrWrapC+  , InstrWrapOneC+  , InstrCaseC+  , InstrUnwrapC+  , instrWrap+  , instrWrapOne+  , hsWrap+  , instrCase+  , (//->)+  , unsafeInstrUnwrap+  , hsUnwrap++  , CaseClauseParam (..)+  , CaseClause (..)+  , CaseClauses+  , GCaseClauses+  , GCaseBranchInput++  , Branch (..)+  , Path+  , CtorField (..)+  , ExtractCtorField+  , AppendCtorField+  , AppendCtorFieldAxiom+  , appendCtorFieldAxiom+  , GetCtorField+  , CtorHasOnlyField+  , CtorOnlyField+  , MyCompoundType++    -- * Helpers+  , IsPrimitiveValue+  ) where++import Data.Singletons (SingI(..))+import Data.Type.Bool (type (||))+import Data.Vinyl.Core (Rec(..))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (AppendSymbol, ErrorMessage(..), Symbol, TypeError)+import Type.Reflection ((:~:)(Refl))+import Unsafe.Coerce (unsafeCoerce)++import Morley.Michelson.Text (MText, mt)+import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Haskell.Instr.Helpers+import Morley.Michelson.Typed.Haskell.Value+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.T+import Morley.Michelson.Typed.Value+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature)+import Morley.Util.Label (Label)+import Morley.Util.Named+import Morley.Util.Type+import Morley.Util.TypeTuple++-- Constructors lookup (helper)+----------------------------------------------------------------------------++-- | We support only two scenarious - constructor with one field and+-- without fields. Nonetheless, it's not that sad since for sum types+-- we can't even assign names to fields if there are many (the style+-- guide prohibits partial records).+data CtorField+  = OneField Type+  | NoFields++-- | Get /something/ as field of the given constructor.+type family ExtractCtorField (cf :: CtorField) where+  ExtractCtorField ('OneField t) = t+  ExtractCtorField 'NoFields = ()++-- | Push field to stack, if any.+type family AppendCtorField (cf :: CtorField) (l :: [k]) :: [k] where+  AppendCtorField ('OneField t) (l :: [T]) = ToT t ': l+  AppendCtorField ('OneField t) (l :: [Type]) = t ': l+  AppendCtorField 'NoFields (l :: [T]) = l+  AppendCtorField 'NoFields (l :: [Type]) = l++-- | To use 'AppendCtorField' not only here for 'T'-based stacks, but also+-- later in Lorentz with 'Type'-based stacks we need the following property.+type AppendCtorFieldAxiom (cf :: CtorField) (st :: [Type]) =+  ToTs (AppendCtorField cf st) ~ AppendCtorField cf (ToTs st)++-- | Proof of 'AppendCtorFieldAxiom'.+appendCtorFieldAxiom+  :: ( AppendCtorFieldAxiom ('OneField Word) '[Int]+     , AppendCtorFieldAxiom 'NoFields '[Int]+     )+  => Dict (AppendCtorFieldAxiom cf st)+appendCtorFieldAxiom =+  -- In order to avoid a lot of boilerplate and burdening GHC type checker we+  -- write an unsafe code. Its correctness is tested in dummy constraints of+  -- this function.+  -- Alternative approach I compare this unsafe one with+  -- would be to implement @instance SingI@ for 'CtorField' and consider cases+  -- of 'CtorField' one by one, but this would require propagading+  -- @SingI (cf :: CtorField)@ constraint to all users of 'appendCtorFieldAxiom'.+  unsafeCoerce $ Dict @(AppendCtorFieldAxiom 'NoFields '[])++-- | Result of constructor lookup - entry type and path to it in the tree.+data LookupNamedResult = LNR CtorField Path++type family LnrFieldType (lnr :: LookupNamedResult) where+  LnrFieldType ('LNR f _) = f+type family LnrBranch (lnr :: LookupNamedResult) :: Path where+  LnrBranch ('LNR _ p) = p++-- | Transitively find constructor of some sum type by its name.+--+-- Transitivity means that if sum type consists of other sum types,+-- they will be searched recursively.+type GetNamed name a = LNRequireFound name a (GLookupNamed name (G.Rep a))++-- | Force result of 'GLookupNamed' to be 'Just'+type family LNRequireFound+  (name :: Symbol)+  (a :: Type)+  (mf :: Maybe LookupNamedResult)+    :: LookupNamedResult where+  LNRequireFound _ _ ('Just lnr) = lnr+  LNRequireFound name a 'Nothing = TypeError+    ('Text "Datatype " ':<>: 'ShowType a ':<>:+     'Text " has no (sub)constructor " ':<>: 'ShowType name)++type family GLookupNamed (name :: Symbol) (x :: Type -> Type)+          :: Maybe LookupNamedResult where+  GLookupNamed name (G.D1 _ x) = GLookupNamed name x+  GLookupNamed name (G.C1 ('G.MetaCons ctorName _ _) x) =+    -- This case corresponds to going straight into a data type (as+    -- opposed to going left or right when we encounter a sum type),+    -- so we need to prepend 'S' here if we successfully find a+    -- constructor.+    PrependS+    -- If we encounter a constructor with requested name, we consider+    -- search successful.+    (If (name == ctorName || name == ("c" `AppendSymbol` ctorName))+       ('Just $ 'LNR (GExtractFields x) '[])+        -- If we do not, we check whether we can go deeper (see+        -- description below).+        (If (GCanGoDeeper x)+        -- And here we essentially just recursively call this search.+        (GLookupNamedDeeper name x)+        -- Or return 'Nothing' if we can not go deeper.+         'Nothing+      )+    )+  GLookupNamed name (x :+: y) =+    LNMergeFound name (GLookupNamed name x) (GLookupNamed name y)+  GLookupNamed _ G.V1 = 'Nothing++-- Prepend 'S' to the path inside 'LookupNamedResult' (if 'Just' is passed).+-- Should be done in the case when we go straight into a data type.+type family PrependS (x :: Maybe LookupNamedResult) :: Maybe LookupNamedResult where+  PrependS 'Nothing = 'Nothing+  PrependS ('Just ('LNR cf path)) = 'Just ('LNR cf ('S ': path))++-- Helper type family to check whether we should search for a+-- constructor inside given data type which is supposed to be part of+-- another constructor. Basically we can go deeper only if we+-- encounter another ADT with a constructor storing at least something+-- and which is not a primitive type. We do not go deeper when we+-- encounter a product type here, because it means that there are multiple+-- fields inside one constructor (it is not supported).+type family GCanGoDeeper (x :: Type -> Type) :: Bool where+  GCanGoDeeper (_ :+: _) = 'True+  GCanGoDeeper (G.D1 _ x) = GCanGoDeeper x+  GCanGoDeeper (G.S1 _ (G.Rec0 x)) = CanGoDeeper x+  GCanGoDeeper (G.C1 _ _) = 'True+  GCanGoDeeper G.V1 = 'False+  GCanGoDeeper G.U1 = 'False+  GCanGoDeeper (_ :*: _) = 'False+  GCanGoDeeper x = TypeError+    ('Text "GCanGoDeeper encountered unexpected pattern: " ':<>: 'ShowType x)++-- | Whether given type represents an atomic Michelson value.+type family IsPrimitiveValue (x :: Type) :: Bool where+  IsPrimitiveValue (Maybe _) = 'True+  IsPrimitiveValue (NamedF _ _ _) = 'True+  IsPrimitiveValue Integer = 'True+  IsPrimitiveValue Natural = 'True+  IsPrimitiveValue Text = 'True+  IsPrimitiveValue MText = 'True+  IsPrimitiveValue Bool = 'True+  IsPrimitiveValue ByteString = 'True+  IsPrimitiveValue Mutez = 'True+  IsPrimitiveValue Address = 'True+  IsPrimitiveValue EpAddress = 'True+  IsPrimitiveValue KeyHash = 'True+  IsPrimitiveValue Timestamp = 'True+  IsPrimitiveValue PublicKey = 'True+  IsPrimitiveValue Signature = 'True+  IsPrimitiveValue (ContractRef _) = 'True+  IsPrimitiveValue (BigMap _ _) = 'True+  IsPrimitiveValue (Map _ _) = 'True+  IsPrimitiveValue (Set _) = 'True+  IsPrimitiveValue ([_]) = 'True+  IsPrimitiveValue (Operation' _) = 'True+  IsPrimitiveValue ChainId = 'True+  IsPrimitiveValue _ = 'False++-- Some types don't have Generic instances (e. g. primitives like Integer), so+-- we need another type family to handle them.+type CanGoDeeper (x :: Type) =+  If (IsPrimitiveValue x)+     'False+     (GCanGoDeeper (G.Rep x))++type family GLookupNamedDeeper (name :: Symbol) (x :: Type -> Type)+          :: Maybe LookupNamedResult where+  GLookupNamedDeeper name (G.S1 _ (G.Rec0 y))  = GLookupNamed name (G.Rep y)+  GLookupNamedDeeper name _ = TypeError+    ('Text "Attempt to go deeper failed while looking for sum type constructor"+     ':<>: 'ShowType name+     ':$$:+     'Text "Make sure that all constructors have exactly one field inside."+    )++type family LNMergeFound+  (name :: Symbol)+  (f1 :: Maybe LookupNamedResult)+  (f2 :: Maybe LookupNamedResult)+    :: Maybe LookupNamedResult where+  LNMergeFound _ 'Nothing 'Nothing = 'Nothing+  LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p)+  LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p)+  LNMergeFound name ('Just _) ('Just _) = TypeError+    ('Text "Ambiguous reference to datatype constructor: " ':<>: 'ShowType name)++type family GExtractFields (x :: Type -> Type)+          :: CtorField where+  GExtractFields (G.S1 _ x) = GExtractFields x+  GExtractFields (G.Rec0 a) = 'OneField a+  GExtractFields G.U1 = 'NoFields+  GExtractFields (_ :*: _) = TypeError+    ('Text "Cannot automatically lookup constructors having multiple fields"+     ':$$:+     'Text "Consider using tuple instead")+    --- ^ @martoon: Probably we will have no use cases for such scenario+    --- anyway, tuples seem to be not worse than separate fields in most cases.++-- | Get type of constructor fields (one or zero) referred by given datatype+-- and name.+type GetCtorField dt ctor =+  LnrFieldType (GetNamed ctor dt)++-- | Expect referred constructor to have only one field (in form of constraint)+-- and extract its type.+type CtorHasOnlyField ctor dt f =+  GetCtorField dt ctor ~ 'OneField f++type family RequireOneField (ctor :: Symbol) (cf :: CtorField) :: Type where+  RequireOneField _ ('OneField f) = f+  RequireOneField ctor 'NoFields = TypeError+    ('Text "Expected exactly one field" ':$$:+     'Text "In constructor " ':<>: 'ShowType ctor)++-- | Expect referred constructor to have only one field+-- (otherwise compile error is raised) and extract its type.+type CtorOnlyField name dt =+  RequireOneField name (GetCtorField dt name)++----------------------------------------------------------------------------+-- Constructor wrapping instruction+----------------------------------------------------------------------------++-- | Wrap given element into a constructor with the given name.+--+-- Mentioned constructor must have only one field.+--+-- Since labels interpretable by @OverloadedLabels@ extension cannot+-- start with capital latter, prepend constructor name with letter+-- "c" (see examples below).+instrWrap+  :: forall dt name st.+     InstrWrapC dt name+  => Label name+  -> Instr (AppendCtorField (GetCtorField dt name) st)+           (ToT dt ': st)+instrWrap _ =+  gInstrWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                         @(LnrFieldType (GetNamed name dt))++-- | Like 'instrWrap' but only works for contructors with a single field.+-- Results in a type error if a constructor with no field is used instead.+instrWrapOne+  :: forall dt name st.+     InstrWrapOneC dt name+  => Label name+  -> Instr (ToT (CtorOnlyField name dt) ': st) (ToT dt ': st)+instrWrapOne _ =+  gInstrWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                         @(LnrFieldType (GetNamed name dt))++type InstrWrapC dt name =+  ( GenericIsoValue dt+  , GInstrWrap (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (LnrFieldType (GetNamed name dt))+  )++type InstrWrapOneC dt name =+  ( InstrWrapC dt name+  , GetCtorField dt name ~ 'OneField (CtorOnlyField name dt)+  )++-- | Wrap a haskell value into a constructor with the given name.+--+-- This is symmetric to 'instrWrap'.+hsWrap+  :: forall dt name.+     InstrWrapC dt name+  => Label name+  -> ExtractCtorField (GetCtorField dt name)+  -> dt+hsWrap _ =+  G.to . gHsWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                             @(LnrFieldType (GetNamed name dt))++-- | Generic traversal for 'instrWrap'.+class GIsoValue x =>+  GInstrWrap+    (x :: Type -> Type)+    (path :: Path)+    (entryTy :: CtorField) where+  gInstrWrap+    :: GIsoValue x+    => Instr (AppendCtorField entryTy s) (GValueType x ': s)+  gHsWrap+    :: GIsoValue x+    => ExtractCtorField entryTy -> x p++instance GInstrWrap x path e => GInstrWrap (G.D1 i x) path e where+  gInstrWrap = gInstrWrap @x @path @e+  gHsWrap = G.M1 . gHsWrap @x @path @e++instance (GInstrWrap x path e, GIsoValue y, SingI (GValueType y)) =>+         GInstrWrap (x :+: y) ('L ': path) e where+  gInstrWrap = gInstrWrap @x @path @e `Seq` LEFT+  gHsWrap = G.L1 . gHsWrap @x @path @e++instance (GInstrWrap y path e, GIsoValue x, SingI (GValueType x)) =>+         GInstrWrap (x :+: y) ('R ': path) e where+  gInstrWrap = gInstrWrap @y @path @e `Seq` RIGHT+  gHsWrap = G.R1 . gHsWrap @y @path @e++instance (IsoValue e) =>+         GInstrWrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] ('OneField e) where+  gInstrWrap = Nop+  gHsWrap = G.M1 . G.M1 . G.K1++-- This is the case when a sum type is part of another sum type.+-- Here 'sub' is intermediate sum type.+instance ( path ~ (x ': xs)+         , GInstrWrap (G.Rep sub) path e+         , GenericIsoValue sub+         , GIsoValue (G.Rep sub)+         ) =>+         GInstrWrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where+  gInstrWrap = gInstrWrap @(G.Rep sub) @path @e+  gHsWrap = G.M1 . G.M1 . G.K1 . G.to . gHsWrap @(G.Rep sub) @path @e++instance GInstrWrap (G.C1 c G.U1) '[ 'S] 'NoFields where+  gInstrWrap = PUSH VUnit+  gHsWrap () = G.M1 G.U1++-- Examples+----------------------------------------------------------------------------++-- TODO [TM-186] Consider moving this stuff to test-suite using+-- doctest. Or at least add tests for correctness.++data MyType+  = MyCtor Integer+  | ComplexThing ()+  | UselessThing ("field1" :! ByteString, "field2" :! ())+  deriving stock Generic+  deriving anyclass IsoValue++_MyTypeMyCtor ::+  GetNamed "cMyCtor" MyType :~: 'LNR ('OneField Integer) '[ 'L, 'S]+_MyTypeMyCtor = Refl++_MyTypeComplexThing ::+  GetNamed "cComplexThing" MyType :~: 'LNR ('OneField ()) '[ 'R, 'L, 'S]+_MyTypeComplexThing = Refl++_wrapMyType1 :: Instr (ToT Integer ': s) (ToT MyType ': s)+_wrapMyType1 = instrWrap @MyType #cMyCtor++-- If @c@ prefix is too annoying, one can construct labels without+-- @OverloadedLabels@ extension.+_wrapMyType1' :: Instr (ToT Integer ': s) (ToT MyType ': s)+_wrapMyType1' = instrWrap @MyType @"MyCtor" fromLabel++_wrapMyType2 :: Instr (ToT () ': s) (ToT MyType ': s)+_wrapMyType2 = instrWrap @MyType #cComplexThing++_wrapMyType3 :: Instr (ToT (ByteString, ()) ': s) (ToT MyType ': s)+_wrapMyType3 = instrWrap @MyType #cUselessThing++data MyType' = WrapBool Bool+  deriving stock Generic+  deriving anyclass IsoValue++_MyType'WrapBool ::+  GetNamed "cWrapBool" MyType' :~: 'LNR ('OneField Bool) '[ 'S]+_MyType'WrapBool = Refl++_wrapMyType' :: Instr (ToT Bool ': s) (ToT MyType' ': s)+_wrapMyType' = instrWrap @MyType' #cWrapBool++data MyCompoundType+  = CompoundPart1 MyType+  | CompoundPart2 Integer+  | CompoundPart3 Address+  | CompoundPart4 MyType'+  deriving stock Generic+  deriving anyclass IsoValue++_MyCompoundTypeCompoundPart1 ::+  GetNamed "cCompoundPart1" MyCompoundType :~: 'LNR ('OneField MyType) '[ 'L, 'L, 'S]+_MyCompoundTypeCompoundPart1 = Refl++_MyCompoundTypeMyCtor ::+  GetNamed "cMyCtor" MyCompoundType :~: 'LNR ('OneField Integer) '[ 'L, 'L, 'S, 'L, 'S]+_MyCompoundTypeMyCtor = Refl++_MyCompoundTypeCompoundPart2 ::+  GetNamed "cCompoundPart2" MyCompoundType :~: 'LNR ('OneField Integer) '[ 'L, 'R, 'S]+_MyCompoundTypeCompoundPart2 = Refl++_MyCompoundTypeCompoundPart4 ::+  GetNamed "cCompoundPart4" MyCompoundType :~: 'LNR ('OneField MyType') '[ 'R, 'R, 'S]+_MyCompoundTypeCompoundPart4 = Refl++_MyCompoundTypeWrapBool ::+  GetNamed "cWrapBool" MyCompoundType :~: 'LNR ('OneField Bool) '[ 'R, 'R, 'S, 'S]+_MyCompoundTypeWrapBool = Refl++_wrapMyCompoundType1 :: Instr (ToT Integer ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType1 = instrWrap @MyCompoundType #cMyCtor++_wrapMyCompoundType2 :: Instr (ToT Integer ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType2 = instrWrap @MyCompoundType #cCompoundPart2++_wrapMyCompoundType3 :: Instr (ToT Bool ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType3 = instrWrap @MyCompoundType #cWrapBool++_wrapMyCompoundType4 :: Instr (ToT MyType' ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType4 = instrWrap @MyCompoundType #cCompoundPart4++data MyEnum = Case1 | Case2 | CaseN Integer | CaseDef+  deriving stock Generic+  deriving anyclass IsoValue++_wrapMyEnum1 :: Instr s (ToT MyEnum ': s)+_wrapMyEnum1 = instrWrap @MyEnum #cCase1++_wrapMyEnum2 :: Instr (ToT Integer ': s) (ToT MyEnum ': s)+_wrapMyEnum2 = instrWrap @MyEnum #cCaseN++data MyTypeWithNamedField+  = MeaninglessCtor+  | CtorWithNamedField ("name" :! Natural)+  deriving stock Generic+  deriving anyclass IsoValue++_accessMyTypeWithNamedField :: Instr (ToT Natural ': s) (ToT MyTypeWithNamedField ': s)+_accessMyTypeWithNamedField = instrWrap @MyTypeWithNamedField #cCtorWithNamedField++----------------------------------------------------------------------------+-- "case" instruction+----------------------------------------------------------------------------++-- | Pattern-match on the given datatype.+instrCase+  :: forall dt out inp.+     InstrCaseC dt+  => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt ': inp) out+instrCase = gInstrCase @(G.Rep dt)++type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (G.Rep dt))++-- | In what different case branches differ - related constructor name and+-- input stack type which the branch starts with.+data CaseClauseParam = CaseClauseParam Symbol CtorField++-- | Type information about single case clause.+data CaseClause (inp :: [T]) (out :: [T]) (param :: CaseClauseParam) where+  CaseClause+    :: RemFail Instr (AppendCtorField x inp) out+    -> CaseClause inp out ('CaseClauseParam ctor x)++-- | Lift an instruction to case clause.+--+-- You should write out constructor name corresponding to the clause+-- explicitly. Prefix constructor name with "c" letter, otherwise+-- your label will not be recognized by Haskell parser.+-- Passing constructor name can be circumvented but doing so is not recomended+-- as mentioning contructor name improves readability and allows avoiding+-- some mistakes.+(//->)+  :: Label ("c" `AppendSymbol` ctor)+  -> RemFail Instr (AppendCtorField x inp) out+  -> CaseClause inp out ('CaseClauseParam ctor x)+(//->) _ = CaseClause+infixr 8 //->++-- | List of 'CaseClauseParam's required to pattern match on the given type.+type CaseClauses a = GCaseClauses (G.Rep a)++-- | Generic traversal for 'instrWrap'.+class GIsoValue x => GInstrCase (x :: Type -> Type) where++  type GCaseClauses x :: [CaseClauseParam]++  gInstrCase+    :: GIsoValue x+    => Rec (CaseClause inp out) (GCaseClauses x) -> RemFail Instr (GValueType x ': inp) out++instance GInstrCase x => GInstrCase (G.D1 i x) where+  type GCaseClauses (G.D1 i x) = GCaseClauses x+  gInstrCase = gInstrCase @x++instance (GInstrCase x, GInstrCase y, RSplit (GCaseClauses x) (GCaseClauses y)) =>+         GInstrCase (x :+: y) where+  type GCaseClauses (x :+: y) = GCaseClauses x ++ GCaseClauses y+  gInstrCase clauses =+    let (leftClauses, rightClauses) = rsplit clauses+    in rfMerge IF_LEFT (gInstrCase @x leftClauses) (gInstrCase @y rightClauses)++instance GInstrCase G.V1 where+  type GCaseClauses G.V1 = '[]+  gInstrCase RNil = RfAlwaysFails NEVER++instance GInstrCaseBranch ctor x => GInstrCase (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GCaseClauses (G.C1 ('G.MetaCons ctor _1 _2) x) = '[GCaseBranchInput ctor x]+  gInstrCase (clause :& RNil) = gInstrCaseBranch @ctor @x clause++-- | Traverse a single contructor and supply its field to instruction in case clause.+class GIsoValue x =>+      GInstrCaseBranch (ctor :: Symbol) (x :: Type -> Type) where++  type GCaseBranchInput ctor x :: CaseClauseParam++  gInstrCaseBranch+    :: CaseClause inp out (GCaseBranchInput ctor x)+    -> RemFail Instr (GValueType x ': inp) out++instance+  ( GIsoValue x, GIsoValue y+  , TypeError ('Text "Cannot pattern match on constructors with more than 1 field"+               ':$$: 'Text "Consider using tuples instead")+  ) => GInstrCaseBranch ctor (x :*: y) where++  type GCaseBranchInput ctor (x :*: y) = 'CaseClauseParam ctor 'NoFields+  gInstrCaseBranch = error "impossible"++instance GInstrCaseBranch ctor x => GInstrCaseBranch ctor (G.S1 i x) where+  type GCaseBranchInput ctor (G.S1 i x) = GCaseBranchInput ctor x+  gInstrCaseBranch = gInstrCaseBranch @ctor @x++instance IsoValue a => GInstrCaseBranch ctor (G.Rec0 a) where+  type GCaseBranchInput ctor (G.Rec0 a) = 'CaseClauseParam ctor ('OneField a)+  gInstrCaseBranch (CaseClause i) = i++instance GInstrCaseBranch ctor G.U1 where+  type GCaseBranchInput ctor G.U1 = 'CaseClauseParam ctor 'NoFields+  gInstrCaseBranch (CaseClause i) = rfMapAnyInstr (DROP `Seq`) i++-- Examples+----------------------------------------------------------------------------++_caseMyType :: RemFail Instr (ToT MyType ': s) (ToT Integer ': s)+_caseMyType = instrCase @MyType $+     #cMyCtor //-> RfNormal Nop+  :& #cComplexThing //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 5))+  :& #cUselessThing //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 0))+  :& RNil++-- Another version, written via tuple.+_caseMyType2 :: RemFail Instr (ToT MyType ': s) (ToT Integer ': s)+_caseMyType2 = instrCase @MyType $ recFromTuple+  ( #cMyCtor //->+      RfNormal Nop+  , #cComplexThing //->+      RfNormal (DROP `Seq` PUSH (toVal @Integer 5))+  , #cUselessThing //->+      RfNormal (DROP `Seq` PUSH (toVal @Integer 0))+  )++_caseMyEnum :: RemFail Instr (ToT MyEnum ': ToT Integer ': s) (ToT Integer ': s)+_caseMyEnum = instrCase @MyEnum $ recFromTuple+  ( #cCase1 //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 1))+  , #cCase2 //-> RfNormal (DROP `Seq` PUSH (toVal @Integer 2))+  , #cCaseN //-> RfNormal (DIP DROP `Seq` Nop)+  , #cCaseDef //-> RfNormal Nop+  )++----------------------------------------------------------------------------+-- Constructor unwrapping instruction+----------------------------------------------------------------------------++-- | Unwrap a constructor with the given name.+--+-- Rules which apply to 'instrWrap' function work here as well.+-- Although, unlike @instrWrap@, this function does not work for nullary+-- constructors.+unsafeInstrUnwrap+  :: forall dt name st.+     InstrUnwrapC dt name+  => Label name+  -> Instr (ToT dt ': st)+           (ToT (CtorOnlyField name dt) ': st)+unsafeInstrUnwrap _ =+  unsafeGInstrUnwrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                                 @(CtorOnlyField name dt)++type InstrUnwrapC dt name =+  ( GenericIsoValue dt+  , GInstrUnwrap (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (CtorOnlyField name dt)+  )++-- | Try to unwrap a constructor with the given name.+hsUnwrap+  :: forall dt name.+     InstrUnwrapC dt name+  => Label name+  -> dt+  -> Maybe (CtorOnlyField name dt)+hsUnwrap _ =+  gHsUnwrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+            @(CtorOnlyField name dt) .+  G.from++class GIsoValue x =>+  GInstrUnwrap+    (x :: Type -> Type)+    (path :: Path)+    (entryTy :: Type) where+  unsafeGInstrUnwrap+    :: GIsoValue x+    => Instr (GValueType x ': s) (ToT entryTy ': s)+  gHsUnwrap+    :: x p -> Maybe entryTy++instance GInstrUnwrap x path e => GInstrUnwrap (G.D1 i x) path e where+  unsafeGInstrUnwrap = unsafeGInstrUnwrap @x @path @e+  gHsUnwrap = gHsUnwrap @x @path @e . G.unM1++instance (GInstrUnwrap x path e, GIsoValue y, SingI (GValueType y)) =>+         GInstrUnwrap (x :+: y) ('L ': path) e where+  unsafeGInstrUnwrap = IF_LEFT (unsafeGInstrUnwrap @x @path @e) failWithWrongCtor+  gHsUnwrap = \case+    G.L1 x -> gHsUnwrap @x @path @e x+    G.R1 _ -> Nothing++instance (GInstrUnwrap y path e, GIsoValue x, SingI (GValueType x)) =>+         GInstrUnwrap (x :+: y) ('R ': path) e where+  unsafeGInstrUnwrap = IF_LEFT failWithWrongCtor (unsafeGInstrUnwrap @y @path @e)+  gHsUnwrap = \case+    G.R1 y -> gHsUnwrap @y @path @e y+    G.L1 _ -> Nothing++instance (IsoValue e) =>+         GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] e where+  unsafeGInstrUnwrap = Nop+  gHsUnwrap = Just . G.unK1 . G.unM1 . G.unM1++-- This is the case when a sum type is part of another sum type.+-- Here 'sub' is intermediate sum type.+instance ( path ~ (x ': xs)+         , GInstrUnwrap (G.Rep sub) path e+         , GenericIsoValue sub+         , GIsoValue (G.Rep sub)+         ) =>+         GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where+  unsafeGInstrUnwrap = unsafeGInstrUnwrap @(G.Rep sub) @path @e+  gHsUnwrap = gHsUnwrap @(G.Rep sub) @path @e . G.from . G.unK1 . G.unM1 . G.unM1++-- | Failure indicating that we expected value created with one constructor,+-- but got value with different one.+-- The error message is intentionally ugly to keep it relatively short and+-- save on gas.+failWithWrongCtor :: Instr i o+failWithWrongCtor =+  PUSH (toVal [mt|BadCtor|]) `Seq`+  FAILWITH++-- Examples+----------------------------------------------------------------------------++_unwrapMyType :: Instr (ToT MyType ': s) (ToT Integer ': s)+_unwrapMyType = unsafeInstrUnwrap @MyType #cMyCtor++_unwrapMyCompoundType :: Instr (ToT MyCompoundType ': s) (ToT Integer ': s)+_unwrapMyCompoundType = unsafeInstrUnwrap @MyCompoundType #cMyCtor++_unwrapMyCompoundType2 :: Instr (ToT MyCompoundType ': s) (ToT Address ': s)+_unwrapMyCompoundType2 = unsafeInstrUnwrap @MyCompoundType #cCompoundPart3++_unwrapMyCompoundType3 :: Instr (ToT MyCompoundType ': s) (ToT Bool ': s)+_unwrapMyCompoundType3 = unsafeInstrUnwrap @MyCompoundType #cWrapBool++_unwrapMyCompoundType4 :: Instr (ToT MyCompoundType ': s) (ToT MyType' ': s)+_unwrapMyCompoundType4 = unsafeInstrUnwrap @MyCompoundType #cCompoundPart4

+ src/Morley/Michelson/Typed/Haskell/LooseSum.hs view

@@ -0,0 +1,129 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Representation of Haskell sum types via loosy typed Michelson values,+-- useful for e.g. errors and enums.+--+-- In particular, ADT sum can be represented as constructor name + data+-- it carries. Such expression does not have particular type because+-- different constructors may carry different data, and we avoid lifting+-- this data to a union in order to keep only the significant parts+-- (and thus not to confuse the client).+module Morley.Michelson.Typed.Haskell.LooseSum+  ( ComposeResult (..)+  , fromTaggedVal+  , toTaggedVal+  , LooseSumC+  ) where++import Data.Singletons+import GHC.Generics ((:*:), (:+:))+import qualified GHC.Generics as G++import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Existential+import Morley.Michelson.Typed.Haskell.Value+import Morley.Michelson.Typed.T+import Morley.Util.Sing (castSing)+import Morley.Util.TypeLits++-- | Possible outcomes of an attempt to construct a Haskell ADT value+-- from constructor name and relevant data.+data ComposeResult a+  = ComposeOk a+    -- ^ Composed fine.+  | ComposeCtorNotFound+    -- ^ No constructor with such name.+  | ComposeFieldTypeMismatch T T+    -- ^ Found required constructor, but type of data does not correspond+    -- to provided one.+  deriving stock (Functor)++instance Semigroup (ComposeResult a) where+  r@(ComposeOk _) <> _ = r+  _ <> r@(ComposeOk _) = r+  r@(ComposeFieldTypeMismatch _ _) <> _ = r+  _ <> r@(ComposeFieldTypeMismatch _ _) = r+  r@ComposeCtorNotFound <> ComposeCtorNotFound = r++instance Monoid (ComposeResult a) where+  mempty = ComposeCtorNotFound+  mappend = (<>)++-- | Constraint for 'toTaggedVal' and 'fromTaggedVal'.+type LooseSumC dt =+  ( Generic dt, GLooseSum (G.Rep dt)+  )++-- | Decompose Haskell type into constructor name and+-- data it carries, converting the latter into Michelson 'Value'.+toTaggedVal :: LooseSumC dt => dt -> (Text, SomeValue)+toTaggedVal = gToTaggedVal . G.from++-- | Inverse to 'toTaggedVal'.+fromTaggedVal :: LooseSumC dt => (Text, SomeValue) -> ComposeResult dt+fromTaggedVal = fmap G.to . gFromTaggedVal++-- | Generic traversal for 'toTaggedVal' and 'fromTaggedVal'.+class GLooseSum (x :: Type -> Type) where+  gToTaggedVal :: x p -> (Text, SomeValue)+  gFromTaggedVal :: (Text, SomeValue) -> ComposeResult (x p)++instance GLooseSum x => GLooseSum (G.D1 i x) where+  gToTaggedVal = gToTaggedVal . G.unM1+  gFromTaggedVal = fmap G.M1 . gFromTaggedVal++instance (GLooseSum x, GLooseSum y) => GLooseSum (x :+: y) where+  gToTaggedVal = \case+    G.L1 x -> gToTaggedVal x+    G.R1 y -> gToTaggedVal y+  gFromTaggedVal v = mconcat+    [ G.L1 <$> gFromTaggedVal v+    , G.R1 <$> gFromTaggedVal v+    ]++instance (GAccessField x, KnownSymbol ctor) =>+         GLooseSum (G.C1 ('G.MetaCons ctor f o) x) where+  gToTaggedVal = (symbolValT' @ctor, ) . gExtractField @x . G.unM1+  gFromTaggedVal (ctor, val)+    | symbolValT' @ctor == ctor = G.M1 <$> gMakeField @x val+    | otherwise = ComposeCtorNotFound++instance GLooseSum G.V1 where+  gToTaggedVal = \case{}+  gFromTaggedVal _ = mempty++-- | Pick a field from constructor with zero or one fields.+class GAccessField (x :: Type -> Type) where+  gExtractField :: x p -> SomeValue+  gMakeField :: SomeValue -> ComposeResult (x p)++instance GAccessField x => GAccessField (G.S1 i x) where+  gExtractField = gExtractField . G.unM1+  gMakeField v = G.M1 <$> gMakeField @x v++instance IsoValue a =>+         GAccessField (G.Rec0 a) where+  gExtractField = SomeValue . toVal . G.unK1+  gMakeField (SomeValue v) = G.K1 . fromVal <$> composeCast v++instance GAccessField G.U1 where+  gExtractField G.U1 = SomeValue $ toVal ()+  gMakeField (SomeValue v) = G.U1 <$ composeCast @_ @'TUnit v++composeCast :: forall a b. (SingI a, SingI b) => Value a -> ComposeResult (Value b)+composeCast a =+  case castSing a of+    Nothing -> ComposeFieldTypeMismatch (demote @a) (demote @b)+    Just b -> ComposeOk b++instance+  TypeError ('Text "Cannot compose/decompose constructors with more \+             \than one field" ':$$:+             'Text "Consider using tuple instead") =>+  GAccessField (x :*: y) where+  gExtractField = error "impossible"+  gMakeField = error "impossible"

+ src/Morley/Michelson/Typed/Haskell/ValidateDescription.hs view

@@ -0,0 +1,135 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Type-level field description validators+module Morley.Michelson.Typed.Haskell.ValidateDescription+  ( FieldDescriptions+  , FieldDescriptionsV++  , FieldDescriptionsValid+  ) where++import Data.Singletons (Demote)+import Data.Type.Bool+import qualified GHC.Generics as G+import GHC.TypeLits++-- | Description of constructors and fields of some datatype.+--+-- This type is just two nested maps represented as associative lists. It is supposed to+-- be interpreted like this:+--+-- > [(Constructor name, (Maybe constructor description, [(Field name, Field description)]))]+--+-- Example with a concrete data type:+--+-- > data Foo+-- >   = Foo+-- >       { fFoo :: Int+-- >       }+-- >   | Bar+-- >       { fBar :: Text+-- >       }+-- >   deriving (Generic)+-- >+-- > type FooDescriptions =+-- >   '[ '( "Foo", '( 'Just "foo constructor",+-- >       , '[ '("fFoo", "some number")+-- >          ])+-- >       )+-- >    , '( "Bar", '( 'Nothing,+-- >       , '[ '("fBar", "some string")+-- >          ])+-- >       )+-- >    ]+type FieldDescriptions = [(Symbol, (Maybe Symbol, [(Symbol, Symbol)]))]++-- | Value-level counterpart to 'FieldDescriptions'.+type FieldDescriptionsV = Demote FieldDescriptions++-- | This type family checks that field descriptions mention only existing constructors and fields.+--+-- When @descr@ is empty this family does nothing, to avoid breaking for built-in, non-ADT types.+--+-- When @descr@ is not empty, this family will demand 'G.Generic' instance for @typ@ and fail with a+-- 'TypeError' if there none.+type family FieldDescriptionsValid (descr :: FieldDescriptions) (typ :: Type) :: Constraint where+  FieldDescriptionsValid '[] _ = ()+  FieldDescriptionsValid descr typ =+    Assert+      (TypeError+        ('Text "No Generic instance for " ':<>: 'ShowType typ ':<>: 'Text "." ':$$:+         'Text "Generic is needed to validate TypeDocFieldDescriptions.")+      )+      (G.Rep typ)+      (FieldDescriptionsValidImpl descr typ)++-- | Actual recursive implementation for 'FieldDescriptionsValid'.+type family FieldDescriptionsValidImpl (descr :: FieldDescriptions) (typ :: Type) :: Constraint where+  FieldDescriptionsValidImpl '[] _ = ()+  FieldDescriptionsValidImpl ( '(conName, '(_, fields)) ': rest ) typ =+    ( HasAllFields conName fields typ+    , FieldDescriptionsValidImpl rest typ+    )++-- | Check whether given constructor name @conName@ is present in 'G.Rep' of a datatype.+type family HasConstructor (conName :: Symbol) (g :: Type -> Type) :: Bool where+  HasConstructor conName (G.D1 _ cs) = HasConstructor conName cs+  HasConstructor conName (G.C1 ('G.MetaCons conName _ _) _) = 'True+  HasConstructor conName (l G.:+: r) = HasConstructor conName l || HasConstructor conName r+  HasConstructor _ _ = 'False++-- | Check whether all fields described for given constructor @conName@ are present in the datatype.+--+-- This family also checks whether the constructor is present and fails with a 'TypeError'+-- otherwise.+type family HasAllFields (conName :: Symbol) (fields :: [(Symbol, Symbol)]) (typ :: Type) :: Constraint where+  HasAllFields conName fields typ =+    If+      (HasConstructor conName (G.Rep typ))+      (HasAllFieldsImpl conName fields typ)+      (TypeError+        ('Text "No constructor " ':<>: 'ShowType conName ':<>: 'Text " in type " ':<>: 'ShowType typ ':<>: 'Text "." )+      )++-- | Actual recursive implementation of 'HasAllFields'.+type family HasAllFieldsImpl (conName :: Symbol) (fields :: [(Symbol, Symbol)]) (typ :: Type) :: Constraint where+  HasAllFieldsImpl _ '[] _ = ()+  HasAllFieldsImpl conName ( '(fieldName, _) ': rest ) typ =+    ( If+        (HasField conName fieldName (G.Rep typ))+        (() :: Constraint)+        (TypeError+          ('Text "No field " ':<>: 'ShowType fieldName ':<>: 'Text " in constructor " ':<>:+           'ShowType conName ':<>: 'Text " of type " ':<>: 'ShowType typ ':<>: 'Text "."+          )+        )+    , HasAllFieldsImpl conName rest typ+    )++-- | Check that Generic 'G.Rep' has given field @fieldName@ in a given constructor @conName@.+type family HasField (conName :: Symbol) (fieldName :: Symbol) (g :: Type -> Type) :: Bool where+  HasField conName fieldName (G.D1 _ cs) = HasField conName fieldName cs+  HasField conName fieldName (G.C1 ('G.MetaCons conName _ _) c) = ConHasField fieldName c+  HasField conName fieldName (l G.:+: r) = HasField conName fieldName l || HasField conName fieldName r+  HasField _ _ _ = 'False++-- | Check that Generic representation for a constructor has given field @fieldName@.+type family ConHasField (fieldName :: Symbol) (g :: Type -> Type) :: Bool where+  ConHasField fieldName (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) _) = 'True+  ConHasField fieldName (l G.:*: r) = ConHasField fieldName l || ConHasField fieldName r+  ConHasField _ _ = 'False++-- A trick by Csongor Kiss: https://kcsongor.github.io/report-stuck-families/+--+-- 'T1' is a dummy type and 'Assert' will get stuck whenever its argument @break@ is stuck.+--+-- This happens because for stuck argument GHC can't check whether it is equal to 'T1' and therefore+-- can't select one of 'Assert's equations.++data T1 a++type family Assert (err :: Constraint) (break :: Type -> Type) (v :: k) :: k where+  Assert _ T1 _ = Any+  Assert _ _ k = k

+ src/Morley/Michelson/Typed/Haskell/Value.hs view

@@ -0,0 +1,521 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Conversions between haskell types/values and Michelson ones.+module Morley.Michelson.Typed.Haskell.Value+  ( -- * Value conversions+    IsoValue (..)+  , KnownIsoT+  , GIsoValue (GValueType)+  , ToT'+  , GenericIsoValue+  , WellTyped+  , WellTypedIsoValue+  , WellTypedToT+  , HasNoOpToT++  , Dict(..) -- * Re-exporting to use in tests.++    -- * Missing Haskell analogies to Michelson values+  , EntrypointCall+  , SomeEntrypointCall+  , ContractRef (..)+  , coerceContractRef+  , contractRefToAddr+  , Ticket (..)+  , BigMapId(..)+  , BigMap(..)+  , ToBigMap(..)++    -- * Stack conversion+  , ToTs+  , ToTs'+  , IsoValuesStack (..)+  , totsKnownLemma+  , totsAppendLemma+  ) where++import Data.Constraint (Dict(..))+import Data.Data (Data)+import Data.Default (Default(..))+import Data.Fixed (Fixed(..))+import Data.Foldable (Foldable(foldr))+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Vinyl.Core (Rec(..))+import Fmt (Buildable(..), mapF)+import GHC.Exts as Exts (IsList(..))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G++import Morley.Michelson.Text+import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.T+import Morley.Michelson.Typed.Value+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature)+import Morley.Util.Named+import Morley.Util.Type++----------------------------------------------------------------------------+-- Complex values isomorphism+----------------------------------------------------------------------------++type KnownIsoT a = SingI (ToT a)++-- | Isomorphism between Michelson values and plain Haskell types.+--+-- Default implementation of this typeclass converts ADTs to Michelson+-- "pair"s and "or"s.+class (WellTypedToT a) => IsoValue a where+  -- | Type function that converts a regular Haskell type into a @T@ type.+  type ToT a :: T+  type ToT a = GValueType (G.Rep a)++  -- | Converts a Haskell structure into @Value@ representation.+  toVal :: a -> Value (ToT a)+  default toVal+    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GValueType (G.Rep a))+    => a -> Value (ToT a)+  toVal = gToValue . G.from++  -- | Converts a @Value@ into Haskell type.+  fromVal :: Value (ToT a) -> a+  default fromVal+    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GValueType (G.Rep a))+    => Value (ToT a) -> a+  fromVal = G.to . gFromValue++-- | Overloaded version of 'ToT' to work on Haskell and @T@ types.+type family ToT' (t :: k) :: T where+  ToT' (t :: T) = t+  ToT' (t :: Type) = ToT t++-- Instances+----------------------------------------------------------------------------++instance WellTyped t => IsoValue (Value t) where+  type ToT (Value t) = t+  toVal = id+  fromVal = id++instance IsoValue Integer where+  type ToT Integer = 'TInt+  toVal = VInt+  fromVal (VInt x) = x++instance IsoValue Natural where+  type ToT Natural = 'TNat+  toVal = VNat+  fromVal (VNat x) = x++instance IsoValue MText where+  type ToT MText = 'TString+  toVal = VString+  fromVal (VString x) = x++instance DoNotUseTextError => IsoValue Text where+  type ToT Text = ToT MText+  toVal = error "impossible"+  fromVal = error "impossible"++instance IsoValue Bool where+  type ToT Bool = 'TBool+  toVal = VBool+  fromVal (VBool x) = x++instance IsoValue ByteString where+  type ToT ByteString = 'TBytes+  toVal = VBytes+  fromVal (VBytes x) = x++instance IsoValue Mutez where+  type ToT Mutez = 'TMutez+  toVal = VMutez+  fromVal (VMutez x) = x++instance IsoValue KeyHash where+  type ToT KeyHash = 'TKeyHash+  toVal = VKeyHash+  fromVal (VKeyHash x) = x++instance IsoValue Bls12381Fr where+  type ToT Bls12381Fr = 'TBls12381Fr+  toVal = VBls12381Fr+  fromVal (VBls12381Fr x) = x++instance IsoValue Bls12381G1 where+  type ToT Bls12381G1 = 'TBls12381G1+  toVal = VBls12381G1+  fromVal (VBls12381G1 x) = x++instance IsoValue Bls12381G2 where+  type ToT Bls12381G2 = 'TBls12381G2+  toVal = VBls12381G2+  fromVal (VBls12381G2 x) = x++instance IsoValue Timestamp where+  type ToT Timestamp = 'TTimestamp+  toVal = VTimestamp+  fromVal (VTimestamp x) = x++instance IsoValue Address where+  type ToT Address = 'TAddress+  toVal addr = VAddress $ EpAddress addr DefEpName+  fromVal (VAddress x) = eaAddress x++instance IsoValue EpAddress where+  type ToT EpAddress = 'TAddress+  toVal = VAddress+  fromVal (VAddress x) = x++instance IsoValue PublicKey where+  type ToT PublicKey = 'TKey+  toVal = VKey+  fromVal (VKey x) = x++instance IsoValue Signature where+  type ToT Signature = 'TSignature+  toVal = VSignature+  fromVal (VSignature x) = x++instance IsoValue ChainId where+  type ToT ChainId = 'TChainId+  toVal = VChainId+  fromVal (VChainId x) = x++instance IsoValue (Fixed p) where+  type ToT (Fixed p) = 'TInt+  toVal (MkFixed x) = VInt x+  fromVal (VInt x) = MkFixed x++instance IsoValue ()++instance IsoValue a => IsoValue [a] where+  type ToT [a] = 'TList (ToT a)+  toVal = VList . map toVal+  fromVal (VList x) = map fromVal x++instance IsoValue a => IsoValue (Maybe a) where+  type ToT (Maybe a) = 'TOption (ToT a)+  toVal = VOption . fmap toVal+  fromVal (VOption x) = fmap fromVal x++instance IsoValue Void++instance (IsoValue l, IsoValue r) => IsoValue (Either l r)++instance (IsoValue a, IsoValue b) => IsoValue (a, b)++instance (Comparable (ToT c), Ord c, IsoValue c) => IsoValue (Set c) where+  type ToT (Set c) = 'TSet (ToT c)+  toVal = VSet . Set.map toVal+  fromVal (VSet x) = Set.map fromVal x++instance (Comparable (ToT k), Ord k, IsoValue k, IsoValue v) => IsoValue (Map k v) where+  type ToT (Map k v) = 'TMap (ToT k) (ToT v)+  toVal = VMap . Map.mapKeys toVal . Map.map toVal+  fromVal (VMap x) = Map.map fromVal $ Map.mapKeys fromVal x++instance IsoValue Operation where+  type ToT Operation = 'TOperation+  toVal = VOp+  fromVal (VOp x) = x++deriving newtype instance IsoValue a => IsoValue (Identity a)+deriving newtype instance IsoValue a => IsoValue (NamedF Identity a name)+deriving newtype instance IsoValue a => IsoValue (NamedF Maybe a name)++instance (IsoValue a, IsoValue b, IsoValue c) => IsoValue (a, b, c)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d)+       => IsoValue (a, b, c, d)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e)+       => IsoValue (a, b, c, d, e)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e,+          IsoValue f)+       => IsoValue (a, b, c, d, e, f)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e,+          IsoValue f, IsoValue g)+       => IsoValue (a, b, c, d, e, f, g)++-- Types used specifically for conversion+----------------------------------------------------------------------------++type EntrypointCall param arg = EntrypointCallT (ToT param) (ToT arg)++type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)++type WellTypedToT a = WellTyped (ToT a)+type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)++type HasNoOpToT a = HasNoOp (ToT a)+type HasNoBigMapToT a = HasNoBigMap (ToT a)++-- | Since @Contract@ name is used to designate contract code, lets call+-- analogy of 'TContract' type as follows.+--+-- Note that type argument always designates an argument of entrypoint.+-- If a contract has explicit default entrypoint (and no root entrypoint),+-- @ContractRef@ referring to it can never have the entire parameter as its+-- type argument.+data ContractRef (arg :: Type) = ContractRef+  { crAddress :: Address+  , crEntrypoint :: SomeEntrypointCall arg+  } deriving stock (Eq, Show)++instance (IsoValue (ContractRef arg)) => Buildable (ContractRef arg) where+  build = buildVContract . toVal++instance (HasNoOpToT arg, WellTypedToT arg) => IsoValue (ContractRef arg) where+  type ToT (ContractRef arg) = 'TContract (ToT arg)+  toVal ContractRef{..} = VContract crAddress crEntrypoint+  fromVal (VContract addr epc) = ContractRef addr epc++-- | Replace type argument of 'ContractRef' with isomorphic one.+coerceContractRef :: (ToT a ~ ToT b) => ContractRef a -> ContractRef b+coerceContractRef ContractRef{..} = ContractRef{..}++contractRefToAddr :: ContractRef cp -> EpAddress+contractRefToAddr ContractRef{..} = EpAddress crAddress (sepcName crEntrypoint)++-- | Ticket type.+data Ticket (arg :: Type) = Ticket+  { tTicketer :: Address+  , tData :: arg+  , tAmount :: Natural+  } deriving stock (Eq, Show)++instance (Comparable (ToT a), IsoValue a) => IsoValue (Ticket a) where+  type ToT (Ticket a) = 'TTicket (ToT a)+  toVal Ticket{..} = VTicket tTicketer (toVal tData) tAmount+  fromVal (VTicket tTicketer dat tAmount) = Ticket{ tData = fromVal dat, .. }++-- | Phantom type that represents the ID of a big_map with+-- keys of type @k@ and values of type @v@.+newtype BigMapId k v = BigMapId { unBigMapId :: Natural }+  -- Note: we purposefully do not derive an `Eq` instance.+  -- If we did, it would be possible for a @cleveland@ user to mistakenly+  -- compare two big_map IDs, whilst being under the impression that they were+  -- actually comparing the big_map's contents.+  -- To avoid this confusion, we simply do not create an `Eq` instance.+  -- For context, see: https://gitlab.com/morley-framework/morley/-/merge_requests/833#note_598577341+  deriving stock (Show, Data)+  deriving newtype (IsoValue, Buildable, Num)++data BigMap k v = BigMap+  { bmId :: Maybe (BigMapId k v)+  , bmMap :: Map k v+  }+  deriving stock (Show, Generic, Data)+  deriving anyclass (Default, Container)++class ToBigMap m where+  type ToBigMapKey m+  type ToBigMapValue m+  mkBigMap :: m -> BigMap (ToBigMapKey m) (ToBigMapValue m)++instance Ord k => ToBigMap [(k, v)] where+  type ToBigMapValue [(k, v)] = v+  type ToBigMapKey [(k, v)] = k+  mkBigMap = Exts.fromList++instance ToBigMap (Map k v) where+  type ToBigMapValue (Map k v) = v+  type ToBigMapKey (Map k v) = k+  mkBigMap = BigMap Nothing++instance Ord k => ToBigMap (NonEmpty (k, v)) where+  type ToBigMapValue (NonEmpty (k, v)) = v+  type ToBigMapKey (NonEmpty (k, v)) = k+  mkBigMap (h :| t) = one h <> mkBigMap t++instance Ord k => Semigroup (BigMap k v) where+  BigMap _ m1 <> BigMap _ m2 = BigMap Nothing (m1 <> m2)++instance Foldable (BigMap k) where+  foldr f z (BigMap _ bmMap) = Map.foldr f z bmMap++instance One (BigMap k v) where+  type OneItem (BigMap k v) = OneItem (Map k v)+  one x = BigMap Nothing (one x)++instance Ord k => IsList (BigMap k v) where+  type Item (BigMap k v) = Item (Map k v)+  fromList xs = BigMap Nothing (Exts.fromList xs)+  toList (BigMap _ xs) = Exts.toList xs++instance (Ord k, Buildable k, Buildable v) => Buildable (BigMap k v) where+  build = mapF++instance+  ( Comparable (ToT k) , Ord k, IsoValue k+  , IsoValue v, HasNoBigMapToT v, HasNoOpToT v+  ) => IsoValue (BigMap k v) where+  type ToT (BigMap k v) = 'TBigMap (ToT k) (ToT v)+  toVal (BigMap bmId bmMap) =+    VBigMap+      (unBigMapId <$> bmId)+      (Map.mapKeys toVal $ Map.map toVal bmMap)+  fromVal (VBigMap bmId x) =+    BigMap+      (BigMapId <$> bmId)+      (Map.map fromVal $ Map.mapKeys fromVal x)++-- Generic magic+----------------------------------------------------------------------------++-- | Implements ADT conversion to Michelson value.+--+-- Thanks to Generic, Michelson representation will+-- be a balanced tree; this reduces average access time in general case.+--+-- A drawback of such approach is that, in theory, in new GHC version+-- generified representation may change; however, chances are small and+-- I (martoon) believe that contract versions will change much faster anyway.+--+-- In case an unbalanced tree is needed, the Generic instance can be derived by+-- using the utilities in the "Morley.Util.Generic" module.+class SingI (GValueType x) =>+      GIsoValue (x :: Type -> Type) where+  type GValueType x :: T+  gToValue :: x p -> Value (GValueType x)+  gFromValue :: Value (GValueType x) -> x p++instance GIsoValue x => GIsoValue (G.M1 t i x) where+  type GValueType (G.M1 t i x) = GValueType x+  gToValue = gToValue . G.unM1+  gFromValue = G.M1 . gFromValue++instance (GIsoValue x, GIsoValue y) => GIsoValue (x :+: y) where+  type GValueType (x :+: y) = 'TOr (GValueType x) (GValueType y)+  gToValue = VOr . \case+    L1 x -> Left (gToValue x)+    R1 y -> Right (gToValue y)+  gFromValue (VOr e) = case e of+    Left vx -> L1 (gFromValue vx)+    Right vy -> R1 (gFromValue vy)++instance (GIsoValue x, GIsoValue y) => GIsoValue (x :*: y) where+  type GValueType (x :*: y) = 'TPair (GValueType x) (GValueType y)+  gToValue (x :*: y) = VPair (gToValue x, gToValue y)+  gFromValue (VPair (vx, vy)) = gFromValue vx :*: gFromValue vy++instance GIsoValue G.U1 where+  type GValueType G.U1 = 'TUnit+  gToValue G.U1 = VUnit+  gFromValue VUnit = G.U1++instance GIsoValue G.V1 where+  type GValueType G.V1 = 'TNever+  gToValue = \case+  gFromValue = \case++instance IsoValue a => GIsoValue (G.Rec0 a) where+  type GValueType (G.Rec0 a) = ToT a+  gToValue = toVal . G.unK1+  gFromValue = G.K1 . fromVal++-- | Whether Michelson representation of the type is derived via Generics.+type GenericIsoValue t =+  (IsoValue t, Generic t, ToT t ~ GValueType (G.Rep t))++----------------------------------------------------------------------------+-- Stacks conversion+----------------------------------------------------------------------------++-- | Type function to convert a Haskell stack type to @T@-based one.+type family ToTs (ts :: [Type]) :: [T] where+  ToTs '[] = '[]+  ToTs (x ': xs) = ToT x ': ToTs xs++-- | Overloaded version of 'ToTs' to work on Haskell and @T@ stacks.+type family ToTs' (t :: [k]) :: [T] where+  ToTs' (t :: [T]) = t+  ToTs' (a :: [Type]) = ToTs a++-- | Isomorphism between Michelson stack and its Haskell reflection.+class IsoValuesStack (ts :: [Type]) where+  toValStack :: Rec Identity ts -> Rec Value (ToTs ts)+  fromValStack :: Rec Value (ToTs ts) -> Rec Identity ts++instance IsoValuesStack '[] where+  toValStack RNil = RNil+  fromValStack RNil = RNil++instance (IsoValue t, IsoValuesStack st) => IsoValuesStack (t ': st) where+  toValStack (v :& vs) = toVal v :& toValStack vs+  fromValStack (v :& vs) = fromVal v :& fromValStack vs++totsKnownLemma :: forall s. KnownList s :- KnownList (ToTs s)+totsKnownLemma = Sub $ case klist @s of+  KNil -> Dict+  KCons _ (_ :: Proxy a') ->+    case totsKnownLemma @a' of Sub Dict -> Dict++totsAppendLemma+  :: forall a b.+      (KnownList a)+  => Dict (ToTs (a ++ b) ~ (ToTs a ++ ToTs b))+totsAppendLemma = case klist @a of+  KNil -> Dict+  KCons _ (_ :: Proxy a') ->+    case totsAppendLemma @a' @b of Dict -> Dict++-- | This class encodes Michelson rules w.r.t where it requires comparable+-- types. Earlier we had a dedicated type for representing comparable types @CT@.+-- But then we integreated those types into @T@. This meant that some of the+-- types that could be formed with various combinations of @T@ would be+-- illegal as per Michelson typing rule. Using this class, we inductively+-- enforce that a type and all types it contains are well typed as per+-- Michelson's rules.+class (SingI t, WellTypedSuperC t) => WellTyped (t :: T) where+  -- | Constraints required for instance of a given type.+  type WellTypedSuperC t :: Constraint+  type WellTypedSuperC _ = ()++instance WellTyped 'TKey where+instance WellTyped 'TUnit where+instance WellTyped 'TNever where+instance WellTyped 'TSignature where+instance WellTyped 'TChainId where+instance WellTyped t => WellTyped ('TOption t) where+  type WellTypedSuperC ('TOption t) = WellTyped t+instance WellTyped t => WellTyped ('TList t) where+  type WellTypedSuperC ('TList t) = WellTyped t+instance (Comparable t, WellTyped t) => WellTyped ('TSet t) where+  type WellTypedSuperC ('TSet t) = (Comparable t, WellTyped t)+instance WellTyped 'TOperation where+instance (WellTyped t, HasNoOp t) => WellTyped ('TContract t) where+  type WellTypedSuperC ('TContract t) = (WellTyped t, HasNoOp t)+instance (WellTyped t, Comparable t) => WellTyped ('TTicket t) where+  type WellTypedSuperC ('TTicket t) = (WellTyped t, Comparable t)+instance (WellTyped t1, WellTyped t2) => WellTyped ('TPair t1 t2) where+  type WellTypedSuperC ('TPair t1 t2) = (WellTyped t1, WellTyped t2)+instance (WellTyped t1, WellTyped t2) => WellTyped ('TOr t1 t2) where+  type WellTypedSuperC ('TOr t1 t2) = (WellTyped t1, WellTyped t2)+instance (WellTyped t1, WellTyped t2) => WellTyped ('TLambda t1 t2) where+  type WellTypedSuperC ('TLambda t1 t2) = (WellTyped t1, WellTyped t2)+instance (Comparable k, WellTyped k, WellTyped v) => WellTyped ('TMap k v) where+  type WellTypedSuperC ('TMap k v) = (Comparable k, WellTyped k, WellTyped v)+instance (Comparable k, WellTyped k, WellTyped v, HasNoBigMap v, HasNoOp v)+         => WellTyped ('TBigMap k v) where+  type WellTypedSuperC ('TBigMap k v) = ( Comparable k, WellTyped k, WellTyped v+                                        , HasNoBigMap v, HasNoOp v)+instance WellTyped 'TInt+instance WellTyped 'TNat+instance WellTyped 'TString+instance WellTyped 'TBytes+instance WellTyped 'TMutez+instance WellTyped 'TBool+instance WellTyped 'TKeyHash+instance WellTyped 'TBls12381Fr+instance WellTyped 'TBls12381G1+instance WellTyped 'TBls12381G2+instance WellTyped 'TTimestamp+instance WellTyped 'TAddress

+ src/Morley/Michelson/Typed/Instr.hs view

@@ -0,0 +1,972 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Module, containing data types for Michelson value.+module Morley.Michelson.Typed.Instr+  ( Instr (..)+  , castInstr+  , pattern (:#)+  , ExtInstr (..)+  , CommentType (..)+  , StackRef (..)+  , mkStackRef+  , PrintComment (..)+  , TestAssert (..)+  , ContractCode+  , Contract (..)+  , SomeMeta (..)+  , defaultContract+  , mapContractCode+  , mapEntriesOrdered+  , pattern CAR+  , pattern CDR+  , pattern LEFT+  , pattern PAIR+  , pattern RIGHT+  , pattern UNPAIR+  , ConstraintDUPN+  , ConstraintDUPN'+  , ConstraintDIPN+  , ConstraintDIPN'+  , ConstraintDIG+  , ConstraintDIG'+  , ConstraintDUG+  , ConstraintDUG'+  , ConstraintPairN+  , PairN+  , RightComb+  , ConstraintUnpairN+  , UnpairN+  , ConstraintGetN+  , GetN+  , ConstraintUpdateN+  , UpdateN+  ) where++import Data.Default+import Data.Type.Equality ((:~:)(..))+import Data.Vinyl (RMap, Rec(..), RecordToList, ReifyConstraint(..))+import Fmt ((+||), (||+))+import GHC.TypeNats (type (+))+import qualified GHC.TypeNats as GHC (Nat)+import qualified Text.Show++import Morley.Michelson.Doc+import Morley.Michelson.ErrorPos+import Morley.Michelson.Typed.Annotation (Notes(..), starNotes)+import Morley.Michelson.Typed.Arith+import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Polymorphic+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.T (T(..))+import Morley.Michelson.Typed.TypeLevel+  (CombedPairLeafCount, CombedPairLeafCountIsAtLeast, CombedPairNodeCount,+  CombedPairNodeIndexIsValid, IsPair)+import Morley.Michelson.Typed.Value (Comparable, ContractInp, ContractOut, Value'(..))+import Morley.Michelson.Untyped+  (Annotation(..), EntriesOrder(..), FieldAnn, StackFn, StackTypePattern, TypeAnn, VarAnn, VarAnns,+  entriesOrderToInt)+import Morley.Util.Peano+import Morley.Util.PeanoNatural+import Morley.Util.Sing (eqI)+import Morley.Util.TH+import Morley.Util.Type (If, KnownList, type (++))+import Morley.Util.TypeLits (ErrorMessage(ShowType, Text, (:$$:), (:<>:)), TypeErrorUnless)++{-+Note [Annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When typechecking a sequence of instructions:++1. We'll typecheck an "untyped instruction" like `EMPTY_SET :ta @va unit`, producing:+    * a "typed instruction" `EMPTY_SET :: Instr s (TSet TUnit : s)`, and+    * an output stack with a `@va set :ta int` at the top.+2. In `Morley.Michelson.TypeCheck.Helpers.wrapWithNotes`:+    * if the original instruction had a var annotation (e.g. `SOME_INSTR @some_ann`),+      then we wrap the "typed instruction" in `InstrWithVarNotes`.+    * if the element at the top of the output stack has a var annotation,+      we wrap it in `InstrWithVarAnns`.+    * if the element at the top of the output stack has field/type anns,+      we wrap it in `InstrWithNotes`+        ```+        InstrWithNotes Proxy (NTSet "ta" (NTUnit "")) $+          InstrWithVarNotes (one "va") $+            InstrWithVarAnns (OneVarAnn "va") $+              EMPTY_SET+        ```++These "meta-instruction" wrappers are later used in the interpreter/serializer.++The interpreter ('Morley.Michelson.Interpret'):+  * Looks at the typed instruction (e.g. `EMPTY_SET`), and simply adds/removes/moves elements+    in the stack, without caring about annotations.+  * Looks at the `InstrWithNotes` and `InstrWithVarAnns` meta-instructions, and blindly+    applies a series of annotations to the output stack, without caring about the underlying+    instruction.++The serializer ('Morley.Michelson.Interpret.Pack'):+  * Looks at the `InstrWithNotes` and `InstrWithVarNotes` meta-instructions, and infers+    that the original `EMPTY_SET` instruction must have had two explicit `:ta` and `@va` annotations.++Notice that the interpreter does not care about the `InstrWithVarNotes` meta-instruction, and+the serializer does not care about the `InstrWithVarAnns` meta-instruction.++++Note [Annotations - Exceptional scenarios]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For the most part, this works without a hitch.+However, `wrapWithNotes` makes the assumption that we can infer an instruction's+original annotations by simply looking at the output stack, e.g.:++> If after running an `EMPTY_SET` instruction we end up with a `@va set :ta int`+> at the top of output stack, then we can infer that the `EMPTY_SET` instruction+> had two `@va` and `:ta` annotations.++Unfortunately, that assumption doesn't always hold.+Here are some counter examples:++* Special annotations.+    These 3 `CAR` instructions will all put a `@p.a nat` at the top of the stack:++    > PUSH @p (pair (nat %a) nat) (Pair 1 2);+    > CAR @%%;++    > PUSH (pair (nat %p.a) nat) (Pair 1 2);+    > CAR @%;++    > PUSH (pair (nat %p.a) nat) (Pair 1 2);+    > CAR @p.a;++    Therefore, it's impossible for `wrapWithNotes` to figure out what+    CAR's original var annotation was.++    This scenario affects all instructions that can take special annotations:+    - PAIR, LEFT, RIGHT: accept special field anns+    - UNPAIR, CAR, CDR: accept special var anns++* Annotations that do not affect the output stack whatsoever.+    For example, CAR may take a field annotation, but it's only used by the typechecker+    to verify that the pair in the input stack has a matching field ann.++    The following instructions will generate the exact same output stack,+    with an un-annotated `nat` at the top.++    > PUSH (pair (nat %a) nat) (Pair 1 2);+    > CAR %a;++    > PUSH (pair (nat %a) nat) (Pair 1 2);+    > CAR;++    Therefore, it's impossible for `wrapWithNotes` to figure out whether+    CAR had a field annotation.++    This scenario affects: UNPAIR, CAR, CDR.+++In situations like the above, where the instruction's annotations cannot be inferred from+looking at the output stack, we have to save and store the instruction's annotations inside+the typed instruction's constructor, instead of using meta-instructions.+E.g.:++> AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s)++TODO [#580]: address the assumptions mentioned above.++-}++-- This next comment is needed to run the doctest examples throughout this module.++-- $setup+-- >>> :m +Morley.Michelson.Typed.T Morley.Util.Peano Morley.Util.PeanoNatural+-- >>> :set -XPartialTypeSignatures++-- | Constraint that is used in DUPN, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) =+  ( RequireLongerOrSameLength inp n, n > 'Z ~ 'True+  , inp ~ (Take (Decrement n) inp ++ (a ': Drop n inp))+  , out ~ (a ': inp)+  )++type ConstraintDUPN n inp out a = ConstraintDUPN' T n inp out a++-- | Constraint that is used in DIPN, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDIPN' kind (n :: Peano) (inp :: [kind])+  (out :: [kind]) (s :: [kind]) (s' :: [kind]) =+  ( RequireLongerOrSameLength inp n+  , ((Take n inp) ++ s) ~ inp+  , ((Take n inp) ++ s') ~ out+  )++type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s'++-- | Constraint that is used in DIG, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDIG' kind (n :: Peano) (inp :: [kind])+  (out :: [kind]) (a :: kind) =+  ( RequireLongerThan inp n+  , inp ~ (Take n inp ++ (a ': Drop ('S n) inp))+  , out ~ (a ': Take n inp ++ Drop ('S n) inp)+  )++type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a++-- | Constraint that is used in DUG, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDUG' kind (n :: Peano) (inp :: [kind])+  (out :: [kind]) (a :: kind) =+  ( RequireLongerThan out n+  , inp ~ (a ': Drop ('S 'Z) inp)+  , out ~ (Take n (Drop ('S 'Z) inp) ++ (a ': Drop ('S n) inp))+  )++type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a++type ConstraintPairN (n :: Peano) (inp :: [T]) =+  ( RequireLongerOrSameLength inp n+  , TypeErrorUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n ≥ 2")+  )++type PairN (n :: Peano) (s :: [T]) = (RightComb (Take n s) ': Drop n s)++-- | Folds a stack into a right-combed pair.+--+-- > RightComb '[ 'TInt,  'TString, 'TUnit ]+-- > ~+-- > 'TPair 'TInt ('TPair 'TString 'TUnit)+type family RightComb (s :: [T]) :: T where+  RightComb '[ x, y ] = 'TPair x y+  RightComb (x ': xs) = 'TPair x (RightComb xs)++type ConstraintUnpairN (n :: Peano) (pair :: T) =+  ( TypeErrorUnless (n >= ToPeano 2)+      ('Text "'UNPAIR n' expects n ≥ 2")++  , TypeErrorUnless (CombedPairLeafCountIsAtLeast n pair)+      (If (IsPair pair)+        ('Text "'UNPAIR "+          ':<>: 'ShowType (FromPeano n)+          ':<>: 'Text "' expects a right-combed pair with at least "+          ':<>: 'ShowType (FromPeano n)+          ':<>: 'Text " elements at the top of the stack,"+          ':$$: 'Text "but the pair only contains "+          ':<>: 'ShowType (FromPeano (CombedPairLeafCount pair))+          ':<>: 'Text " elements.")+        ('Text "Expected a pair at the top of the stack, but found: "+          ':<>: 'ShowType pair+        )+      )+  )++-- | Splits a right-combed pair into @n@ elements.+--+-- > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString 'TUnit))+-- > ~+-- > '[ 'TInt, 'TString, 'TUnit]+--+-- > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString ('TPair 'TUnit 'TInt)))+-- > ~+-- > '[ 'TInt, 'TString, 'TPair 'TUnit 'TInt]+type family UnpairN (n :: Peano) (s :: T) :: [T] where+  UnpairN ('S ('S 'Z)) ('TPair x y) = [x, y]+  UnpairN ('S n)       ('TPair x y) = x : UnpairN n y++type ConstraintGetN (ix :: Peano) (pair :: T) =+  ( TypeErrorUnless (CombedPairNodeIndexIsValid ix pair)+      (If (IsPair pair)+        ('Text "'GET "+          ':<>: 'ShowType (FromPeano ix)+          ':<>: 'Text "' expects a right-combed pair with at least "+          ':<>: 'ShowType (FromPeano ix + 1)+          ':<>: 'Text " nodes at the top of the stack,"+          ':$$: 'Text "but the pair only contains "+          ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))+          ':<>: 'Text " nodes.")+        ('Text "Expected a pair at the top of the stack, but found: "+          ':<>: 'ShowType pair+        )+      )+  )++-- | Get the node at index @ix@ of a right-combed pair.+type family GetN (ix :: Peano) (pair :: T) :: T where+  GetN 'Z val                       = val+  GetN ('S 'Z) ('TPair left _)      = left+  GetN ('S ('S n)) ('TPair _ right) = GetN n right++type ConstraintUpdateN (ix :: Peano) (pair :: T) =+  ( TypeErrorUnless (CombedPairNodeIndexIsValid ix pair)+      (If (IsPair pair)+        ('Text "'UPDATE "+          ':<>: 'ShowType (FromPeano ix)+          ':<>: 'Text "' expects the 2nd element of the stack to be a right-combed pair with at least "+          ':<>: 'ShowType (FromPeano ix + 1)+          ':<>: 'Text " nodes,"+          ':$$: 'Text "but the pair only contains "+          ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))+          ':<>: 'Text " nodes.")+        ('Text "Expected the 2nd element of the stack to be a pair, but found: "+          ':<>: 'ShowType pair+        )+      )+  )++-- | Update the node at index @ix@ of a right-combed pair.+type family UpdateN (ix :: Peano) (val :: T) (pair :: T) :: T where+  UpdateN 'Z          val _                   = val+  UpdateN ('S 'Z)     val ('TPair _  right)   = 'TPair val right+  UpdateN ('S ('S n)) val ('TPair left right) = 'TPair left (UpdateN n val right)++-- | Representation of Michelson instruction or sequence+-- of instructions.+--+-- Each Michelson instruction is represented by exactly one+-- constructor of this data type. Sequence of instructions+-- is represented with use of @Seq@ constructor in following+-- way: @SWAP; DROP ; DUP;@ -> @SWAP \`Seq\` DROP \`Seq\` DUP@.+-- Special case where there are no instructions is represented+-- by constructor @Nop@, e.g. @IF_NONE {} { SWAP; DROP; }@ ->+-- @IF_NONE Nop (SWAP \`Seq\` DROP)@.+--+-- Type parameter @inp@ states for input stack type. That is,+-- type of the stack that is required for operation to execute.+--+-- Type parameter @out@ states for output stack type or type+-- of stack that will be left after instruction's execution.+data Instr (inp :: [T]) (out :: [T]) where+  -- | A wrapper carrying original source location of the instruction.+  --+  -- TODO [#283]: replace this wrapper with something more clever and abstract.+  WithLoc :: InstrCallStack -> Instr a b -> Instr a b++  -- | A wrapper allowing arbitrary user metadata to be stored by some instruction.+  -- TODO [#689]: Use this instead of `DOC_ITEM`.+  Meta :: SomeMeta -> Instr a b -> Instr a b++  -- | A wrapper for instructions that, when interpreted, will+  -- place field/type annotations on one or more of the elements at+  -- the top of the stack.+  --+  -- This can wrap only instructions with at least one non-failing execution+  -- branch.+  --+  -- See: Note [Annotations]+  InstrWithNotes+    :: forall a (topElems :: [T]) (s :: [T]).+      ( RMap topElems+      , RecordToList topElems+      , ReifyConstraint Show Notes topElems+      , ReifyConstraint NFData Notes topElems+      , Each '[ SingI ] topElems+      )+    => Proxy s -> Rec Notes topElems+    -> Instr a (topElems ++ s) -> Instr a (topElems ++ s)++  -- | A wrapper for instructions that have var annotations, e.g. `SOME_INSTR @ann1`.+  --+  -- This information is necessary for serializing the instruction back to json/binary.+  --+  -- See: Note [Annotations]+  InstrWithVarNotes :: NonEmpty VarAnn -> Instr a b -> Instr a b++  -- | A wrapper for instructions that, when interpreted, will+  -- place var annotations on one or more of the elements at+  -- the top of the stack.+  --+  -- See: Note [Annotations]+  InstrWithVarAnns :: VarAnns -> Instr a b -> Instr a b++  -- | Execute given instruction on truncated stack.+  --+  -- This can wrap only instructions with at least one non-failing execution+  -- branch.+  --+  -- Morley has no such instruction, it is used solely in eDSLs.+  -- This instruction is sound because for all Michelson instructions+  -- the following property holds: if some code accepts stack @i@ and+  -- produces stack @o@, when it can also be run on stack @i + s@+  -- producing stack @o + s@; and also because Michelson never makes+  -- implicit assumptions on types, rather you have to express all+  -- "yet ambiguous" type information in code.+  -- We could make this not an instruction but rather a function+  -- which modifies an instruction (this would also automatically prove+  -- soundness of used transformation), but it occurred to be tricky+  -- (in particular for TestAssert and DipN and family), so let's leave+  -- this for future work.+  FrameInstr+    :: forall a b s.+       (KnownList a, KnownList b)+    => Proxy s -> Instr a b -> Instr (a ++ s) (b ++ s)++  Seq :: Instr a b -> Instr b c -> Instr a c+  -- | Nop operation. Missing in Michelson spec, added to parse construction+  -- like  `IF {} { SWAP; DROP; }`.+  Nop :: Instr s s+  Ext :: ExtInstr s -> Instr s s+  -- | Nested wrapper is going to wrap a sequence of instructions with { }.+  -- It is crucial because serialisation of a contract+  -- depends on precise structure of its code.+  Nested :: Instr inp out -> Instr inp out+  -- | Places documentation generated for given instruction under some group.+  -- This is not part of 'ExtInstr' because it does not behave like 'Nop';+  -- instead, it inherits the behaviour of the instruction put within it.+  DocGroup :: DocGrouping -> Instr inp out -> Instr inp out+  -- | Represents a typed stack function.+  -- This is not part of 'ExtInstr' because it does not behave like 'Nop';+  -- instead, it inherits the behaviour of the instruction put within it.+  Fn :: Text -> StackFn -> Instr inp out -> Instr inp out++  -- | CAR and CDR's original annotations must be retained inside+  -- the instruction's constructor.+  -- See: Note [Annotations - Exceptional scenarios].+  AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s)+  AnnCDR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (b ': s)++  -- Note that we can not merge DROP and DROPN into one instruction+  -- because they are packed differently.+  DROP :: Instr (a ': s) s+  DROPN+    :: forall (n :: Peano) s.+    (RequireLongerOrSameLength s n)+    => PeanoNatural n -> Instr s (Drop n s)+  DUP :: DupableScope a => Instr (a ': s) (a ': a ': s)+  DUPN+    :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, DupableScope a)+    => PeanoNatural n -> Instr inp out+  SWAP :: Instr (a ': b ': s) (b ': a ': s)+  DIG+    :: forall (n :: Peano) inp out a. (ConstraintDIG n inp out a)+    => PeanoNatural n -> Instr inp out+  DUG+    :: forall (n :: Peano) inp out a. (ConstraintDUG n inp out a)+    => PeanoNatural n -> Instr inp out+  PUSH+    :: forall t s . ConstantScope t+    => Value' Instr t -> Instr s (t ': s)+  SOME :: Instr (a ': s) ('TOption a ': s)+  NONE :: forall a s . SingI a => Instr s ('TOption a ': s)+  UNIT :: Instr s ('TUnit ': s)+  IF_NONE+    :: Instr s s'+    -> Instr (a ': s) s'+    -> Instr ('TOption a ': s) s'+  -- | PAIR's original annotations must be retained inside+  -- the instruction's constructor.+  -- See: Note [Annotations - Exceptional scenarios].+  AnnPAIR :: TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': b ': s) ('TPair a b ': s)+  -- | UNPAIR's original annotations must be retained inside+  -- the instruction's constructor.+  -- See: Note [Annotations - Exceptional scenarios].+  AnnUNPAIR :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': b ': s)+  -- |+  -- >>> :t PAIRN (toPeanoNatural' @3) :: Instr '[ 'TInt, 'TUnit, 'TString ] _+  -- ...+  -- ...:: Instr+  -- ...    '[ 'TInt, 'TUnit, 'TString]+  -- ...    '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]+  --+  --+  -- >>> PAIRN (toPeanoNatural' @1) :: Instr '[ 'TInt, 'TInt ] _+  -- ...+  -- ... 'PAIR n' expects n ≥ 2+  -- ...+  --+  -- >>> PAIRN (toPeanoNatural' @3) :: Instr '[ 'TInt, 'TInt ] _+  -- ...+  -- ... Expected stack with length >= 3+  -- ... Current stack has size of only 2:+  -- ...+  PAIRN+    :: forall n inp. ConstraintPairN n inp+    => PeanoNatural n -> Instr inp (PairN n inp)+  -- |+  -- >>> :t UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit 'TString) ] _+  -- ...+  -- ...:: Instr+  -- ...   '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]+  -- ...   '[ 'TInt, 'TUnit, 'TString]+  --+  -- >>> :t UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat)) ] _+  -- ...+  -- ...:: Instr+  -- ...   '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat))]+  -- ...   '[ 'TInt, 'TUnit, 'TPair 'TString 'TNat]+  --+  -- >>> UNPAIRN (toPeanoNatural' @1) :: Instr '[ 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'UNPAIR n' expects n ≥ 2+  -- ...+  --+  -- >>> UNPAIRN (toPeanoNatural' @2) :: Instr '[ 'TInt, 'TUnit, 'TString ] _+  -- ...+  -- ...Expected a pair at the top of the stack, but found: 'TInt+  -- ...+  --+  -- >>> UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'UNPAIR 3' expects a right-combed pair with at least 3 elements at the top of the stack,+  -- ...but the pair only contains 2 elements.+  -- ...+  UNPAIRN+    :: forall (n :: Peano) (pair :: T) (s :: [T]).+       ConstraintUnpairN n pair+    => PeanoNatural n+    -> Instr (pair : s) (UnpairN n pair ++ s)++  -- | LEFT and RIGHT's original annotations must be retained inside+  -- the instruction's constructor.+  -- See: Note [Annotations - Exceptional scenarios].+  AnnLEFT :: SingI b => TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': s) ('TOr a b ': s)+  AnnRIGHT :: SingI a => TypeAnn -> FieldAnn -> FieldAnn -> Instr (b ': s) ('TOr a b ': s)+  IF_LEFT+    :: Instr (a ': s) s'+    -> Instr (b ': s) s'+    -> Instr ('TOr a b ': s) s'+  NIL :: SingI p => Instr s ('TList p ': s)+  CONS :: Instr (a ': 'TList a ': s) ('TList a ': s)+  IF_CONS+    :: Instr (a ': 'TList a ': s) s'+    -> Instr s s'+    -> Instr ('TList a ': s) s'+  SIZE :: SizeOp c => Instr (c ': s) ('TNat ': s)+  EMPTY_SET :: (SingI e, Comparable e) => Instr s ('TSet e ': s)+  EMPTY_MAP :: (SingI a, SingI b, Comparable a) => Instr s ('TMap a b ': s)+  EMPTY_BIG_MAP :: (SingI a, SingI b, Comparable a, HasNoBigMap b) => Instr s ('TBigMap a b ': s)+  MAP :: (MapOp c, SingI b)+      => Instr (MapOpInp c ': s) (b ': s)+      -> Instr (c ': s) (MapOpRes c b ': s)+  ITER :: IterOp c => Instr (IterOpEl c ': s) s -> Instr (c ': s) s+  MEM :: MemOp c => Instr (MemOpKey c ': c ': s) ('TBool ': s)+  GET+    :: (GetOp c, SingI (GetOpVal c))+    => Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s)+  -- | Get the node at index @ix@ of a right-combed pair.+  -- Nodes are 0-indexed, and are numbered in a breadth-first,+  -- left-to-right fashion.+  --+  -- For example, a pair with 3 elements @pair a b c@ will be+  -- represented as a tree with 5 nodes:+  --+  -- >    pair+  -- >    /   \+  -- >  a     pair+  -- >        /   \+  -- >      b       c+  --+  -- Where the nodes are numbered as follows:+  --+  -- >      0+  -- >    /   \+  -- >  1       2+  -- >        /   \+  -- >      3       4+  --+  -- >>> :t GETN (toPeanoNatural' @1) :: Instr '[ 'TPair 'TInt 'TUnit] _+  -- ...+  -- ...:: Instr '[ 'TPair 'TInt 'TUnit] '[ 'TInt]+  --+  -- >>> GETN (toPeanoNatural' @1) :: Instr '[ 'TUnit ] _+  -- ...+  -- ...Expected a pair at the top of the stack, but found: 'TUnit+  -- ...+  --+  -- >>> GETN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'GET 3' expects a right-combed pair with at least 4 nodes at the top of the stack,+  -- ...but the pair only contains 3 nodes.+  -- ...+  --+  -- Note that @GET 0@ is just the identity function and works for all types (not just pairs).+  --+  -- >>> :t GETN (toPeanoNatural' @0) :: Instr '[ 'TInt ] _+  -- ...+  -- ...:: Instr '[ 'TInt] '[ 'TInt]+  GETN+    :: forall (ix :: Peano) (pair :: T) (s :: [T]).+       ConstraintGetN ix pair+    => PeanoNatural ix+    -> Instr (pair : s) (GetN ix pair ': s)+  UPDATE+    :: UpdOp c+    => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) (c ': s)+  -- | Update the node at index @ix@ of a right-combed pair.+  --+  -- >>> :t UPDATEN (toPeanoNatural' @1) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit] _+  -- ...+  -- ...:: Instr+  -- ...     '[ 'TString, 'TPair 'TInt 'TUnit] '[ 'TPair 'TString 'TUnit]+  --+  -- >>> UPDATEN (toPeanoNatural' @1) :: Instr '[ 'TUnit, 'TInt ] _+  -- ...+  -- ...Expected the 2nd element of the stack to be a pair, but found: 'TInt+  -- ...+  --+  -- >>> UPDATEN (toPeanoNatural' @3) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'UPDATE 3' expects the 2nd element of the stack to be a right-combed pair with at least 4 nodes,+  -- ...but the pair only contains 3 nodes.+  -- ...+  --+  -- Note that @UPDATE 0@ is equivalent to @DIP { DROP }@.+  --+  -- >>> :t UPDATEN (toPeanoNatural' @0) :: Instr '[ 'TInt, 'TString ] _+  -- ...+  -- ...:: Instr '[ 'TInt, 'TString] '[ 'TInt]+  UPDATEN+    :: forall (ix :: Peano) (val :: T) (pair :: T) (s :: [T]).+       ConstraintUpdateN ix pair+    => PeanoNatural ix+    -> Instr (val : pair : s) (UpdateN ix val pair ': s)+  GET_AND_UPDATE+    :: ( GetOp c, UpdOp c, SingI (GetOpVal c)+       , UpdOpKey c ~ GetOpKey c+       )+    => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) ('TOption (GetOpVal c) : c ': s)+  IF :: Instr s s'+     -> Instr s s'+     -> Instr ('TBool ': s) s'+  LOOP :: Instr s ('TBool ': s)+       -> Instr ('TBool ': s) s+  LOOP_LEFT+    :: Instr (a ': s) ('TOr a b ': s)+    -> Instr ('TOr a b ': s) (b ': s)+  LAMBDA :: forall i o s . (SingI i, SingI o)+         => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s)+  EXEC :: Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s)+  APPLY+    :: forall a b c s . (ConstantScope a, SingI b)+    => Instr (a ': 'TLambda ('TPair a b) c ': s) ('TLambda b c ': s)+  DIP :: Instr a c -> Instr (b ': a) (b ': c)+  DIPN+    :: forall (n :: Peano) inp out s s'. (ConstraintDIPN n inp out s s')+    => PeanoNatural n -> Instr s s' -> Instr inp out+  -- Since 008 it's prohibited to fail with non-packable values and with the+  -- 'Contract t' type values, which is equivalent to our @ConstantScope@ constraint.+  -- See https://gitlab.com/tezos/tezos/-/issues/1093#note_496066354 for more information.+  FAILWITH :: (SingI a, ConstantScope a) => Instr (a ': s) t+  CAST :: forall a s . SingI a => Instr (a ': s) (a ': s)+  RENAME :: Instr (a ': s) (a ': s)+  PACK :: PackedValScope a => Instr (a ': s) ('TBytes ': s)+  UNPACK :: (UnpackedValScope a, SingI a) => Instr ('TBytes ': s) ('TOption a ': s)+  CONCAT :: ConcatOp c => Instr (c ': c ': s) (c ': s)+  CONCAT' :: ConcatOp c => Instr ('TList c ': s) (c ': s)+  SLICE+    :: (SliceOp c, SingI c)+    => Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s)+  ISNAT :: Instr ('TInt ': s) ('TOption ('TNat) ': s)+  ADD+    :: ArithOp Add n m+    => Instr (n ': m ': s) (ArithRes Add n m ': s)+  SUB+    :: ArithOp Sub n m+    => Instr (n ': m ': s) (ArithRes Sub n m ': s)+  MUL+    :: ArithOp Mul n m+    => Instr (n ':  m ': s) (ArithRes Mul n m ': s)+  EDIV+    :: ArithOp EDiv n m+    => Instr (n ':  m ': s) (ArithRes EDiv n m ': s)+  ABS+    :: UnaryArithOp Abs n+    => Instr (n ': s) (UnaryArithRes Abs n ': s)+  NEG+    :: UnaryArithOp Neg n+    => Instr (n ': s) (UnaryArithRes Neg n ': s)+  LSL+    :: ArithOp Lsl n m+    => Instr (n ': m ': s) (ArithRes Lsl n m ': s)+  LSR+    :: ArithOp Lsr n m+    => Instr (n ':  m ': s) (ArithRes Lsr n m ': s)+  OR+    :: ArithOp Or n m+    => Instr (n ': m ': s) (ArithRes Or n m ': s)+  AND+    :: ArithOp And n m+    => Instr (n ': m ': s) (ArithRes And n m ': s)+  XOR+    :: ArithOp Xor n m+    => Instr (n ': m ': s) (ArithRes Xor n m ': s)+  NOT+    :: UnaryArithOp Not n+    => Instr (n ': s) (UnaryArithRes Not n ': s)+  COMPARE+    :: (Comparable n, SingI n)+    => Instr (n ': n ': s) ('TInt ': s)+  EQ+    :: UnaryArithOp Eq' n+    => Instr (n ': s) (UnaryArithRes Eq' n ': s)+  NEQ+    :: UnaryArithOp Neq n+    => Instr (n ': s) (UnaryArithRes Neq n ': s)+  LT+    :: UnaryArithOp Lt n+    => Instr (n ': s) (UnaryArithRes Lt n ': s)+  GT+    :: UnaryArithOp Gt n+    => Instr (n ': s) (UnaryArithRes Gt n ': s)+  LE+    :: UnaryArithOp Le n+    => Instr (n ': s) (UnaryArithRes Le n ': s)+  GE+    :: UnaryArithOp Ge n+    => Instr (n ': s) (UnaryArithRes Ge n ': s)+  INT+    :: ToIntArithOp n+    => Instr (n ': s) ('TInt ': s)+  SELF+    :: forall (arg :: T) s .+       (ParameterScope arg)+    => SomeEntrypointCallT arg+    -> Instr s ('TContract arg ': s)+  CONTRACT+    :: (ParameterScope p)+    => Notes p   -- Store Notes to be able to verify CONTRACT in typechecker+    -> EpName+    -> Instr ('TAddress ': s) ('TOption ('TContract p) ': s)+  TRANSFER_TOKENS+    :: (ParameterScope p) =>+       Instr (p ': 'TMutez ': 'TContract p ': s)+                   ('TOperation ': s)+  SET_DELEGATE+    :: Instr ('TOption 'TKeyHash ': s) ('TOperation ': s)++  CREATE_CONTRACT+    :: (ParameterScope p, StorageScope g)+    => Contract p g+    -> Instr ('TOption 'TKeyHash ':+              'TMutez ':+               g ': s)+             ('TOperation ': 'TAddress ': s)+  IMPLICIT_ACCOUNT+    :: Instr ('TKeyHash ': s) ('TContract 'TUnit ': s)+  NOW :: Instr s ('TTimestamp ': s)+  AMOUNT :: Instr s ('TMutez ': s)+  BALANCE :: Instr s ('TMutez ': s)+  VOTING_POWER :: Instr ('TKeyHash ': s) ('TNat ': s)+  TOTAL_VOTING_POWER :: Instr s ('TNat ': s)+  CHECK_SIGNATURE+    :: Instr ('TKey ': 'TSignature ': 'TBytes ': s)+                   ('TBool ': s)+  SHA256 :: Instr ('TBytes ': s) ('TBytes ': s)+  SHA512 :: Instr ('TBytes ': s) ('TBytes ': s)+  BLAKE2B :: Instr ('TBytes ': s) ('TBytes ': s)+  SHA3 :: Instr ('TBytes ': s) ('TBytes ': s)+  KECCAK :: Instr ('TBytes ': s) ('TBytes ': s)+  HASH_KEY :: Instr ('TKey ': s) ('TKeyHash ': s)+  PAIRING_CHECK+    :: Instr ('TList ('TPair 'TBls12381G1 'TBls12381G2) ': s) ('TBool ': s)+  SOURCE :: Instr s ('TAddress ': s)+  SENDER :: Instr s ('TAddress ': s)+  ADDRESS :: Instr ('TContract a ': s) ('TAddress ': s)+  CHAIN_ID :: Instr s ('TChainId ': s)+  LEVEL :: Instr s ('TNat ': s)+  SELF_ADDRESS :: Instr s ('TAddress ': s)+  NEVER :: Instr ('TNever ': s) t+  TICKET+    :: (Comparable a)+    => Instr (a ': 'TNat ': s) ('TTicket a ': s)+  READ_TICKET+    :: Instr ('TTicket a ': s)+             (RightComb ['TAddress, a, 'TNat] ': 'TTicket a ': s)+  SPLIT_TICKET+    :: Instr ('TTicket a ': 'TPair 'TNat 'TNat ': s)+             ('TOption ('TPair ('TTicket a) ('TTicket a)) ': s)+  JOIN_TICKETS+    :: Instr ('TPair ('TTicket a) ('TTicket a) ': s)+             ('TOption ('TTicket a) ': s)++castInstr+  :: forall inp1 out1 inp2 out2.+  ( SingI inp1+  , SingI out1+  , SingI inp2+  , SingI out2+  )+  => Instr inp1 out1 -> Maybe (Instr inp2 out2)+castInstr instr =+  case (eqI @inp1 @inp2, eqI @out1 @out2) of+    (Just Refl, Just Refl) -> Just instr+    (_,_) -> Nothing++-- | Right-associative operator for v'Seq'.+--+-- >>> show (DROP :# UNIT :# Nop) == show (DROP :# (UNIT :# Nop))+-- True+pattern (:#) :: Instr a b -> Instr b c -> Instr a c+pattern a :# b = Seq a b+infixr 8 :#++deriving stock instance Show (Instr inp out)++instance Semigroup (Instr s s) where+  (<>) = Seq+instance Monoid (Instr s s) where+  mempty = Nop++-- We have to write down pattern like this because simple+-- @Instr (TPair a b : s) (a : s)@ signature would assume that we /expect/+-- the input stack to have pair on top, but we want to /provide/ this info+-- in scope of a pattern-match.+-- In pattern declaration we have to write down the two mentioned constraints+-- explicitly.+--+-- Note that internally GADT constructors are rewritten in the very same way.+pattern CAR :: () => (i ~ ('TPair a b : s), o ~ (a : s)) => Instr i o+pattern CAR = AnnCAR (UnsafeAnnotation "") (UnsafeAnnotation "")++pattern CDR :: () => (i ~ ('TPair a b : s), o ~ (b : s)) => Instr i o+pattern CDR = AnnCDR (UnsafeAnnotation "") (UnsafeAnnotation "")++pattern UNPAIR :: () => (i ~ ('TPair a b : s), o ~ (a : b : s)) => Instr i o+pattern UNPAIR = AnnUNPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")++pattern PAIR :: () => (i ~ (a ': b ': s), o ~ ('TPair a b ': s)) => Instr i o+pattern PAIR = AnnPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")++pattern LEFT :: () => (SingI b, i ~ (a ': s), o ~ ('TOr a b ': s)) => Instr i o+pattern LEFT = AnnLEFT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")++pattern RIGHT :: () => (SingI a, i ~ (b ': s), o ~ ('TOr a b ': s)) => Instr i o+pattern RIGHT = AnnRIGHT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")++data TestAssert (s :: [T]) where+  TestAssert+    :: Text+    -> PrintComment inp+    -> Instr inp ('TBool ': out)+    -> TestAssert inp++deriving stock instance Show (TestAssert s)+instance NFData (TestAssert s) where+  rnf (TestAssert a b c) = rnf (a, b, c)++-- | A reference into the stack of a given type.+data StackRef (st :: [T]) where+  -- | Keeps 0-based index to a stack element counting from the top.+  StackRef+    :: (RequireLongerThan st idx)+    => PeanoNatural idx -> StackRef st++instance NFData (StackRef st) where+  rnf (StackRef s) = rnf s++instance Eq (StackRef st) where+  StackRef snat1 == StackRef snat2 = fromPeanoNatural snat1 == fromPeanoNatural snat2++instance Show (StackRef st) where+  show (StackRef snat) = "StackRef {" +|| fromPeanoNatural snat ||+ "}"++-- | Create a stack reference, performing checks at compile time.+mkStackRef+  :: forall (gn :: GHC.Nat) st n.+      (n ~ ToPeano gn, SingI (ToPeano gn), RequireLongerThan st n)+  => StackRef st+mkStackRef = StackRef $ toPeanoNatural' @gn++-- | A print format with references into the stack+newtype PrintComment (st :: [T]) = PrintComment+  { unPrintComment :: [Either Text (StackRef st)]+  } deriving stock (Eq, Show, Generic)+    deriving newtype (Semigroup, Monoid)++instance NFData (PrintComment st)++instance IsString (PrintComment st) where+  fromString = PrintComment . one . Left . fromString++data CommentType+ = FunctionStarts Text+ | FunctionEnds Text+ | StatementStarts Text+ | StatementEnds Text+ | JustComment Text+ | StackTypeComment (Maybe [T]) -- ^ 'Nothing' for any stack type+ deriving stock (Show, Generic)++instance NFData CommentType++instance IsString CommentType where+  fromString = JustComment . fromString++data ExtInstr s+  = TEST_ASSERT (TestAssert s)+  | PRINT (PrintComment s)+  -- TODO [#689]: Use `Meta` instead of `DOC_ITEM`.+  | DOC_ITEM SomeDocItem+  | COMMENT_ITEM CommentType+  | STACKTYPE StackTypePattern+  deriving stock (Show, Generic)++instance NFData (ExtInstr s)++data SomeMeta where+  SomeMeta+    :: forall meta+     . With [NFData, Show, Typeable] meta+    => meta+    -> SomeMeta++instance NFData SomeMeta where+  rnf (SomeMeta meta) = rnf meta++deriving stock instance Show SomeMeta++---------------------------------------------------++type ContractCode cp st = Instr (ContractInp cp st) (ContractOut st)++-- | Typed contract and information about annotations+-- which is not present in the contract code.+data Contract cp st = (ParameterScope cp, StorageScope st) => Contract+  { cCode       :: ContractCode cp st+  , cParamNotes :: ParamNotes cp+  , cStoreNotes :: Notes st+  , cEntriesOrder :: EntriesOrder+  }++deriving stock instance Show (Contract cp st)+deriving stock instance Eq (ContractCode cp st) => Eq (Contract cp st)+instance NFData (Contract cp st) where+  rnf (Contract a b c d) = rnf (a, b, c, d)++defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode cp st -> Contract cp st+defaultContract code = Contract+  { cCode = code+  , cParamNotes = starParamNotes+  , cStoreNotes = starNotes+  , cEntriesOrder = def+  }++mapContractCode+  :: (ContractCode cp st -> ContractCode cp st)+  -> Contract cp st+  -> Contract cp st+mapContractCode f contract = contract { cCode = f $ cCode contract }++-- | Map each typed contract fields by the given function and sort the output+-- based on the 'EntriesOrder'.+mapEntriesOrdered+  :: Contract cp st+  -> (ParamNotes cp -> a)+  -> (Notes st -> a)+  -> (ContractCode cp st -> a)+  -> [a]+mapEntriesOrdered Contract{..} fParam fStorage fCode =+  fmap snd+    $ sortWith fst+        [ (paramPos, fParam cParamNotes)+        , (storagePos, fStorage cStoreNotes)+        , (codePos, fCode cCode)+        ]+  where+    (paramPos, storagePos, codePos) = entriesOrderToInt cEntriesOrder++$(deriveGADTNFData ''Instr)

+ src/Morley/Michelson/Typed/OpSize.hs view

@@ -0,0 +1,33 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Measuring operation size of typed stuff.+module Morley.Michelson.Typed.OpSize+  ( OpSize (..)+  , U.opSizeHardLimit+  , U.smallTransferOpSize++  , instrOpSize+  , contractOpSize+  , valueOpSize+  ) where++import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Convert+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Untyped (OpSize)+import qualified Morley.Michelson.Untyped as U++-- | Estimate instruction operation size.+instrOpSize :: Instr inp out -> OpSize+instrOpSize = U.expandedInstrsOpSize . instrToOps++-- | Estimate contract code operation size.+contractOpSize :: Contract cp st -> OpSize+contractOpSize = instrOpSize . cCode++-- | Estimate value operation size.+valueOpSize :: (UntypedValScope t) => Value t -> OpSize+valueOpSize = U.valueOpSize . untypeValue

+ src/Morley/Michelson/Typed/Operation.hs view

@@ -0,0 +1,173 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Typed.Operation+  ( OperationHash (..)+  , OriginationOperation (..)+  , TransferOperation (..)+  , SetDelegateOperation (..)+  , mkContractAddress+  , mkOriginationOperationHash+  , mkTransferOperationHash+  , mkDelegationOperationHash+  ) where++import Data.Binary.Put (putWord64be, runPut)+import qualified Data.ByteString.Lazy as BSL++import Morley.Michelson.Interpret.Pack (toBinary, toBinary')+import Morley.Michelson.Runtime.TxData (TxData(..))+import Morley.Michelson.Typed (EpName)+import Morley.Michelson.Typed.Aliases (Value)+import Morley.Michelson.Typed.Entrypoints (EpAddress(..))+import Morley.Michelson.Typed.Haskell.Value (IsoValue(..))+import Morley.Michelson.Typed.Instr (Contract(..), cCode)+import Morley.Michelson.Typed.Scope (ParameterScope, StorageScope)+import Morley.Tezos.Address (Address(ContractAddress), ContractHash(..), GlobalCounter(..))+import Morley.Tezos.Core (Mutez(..))+import Morley.Tezos.Crypto (KeyHash, blake2b, blake2b160)++newtype OperationHash = OperationHash+  { unOperationHash :: ByteString+  }+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (NFData)++-- | "optional" encoding in Tezos.+--+-- See https://gitlab.com/nomadic-labs/data-encoding/-/blob/2c2b795a37e7d76e3eaa861da9855f2098edc9b9/src/binary_writer.ml#L278-283+packMaybe :: (a -> ByteString) -> Maybe a -> ByteString+packMaybe _ Nothing = "\255"+packMaybe f (Just a) = "\0" <> f a++----------------------------------------------------------------------------+-- Origination+----------------------------------------------------------------------------++-- | Data necessary to originate a contract.+data OriginationOperation =+  forall cp st.+  (StorageScope st, ParameterScope cp) =>+  OriginationOperation+  { ooOriginator :: Address+  -- ^ Originator of the contract.+  , ooDelegate :: Maybe KeyHash+  -- ^ Optional delegate.+  , ooBalance :: Mutez+  -- ^ Initial balance of the contract.+  , ooStorage :: Value st+  -- ^ Initial storage value of the contract.+  , ooContract :: Contract cp st+  -- ^ The contract itself.+  , ooCounter :: GlobalCounter+  -- ^ The value of the global counter at the time the operation was created.+  -- We store it here so that the resulting addresses of @CREATE_CONTRACT@ and+  -- performing of origination operation are the same.++  -- In Tezos each operation also has a special field called @counter@, see here:+  -- https://gitlab.com/tezos/tezos/-/blob/397dd233a10cc6df0df959e2a624c7947997dd0c/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L113-120++  -- This counter seems to be a part of global state of Tezos network. In fact, it may be observed+  -- in raw JSON representation of the operation in the network explorer.+  }++deriving stock instance Show OriginationOperation++-- | Construct 'OperationHash' for an 'OriginationOperation'.+mkOriginationOperationHash :: OriginationOperation -> OperationHash+mkOriginationOperationHash OriginationOperation{..} =+  OperationHash $ blake2b packedOperation+  where+    -- In Tezos OriginationOperation is encoded as 4-tuple of+    -- (balance, optional delegate, code, storage)+    --+    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L314+    -- and https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/script_repr.ml#L68+    packedOperation =+      BSL.toStrict (runPut $ putWord64be $ unMutez ooBalance)+      <> packMaybe (toBinary' . toVal) ooDelegate+      <> toBinary' (cCode ooContract)+      <> toBinary' ooStorage++-- | Compute address of a contract from its origination operation and global counter.+--+-- However, in real Tezos encoding of the operation is more than just 'OriginationOperation'.+-- There an Operation has several more meta-fields plus a big sum-type of all possible operations.+--+-- See here: https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78+--+-- In other words, contract hash is calculated as the blake2b160 (20-byte) hash of+-- origination operation hash + word64 global counter.+--+-- In Morley we do not yet support full encoding of Tezos Operations, therefore we choose+-- to generate contract addresses in a simplified manner.+--+-- Namely, we encode 'OriginationOperation' as we can and concat it with the global counter.++-- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's+-- address.+mkContractAddress+  :: OperationHash+  -> GlobalCounter+  -> Address+mkContractAddress (OperationHash opHash) (GlobalCounter counter) =+  ContractAddress+  $ ContractHash+  $ blake2b160+  $ opHash <> BSL.toStrict (runPut $ putWord64be counter)++----------------------------------------------------------------------------+-- Transfer+----------------------------------------------------------------------------++-- | Data necessary to send a transaction to given address which is assumed to be the+-- address of an originated contract.+data TransferOperation = TransferOperation+  { toDestination :: Address+  , toTxData :: TxData+  , toCounter :: GlobalCounter+  } deriving stock (Show)++mkTransferOperationHash+  :: ParameterScope t+  => Address+  -> Value t+  -> EpName+  -> Mutez+  -> OperationHash+mkTransferOperationHash to param epName amount =+  OperationHash $ blake2b packedOperation+  where+    -- In Tezos, transfer operations are encoded as 4-tuple of+    -- (amount, destination, entrypoint, value)+    --+    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L275-282+    packedOperation =+      BSL.toStrict $+        (runPut $ putWord64be $ unMutez amount)+        <> (toBinary $ toVal (EpAddress to epName))+        <> toBinary param++----------------------------------------------------------------------------+-- Set Delegate+----------------------------------------------------------------------------++-- | Set contract's delegate+data SetDelegateOperation = SetDelegateOperation+  { sdoContract :: Address+  -- ^ The contract we're setting delegate of+  , sdoDelegate :: Maybe KeyHash+  -- ^ The delegate we're setting+  , sdoCounter :: GlobalCounter+  } deriving stock Show++-- | Construct 'OperationHash' for a 'SetDelegateOperation'.+mkDelegationOperationHash :: SetDelegateOperation -> OperationHash+mkDelegationOperationHash SetDelegateOperation{..} =+  OperationHash $ blake2b packedOperation+  where+    -- In Tezos DelegationOperation is encoded as simply the delegation key hash+    --+    -- https://gitlab.com/tezos/tezos/-/blob/685227895f48a2564a9de3e1e179e7cd741d52fb/src/proto_010_PtGRANAD/lib_protocol/operation_repr.ml#L354+    packedOperation = packMaybe (toBinary' . toVal) sdoDelegate

+ src/Morley/Michelson/Typed/Polymorphic.hs view

@@ -0,0 +1,283 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, containing type classes for operating with Michelson values+-- in the context of polymorphic stack type operations.++module Morley.Michelson.Typed.Polymorphic+  ( EDivOp (..)+  , MemOp (..)+  , MapOp (..)+  , IterOp (..)+  , SizeOp (..)+  , GetOp (..)+  , UpdOp (..)+  , SliceOp (..)+  , ConcatOp (..)+  , divMich+  , modMich+  ) where++import qualified Data.ByteString as B+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Singletons (SingI)+import qualified Unsafe (fromIntegral)++import Morley.Michelson.Text+import Morley.Michelson.Typed.Annotation+import Morley.Michelson.Typed.T (T(..))+import Morley.Michelson.Typed.Value (Value'(..))+import Morley.Michelson.Untyped.Annotation (noAnn)++import Morley.Tezos.Core (divModMutez, divModMutezInt)++class MemOp (c :: T) where+  type MemOpKey c :: T+  evalMem :: Value' instr (MemOpKey c) -> Value' instr c -> Bool+instance MemOp ('TSet e) where+  type MemOpKey ('TSet e) = e+  evalMem e (VSet s) = e `S.member` s+instance MemOp ('TMap k v) where+  type MemOpKey ('TMap k v) = k+  evalMem k (VMap m) = k `M.member` m+instance MemOp ('TBigMap k v) where+  type MemOpKey ('TBigMap k v) = k+  evalMem k (VBigMap _ m) = k `M.member` m++class MapOp (c :: T) where+  type MapOpInp c :: T+  type MapOpRes c :: T -> T+  mapOpToList :: Value' instr c -> [Value' instr (MapOpInp c)]+  mapOpFromList+    :: (SingI b)+    => Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b)+  mapOpNotes :: Notes c -> Notes (MapOpInp c)+instance MapOp ('TMap k v) where+  type MapOpInp ('TMap k v) = 'TPair k v+  type MapOpRes ('TMap k v) = 'TMap k+  mapOpToList (VMap m) = map (\(k, v) -> VPair (k, v)) $ M.toAscList m+  mapOpFromList (VMap m) l =+    VMap $ M.fromList $ zip (map fst $ M.toAscList m) l+  mapOpNotes (NTMap _ nk nv) = NTPair noAnn noAnn noAnn noAnn noAnn nk nv+instance MapOp ('TList e) where+  type MapOpInp ('TList e) = e+  type MapOpRes ('TList e) = 'TList+  mapOpToList (VList l) = l+  mapOpFromList (VList _) l' = VList l'+  mapOpNotes (NTList _ n) = n+-- If you find it difficult to implement 'MapOp' for your datatype+-- because of order of type arguments in it, consider wrapping it+-- into a newtype.++class IterOp (c :: T) where+  type IterOpEl c :: T+  iterOpDetachOne ::+    Value' instr c -> (Maybe (Value' instr (IterOpEl c)), Value' instr c)+  iterOpNotes :: Notes c -> Notes (IterOpEl c)+instance IterOp ('TMap k v) where+  type IterOpEl ('TMap k v) = 'TPair k v+  iterOpDetachOne (VMap m) =+    (VPair <$> M.lookupMin m, VMap $ M.deleteMin m)+  iterOpNotes (NTMap _ nk nv) = NTPair noAnn noAnn noAnn noAnn noAnn nk nv+instance IterOp ('TList e) where+  type IterOpEl ('TList e) = e+  iterOpDetachOne (VList l) =+    case l of+      x : xs -> (Just x, VList xs)+      [] -> (Nothing, VList [])+  iterOpNotes (NTList _ n) = n+instance IterOp ('TSet e) where+  type IterOpEl ('TSet e) = e+  iterOpDetachOne (VSet s) = (S.lookupMin s, VSet $ S.deleteMin s)+  iterOpNotes (NTSet _ n) = n++class SizeOp (c :: T) where+  evalSize :: Value' instr c -> Int+instance SizeOp 'TString where+  evalSize (VString s) = length s+instance SizeOp ('TBytes) where+  evalSize (VBytes b) = length b+instance SizeOp ('TSet a) where+  evalSize (VSet s) = S.size s+instance SizeOp ('TList a) where+  evalSize (VList l) = length l+instance SizeOp ('TMap k v) where+  evalSize (VMap m) = M.size m++class UpdOp (c :: T) where+  type UpdOpKey c :: T+  type UpdOpParams c :: T+  evalUpd+    :: Value' instr (UpdOpKey c)+    -> Value' instr (UpdOpParams c) -> Value' instr c -> Value' instr c+instance UpdOp ('TMap k v) where+  type UpdOpKey ('TMap k v) = k+  type UpdOpParams ('TMap k v) = 'TOption v+  evalUpd k (VOption o) (VMap m) =+    case o of+      Just newV -> VMap $ M.insert k newV m+      Nothing -> VMap $ M.delete k m+instance UpdOp ('TBigMap k v) where+  type UpdOpKey ('TBigMap k v) = k+  type UpdOpParams ('TBigMap k v) = 'TOption v+  evalUpd k (VOption o) (VBigMap bmId m) =+    case o of+      Just newV -> VBigMap bmId $ M.insert k newV m+      Nothing -> VBigMap bmId $ M.delete k m+instance UpdOp ('TSet a) where+  type UpdOpKey ('TSet a) = a+  type UpdOpParams ('TSet a) = 'TBool+  evalUpd k (VBool b) (VSet s) =+    case b of+      True -> VSet $ S.insert k s+      False -> VSet $ S.delete k s++class GetOp (c :: T) where+  type GetOpKey c :: T+  type GetOpVal c :: T+  evalGet :: Value' instr (GetOpKey c) -> Value' instr c -> Maybe (Value' instr (GetOpVal c))+instance GetOp ('TBigMap k v) where+  type GetOpKey ('TBigMap k v) = k+  type GetOpVal ('TBigMap k v) = v+  evalGet k (VBigMap _ m) = k `M.lookup` m+instance GetOp ('TMap k v) where+  type GetOpKey ('TMap k v) = k+  type GetOpVal ('TMap k v) = v+  evalGet k (VMap m) = k `M.lookup` m++class ConcatOp (c :: T) where+  evalConcat :: Value' instr c -> Value' instr c -> Value' instr c+  evalConcat' :: [Value' instr c] -> Value' instr c+instance ConcatOp ('TString) where+  evalConcat (VString s1) (VString s2) = (VString) (s1 <> s2)+  evalConcat' l =+    (VString) $ mconcat $ map (\(VString s) -> s) l+instance ConcatOp ('TBytes) where+  evalConcat (VBytes b1) (VBytes b2) = VBytes (b1 <> b2)+  evalConcat' l =+    (VBytes) $ foldr ((<>) . (\(VBytes b) -> b)) mempty l++class SliceOp (c :: T) where+  evalSlice :: Natural -> Natural -> Value' instr c -> Maybe (Value' instr c)+instance SliceOp 'TString where+  evalSlice o l (VString s) =+    VString <$> sliceImpl dropMText takeMText o l s+instance SliceOp 'TBytes where+  evalSlice o l (VBytes b) =+    VBytes <$> sliceImpl B.drop B.take o l b++sliceImpl ::+  Container str+  => (Int -> str -> str)+  -> (Int -> str -> str)+  -> Natural+  -> Natural+  -> str+  -> Maybe str+sliceImpl dropF takeF offset l s+  | offset >= Unsafe.fromIntegral @Int @Natural (length s) || offset + l > Unsafe.fromIntegral @Int @Natural (length s) =+    Nothing+  | otherwise+  -- Drop offset and then take requested number of items.+   = Just . takeF (Unsafe.fromIntegral @Natural @Int l) . dropF (Unsafe.fromIntegral @Natural @Int offset) $ s++class EDivOp (n :: T) (m :: T) where+  type EDivOpRes n m :: T+  type EModOpRes n m :: T++  -- | Converge the notes of given operands.+  convergeEDiv+    :: Notes n+    -> Notes m+    -> Either AnnConvergeError+        (Notes ('TOption ('TPair (EDivOpRes n m)+                                  (EModOpRes n m))))++  evalEDivOp+    :: Value' instr n+    -> Value' instr m+    -> Value' instr ('TOption ('TPair (EDivOpRes n m)+                                     (EModOpRes n m)))++instance EDivOp 'TInt 'TInt where+  type EDivOpRes 'TInt 'TInt = 'TInt+  type EModOpRes 'TInt 'TInt = 'TNat+  convergeEDiv n1 n2 =+    (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a $ NTNat noAnn)+      <$> converge n1 n2+  evalEDivOp (VInt i) (VInt j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VInt (divMich i j), VNat $ fromInteger $ modMich i j)+instance EDivOp 'TInt 'TNat where+  type EDivOpRes 'TInt 'TNat = 'TInt+  type EModOpRes 'TInt 'TNat = 'TNat+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1+    $ NTNat noAnn+  evalEDivOp (VInt i) (VNat j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VInt (divMich i (toInteger j)), VNat $ fromInteger $ modMich i (toInteger j))+instance EDivOp 'TNat 'TInt where+  type EDivOpRes 'TNat 'TInt = 'TInt+  type EModOpRes 'TNat 'TInt = 'TNat+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn+    (NTInt noAnn) n1+  evalEDivOp (VNat i) (VInt j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VInt (divMich (toInteger i) j), VNat $ fromInteger $ modMich (toInteger i) j)+instance EDivOp 'TNat 'TNat where+  type EDivOpRes 'TNat 'TNat = 'TNat+  type EModOpRes 'TNat 'TNat = 'TNat+  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a a)+    <$> converge n1 n2+  evalEDivOp (VNat i) (VNat j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VNat (divMich i j), VNat $ (modMich i j))+instance EDivOp 'TMutez 'TMutez where+  type EDivOpRes 'TMutez 'TMutez = 'TNat+  type EModOpRes 'TMutez 'TMutez = 'TMutez+  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn (NTNat noAnn) a)+    <$> converge n1 n2+  evalEDivOp (VMutez i) (VMutez j) =+    VOption $+    i `divModMutez` j <&> \case+      (quotient, remainder) ->+        VPair (VNat (fromIntegral quotient), VMutez remainder)++instance EDivOp 'TMutez 'TNat where+  type EDivOpRes 'TMutez 'TNat = 'TMutez+  type EModOpRes 'TMutez 'TNat = 'TMutez+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1 n1+  evalEDivOp (VMutez i) (VNat j) =+    VOption $+    i `divModMutezInt` j <&> \case+      (quotient, remainder) ->+        VPair (VMutez quotient, VMutez remainder)++-- | Computing 'div' function in Michelson style.+-- When divisor is negative, Haskell gives x as integer part,+-- while Michelson gives x+1.+divMich :: Integral a => a -> a -> a+divMich divisible divisor = divisible `div` divisor + extra+  where+    extra =+      if divisor > 0 ||+         divisible `mod` divisor == 0+      then 0+      else 1++-- | Computing 'mod' function in Michelson style.+-- When divisor is negative, Haskell gives a negative modulo,+-- while there is a positive modulo in Michelson.+modMich :: Integral a => a -> a -> a+modMich divisible divisor = divisible - divisor * intPart+  where intPart = divMich divisible divisor

+ src/Morley/Michelson/Typed/Scope.hs view

@@ -0,0 +1,1021 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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 Morley.Michelson.Typed.Scope+  ( -- * Scopes+    ConstantScope+  , DupableScope+  , StorageScope+  , PackedValScope+  , ParameterScope+  , UntypedValScope+  , UnpackedValScope++  , ProperParameterBetterErrors+  , ProperStorageBetterErrors+  , ProperConstantBetterErrors+  , ProperDupableBetterErrors+  , ProperPackedValBetterErrors+  , ProperUnpackedValBetterErrors+  , ProperUntypedValBetterErrors+  , ProperNonComparableValBetterErrors++  , properParameterEvi+  , properStorageEvi+  , properConstantEvi+  , properDupableEvi+  , properPackedValEvi+  , properUnpackedValEvi+  , properUntypedValEvi+  , (:-)(..)++  , BadTypeForScope (..)+  , CheckScope (..)+  , WithDeMorganScope (..)++    -- * Implementation internals+  , HasNoBigMap+  , HasNoNestedBigMaps+  , HasNoOp+  , HasNoContract+  , HasNoTicket+  , ContainsBigMap+  , ContainsContract+  , ContainsNestedBigMaps+  , ContainsOp+  , ContainsTicket+  , IsComparable++  , ForbidOp+  , ForbidContract+  , ForbidTicket+  , ForbidBigMap+  , ForbidNestedBigMaps+  , ForbidNonComparable+  , FailOnBigMapFound+  , FailOnContractFound+  , FailOnNestedBigMapsFound+  , FailOnOperationFound+  , FailOnTicketFound+  , FailOnNonComparableFound++  , OpPresence (..)+  , ContractPresence (..)+  , TicketPresence (..)+  , BigMapPresence (..)+  , NestedBigMapsPresence (..)+  , checkOpPresence+  , checkContractTypePresence+  , checkTicketPresence+  , checkBigMapPresence+  , checkNestedBigMapsPresence+  , opAbsense+  , contractTypeAbsense+  , bigMapAbsense+  , nestedBigMapsAbsense+  , forbiddenOp+  , forbiddenContractType+  , forbiddenBigMap+  , forbiddenNestedBigMaps++    -- * Re-exports+  , withDict+  , SingI (..)+  ) where++import Data.Constraint (Dict(..), withDict, (:-)(..), (\\))+import Data.Singletons (Sing, SingI(..))+import Data.Type.Bool (type (&&), type (||))+import Fmt (Buildable(..))+import GHC.TypeLits (ErrorMessage(..), TypeError)++import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)+import Morley.Michelson.Typed.Sing (SingT(..))+import Morley.Michelson.Typed.T (T(..))++----------------------------------------------------------------------------+-- Constraints+----------------------------------------------------------------------------+-- | Whether a value of this type _may_ contain an operation.+--+-- 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 'TKey = 'False+  ContainsOp 'TUnit = 'False+  ContainsOp 'TSignature = 'False+  ContainsOp 'TChainId = 'False+  ContainsOp ('TOption t) = ContainsOp t+  ContainsOp ('TList t) = ContainsOp t+  ContainsOp ('TSet t) = ContainsOp t+  ContainsOp 'TOperation = 'True+  ContainsOp ('TContract _) = 'False+  ContainsOp ('TTicket t) = ContainsOp t+  ContainsOp ('TPair a b) = ContainsOp a || ContainsOp b+  ContainsOp ('TOr a b) = ContainsOp a || ContainsOp b+  ContainsOp ('TLambda _ _) = 'False+  ContainsOp ('TMap k v) = ContainsOp k || ContainsOp v+  ContainsOp ('TBigMap k v) = ContainsOp k || ContainsOp v+  ContainsOp _ = 'False++-- | Whether a value of this type _may_ contain a @contract@ value.+--+-- 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 '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+  ContainsContract _ = 'False++-- | Whether a value of this type _may_ contain a @ticket@ value.+type family ContainsTicket (t :: T) :: Bool where+  ContainsTicket ('TOption t) = ContainsTicket t+  ContainsTicket ('TList t) = ContainsTicket t+  ContainsTicket ('TSet _) = 'False+  ContainsTicket ('TTicket _) = 'True+  ContainsTicket ('TPair a b) = ContainsTicket a || ContainsTicket b+  ContainsTicket ('TOr a b) = ContainsTicket a || ContainsTicket b+  ContainsTicket ('TLambda _ _) = 'False+  ContainsTicket ('TMap _ v) = ContainsTicket v+  ContainsTicket ('TBigMap _ v) = ContainsTicket v+  ContainsTicket _ = 'False++-- | Whether a value of this type _may_ contain a @big_map@ value.+type family ContainsBigMap (t :: T) :: Bool where+  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 _) = 'False+  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+  ContainsBigMap _ = 'False++-- | Whether a value of this type _may_ contain nested @big_map@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 don't work with big_map at all.+type family ContainsNestedBigMaps (t :: T) :: Bool where+  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 _) = 'False+  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+  ContainsNestedBigMaps _ = 'False++-- | Constraint which ensures that type is comparable.+type family IsComparable (t :: T) :: Bool where+  IsComparable ('TPair a b) =  IsComparable a && IsComparable b+  IsComparable ('TOption t) = IsComparable t+  IsComparable 'TBls12381Fr = 'False+  IsComparable 'TBls12381G1 = 'False+  IsComparable 'TBls12381G2 = 'False+  IsComparable ('TList _) = 'False+  IsComparable ('TSet _) = 'False+  IsComparable 'TOperation = 'False+  IsComparable ('TContract _) = 'False+  IsComparable ('TTicket _) = 'False+  IsComparable ('TOr a b) = IsComparable a && IsComparable b+  IsComparable ('TLambda _ _) = 'False+  IsComparable ('TMap _ _) = 'False+  IsComparable ('TBigMap _ _) = 'False+  IsComparable _            = 'True++-- | Constraint which ensures that a value of type @t@ does not contain operations.+--+-- 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 a value of type @t@ does not contain @contract@ values.+class (ContainsContract t ~ 'False) => HasNoContract t+instance (ContainsContract t ~ 'False) => HasNoContract t++-- | Constraint which ensures that a value of type @t@ does not contain @ticket@ values.+class (ContainsTicket t ~ 'False) => HasNoTicket t+instance (ContainsTicket t ~ 'False) => HasNoTicket t++-- | Constraint which ensures that a value of type @t@ does not contain @big_map@ values.+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 "Type `contract` is not allowed in this scope")+  FailOnContractFound 'False = ()++-- | Report a human-readable error about 'TTicket' at a wrong place.+type family FailOnTicketFound (enabled :: Bool) :: Constraint where+  FailOnTicketFound 'True =+    TypeError ('Text "Type `ticket` is not allowed in this scope")+  FailOnTicketFound '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 = ()++-- | Report a human-readable error that given value is not comparable+type family FailOnNonComparableFound (comparable :: Bool) :: Constraint where+  FailOnNonComparableFound 'True = ()+  FailOnNonComparableFound 'False =+    TypeError ('Text "Only comparable types are allowed here")++-- | 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'.+-- Though, hopefully, it will someday:+-- <https://gitlab.haskell.org/ghc/ghc/issues/11503 #11503>.+--+-- Use this constraint in our eDSL.+type ForbidOp t = FailOnOperationFound (ContainsOp t)++type ForbidContract t = FailOnContractFound (ContainsContract t)++type ForbidTicket t = FailOnTicketFound (ContainsTicket t)++type ForbidBigMap t = FailOnBigMapFound (ContainsBigMap t)++type ForbidNestedBigMaps t = FailOnNestedBigMapsFound (ContainsNestedBigMaps t)++-- | Constraint that rises human-readable error message, in case given value+-- can't be compared+type ForbidNonComparable t = FailOnNonComparableFound (IsComparable 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++-- | Reify 'HasNoTicket' contraint from 'ForbidTicket'.+forbiddenTicketTypeEvi+  :: forall t. (SingI t, ForbidTicket t) :- HasNoTicket t+forbiddenTicketTypeEvi = Sub $+  case checkTicketPresence (sing @t) of+    TicketAbsent -> Dict+    TicketPresent -> error "impossible"++-- | Whether a value of this type _may_ contain an operation.+data OpPresence (t :: T)+  = ContainsOp t ~ 'True => OpPresent+    -- ^ A value of type @t@ may or may not contain an operation.+  | ContainsOp t ~ 'False => OpAbsent+    -- ^ A value of type @t@ cannot contain @big_map@ values.++-- | Whether a value of this type _may_ contain a @contract@ value.+data ContractPresence (t :: T)+  = ContainsContract t ~ 'True => ContractPresent+    -- ^ A value of type @t@ may or may not contain a @contract@ value.+  | ContainsContract t ~ 'False => ContractAbsent+    -- ^ A value of type @t@ cannot contain @contract@ values.++-- | Whether a value of this type _may_ contain a @ticket@ value.+data TicketPresence (t :: T)+  = ContainsTicket t ~ 'True => TicketPresent+    -- ^ A value of type @t@ may or may not contain a @ticket@ value.+  | ContainsTicket t ~ 'False => TicketAbsent+    -- ^ A value of type @t@ cannot contain @ticket@ values.++-- | Whether a value of this type _may_ contain a @big_map@ value.+data BigMapPresence (t :: T)+  = ContainsBigMap t ~ 'True => BigMapPresent+    -- ^ A value of type @t@ may or may not contain a @big_map@ value.+  | ContainsBigMap t ~ 'False => BigMapAbsent+    -- ^ A value of type @t@ cannot contain @big_map@ values.++-- | Whether a value of this type _may_ contain nested @big_map@s.+data NestedBigMapsPresence (t :: T)+  = ContainsNestedBigMaps t ~ 'True => NestedBigMapsPresent+    -- ^ A value of type @t@ may or may not contain nested @big_map@s.+  | ContainsNestedBigMaps t ~ 'False => NestedBigMapsAbsent+    -- ^ A value of type @t@ cannot contain nested @big_map@s.++-- @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 a value of the given type _may_ contain an operation.+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.+  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 a -> case checkOpPresence a of+    OpPresent -> OpPresent+    OpAbsent -> OpAbsent+  STOperation -> OpPresent+  STContract _ -> OpAbsent+  STTicket 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 k v -> case (checkOpPresence k, checkOpPresence v) of+    (OpAbsent, OpAbsent) -> OpAbsent+    (OpPresent, _) -> OpPresent+    (_, OpPresent) -> OpPresent+  STBigMap k v -> case (checkOpPresence k, checkOpPresence v) of+    (OpAbsent, OpAbsent) -> OpAbsent+    (OpPresent, _) -> OpPresent+    (_, OpPresent) -> OpPresent+  STInt -> OpAbsent+  STNat -> OpAbsent+  STString -> OpAbsent+  STBytes -> OpAbsent+  STMutez -> OpAbsent+  STBool -> OpAbsent+  STKeyHash -> OpAbsent+  STBls12381Fr -> OpAbsent+  STBls12381G1 -> OpAbsent+  STBls12381G2 -> OpAbsent+  STTimestamp -> OpAbsent+  STAddress -> OpAbsent+  STNever -> OpAbsent++-- | Check at runtime whether a value of the given type _may_ contain a @contract@ value.+checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty+checkContractTypePresence = \case+  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+  STTicket _ -> ContractAbsent  -- contract type is not allowed in tickets at all+  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+  STInt -> ContractAbsent+  STNat -> ContractAbsent+  STString -> ContractAbsent+  STBytes -> ContractAbsent+  STMutez -> ContractAbsent+  STBool -> ContractAbsent+  STKeyHash -> ContractAbsent+  STBls12381Fr -> ContractAbsent+  STBls12381G1 -> ContractAbsent+  STBls12381G2 -> ContractAbsent+  STTimestamp -> ContractAbsent+  STAddress -> ContractAbsent+  STNever -> ContractAbsent++-- | Check at runtime whether a value of the given type _may_ contain a @ticket@ value.+checkTicketPresence :: Sing (ty :: T) -> TicketPresence ty+checkTicketPresence = \case+  STKey -> TicketAbsent+  STSignature -> TicketAbsent+  STChainId -> TicketAbsent+  STUnit -> TicketAbsent+  STOption t -> case checkTicketPresence t of+    TicketPresent -> TicketPresent+    TicketAbsent -> TicketAbsent+  STList t -> case checkTicketPresence t of+    TicketPresent -> TicketPresent+    TicketAbsent -> TicketAbsent+  STSet _ -> TicketAbsent+  STOperation -> TicketAbsent+  STContract _ -> TicketAbsent+  STTicket _ -> TicketPresent+  STPair a b -> case (checkTicketPresence a, checkTicketPresence b) of+    (TicketPresent, _) -> TicketPresent+    (_, TicketPresent) -> TicketPresent+    (TicketAbsent, TicketAbsent) -> TicketAbsent+  STOr a b -> case (checkTicketPresence a, checkTicketPresence b) of+    (TicketPresent, _) -> TicketPresent+    (_, TicketPresent) -> TicketPresent+    (TicketAbsent, TicketAbsent) -> TicketAbsent+  STLambda _ _ -> TicketAbsent+  STMap _ v -> case checkTicketPresence v of+    TicketPresent -> TicketPresent+    TicketAbsent -> TicketAbsent+  STBigMap _ v -> case checkTicketPresence v of+    TicketPresent -> TicketPresent+    TicketAbsent -> TicketAbsent+  STInt -> TicketAbsent+  STNat -> TicketAbsent+  STString -> TicketAbsent+  STBytes -> TicketAbsent+  STMutez -> TicketAbsent+  STBool -> TicketAbsent+  STKeyHash -> TicketAbsent+  STBls12381Fr -> TicketAbsent+  STBls12381G1 -> TicketAbsent+  STBls12381G2 -> TicketAbsent+  STTimestamp -> TicketAbsent+  STAddress -> TicketAbsent+  STNever -> TicketAbsent++-- | Check at runtime whether a value of the given type _may_ contain a @big_map@ value.+checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty+checkBigMapPresence = \case+  -- More boilerplate to boilerplate god.+  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 _ -> BigMapAbsent+  STTicket _ -> BigMapAbsent  -- big_maps are not allowed in tickets at all+  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+  STInt -> BigMapAbsent+  STNat -> BigMapAbsent+  STString -> BigMapAbsent+  STBytes -> BigMapAbsent+  STMutez -> BigMapAbsent+  STBool -> BigMapAbsent+  STKeyHash -> BigMapAbsent+  STBls12381Fr -> BigMapAbsent+  STBls12381G1 -> BigMapAbsent+  STBls12381G2 -> BigMapAbsent+  STTimestamp -> BigMapAbsent+  STAddress -> BigMapAbsent+  STNever -> BigMapAbsent++-- | Check at runtime whether a value of the given type _may_ contain nested @big_map@s.+checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty+checkNestedBigMapsPresence = \case+  -- More boilerplate to boilerplate god.+  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 _ -> NestedBigMapsAbsent+  STTicket _ -> 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+  STInt -> NestedBigMapsAbsent+  STNat -> NestedBigMapsAbsent+  STString -> NestedBigMapsAbsent+  STBytes -> NestedBigMapsAbsent+  STMutez -> NestedBigMapsAbsent+  STBool -> NestedBigMapsAbsent+  STKeyHash -> NestedBigMapsAbsent+  STBls12381Fr -> NestedBigMapsAbsent+  STBls12381G1 -> NestedBigMapsAbsent+  STBls12381G2 -> NestedBigMapsAbsent+  STTimestamp -> NestedBigMapsAbsent+  STAddress -> NestedBigMapsAbsent+  STNever -> NestedBigMapsAbsent++-- | Check at runtime that a value of the given type cannot contain operations.+opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)+opAbsense s = case checkOpPresence s of+  OpPresent -> Nothing+  OpAbsent -> Just Dict++-- | Check at runtime that a value of the given type cannot contain @contract@ values.+contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoContract t)+contractTypeAbsense s = case checkContractTypePresence s of+  ContractPresent -> Nothing+  ContractAbsent -> Just Dict++-- | Check at runtime that a value of the given type cannot contain @ticket@ values.+ticketAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoTicket t)+ticketAbsense s = case checkTicketPresence s of+  TicketPresent -> Nothing+  TicketAbsent -> Just Dict++-- | Check at runtime that a value of the given type cannot containt @big_map@ values+bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t)+bigMapAbsense s = case checkBigMapPresence s of+  BigMapPresent -> Nothing+  BigMapAbsent -> Just Dict++-- | Check at runtime that a value of the given type cannot contain nested @big_map@s.+nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoNestedBigMaps t)+nestedBigMapsAbsense s = case checkNestedBigMapsPresence s of+  NestedBigMapsPresent -> Nothing+  NestedBigMapsAbsent -> Just Dict++----------------------------------------------------------------------------+-- Scopes+----------------------------------------------------------------------------++data BadTypeForScope+  = BtNotComparable+  | BtIsOperation+  | BtHasBigMap+  | BtHasNestedBigMap+  | BtHasContract+  | BtHasTicket+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)++instance Buildable BadTypeForScope where+  build = buildRenderDoc++instance RenderDoc BadTypeForScope where+  renderDoc _ = \case+    BtNotComparable -> "is not comparable"+    BtIsOperation -> "has 'operation' type"+    BtHasBigMap -> "has 'big_map'"+    BtHasNestedBigMap -> "has nested 'big_map'"+    BtHasContract -> "has 'contract' type"+    BtHasTicket -> "has 'ticket' type"++-- | Set of constraints that Michelson applies to parameters.+--+-- Not just a type alias in order to be able to partially apply it+class (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t+instance (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t++-- | Set of constraints that Michelson applies to contract storage.+--+-- Not just a type alias in order to be able to partially apply it+class (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t+instance (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t++-- | Set of constraints that Michelson applies to pushed constants.+--+-- Not just a type alias in order to be able to partially apply it+class (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t+instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t++-- | Alias for constraints which Michelson requires in @DUP@ instruction.+class (SingI t, HasNoTicket t) => DupableScope t+instance (SingI t, HasNoTicket t) => DupableScope t++-- | Set of constraints that Michelson applies to packed values.+--+-- Not just a type alias in order to be able to partially apply it+class (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t+instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t++-- | Set of constraints that Michelson applies to unpacked values.+--+-- It is different from 'PackedValScope', e.g. @contract@ type cannot appear+-- in a value we unpack to.+--+-- Not just a type alias in order to be able to partially apply it+class (PackedValScope t, ConstantScope t) => UnpackedValScope t+instance (PackedValScope t, ConstantScope t) => UnpackedValScope t++-- | Alias for constraints which are required for untyped representation.+type UntypedValScope t = (SingI t, HasNoOp t)++----------------------------------------------------------------------------+-- Conveniences+----------------------------------------------------------------------------++-- | Should be present for common scopes.+class CheckScope (c :: Constraint) where+  -- | Check that constraint hold for a given type.+  checkScope :: Either BadTypeForScope (Dict c)++instance SingI t => CheckScope (HasNoOp t) where+  checkScope = maybeToRight BtIsOperation $ opAbsense sing+instance SingI t => CheckScope (HasNoBigMap t) where+  checkScope = maybeToRight BtHasBigMap $ bigMapAbsense sing+instance SingI t => CheckScope (HasNoNestedBigMaps t) where+  checkScope = maybeToRight BtHasNestedBigMap $ nestedBigMapsAbsense sing+instance SingI t => CheckScope (HasNoContract t) where+  checkScope = maybeToRight BtHasContract $ contractTypeAbsense sing+instance SingI t => CheckScope (HasNoTicket t) where+  checkScope = maybeToRight BtHasTicket $ ticketAbsense sing++instance SingI t => CheckScope (ParameterScope t) where+  checkScope =+    (\Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoNestedBigMaps t)++instance SingI t => CheckScope (StorageScope t) where+  checkScope =+    (\Dict Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoNestedBigMaps t)+      <*> checkScope @(HasNoContract t)++instance SingI t => CheckScope (ConstantScope t) where+  checkScope =+    (\Dict Dict Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoBigMap t)+      <*> checkScope @(HasNoContract t)+      <*> checkScope @(HasNoTicket t)++instance SingI t => CheckScope (DupableScope t) where+  checkScope =+    (\Dict -> Dict)+      <$> checkScope @(HasNoTicket t)++instance SingI t => CheckScope (PackedValScope t) where+  checkScope =+    (\Dict Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoBigMap t)+      <*> checkScope @(HasNoTicket t)++instance SingI t => CheckScope (UnpackedValScope t) where+  checkScope =+    (\Dict Dict -> Dict)+      <$> checkScope @(PackedValScope t)+      <*> checkScope @(ConstantScope t)++-- | Allows using a scope that can be proven true with a De Morgan law.+--+-- Many scopes are defined as @not a@ (or rather @a ~ 'False@) where @a@ is a+-- negative property we want to avoid as a 'Constraint'.+-- The negative constraints are implemented with a type family that for some+-- combination types resolves to itself applied to the type arguments in an @or@,+-- e.g. A @pair l r@ has @x@ if @l@ or @r@ contain @x@.+--+-- Because of the De Morgan laws @not (a or b)@ implies @(not a) and (not b)@+-- or in our case: @pair@ does not contain @x@ -> @a@ and @b@ don't contain @x@.+--+-- GHC is however not able to prove this, so we need to use another (impossible)+-- 'error' to forcefully "prove" one of the two scopes.+-- Funnily enough however GHC is able to prove that if one holds then the other+-- does too, so we don't actually have to prove both, see 'mkWithDeMorgan'.+class WithDeMorganScope (c :: T -> Constraint) t a b where+  withDeMorganScope :: c (t a b) => ((c a, c b) => ret) -> ret++-- | Helper to builds a 'WithDeMorganScope' by using a 'CheckScope' that we know+-- cannot fail.+--+-- This can be used to make instances that also prove the other side of a+-- negative @or-like@ scope constraint, see 'WithDeMorganScope'.+mkWithDeMorgan+  :: forall scope a ret. CheckScope (scope a)+  => (scope a => ret) -> ret+mkWithDeMorgan f = fromRight (error "impossible") $ do+  Dict <- checkScope @(scope a)+  pure f++instance SingI a => WithDeMorganScope HasNoOp 'TPair a b where+  withDeMorganScope = mkWithDeMorgan @HasNoOp @a++instance SingI a => WithDeMorganScope HasNoContract 'TPair a b where+  withDeMorganScope = mkWithDeMorgan @HasNoContract @a++instance SingI a => WithDeMorganScope HasNoTicket 'TPair a b where+  withDeMorganScope = mkWithDeMorgan @HasNoTicket @a++instance SingI a => WithDeMorganScope HasNoBigMap 'TPair a b where+  withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a++instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TPair a b where+  withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a++instance SingI a => WithDeMorganScope HasNoOp 'TOr a b where+  withDeMorganScope = mkWithDeMorgan @HasNoOp @a++instance SingI a => WithDeMorganScope HasNoContract 'TOr a b where+  withDeMorganScope = mkWithDeMorgan @HasNoContract @a++instance SingI a => WithDeMorganScope HasNoTicket 'TOr a b where+  withDeMorganScope = mkWithDeMorgan @HasNoTicket @a++instance SingI a => WithDeMorganScope HasNoBigMap 'TOr a b where+  withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a++instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TOr a b where+  withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a++instance SingI k => WithDeMorganScope HasNoOp 'TMap k v where+  withDeMorganScope = mkWithDeMorgan @HasNoOp @k++instance SingI k => WithDeMorganScope HasNoOp 'TBigMap k v where+  withDeMorganScope = mkWithDeMorgan @HasNoOp @k++instance+  ( WithDeMorganScope HasNoOp t a b+  , WithDeMorganScope HasNoNestedBigMaps t a b+  , SingI a, SingI b+  ) => WithDeMorganScope ParameterScope t a b where+  withDeMorganScope f =+    withDeMorganScope @HasNoOp @t @a @b $+    withDeMorganScope @HasNoNestedBigMaps @t @a @b f++instance+  ( WithDeMorganScope HasNoOp t a b+  , WithDeMorganScope HasNoNestedBigMaps t a b+  , WithDeMorganScope HasNoContract t a b+  , SingI a, SingI b+  ) => WithDeMorganScope StorageScope t a b where+  withDeMorganScope f =+    withDeMorganScope @HasNoOp @t @a @b $+    withDeMorganScope @HasNoNestedBigMaps @t @a @b $+    withDeMorganScope @HasNoContract @t @a @b f++instance+  ( WithDeMorganScope HasNoOp t a b+  , WithDeMorganScope HasNoBigMap t a b+  , WithDeMorganScope HasNoContract t a b+  , WithDeMorganScope HasNoTicket t a b+  , SingI a, SingI b+  ) => WithDeMorganScope ConstantScope t a b where+  withDeMorganScope f =+    withDeMorganScope @HasNoOp @t @a @b $+    withDeMorganScope @HasNoBigMap @t @a @b $+    withDeMorganScope @HasNoContract @t @a @b $+    withDeMorganScope @HasNoTicket @t @a @b f++instance+  ( WithDeMorganScope HasNoOp t a b+  , WithDeMorganScope HasNoBigMap t a b+  , WithDeMorganScope HasNoTicket t a b+  , SingI a, SingI b+  ) => WithDeMorganScope PackedValScope t a b where+  withDeMorganScope f =+    withDeMorganScope @HasNoOp @t @a @b $+    withDeMorganScope @HasNoBigMap @t @a @b $+    withDeMorganScope @HasNoTicket @t @a @b f++instance+  ( WithDeMorganScope PackedValScope t a b+  , WithDeMorganScope ConstantScope t a b+  , SingI a, SingI b+  ) => WithDeMorganScope UnpackedValScope t a b where+  withDeMorganScope f =+    withDeMorganScope @PackedValScope @t @a @b $+    withDeMorganScope @ConstantScope @t @a @b f++-- 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 =+  (SingI t, ForbidOp t, ForbidNestedBigMaps t)++type ProperStorageBetterErrors t =+  (SingI t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)++type ProperConstantBetterErrors t =+  (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t, ForbidTicket t)++type ProperDupableBetterErrors t =+  (SingI t, ForbidTicket t)++type ProperPackedValBetterErrors t =+  (SingI t, ForbidOp t, ForbidBigMap t, ForbidTicket t)++type ProperUnpackedValBetterErrors t =+  (ProperPackedValBetterErrors t, ProperConstantBetterErrors t)++type ProperUntypedValBetterErrors t =+  (SingI t, ForbidOp t)++type ProperNonComparableValBetterErrors t =+  (SingI t, ForbidNonComparable 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+       \\ forbiddenTicketTypeEvi @t++properDupableEvi :: forall t. ProperDupableBetterErrors t :- DupableScope t+properDupableEvi = Sub $+  Dict \\ forbiddenTicketTypeEvi @t++properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t+properPackedValEvi = Sub $+  Dict \\ forbiddenOpEvi @t+       \\ forbiddenBigMapEvi @t+       \\ forbiddenTicketTypeEvi @t++properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t+properUnpackedValEvi = Sub $+  Dict \\ properPackedValEvi @t+       \\ properConstantEvi @t++properUntypedValEvi :: forall t. ProperUntypedValBetterErrors t :- UntypedValScope t+properUntypedValEvi = Sub $+  Dict \\ forbiddenOpEvi @t

+ src/Morley/Michelson/Typed/Sing.hs view

@@ -0,0 +1,93 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE StandaloneKindSignatures #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Module, providing singleton boilerplate for+-- 'T' data types.+--+-- Some functions from Data.Singletons are provided alternative version here.++module Morley.Michelson.Typed.Sing+  ( SingT (..)+  , castSingE+  , castM+  , eqP+  , requireEq+  ) where++import Data.Singletons (Demote, KindOf, SingI(..), demote)+import Data.Singletons.TH (genSingletons, singDecideInstance)+import Data.Singletons.TH.Options (Options(..), defaultOptions, withOptions)+import Data.Type.Equality ((:~:)(..))+import Language.Haskell.TH (Name, mkName, nameBase)++import Fmt ((+||), (||+))+import Morley.Michelson.Typed.T (T(..))+import Morley.Util.Sing (SingI1(..), castSing, eqI)++-- | 'SingI' and 'Data.Singletons.TH.SDecide' instances for the 'T' kind.+$(let singPrefix, sPrefix :: Name -> Name+      singPrefix nm = mkName ("Sing" ++ nameBase nm)+      sPrefix nm = mkName ("S" ++ nameBase nm) in++  withOptions defaultOptions{singledDataConName = sPrefix, singledDataTypeName = singPrefix} $+  concat <$> sequence [genSingletons [''T], singDecideInstance ''T]+  )++---------------------------------------------+-- 'Data.Singletons.withSingI' usage+--------------------------------------------++-- | Previously, we were using 'SingI' constraints in 'SingT'+-- constructors. That was not so optimal because we have been+-- spending too much space at runtime. Instead of that, we process+-- values of 'SingT' using the function 'Data.Singletons.withSingI' in those places+-- where the 'SingI' constraint is required. 'Data.Singletons.withSingI' allows one+-- to create the 'SingI' context for a given t'Data.Singletons.Sing'.++---------------------------------------------+-- Singleton-related helpers for T+----------------------------------------------+instance SingI1 'TList where+  withSingI1 x = x++instance SingI k => SingI1 ('TMap k) where+  withSingI1 x = x++castSingE+  :: forall (a :: T) (b :: T) t. (SingI a, SingI b)+  => t a -> Either Text (t b)+castSingE = maybeToRight errMsg . castSing+  where+    errMsg = "Type mismatch: expected " +|| demote @a ||++                               ", got " +|| demote @b ||+ ""++-- | Monadic version of 'castSing'.+-- Throws an error using the given function if the cast fails.+castM+  :: forall (a :: T) (b :: T) t m. (SingI a, SingI b, Monad m)+  => t a+  -> (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x)+  -> m (t b)+castM a throwErr =+  requireEq @a @b throwErr <&> \Refl -> a++-- | Monadic version of 'eqI'.+-- Throws an error using the given function if the two types are not equal.+requireEq+  :: forall (a :: T) (b :: T) m. (SingI a, SingI b, Monad m)+  => (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x)+  -> m (a :~: b)+requireEq throwErr =+  case eqI @a @b of+    Just p -> pure p+    Nothing -> throwErr (demote @a) (demote @b)++-- | Version of 'eqI' that uses 'Proxy'+eqP :: forall (a :: T) (b :: T). (SingI a, SingI b) => Proxy a -> Proxy b -> Maybe (a :~: b)+eqP _ _ = eqI @a @b

+ src/Morley/Michelson/Typed/T.hs view

@@ -0,0 +1,99 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, providing 'T' data type, representing Michelson+-- language types without annotations.+module Morley.Michelson.Typed.T+  ( T (..)+  , toUType+  , buildStack+  ) where++import Fmt (Buildable(..), Builder, listF)+import Morley.Michelson.Printer.Util (RenderDoc(..))+import qualified Morley.Michelson.Untyped.Annotation as Un+import qualified Morley.Michelson.Untyped.Type as Un++-- | Michelson language type with annotations stripped off.+data T =+    TKey+  | TUnit+  | TSignature+  | TChainId+  | TOption T+  | TList T+  | TSet T+  | TOperation+  | TContract T+  | TTicket T+  | TPair T T+  | TOr T T+  | TLambda T T+  | TMap T T+  | TBigMap T T+  | TInt+  | TNat+  | TString+  | TBytes+  | TMutez+  | TBool+  | TKeyHash+  | TBls12381Fr+  | TBls12381G1+  | TBls12381G2+  | TTimestamp+  | TAddress+  | TNever+  deriving stock (Eq, Show, Generic)++instance NFData T++-- | Converts from 'T' to 'Un.Ty'.+toUType :: T -> Un.Ty+toUType t = Un.Ty (convert t) Un.noAnn+  where+    convert :: T -> Un.T+    convert TInt = Un.TInt+    convert TNat = Un.TNat+    convert TString = Un.TString+    convert TBytes = Un.TBytes+    convert TMutez = Un.TMutez+    convert TBool = Un.TBool+    convert TKeyHash = Un.TKeyHash+    convert TTimestamp = Un.TTimestamp+    convert TAddress = Un.TAddress+    convert TKey = Un.TKey+    convert TBls12381Fr = Un.TBls12381Fr+    convert TBls12381G1 = Un.TBls12381G1+    convert TBls12381G2 = Un.TBls12381G2+    convert TUnit = Un.TUnit+    convert TSignature = Un.TSignature+    convert TChainId = Un.TChainId+    convert TNever = Un.TNever+    convert (TOption a) = Un.TOption (toUType a)+    convert (TList a) = Un.TList (toUType a)+    convert (TSet a) = Un.TSet $ Un.Ty (Un.unwrapT $ toUType a) Un.noAnn+    convert (TOperation) = Un.TOperation+    convert (TContract a) = Un.TContract (toUType a)+    convert (TTicket a) = Un.TTicket (toUType a)+    convert (TPair a b) =+      Un.TPair Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType a) (toUType b)+    convert (TOr a b) =+      Un.TOr Un.noAnn Un.noAnn (toUType a) (toUType b)+    convert (TLambda a b) =+      Un.TLambda (toUType a) (toUType b)+    convert (TMap a b) =+      Un.TMap (Un.Ty (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)+    convert (TBigMap a b) =+      Un.TBigMap (Un.Ty (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)++instance Buildable T where+  build = build . toUType++instance RenderDoc T where+  renderDoc context = renderDoc context . toUType++-- | Format type stack in a pretty way.+buildStack :: [T] -> Builder+buildStack = listF

+ src/Morley/Michelson/Typed/TypeLevel.hs view

@@ -0,0 +1,59 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | A collection of type families and other type-level machinery+-- for working with Michelson types.+module Morley.Michelson.Typed.TypeLevel+  ( -- * Right-combed pairs+    IsPair+  , CombedPairLeafCount+  , CombedPairNodeCount+  , CombedPairLeafCountIsAtLeast+  , CombedPairNodeIndexIsValid+  )+  where++import Morley.Michelson.Typed.T (T(TPair))+import Morley.Util.Peano (Nat(S, Z), Peano, ToPeano)++----------------------------------------------------------------------------+-- Right-combed pairs+----------------------------------------------------------------------------++type family IsPair (pair :: T) :: Bool where+  IsPair ('TPair _ _) = 'True+  IsPair _ = 'False++-- | Returns the number of leaves in a right-combed pair.+--+-- > CombedPairLeafCount ('TPair 'TInt ('TPair 'TString 'TUnit))+-- > ~+-- > ToPeano 3+--+-- If the pair contains sub-trees to the left, they will not be accounted for.+-- E.g. the length of @pair w (pair x y) z@ is 3.+type family CombedPairLeafCount (t :: T) :: Peano where+  CombedPairLeafCount ('TPair _ ('TPair y z)) = 'S (CombedPairLeafCount ('TPair y z))+  CombedPairLeafCount ('TPair _ _) = ToPeano 2++-- | Returns the number of nodes in a right-combed pair.+type family CombedPairNodeCount (t :: T) :: Peano where+  CombedPairNodeCount ('TPair _ ('TPair y z)) = 'S ('S (CombedPairNodeCount ('TPair y z)))+  CombedPairNodeCount ('TPair _ _) = ToPeano 3++-- | Checks whether a pair contains at least @n@ elements.+type family CombedPairLeafCountIsAtLeast (n :: Peano) (t :: T) :: Bool where+  CombedPairLeafCountIsAtLeast ('S ('S 'Z)) ('TPair _ _) = 'True+  CombedPairLeafCountIsAtLeast ('S n) ('TPair _ y) = CombedPairLeafCountIsAtLeast n y+  CombedPairLeafCountIsAtLeast ('S _) _ = 'False++-- | For a given node index @i@, this type family checks whether+-- a pair has at least @i+1@ nodes.+--+-- Note that the index 0 is always valid, even if the input type is not a pair.+type family CombedPairNodeIndexIsValid (nodeIndex :: Peano) (pair :: T) :: Bool where+  CombedPairNodeIndexIsValid 'Z                   _                = 'True+  CombedPairNodeIndexIsValid ('S 'Z)              ('TPair _ _)     = 'True+  CombedPairNodeIndexIsValid ('S ('S nodeIndex')) ('TPair _ right) = CombedPairNodeIndexIsValid nodeIndex' right+  CombedPairNodeIndexIsValid _ _                                   = 'False

+ src/Morley/Michelson/Typed/Util.hs view

@@ -0,0 +1,792 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | General-purpose utility functions for typed types.++module Morley.Michelson.Typed.Util+  ( DfsSettings (..)+  , CtorEffectsApp (..)+  , ceaBottomToTop+  , dfsInstr+  , dfsFoldInstr+  , dfsModifyInstr++  -- * Changing instruction tree structure+  , linearizeLeft+  , linearizeLeftDeep++  -- * Value analysis+  , dfsFoldMapValue+  , dfsFoldMapValueM+  , dfsMapValue+  , dfsTraverseValue+  , isStringValue+  , isBytesValue+  , allAtomicValues++  -- * Instruction generation+  , PushableStorageSplit (..)+  , splitPushableStorage+  ) where++import Prelude hiding (Ordering(..))++import Control.Monad.Writer.Strict (execWriterT, runWriter, tell, writer)+import Data.Constraint (Dict(..))+import Data.Default (Default(..))+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Text.Show++import Morley.Michelson.Text (MText)+import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.Scope+import qualified Morley.Michelson.Typed.T as T+import Morley.Michelson.Typed.Value++-- | Options for 'dfsInstr'.+data DfsSettings x = DfsSettings+  { dsGoToValues :: Bool+    -- ^ Whether 'dfsInstr' function should go into values which contain other+    -- instructions: lambdas and constant contracts+    -- (which can be passed to @CREATE_CONTRACT@).+  , dsCtorEffectsApp :: CtorEffectsApp x+    -- ^ How do we handle intermediate nodes in instruction tree.+  } deriving stock (Show)++-- | Describes how intermediate nodes in instruction tree are accounted.+data CtorEffectsApp x = CtorEffectsApp+  { ceaName :: Text+    -- ^ Name of this way.+  , ceaApplyEffects+      :: forall i o. Semigroup x => x -> x -> Instr i o -> (Instr i o, x)+    -- ^ This function accepts:+    -- 1. Effects gathered after applying @step@ to node's children, but+    -- before applying it to the node itself.+    -- 2. Effects gathered after applying @step@ to the given intermediate node.+    -- 3. Instruction resulting after all modifications produced by @step@.+  }++instance Show (CtorEffectsApp x) where+  show CtorEffectsApp{..} = show ceaName++-- | Gather effects first for children nodes, then for their parents.+ceaBottomToTop :: CtorEffectsApp x+ceaBottomToTop = CtorEffectsApp+  { ceaName = "Apply after"+  , ceaApplyEffects =+      \effBefore effAfter instr -> (instr, effBefore <> effAfter)+  }++instance Default (DfsSettings x) where+  def = DfsSettings+    { dsGoToValues = False+    , dsCtorEffectsApp = ceaBottomToTop+    }++-- | Traverse a typed instruction in depth-first order.+-- '<>' is used to concatenate intermediate results.+-- Each instructions can be changed using the supplied @step@ function.+-- It does not consider extra instructions (not present in Michelson).+dfsInstr ::+     forall x inp out. Semigroup x+  => DfsSettings x+  -> (forall i o. Instr i o -> (Instr i o, x))+  -> Instr inp out+  -> (Instr inp out, x)+dfsInstr settings@DfsSettings{..} step i =+  case i of+    Seq i1 i2 -> recursion2 Seq i1 i2+    WithLoc loc i1 -> recursion1 (WithLoc loc) i1+    Meta meta i1 -> recursion1 (Meta meta) i1+    InstrWithNotes p notes i1 -> recursion1 (InstrWithNotes p notes) i1+    InstrWithVarNotes varNotes i1 -> recursion1 (InstrWithVarNotes varNotes) i1+    InstrWithVarAnns varAnns i1 -> recursion1 (InstrWithVarAnns varAnns) i1+    FrameInstr p i1 -> recursion1 (FrameInstr p) i1+    Nested i1 -> recursion1 Nested i1+    DocGroup dg i1 -> recursion1 (DocGroup dg) i1+    Fn t sfn i1 -> recursion1 (Fn t sfn) i1+    IF_NONE i1 i2 -> recursion2 IF_NONE i1 i2+    IF_LEFT i1 i2 -> recursion2 IF_LEFT i1 i2+    IF_CONS i1 i2 -> recursion2 IF_CONS i1 i2+    IF i1 i2 -> recursion2 IF i1 i2+    MAP i1 -> recursion1 MAP i1+    ITER i1 -> recursion1 ITER i1+    LOOP i1 -> recursion1 LOOP i1+    LOOP_LEFT i1 -> recursion1 LOOP_LEFT i1+    DIP i1 -> recursion1 DIP i1+    DIPN s i1 -> recursion1 (DIPN s) i1++    -- This case is more complex so we duplicate @recursion1@ a bit.+    -- We have to traverse the pushed value because a lambda can be+    -- somewhere inside of it (e. g. one item of a pair).+    PUSH v -> fromMaybe (step i) do+        guard dsGoToValues+        let+          valueStep :: forall t . Value t -> (Value t, Maybe x)+          valueStep = \case+            -- Using 'analyzeInstrFailure' here (and in case below) is cheap+            -- (O(n) in total) because we never make it run over the same code twice+            VLam lambda -> bimap (VLam . analyzeInstrFailure) Just $+              dfsInstr settings step (rfAnyInstr lambda)+            otherV -> (otherV, Nothing)+        -- Note that @dfsTraverseValue@ does not respect 'CtorEffectsApp',+        -- so if we encounter a value that contains more than one lambda+        -- this function may misbehave.+        -- That's very unlikely in practice.+        -- In #264 we will support this feature in @dfsTraverseValue@.+        let+          (innerV, innerXMaybe) = runWriter $ dfsTraverseValue (writer . valueStep) v++        innerX <- innerXMaybe+        let (outerI, outerX) = step $ PUSH innerV+        pure $ ceaApplyEffects dsCtorEffectsApp innerX outerX outerI++    LAMBDA (VLam i1)+      | dsGoToValues ->+          recursion1 (LAMBDA . VLam . analyzeInstrFailure) (rfAnyInstr i1)+      | otherwise -> step i+    CREATE_CONTRACT contract+      | dsGoToValues ->+        let updateContractCode code = CREATE_CONTRACT $ contract{ cCode = code }+        in recursion1 updateContractCode $ cCode contract+      | otherwise -> step i++    Nop{} -> step i+    Ext (TEST_ASSERT (TestAssert nm pc i1)) ->+      recursion1 (Ext . TEST_ASSERT . TestAssert nm pc) i1+    Ext{} -> step i+    AnnCAR{} -> step i+    AnnCDR{} -> step i+    DROP{} -> step i+    DROPN{} -> step i+    DUP{} -> step i+    DUPN{} -> step i+    SWAP{} -> step i+    DIG{} -> step i+    DUG{} -> step i+    SOME{} -> step i+    NONE{} -> step i+    UNIT{} -> step i+    AnnPAIR{} -> step i+    AnnUNPAIR{} -> step i+    PAIRN{} -> step i+    UNPAIRN{} -> step i+    AnnLEFT{} -> step i+    AnnRIGHT{} -> step i+    NIL{} -> step i+    CONS{} -> step i+    SIZE{} -> step i+    EMPTY_SET{} -> step i+    EMPTY_MAP{} -> step i+    EMPTY_BIG_MAP{} -> step i+    MEM{} -> step i+    GET{} -> step i+    GETN{} -> step i+    UPDATE{} -> step i+    UPDATEN{} -> step i+    GET_AND_UPDATE{} -> step i+    EXEC{} -> step i+    APPLY{} -> step i+    FAILWITH{} -> step i+    CAST{} -> step i+    RENAME{} -> step i+    PACK{} -> step i+    UNPACK{} -> step i+    CONCAT{} -> step i+    CONCAT'{} -> step i+    SLICE{} -> step i+    ISNAT{} -> step i+    ADD{} -> step i+    SUB{} -> step i+    MUL{} -> step i+    EDIV{} -> step i+    ABS{} -> step i+    NEG{} -> step i+    LSL{} -> step i+    LSR{} -> step i+    OR{} -> step i+    AND{} -> step i+    XOR{} -> step i+    NOT{} -> step i+    COMPARE{} -> step i+    EQ{} -> step i+    NEQ{} -> step i+    LT{} -> step i+    GT{} -> step i+    LE{} -> step i+    GE{} -> step i+    INT{} -> step i+    SELF{} -> step i+    CONTRACT{} -> step i+    TRANSFER_TOKENS{} -> step i+    SET_DELEGATE{} -> step i+    IMPLICIT_ACCOUNT{} -> step i+    NOW{} -> step i+    AMOUNT{} -> step i+    BALANCE{} -> step i+    VOTING_POWER{} -> step i+    TOTAL_VOTING_POWER{} -> step i+    CHECK_SIGNATURE{} -> step i+    SHA256{} -> step i+    SHA512{} -> step i+    BLAKE2B{} -> step i+    SHA3{} -> step i+    KECCAK{} -> step i+    HASH_KEY{} -> step i+    PAIRING_CHECK{} -> step i+    SOURCE{} -> step i+    SENDER{} -> step i+    ADDRESS{} -> step i+    CHAIN_ID{} -> step i+    LEVEL{} -> step i+    SELF_ADDRESS{} -> step i+    NEVER{} -> step i+    TICKET{} -> step i+    READ_TICKET{} -> step i+    SPLIT_TICKET{} -> step i+    JOIN_TICKETS{} -> step i+  where+    recursion1 ::+      forall a b c d. (Instr a b -> Instr c d) -> Instr a b -> (Instr c d, x)+    recursion1 constructor i0 =+      let+        (innerI, innerX) = dfsInstr settings step i0+        (outerI, outerX) = step $ constructor innerI+      in ceaApplyEffects dsCtorEffectsApp innerX outerX outerI++    recursion2 ::+      forall i o i1 o1 i2 o2.+      (Instr i1 o1 -> Instr i2 o2 -> Instr i o) ->+      Instr i1 o1 -> Instr i2 o2 -> (Instr i o, x)+    recursion2 constructor i1 i2 =+      let+        (i1', x1) = dfsInstr settings step i1+        (i2', x2) = dfsInstr settings step i2+        (i', x) = step $ constructor i1' i2'+      in ceaApplyEffects dsCtorEffectsApp (x1 <> x2) x i'++-- | Specialization of 'dfsInstr' for case when changing the instruction is+-- not required.+dfsFoldInstr+  :: forall x inp out.+      (Semigroup x)+  => DfsSettings x+  -> (forall i o. Instr i o -> x)+  -> Instr inp out+  -> x+dfsFoldInstr settings step instr =+  snd $ dfsInstr settings (\i -> (i, step i)) instr++-- | Specialization of 'dfsInstr' which only modifies given instruction.+dfsModifyInstr+  :: DfsSettings ()+  -> (forall i o. Instr i o -> Instr i o)+  -> Instr inp out+  -> Instr inp out+dfsModifyInstr settings step instr =+  fst $ dfsInstr settings (\i -> (step i, ())) instr++-- | Check whether instruction fails at each execution path or have at least one+-- non-failing path.+--+-- This function assumes that given instruction contains no dead code+-- (contract with dead code cannot be valid Michelson contract) and may behave+-- in unexpected way if such is present. Term "dead code" includes instructions+-- which render into empty Michelson, like Morley extensions.+-- On the other hand, this function does not traverse the whole instruction tree;+-- performs fastest on left-growing combs.+--+-- Often we already have information about instruction failure, use this+-- function only in cases when this info is actually unavailable or hard+-- to use.+analyzeInstrFailure :: HasCallStack => Instr i o -> RemFail Instr i o+analyzeInstrFailure = go+  where+  go :: Instr i o -> RemFail Instr i o+  go = \case+    WithLoc loc i -> case go i of+      RfNormal i0 ->+        RfNormal (WithLoc loc i0)+      r -> r+    Meta meta i -> case go i of+      RfNormal i0 ->+        RfNormal (Meta meta i0)+      r -> r+    InstrWithNotes p pn i -> case go i of+      RfNormal i0 ->+        RfNormal (InstrWithNotes p pn i0)+      RfAlwaysFails i0 ->+        error $ "InstrWithNotes wraps always-failing instruction: " <> show i0+    InstrWithVarNotes vn i -> case go i of+      RfNormal i0 ->+        RfNormal (InstrWithVarNotes vn i0)+      RfAlwaysFails i0 ->+        error $ "InstrWithVarNotes wraps always-failing instruction: " <> show i0+    InstrWithVarAnns vn i -> case go i of+      RfNormal i0 ->+        RfNormal (InstrWithVarAnns vn i0)+      RfAlwaysFails i0 ->+        error $ "InstrWithVarAnns wraps always-failing instruction: " <> show i0+    FrameInstr s i -> case go i of+      RfNormal i0 ->+        RfNormal (FrameInstr s i0)+      RfAlwaysFails i0 ->+        error $ "FrameInstr wraps always-failing instruction: " <> show i0+    Seq a b -> Seq a `rfMapAnyInstr` go b+    Nop -> RfNormal Nop+    Ext e -> RfNormal (Ext e)+    Nested i -> Nested `rfMapAnyInstr` go i+    DocGroup g i -> DocGroup g `rfMapAnyInstr` go i+    Fn t sfn i -> Fn t sfn `rfMapAnyInstr` go i++    IF_NONE l r -> rfMerge IF_NONE (go l) (go r)+    IF_LEFT l r -> rfMerge IF_LEFT (go l) (go r)+    IF_CONS l r -> rfMerge IF_CONS (go l) (go r)+    IF l r -> rfMerge IF (go l) (go r)++    i@MAP{} -> RfNormal i+    i@ITER{} -> RfNormal i+    i@LOOP{} -> RfNormal i+    i@LOOP_LEFT{} -> RfNormal i+    i@LAMBDA{} -> RfNormal i+    i@DIP{} -> RfNormal i+    i@DIPN{} -> RfNormal i++    i@AnnCAR{} -> RfNormal i+    i@AnnCDR{} -> RfNormal i+    i@DROP{} -> RfNormal i+    i@DROPN{} -> RfNormal i+    i@DUP{} -> RfNormal i+    i@DUPN{} -> RfNormal i+    i@SWAP{} -> RfNormal i+    i@DIG{} -> RfNormal i+    i@DUG{} -> RfNormal i+    i@PUSH{} -> RfNormal i+    i@SOME{} -> RfNormal i+    i@NONE{} -> RfNormal i+    i@UNIT{} -> RfNormal i+    i@AnnPAIR{} -> RfNormal i+    i@AnnUNPAIR{} -> RfNormal i+    i@PAIRN{} -> RfNormal i+    i@UNPAIRN{} -> RfNormal i+    i@AnnLEFT{} -> RfNormal i+    i@AnnRIGHT{} -> RfNormal i+    i@NIL{} -> RfNormal i+    i@CONS{} -> RfNormal i+    i@SIZE{} -> RfNormal i+    i@EMPTY_SET{} -> RfNormal i+    i@EMPTY_MAP{} -> RfNormal i+    i@EMPTY_BIG_MAP{} -> RfNormal i+    i@MEM{} -> RfNormal i+    i@GET{} -> RfNormal i+    i@GETN{} -> RfNormal i+    i@UPDATE{} -> RfNormal i+    i@UPDATEN{} -> RfNormal i+    i@GET_AND_UPDATE{} -> RfNormal i+    i@EXEC{} -> RfNormal i+    i@APPLY{} -> RfNormal i+    FAILWITH -> RfAlwaysFails FAILWITH+    i@CAST -> RfNormal i+    i@RENAME -> RfNormal i+    i@PACK -> RfNormal i+    i@UNPACK -> RfNormal i+    i@CONCAT -> RfNormal i+    i@CONCAT' -> RfNormal i+    i@SLICE -> RfNormal i+    i@ISNAT -> RfNormal i+    i@ADD -> RfNormal i+    i@SUB -> RfNormal i+    i@MUL -> RfNormal i+    i@EDIV -> RfNormal i+    i@ABS -> RfNormal i+    i@NEG -> RfNormal i+    i@LSL -> RfNormal i+    i@LSR -> RfNormal i+    i@OR -> RfNormal i+    i@AND -> RfNormal i+    i@XOR -> RfNormal i+    i@NOT -> RfNormal i+    i@COMPARE -> RfNormal i+    i@EQ -> RfNormal i+    i@NEQ -> RfNormal i+    i@LT -> RfNormal i+    i@GT -> RfNormal i+    i@LE -> RfNormal i+    i@GE -> RfNormal i+    i@INT -> RfNormal i+    i@SELF{} -> RfNormal i+    i@CONTRACT{} -> RfNormal i+    i@TRANSFER_TOKENS -> RfNormal i+    i@SET_DELEGATE -> RfNormal i+    i@CREATE_CONTRACT{} -> RfNormal i+    i@IMPLICIT_ACCOUNT -> RfNormal i+    i@NOW -> RfNormal i+    i@AMOUNT -> RfNormal i+    i@BALANCE -> RfNormal i+    i@VOTING_POWER -> RfNormal i+    i@TOTAL_VOTING_POWER -> RfNormal i+    i@CHECK_SIGNATURE -> RfNormal i+    i@SHA256 -> RfNormal i+    i@SHA512 -> RfNormal i+    i@BLAKE2B -> RfNormal i+    i@SHA3 -> RfNormal i+    i@KECCAK -> RfNormal i+    i@HASH_KEY -> RfNormal i+    i@PAIRING_CHECK -> RfNormal i+    i@SOURCE -> RfNormal i+    i@SENDER -> RfNormal i+    i@ADDRESS -> RfNormal i+    i@CHAIN_ID -> RfNormal i+    i@LEVEL -> RfNormal i+    i@SELF_ADDRESS -> RfNormal i+    NEVER -> RfAlwaysFails NEVER+    i@TICKET -> RfNormal i+    i@READ_TICKET -> RfNormal i+    i@SPLIT_TICKET -> RfNormal i+    i@JOIN_TICKETS -> RfNormal i++-- | There are many ways to represent a sequence of more than 2 instructions.+-- E. g. for @i1; i2; i3@ it can be @Seq i1 $ Seq i2 i3@ or @Seq (Seq i1 i2) i3@.+-- This function enforces a particular structure. Specifically, it makes each+-- v'Seq' have a single instruction (i. e. not v'Seq') in its second argument.+-- This function also erases redundant 'Nop's.+--+-- Please note that this function is not recursive, it does not+-- linearize contents of @IF@ and similar instructions.+linearizeLeft :: Instr inp out -> Instr inp out+linearizeLeft = linearizeLeftHelper False+  where+    -- In order to avoid quadratic performance we make a simple optimization.+    -- We track whether left argument of `Seq` is already linearized.+    -- If it is, we do not need to ever linearize it again.+    linearizeLeftHelper :: Bool -> Instr inp out -> Instr inp out+    linearizeLeftHelper isLeftInstrAlreadyLinear =+      \case+        Seq i1 (Seq i2 i3) ->+          linearizeLeftHelper True $+          Seq (linearizeLeftHelper isLeftInstrAlreadyLinear (Seq i1 i2)) i3+        -- `i2` is not a `Seq`, so we only need to linearize `i1`+        -- and connect it with `i2`.+        Seq i1 i2+          | isLeftInstrAlreadyLinear+          , Nop <- i2 -> i1+          | isLeftInstrAlreadyLinear -> Seq i1 i2+          | Nop <- i2 -> linearizeLeft i1+          | otherwise -> Seq (linearizeLeft i1) i2+        i -> i++-- | \"Deep\" version of 'linearizeLeft'. It recursively linearizes+-- instructions stored in other instructions.+linearizeLeftDeep :: Instr inp out -> Instr inp out+linearizeLeftDeep = dfsModifyInstr def linearizeLeft++----------------------------------------------------------------------------+-- Value analysis+----------------------------------------------------------------------------++-- | Traverse a value in depth-first order.+dfsMapValue ::+     forall t.+     (forall t'. Value t' -> Value t')+  -> Value t+  -> Value t+dfsMapValue step v = runIdentity $ dfsTraverseValue (pure . step) v++-- | Traverse a value in depth-first order.+dfsTraverseValue ::+     forall t m.+     (Monad m)+  => (forall t'. Value t' -> m (Value t'))+  -> Value t+  -> m (Value t)+dfsTraverseValue step i = case i of+  -- Atomic+  VKey{} -> step i+  VUnit -> step i+  VSignature{} -> step i+  VChainId{} -> step i+  VOp{} -> step i+  VContract{} -> step i+  VTicket{} -> step i  -- cannot appear as constant in a contract+  VLam{} -> step i+  VInt{} -> step i+  VNat{} -> step i+  VString{} -> step i+  VBytes{} -> step i+  VMutez{} -> step i+  VBool{} -> step i+  VKeyHash{} -> step i+  VBls12381Fr{} -> step i+  VBls12381G1{} -> step i+  VBls12381G2{} -> step i+  VTimestamp{} -> step i+  VAddress{} -> step i++  -- Non-atomic+  VOption mVal -> case mVal of+    Nothing -> step i+    Just val -> recursion1 (VOption . Just) val+  VList vals -> do+    vs <- traverse (dfsTraverseValue step) vals+    step $ VList vs+  VSet vals -> do+    cs <- S.fromList <$> traverse (dfsTraverseValue step) (S.toList vals)+    step (VSet cs)+  VPair (v1, v2) -> do+    v1' <- dfsTraverseValue step v1+    v2' <- dfsTraverseValue step v2+    step $ VPair (v1', v2')+  VOr vEither -> case vEither of+    Left v -> recursion1 (VOr . Left) v+    Right v -> recursion1 (VOr . Right) v+  VMap vmap -> mapRecursion VMap vmap+  VBigMap bmId vmap -> mapRecursion (VBigMap bmId) vmap+  where+    recursion1 ::+         forall t'.+         (Value t' -> Value t)+      -> Value t'+      -> m (Value t)+    recursion1 constructor v = do+      v' <- dfsTraverseValue step v+      step $ constructor v'++    mapRecursion+      :: forall k v. Comparable k+      => (M.Map (Value k) (Value v) -> Value t)+      -> M.Map (Value k) (Value v)+      -> m (Value t)+    mapRecursion constructor vmap = do+      vmap' <-+        M.fromList <$> forM (M.toList vmap) \(k, v) -> do+          k' <- dfsTraverseValue step k+          v' <- dfsTraverseValue step v+          pure (k', v')+      step $ constructor vmap'++-- | Specialization of 'dfsMapValue' for case when changing the value is+-- not required.+dfsFoldMapValue ::+  Monoid x =>+  (forall t'. Value t' -> x)+  -> Value t+  -> x+dfsFoldMapValue step v =+  runIdentity $ dfsFoldMapValueM (pure . step) v++-- | Specialization of 'dfsMapValue' for case when changing the value is+-- not required.+dfsFoldMapValueM+  :: (Monoid x, Monad m)+  => (forall t'. Value t' -> m x)+  -> Value t+  -> m x+dfsFoldMapValueM step v = do+  execWriterT $+    dfsTraverseValue+      (\val -> do+          x <- lift $ step val+          tell x+          pure val+      )+      v++-- | If value is a string, return the stored string.+isStringValue :: Value t -> Maybe MText+isStringValue =+  \case+    VString str -> Just str+    _ -> Nothing++-- | If value is a bytestring, return the stored bytestring.+isBytesValue :: Value t -> Maybe ByteString+isBytesValue =+  \case+    VBytes bytes -> Just bytes+    _ -> Nothing++-- | Takes a selector which checks whether a value can be converted+-- to something. Recursively applies it to all values. Collects extracted+-- values in a list.+allAtomicValues ::+  forall t a. (forall t'. Value t' -> Maybe a) -> Value t -> [a]+allAtomicValues selector = dfsFoldMapValue (maybeToList . selector)+++--------------------------------------------------------------------------------+-- Instruction generation+--------------------------------------------------------------------------------++-- | Result of splitting a storage 'Value' of @st@ on the stack @s@.+--+-- The idea behind this is to either: prove that the whole 'Value' can be put on+-- the stack without containing a single @big_map@ or to split it into:+-- a 'Value' containing its @big_map@s and an instruction to reconstruct the+-- storage.+--+-- The main idea behind this is to create a large storage in Michelson code to+-- then create a contract using @CREATE_CONTRACT@.+-- Note: a simpler solution would have been to replace @big_map@ 'Value's with+-- an 'EMPTY_BIG_MAP' followed by many 'UPDATE' to push its content, but sadly+-- a bug (tezos/tezos/1154) prevents this from being done.+data PushableStorageSplit s st where+  -- | The type of the storage is fully constant.+  ConstantStorage+    :: ConstantScope st+    => Value st+    -> PushableStorageSplit s st++  -- | The type of the storage is not a constant, but its value does not contain+  -- @big_map@s. E.g. A 'Right ()' value of type 'Either (BigMap k v) ()'.+  PushableValueStorage+    :: StorageScope st+    => Instr s (st ': s)+    -> PushableStorageSplit s st++  -- | The type of the storage and part of its value (here @heavy@) contain one or+  -- more @big_map@s or @ticket@s. The instruction can take the non-pushable+  -- 'Value heavy' and reconstruct the original 'Value st' without using any+  -- 'EMPTY_BIG_MAP'.+  PartlyPushableStorage+    :: (StorageScope heavy, StorageScope st)+    => Value heavy -> Instr (heavy ': s) (st ': s)+    -> PushableStorageSplit s st++-- | Splits the given storage 'Value' into a 'PushableStorageSplit'.+--+-- This is based off the fact that the only storages that cannot be directly+-- 'PUSH'ed are the ones that contain 'Morley.Michelson.Typed.Haskell.Value.BigMap's and tickets.+-- See difference between 'StorageScope' and 'ConstantScope'.+--+-- So what we do here is to create a 'Value' as small as possible with all the+-- @big_map@s in it (if any) and an 'Instr' that can use it to rebuild the original+-- storage 'Value'.+--+-- Note: This is done this way to avoid using 'EMPTY_BIG_MAP' instructions, see+-- 'PushableStorageSplit' for motivation.+splitPushableStorage :: StorageScope t => Value t -> PushableStorageSplit s t+splitPushableStorage v = case v of+  -- Atomic (except op and contract)+  VKey{}        -> ConstantStorage v+  VUnit         -> ConstantStorage v+  VSignature{}  -> ConstantStorage v+  VChainId{}    -> ConstantStorage v+  VLam{}        -> ConstantStorage v+  VInt{}        -> ConstantStorage v+  VNat{}        -> ConstantStorage v+  VString{}     -> ConstantStorage v+  VBytes{}      -> ConstantStorage v+  VMutez{}      -> ConstantStorage v+  VBool{}       -> ConstantStorage v+  VKeyHash{}    -> ConstantStorage v+  VBls12381Fr{} -> ConstantStorage v+  VBls12381G1{} -> ConstantStorage v+  VBls12381G2{} -> ConstantStorage v+  VTimestamp{}  -> ConstantStorage v+  VAddress{}    -> ConstantStorage v+  VTicket{}     -> PartlyPushableStorage v Nop++  -- Non-atomic+  VOption (Nothing :: Maybe (Value tm)) -> case checkScope @(ConstantScope tm) of+    Right Dict -> ConstantStorage $ VOption Nothing+    Left _     -> PushableValueStorage $ NONE+  VOption (Just jVal :: Maybe (Value tm)) -> case splitPushableStorage jVal of+    ConstantStorage _ -> ConstantStorage . VOption $ Just jVal+    PushableValueStorage instr -> PushableValueStorage $ instr `Seq` SOME+    PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` SOME++  VList (vals :: [Value tl]) -> case checkScope @(ConstantScope tl) of+    Right Dict -> ConstantStorage v+    Left _     ->+      -- Here we check that even tho the type contains big_maps, we actually+      -- have big_maps in (one or more of) the values too.+      let handleList+            :: Instr s ('T.TList tl ': s) -> Value tl+            -> Maybe (Instr s ('T.TList tl ': s))+          handleList instr ele = case splitPushableStorage ele of+            ConstantStorage val ->+              Just $ instr `Seq` PUSH val `Seq` CONS+            PushableValueStorage eleInstr ->+              Just $ instr `Seq` eleInstr `Seq` CONS+            PartlyPushableStorage _ _ -> Nothing+      in  maybe (PartlyPushableStorage v Nop) PushableValueStorage $+            foldM handleList NIL vals++  VSet{} -> ConstantStorage v++  VPair (v1 :: Value t1, v2 :: Value t2) ->+    withValueTypeSanity v1 $ withValueTypeSanity v2 $+      withDeMorganScope @StorageScope @'T.TPair @t1 @t2 $+        let handlePair+              :: PushableStorageSplit s t2+              -> PushableStorageSplit (t2 ': s) t1+              -> PushableStorageSplit s ('T.TPair t1 t2)+            handlePair psp2 psp1 = case (psp2, psp1) of+              -- at least one side is a constant+              (ConstantStorage _, ConstantStorage _) ->+                ConstantStorage v+              (ConstantStorage val2, _) ->+                handlePair (PushableValueStorage $ PUSH val2) psp1+              (_, ConstantStorage val1) ->+                handlePair psp2 (PushableValueStorage $ PUSH val1)+              -- at least one side is a constant or has no big_map values+              (PushableValueStorage instr2, PushableValueStorage instr1) ->+                PushableValueStorage $ instr2 `Seq` instr1 `Seq` PAIR+              (PushableValueStorage instr2, PartlyPushableStorage val1 instr1) ->+                PartlyPushableStorage val1 $ DIP instr2 `Seq` instr1 `Seq` PAIR+              (PartlyPushableStorage val2 instr2, PushableValueStorage instr1) ->+                PartlyPushableStorage val2 $ instr2 `Seq` instr1 `Seq` PAIR+              -- both sides contain a big_map+              (PartlyPushableStorage val2 instr2, PartlyPushableStorage val1 instr1) ->+                PartlyPushableStorage (VPair (val1, val2)) $+                  UNPAIR `Seq` DIP instr2 `Seq` instr1 `Seq` PAIR+        in handlePair (splitPushableStorage v2) (splitPushableStorage v1)++  VOr (Left orVal :: Either (Value t1) (Value t2)) ->+    withValueTypeSanity orVal $ withDeMorganScope @StorageScope @'T.TOr @t1 @t2 $+      case splitPushableStorage orVal of+        ConstantStorage val -> case checkScope @(ConstantScope t2) of+          -- note: here we need to check for the opposite branch too+          Right Dict -> ConstantStorage v+          Left _ -> PushableValueStorage $ PUSH val `Seq` LEFT+        PushableValueStorage instr -> PushableValueStorage $ instr `Seq` LEFT+        PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` LEFT+  VOr (Right orVal :: Either (Value t1) (Value t2)) ->+    withValueTypeSanity orVal $ withDeMorganScope @StorageScope @'T.TOr @t1 @t2 $+      case splitPushableStorage orVal of+        ConstantStorage val -> case checkScope @(ConstantScope t1) of+          -- note: here we need to check for the opposite branch too+          Right Dict -> ConstantStorage v+          Left _ -> PushableValueStorage $ PUSH val `Seq` RIGHT+        PushableValueStorage instr -> PushableValueStorage $ instr `Seq` RIGHT+        PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` RIGHT++  VMap (vMap :: (Map (Value tk) (Value tv))) -> case checkScope @(ConstantScope tk) of+    Left _ ->+      -- NOTE: all keys for a map need to be comparable and (even tho it's+      -- not a superclass) that means they have to be constants.+      -- I (@pasqu4le) found no exception to this rule, perhaps it should be+      -- enforced in the type system as well, but it may have more+      -- downsides than it's worth accepting.+      error "impossible: all map keys should be PUSHable"+    Right Dict -> case checkScope @(ConstantScope tv) of+      Right Dict -> ConstantStorage v+      _ -> withDeMorganScope @HasNoOp @'T.TMap @tk @tv $+        -- Similarly as for lists, here we check that even tho the value type+        -- contains a big_map, we actually have big_maps in (one or more of) them.+        let handleMap+              :: Instr s ('T.TMap tk tv ': s) -> (Value tk, Value tv)+              -> Maybe (Instr s ('T.TMap tk tv ': s))+            handleMap instr (key, ele) = case splitPushableStorage (VOption $ Just ele) of+              ConstantStorage val ->+                Just $ instr `Seq` PUSH val `Seq` PUSH key `Seq` UPDATE+              PushableValueStorage eleInstr ->+                Just $ instr `Seq` eleInstr `Seq` PUSH key `Seq` UPDATE+              PartlyPushableStorage _ _ -> Nothing+        in  maybe (PartlyPushableStorage v Nop) PushableValueStorage $+              foldM handleMap EMPTY_MAP $ M.toList vMap++  VBigMap _ _ -> PartlyPushableStorage v Nop

+ src/Morley/Michelson/Typed/Value.hs view

@@ -0,0 +1,464 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE QuantifiedConstraints #-}++-- | Module, containing data types for Michelson value.++module Morley.Michelson.Typed.Value+  ( Comparability (..)+  , Comparable+  , ComparabilityScope+  , ContractInp1+  , ContractInp+  , ContractOut1+  , ContractOut+  , CreateContract (..)+  , Operation' (..)+  , SetDelegate (..)+  , TransferTokens (..)+  , Value' (..)+  , RemFail (..)+  , rfMerge+  , rfAnyInstr+  , rfMapAnyInstr+  , addressToVContract+  , buildVContract+  , checkComparability+  , compileEpLiftSequence+  , comparabilityPresence+  , getComparableProofS+  , liftCallArg+  , valueTypeSanity+  , withValueTypeSanity+  , eqValueExt+  ) where++import Data.Constraint (Dict(..), (\\))+import Data.Singletons (Sing)+import Data.Type.Bool (type (&&))+import Fmt (Buildable(build), Builder, (+|), (|+))++import Morley.Michelson.Text (MText)+import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.Sing+import Morley.Michelson.Typed.T (T(..))+import Morley.Tezos.Address (Address, GlobalCounter(..))+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature)+import Morley.Util.Sing (eqParamSing, eqParamSing3)+import Morley.Util.TH++-- | Data type, representing operation, list of which is returned+-- by Michelson contract (according to calling convention).+--+-- These operations are to be further executed against system state+-- after the contract execution.+data Operation' instr where+  OpTransferTokens+    :: (ParameterScope p)+    => TransferTokens instr p -> Operation' instr+  OpSetDelegate :: SetDelegate -> Operation' instr+  OpCreateContract+    :: ( Show (instr (ContractInp cp st) (ContractOut st))+       , NFData (instr (ContractInp cp st) (ContractOut st))+       , Typeable instr, ParameterScope cp, StorageScope st)+    => CreateContract instr cp st+    -> Operation' instr++instance Buildable (Operation' instr) where+  build =+    \case+      OpTransferTokens tt -> build tt+      OpSetDelegate sd -> build sd+      OpCreateContract cc -> build cc++deriving stock instance Show (Operation' instr)++instance Eq (Operation' instr) where+  op1 == op2 = case (op1, op2) of+    (OpTransferTokens tt1, OpTransferTokens tt2) -> tt1 `eqParamSing` tt2+    (OpTransferTokens _, _) -> False+    (OpSetDelegate sd1, OpSetDelegate sd2) -> sd1 == sd2+    (OpSetDelegate _, _) -> False+    (OpCreateContract cc1, OpCreateContract cc2) -> cc1 `eqParamSing3` cc2+    (OpCreateContract _, _) -> False++data TransferTokens instr p = TransferTokens+  { ttTransferArgument :: Value' instr p+  , ttAmount :: Mutez+  , ttContract :: Value' instr ('TContract p)+  , ttCounter :: GlobalCounter+  } deriving stock (Show, Eq, Generic)++instance NFData (TransferTokens instr p)++instance Buildable (TransferTokens instr p) where+  build TransferTokens {..} =+    "Transfer " +| ttAmount |+ " tokens to " +| buildVContract ttContract |+ ""++data SetDelegate = SetDelegate+  { sdMbKeyHash :: Maybe KeyHash+  , sdCounter :: GlobalCounter+  } deriving stock (Show, Eq, Generic)++instance NFData SetDelegate++instance Buildable SetDelegate where+  build (SetDelegate mbDelegate _) =+    "Set delegate to " <> maybe "<nobody>" build mbDelegate++data CreateContract instr cp st+  = ( Show (instr (ContractInp cp st) (ContractOut st))+    , Eq (instr (ContractInp cp st) (ContractOut st))+    )+  => CreateContract+  { ccOriginator :: Address+  , ccDelegate :: Maybe KeyHash+  , ccBalance :: Mutez+  , ccStorageVal :: Value' instr st+  , ccContractCode :: instr (ContractInp cp st) (ContractOut st)+  , ccCounter :: GlobalCounter+  }++instance NFData (instr (ContractInp cp st) (ContractOut st)) => NFData (CreateContract instr cp st) where+  rnf (CreateContract a b c d e f) = rnf (a, b, c, d, e, f)++instance Buildable (CreateContract instr cp st) where+  build CreateContract {..} =+    "Create a new contract with" <>+    " delegate " +| maybe "<nobody>" build ccDelegate |++    " and balance = " +| ccBalance |+ ""++deriving stock instance Show (CreateContract instr cp st)+deriving stock instance Eq (CreateContract instr cp st)++type ContractInp1 param st = 'TPair param st+type ContractInp param st = '[ ContractInp1 param st ]++type ContractOut1 st = 'TPair ('TList 'TOperation) st+type ContractOut st = '[ ContractOut1 st ]++-- | Wrapper over instruction which remembers whether this instruction+-- always fails or not.+data RemFail (instr :: k -> k -> Type) (i :: k) (o :: k) where+  RfNormal :: instr i o -> RemFail instr i o+  RfAlwaysFails :: (forall o'. instr i o') -> RemFail instr i o++deriving stock instance (forall o'. Show (instr i o')) => Show (RemFail instr i o)+instance (forall o'. NFData (instr i o')) => NFData (RemFail instr i o) where+  rnf (RfNormal a) = rnf a+  rnf (RfAlwaysFails a) = rnf a++-- | Ignoring distinction between constructors here, comparing only semantics.+instance Eq (instr i o) => Eq (RemFail instr i o) where+  RfNormal i1 == RfNormal i2 = i1 == i2+  RfAlwaysFails i1 == RfNormal i2 = i1 == i2+  RfNormal i1 == RfAlwaysFails i2 = i1 == i2+  RfAlwaysFails i1 == RfAlwaysFails i2 = i1 @o == i2++-- | Merge two execution branches.+rfMerge+  :: (forall o'. instr i1 o' -> instr i2 o' -> instr i3 o')+  -> RemFail instr i1 o -> RemFail instr i2 o -> RemFail instr i3 o+rfMerge merger instr1 instr2 = case (instr1, instr2) of+  (RfNormal i1, RfNormal i2) -> RfNormal (merger i1 i2)+  (RfAlwaysFails i1, RfNormal i2) -> RfNormal (merger i1 i2)+  (RfNormal i1, RfAlwaysFails i2) -> RfNormal (merger i1 i2)+  (RfAlwaysFails i1, RfAlwaysFails i2) -> RfAlwaysFails (merger i1 i2)++-- | Get code disregard whether it always fails or not.+rfAnyInstr :: RemFail instr i o -> instr i o+rfAnyInstr = \case+  RfNormal i -> i+  RfAlwaysFails i -> i++-- | Modify inner code.+rfMapAnyInstr+  :: (forall o'. instr i1 o' -> instr i2 o')+  -> RemFail instr i1 o+  -> RemFail instr i2 o+rfMapAnyInstr f = \case+  RfNormal i -> RfNormal $ f i+  RfAlwaysFails i -> RfAlwaysFails $ f i++getComparableProofS :: Sing (a :: T) -> Maybe (Dict (Comparable a))+getComparableProofS s = case checkComparability s of+  CanBeCompared -> Just Dict+  CannotBeCompared -> Nothing++class (IsComparable t ~ 'True) => Comparable t where+  tcompare :: (Value' instr t) -> (Value' instr t) -> Ordering++instance (Comparable e1, Comparable e2, FailOnNonComparableFound (IsComparable e1 && IsComparable e2))+  => Comparable ('TPair e1 e2) where+  tcompare (VPair a) (VPair b) = compare a b+instance (Comparable e1, Comparable e2, FailOnNonComparableFound (IsComparable e1 && IsComparable e2))+  => Comparable ('TOr e1 e2) where+  tcompare (VOr a) (VOr b) = compare a b+instance (Comparable e, ForbidNonComparable e) => Comparable ('TOption e) where+  tcompare (VOption a) (VOption b) = compare a b+instance Comparable 'TUnit where+  tcompare VUnit VUnit = EQ+instance Comparable 'TInt where+  tcompare (VInt a) (VInt b) = compare a b+instance Comparable 'TNat where+  tcompare (VNat a) (VNat b) = compare a b+instance Comparable 'TString where+  tcompare (VString a) (VString b) = compare a b+instance Comparable 'TBytes where+  tcompare (VBytes a) (VBytes b) = compare a b+instance Comparable 'TMutez where+  tcompare (VMutez a) (VMutez b) = compare a b+instance Comparable 'TBool where+  tcompare (VBool a) (VBool b) = compare a b+instance Comparable 'TKeyHash where+  tcompare (VKeyHash a) (VKeyHash b) = compare a b+instance Comparable 'TTimestamp where+  tcompare (VTimestamp a) (VTimestamp b) = compare a b+instance Comparable 'TAddress where+  tcompare (VAddress a) (VAddress b) = compare a b+instance Comparable 'TNever where+  tcompare = \case+instance Comparable 'TChainId where+  tcompare (VChainId a) (VChainId b) = compare a b+instance Comparable 'TSignature where+  tcompare (VSignature a) (VSignature b) = compare a b+instance Comparable 'TKey where+  tcompare (VKey a) (VKey b) = compare a b++instance (Comparable e) => Ord (Value' instr e) where+  compare = tcompare @e++-- | Alias for comparable types.+type ComparabilityScope t =+  (SingI t, Comparable t)++data Comparability t where+  CanBeCompared :: (Comparable t) => Comparability t+  CannotBeCompared :: (IsComparable t ~ 'False) => Comparability t++checkComparability :: Sing t -> Comparability t+checkComparability = \case+  STPair a b -> case (checkComparability a, checkComparability b) of+    (CanBeCompared, CanBeCompared) -> CanBeCompared+    (CannotBeCompared, _) -> CannotBeCompared+    (_, CannotBeCompared) -> CannotBeCompared+  STOr a b -> case (checkComparability a, checkComparability b) of+    (CanBeCompared, CanBeCompared) -> CanBeCompared+    (CannotBeCompared, _) -> CannotBeCompared+    (_, CannotBeCompared) -> CannotBeCompared+  STOption t -> case checkComparability t of+    CanBeCompared -> CanBeCompared+    CannotBeCompared -> CannotBeCompared+  STList _ -> CannotBeCompared+  STSet _ -> CannotBeCompared+  STOperation -> CannotBeCompared+  STContract _ -> CannotBeCompared+  STTicket _ -> CannotBeCompared+  STLambda _ _ -> CannotBeCompared+  STMap _ _ -> CannotBeCompared+  STBigMap _ _ -> CannotBeCompared+  STNever -> CanBeCompared+  STUnit -> CanBeCompared+  STInt -> CanBeCompared+  STNat -> CanBeCompared+  STString -> CanBeCompared+  STBytes -> CanBeCompared+  STMutez -> CanBeCompared+  STBool -> CanBeCompared+  STKeyHash -> CanBeCompared+  STBls12381Fr -> CannotBeCompared+  STBls12381G1 -> CannotBeCompared+  STBls12381G2 -> CannotBeCompared+  STTimestamp -> CanBeCompared+  STAddress -> CanBeCompared+  STKey -> CanBeCompared+  STSignature -> CanBeCompared+  STChainId -> CanBeCompared++comparabilityPresence :: Sing t -> Maybe (Dict $ (Comparable t))+comparabilityPresence s = case checkComparability s of+  CanBeCompared -> Just Dict+  CannotBeCompared -> Nothing++instance SingI t => CheckScope (Comparable t) where+  checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing++instance (SingI t) => CheckScope (ComparabilityScope t) where+  checkScope =+    (\Dict -> Dict) <$> checkScope @(Comparable t)++-- | Representation of Michelson value.+--+-- Type parameter @instr@ stands for Michelson instruction+-- type, i.e. data type to represent an instruction of language.++data Value' instr t where+  VKey :: PublicKey -> Value' instr 'TKey+  VUnit :: Value' instr 'TUnit+  VSignature :: Signature -> Value' instr 'TSignature+  VChainId :: ChainId -> Value' instr 'TChainId+  VOption+    :: forall t instr.+       (SingI t)+    => Maybe (Value' instr t) -> Value' instr ('TOption t)+  VList+    :: forall t instr.+       (SingI t)+    => [Value' instr t] -> Value' instr ('TList t)+  VSet+    :: forall t instr.+       (SingI t, Comparable t)+    => Set (Value' instr t) -> Value' instr ('TSet t)+  VOp+    :: Operation' instr -> Value' instr 'TOperation+  VContract+    :: forall arg instr.+       (SingI arg, HasNoOp arg)+    => Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)+  VTicket+    :: forall arg instr.+       (Comparable arg)+    => Address -> Value' instr arg -> Natural -> Value' instr ('TTicket arg)+  VPair+    :: forall l r instr.+       (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)+  VOr+    :: forall l r instr.+       (SingI l, SingI r)+    => Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)+  VLam+    :: forall inp out instr.+       ( SingI inp, SingI out+       , forall i o. Show (instr i o)+       , forall i o. Eq (instr i o)+       , forall i o. NFData (instr i o)+       )+    => RemFail instr (inp ': '[]) (out ': '[]) -> Value' instr ('TLambda inp out)+  VMap+    :: forall k v instr.+       (SingI k, SingI v, Comparable k)+    => Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v)+  VBigMap+    :: forall k v instr.+       (SingI k, SingI v, Comparable k, HasNoBigMap v)+    => Maybe Natural -- ^ The big_map's ID. This is only used in the interpreter.+    -> Map (Value' instr k) (Value' instr v)+    -> Value' instr ('TBigMap k v)+  VInt       :: Integer ->  Value' instr 'TInt+  VNat       :: Natural -> Value' instr 'TNat+  VString    :: MText -> Value' instr 'TString+  VBytes     :: ByteString -> Value' instr 'TBytes+  VMutez     :: Mutez -> Value' instr 'TMutez+  VBool      :: Bool -> Value' instr 'TBool+  VKeyHash   :: KeyHash -> Value' instr 'TKeyHash+  VTimestamp :: Timestamp -> Value' instr 'TTimestamp+  VAddress   :: EpAddress -> Value' instr 'TAddress+  VBls12381Fr :: Bls12381Fr -> Value' instr 'TBls12381Fr+  VBls12381G1 :: Bls12381G1 -> Value' instr 'TBls12381G1+  VBls12381G2 :: Bls12381G2 -> Value' instr 'TBls12381G2++deriving stock instance Show (Value' instr t)+deriving stock instance Eq (Value' instr t)++-- | Make value of @contract@ type which refers to the given address and+-- does not call any entrypoint.+addressToVContract+  :: forall t instr.+      (ParameterScope t, ForbidOr t)+  => Address -> Value' instr ('TContract t)+addressToVContract addr = VContract addr sepcPrimitive++buildVContract :: Value' instr ('TContract arg) -> Builder+buildVContract = \case+  VContract addr epc -> "Contract " +| addr |+ " call " +| epc |+ ""++-- | Turn 'EpLiftSequence' into actual function on t'Morley.Michelson.Typed.Aliases.Value's.+compileEpLiftSequence+  :: EpLiftSequence arg param+  -> Value' instr arg+  -> Value' instr param+compileEpLiftSequence = \case+  EplArgHere -> id+  EplWrapLeft els -> VOr . Left . compileEpLiftSequence els+  EplWrapRight els -> VOr . Right . compileEpLiftSequence els++-- | Lift entrypoint argument to full parameter.+liftCallArg+  :: EntrypointCallT param arg+  -> Value' instr arg+  -> Value' instr param+liftCallArg epc = compileEpLiftSequence (epcLiftSequence epc)++-- | Get a witness of that value's type is known.+--+-- Note that we cannot pick such witness out of nowhere as not all types+-- of kind 'T' have 'Typeable' and 'SingI' instances; example:+--+-- @+-- type family Any :: T where+--   -- nothing here+-- @+valueTypeSanity :: Value' instr t -> Dict (SingI t)+valueTypeSanity = \case+  VKey{} -> Dict+  VUnit{} -> Dict+  VSignature{} -> Dict+  VChainId{} -> Dict+  VOption{} -> Dict+  VList{} -> Dict+  VSet{} -> Dict+  VOp{} -> Dict+  VContract _ (SomeEpc EntrypointCall{}) -> Dict+  VTicket _ v _ -> case valueTypeSanity v of+    Dict -> Dict+  VPair (l, r) -> case (valueTypeSanity l, valueTypeSanity r) of+    (Dict, Dict) -> Dict+  VOr{} -> Dict+  VLam{} -> Dict+  VMap{} -> Dict+  VBigMap{} -> Dict+  VInt{} -> Dict+  VNat{} -> Dict+  VString{} -> Dict+  VBytes{} -> Dict+  VMutez{} -> Dict+  VBool{} -> Dict+  VKeyHash{} -> Dict+  VBls12381Fr{} -> Dict+  VBls12381G1{} -> Dict+  VBls12381G2{} -> Dict+  VTimestamp{} -> Dict+  VAddress{} -> Dict++-- | Provide a witness of that value's type is known.+withValueTypeSanity :: Value' instr t -> (SingI t => a) -> a+withValueTypeSanity v a = case valueTypeSanity v of Dict -> a++-- | Extended values comparison - it does not require t'Morley.Michelson.Typed.Aliases.Value's to be+-- of the same type, only their content to match.+eqValueExt :: Value' instr t1 -> Value' instr t2 -> Bool+eqValueExt v1 v2 =+  v1 `eqParamSing` v2+    \\ valueTypeSanity v1+    \\ valueTypeSanity v2++-- TODO: actually we should handle big maps with something close+-- to following:+--+--  VBigMap :: BigMap op ref k v -> Value' cp ('TBigMap k v)+--+-- data Value'Op v+--     = New v+--     | Upd v+--     | Rem+--     | NotExisted+--+-- data BigMap op ref k v = BigMap+--  { bmRef :: ref k v, bmChanges :: Map (CValue k) (Value'Op (Value' cp v)) }++$(deriveGADTNFData ''Operation')+$(deriveGADTNFData ''Value')

+ src/Morley/Michelson/Untyped.hs view

@@ -0,0 +1,17 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Untyped+  ( module Exports+  ) where++import Morley.Michelson.Untyped.Aliases as Exports+import Morley.Michelson.Untyped.Annotation as Exports+import Morley.Michelson.Untyped.Contract as Exports+import Morley.Michelson.Untyped.Entrypoints as Exports+import Morley.Michelson.Untyped.Ext as Exports+import Morley.Michelson.Untyped.Instr as Exports+import Morley.Michelson.Untyped.OpSize as Exports+import Morley.Michelson.Untyped.Type as Exports+import Morley.Michelson.Untyped.Value as Exports

+ src/Morley/Michelson/Untyped/Aliases.hs view

@@ -0,0 +1,20 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Some simple aliases for Michelson types.++module Morley.Michelson.Untyped.Aliases+  ( Contract+  , Value+  , ExpandedExtInstr+  ) where++import qualified Morley.Michelson.Untyped.Contract as Untyped+import qualified Morley.Michelson.Untyped.Ext as Untyped+import qualified Morley.Michelson.Untyped.Instr as Untyped+import qualified Morley.Michelson.Untyped.Value as Untyped++type Value = Untyped.Value' Untyped.ExpandedOp+type Contract = Untyped.Contract' Untyped.ExpandedOp+type ExpandedExtInstr = Untyped.ExtInstrAbstract Untyped.ExpandedOp

+ src/Morley/Michelson/Untyped/Annotation.hs view

@@ -0,0 +1,445 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Michelson annotations in untyped model.++module Morley.Michelson.Untyped.Annotation+  ( Annotation (..)+  , VarAnns (..)+  , pattern Annotation+  , pattern WithAnn++  -- * Annotation Set+  , AnnotationSet(..)+  , annsCount+  , emptyAnnSet+  , firstAnn+  , fullAnnSet+  , isNoAnnSet+  , minAnnSetSize+  , secondAnn+  , singleAnnSet+  , singleGroupAnnSet+  , minimizeAnnSet++  -- * Rendering+  , KnownAnnTag(..)+  , TypeAnn+  , FieldAnn+  , VarAnn+  , SomeAnn+  , RootAnn+  , TypeTag+  , FieldTag+  , VarTag++  -- * Creation and conversions+  , noAnn+  , annQ+  , varAnnQ+  , fieldAnnQ+  , typeAnnQ+  , unsafeMkAnnotation+  , mkAnnotation+  , specialVarAnns+  , specialFieldAnn+  , isValidAnnStart+  , isValidAnnBodyChar+  , orAnn+  , unifyAnn+  , unifyPairFieldAnn+  , convergeVarAnns+  , ifAnnUnified+  , convAnn+  ) where++import Data.Aeson.TH (deriveJSON)+import Data.Char (isAlpha, isAscii, isDigit, isNumber)+import Data.Data (Data(..))+import Data.Default (Default(..))+import qualified Data.Text as T+import Data.Typeable (eqT, (:~:)(..))+import Fmt (Buildable(build))+import Instances.TH.Lift ()+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Lift (deriveLift)+import qualified Language.Haskell.TH.Quote as TH+import Text.PrettyPrint.Leijen.Text (Doc, hsep, textStrict, (<+>))+import qualified Text.Show++import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, doesntNeedParens, printDocS)+import Morley.Util.Aeson++-- | Generic Type/Field/Variable Annotation+--+-- As per Michelson documentation, this type has an invariant:+-- (except for the first character, here parametrized in the type @tag@) the+-- allowed character set is the one matching the following regexp:+-- @%|@%%|%@|[@:%][_0-9a-zA-Z][_0-9a-zA-Z\.%@]*+newtype Annotation tag = UnsafeAnnotation { unAnnotation :: Text }+  deriving stock (Eq, Data, Functor, Generic)++instance NFData (Annotation tag)++-- | Unidirectional pattern synonym used to pattern-match on t'Annotation'+-- without invoking 'UnsafeAnnotation'+pattern Annotation :: Text -> Annotation tag+pattern Annotation ann <- UnsafeAnnotation ann++{-# COMPLETE Annotation :: Annotation #-}++instance Default (Annotation tag) where+  def = noAnn++-- | Either one or two variable annotations+data VarAnns+  = OneVarAnn VarAnn+  | TwoVarAnns VarAnn VarAnn+  deriving stock (Generic, Show)+  deriving anyclass (NFData)++--------------------------------------------------------------------------------+-- Annotation Set+--------------------------------------------------------------------------------++-- | An 'AnnotationSet' contains all the type/field/variable t'Annotation's+-- , with each group in order, associated with an entity.+-- Note that in its rendering/show instances the unnecessary annotations will be+-- omitted, as well as in some of the functions operating with it.+-- Necessary t'Annotation's are the ones strictly required for a consistent+-- representation.+-- In particular, for each group (t/f/v):+--   - if all annotations are 'noAnn' they are all omitted+--   - if one or more 'noAnn' follow a non-empty t'Annotation', they are omitted+--   - if one or more 'noAnn' precede a non-empty t'Annotation', they are kept+--   - every non-empty t'Annotation' is obviously kept+-- This is why order for each group is important as well as separation of+-- different groups of t'Annotation's.+data AnnotationSet = AnnotationSet+  { asTypes  :: [TypeAnn]+  , asFields :: [FieldAnn]+  , asVars   :: [VarAnn]+  } deriving stock Eq++instance Semigroup AnnotationSet where+  (AnnotationSet ts1 fs1 vs1) <> (AnnotationSet ts2 fs2 vs2) = AnnotationSet {..}+    where+      asTypes  = ts1 <> ts2+      asFields = fs1 <> fs2+      asVars   = vs1 <> vs2++instance Monoid AnnotationSet where+  mempty = emptyAnnSet++-- | An 'AnnotationSet' without any t'Annotation'.+emptyAnnSet :: AnnotationSet+emptyAnnSet = AnnotationSet [] [] []++-- | An 'AnnotationSet' with only a single t'Annotation' (of any kind).+singleAnnSet :: forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet+singleAnnSet an = singleGroupAnnSet [an]++-- | An 'AnnotationSet' with several t'Annotation's of the same kind.+singleGroupAnnSet :: forall tag. KnownAnnTag tag => [Annotation tag] -> AnnotationSet+singleGroupAnnSet ans = AnnotationSet {..}+  where+    asTypes = case eqT @tag @TypeTag of Just Refl -> ans; Nothing -> []+    asFields = case eqT @tag @FieldTag of Just Refl -> ans; Nothing -> []+    asVars = case eqT @tag @VarTag of Just Refl -> ans; Nothing -> []++-- | An 'AnnotationSet' built from all 3 kinds of t'Annotation'.+fullAnnSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet+fullAnnSet asTypes asFields asVars = AnnotationSet {..}++-- | Returns 'True' if all t'Annotation's in the Set are unnecessary/empty/'noAnn'.+-- False otherwise.+isNoAnnSet :: AnnotationSet -> Bool+isNoAnnSet annSet = null asTypes && null asFields && null asVars+  where AnnotationSet {..} = minimizeAnnSet annSet++-- | Returns the amount of t'Annotation's that are necessary for a consistent+-- representation. See 'AnnotationSet'.+minAnnSetSize :: AnnotationSet -> Int+minAnnSetSize annSet = length asTypes + length asFields + length asVars+  where AnnotationSet {..} = minimizeAnnSet annSet++-- | Removes all unnecessary t'Annotation's. See 'AnnotationSet'.+minimizeAnnSet :: AnnotationSet -> AnnotationSet+minimizeAnnSet (AnnotationSet ts fs vs) = AnnotationSet {..}+  where+    asTypes = trimEndNoAnn ts+    asFields = trimEndNoAnn fs+    asVars = trimEndNoAnn vs++-- | Removes all unnecessary t'Annotation's from a list of the same type+trimEndNoAnn :: [Annotation tag] -> [Annotation tag]+trimEndNoAnn = foldr (\a lst -> if null lst && a == noAnn then [] else a : lst) []++-- | Returns the number of annotations in 'AnnotationSet' for each type.+annsCount :: AnnotationSet -> (Int, Int, Int)+annsCount (AnnotationSet tas fas vas) = (length tas, length fas, length vas)++-- | Returns the first annotation in a list of annotations of a specific type+-- in 'AnnotationSet', or 'noAnn' if this list is empty.+firstAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag+firstAnn = getAnn (\case [] -> noAnn; a : _ -> a)++-- | Returns the second annotation in a list of annotations of a specific type+-- in 'AnnotationSet', or 'noAnn' if this list contains less than 2 elements.+secondAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag+secondAnn = getAnn (\case [] -> noAnn; [_] -> noAnn; _ : a : _ -> a)++-- | Retrieves an annotation of a specific type from 'AnnotationSet' using+-- the passed function.+getAnn :: forall tag. (KnownAnnTag tag)+       => ([Annotation tag] -> Annotation tag)+       -> AnnotationSet+       -> Annotation tag+getAnn getter annSet = case eqT @tag @TypeTag of+  Just Refl -> getter $ asTypes annSet+  Nothing -> case eqT @tag @FieldTag of+    Just Refl -> getter $ asFields annSet+    Nothing -> case eqT @tag @VarTag of+      Just Refl -> getter $ asVars annSet+      Nothing -> error "Impossible"++--------------------------------------------------------------------------------+-- Rendering+--------------------------------------------------------------------------------++-- | A constraint representing that type-level annotation tag is known at+-- compile-time+class Typeable (tag :: Type) => KnownAnnTag tag where+  annPrefix :: Text+  -- ^ What prefix is used for the given annotation type (identified by @tag@) in Michelson code,+  -- i.e. @%@ for field annotations, @\@@ for variable annotations, @:@ for type annotations++instance KnownAnnTag tag => Show (Annotation tag) where+  show = printDocS True . renderDoc doesntNeedParens++-- | Type-level tag for type annotations+data TypeTag+-- | Type-level tag for field annotations+data FieldTag+-- | Type-level tag for variable annotations+data VarTag+-- | Type-level tag for "some" annotations, i.e. those that are unknown at compile-time+data SomeTag++-- | A convenience synonym for type t'Annotation'+type TypeAnn = Annotation TypeTag+-- | A convenience synonym for field t'Annotation'+type FieldAnn = Annotation FieldTag+-- | A convenience synonym for variable t'Annotation'+type VarAnn = Annotation VarTag+-- | A convenience synonym for "some" t'Annotation', i.e. its type is unknown at compile-time+type SomeAnn = Annotation SomeTag++-- | Field annotation for the entire parameter.+type RootAnn = Annotation FieldTag++instance KnownAnnTag FieldTag where+  annPrefix = "%"+instance KnownAnnTag VarTag where+  annPrefix = "@"+instance KnownAnnTag TypeTag where+  annPrefix = ":"++instance KnownAnnTag tag => RenderDoc (Annotation tag) where+  renderDoc _ = renderAnn++instance KnownAnnTag tag => Buildable (Annotation tag) where+  build = buildRenderDoc++instance Show AnnotationSet where+  show = printDocS True . renderDoc doesntNeedParens++instance RenderDoc AnnotationSet where+  renderDoc _ (AnnotationSet {..}) =+    renderAnnGroup asTypes <+> renderAnnGroup asFields <+> renderAnnGroup asVars++instance Buildable AnnotationSet where+  build = buildRenderDoc++-- | Renders a single t'Annotation', this is used in every rendering instance of it.+-- Note that this also renders empty ones/'noAnn's because a single t'Annotation'+-- does not have enough context to know if it can be omitted, use 'singleAnnSet'+-- if you want to hide it instead.+renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc+renderAnn (Annotation text) = textStrict $ annPrefix @tag <> text++-- | Renders a list of t'Annotation's, omitting unnecessary empty ones/'noAnn'.+-- This is used (3 times) to render an 'AnnotationSet'.+renderAnnGroup :: KnownAnnTag tag => [Annotation tag] -> Doc+renderAnnGroup = hsep . map renderAnn . trimEndNoAnn++--------------------------------------------------------------------------------+-- Creation and conversions+--------------------------------------------------------------------------------++-- | Empty t'Annotation', i.e. no annotation+noAnn :: Annotation a+noAnn = UnsafeAnnotation ""++-- | Makes an t'Annotation' from its textual value, prefix (%/@/:) excluded+-- Throws an error if the given 'Text' contains invalid characters+unsafeMkAnnotation :: HasCallStack => Text -> Annotation a+unsafeMkAnnotation = either error id . mkAnnotation++-- | Makes an t'Annotation' from its textual value, prefix (%/@/:) excluded+-- Returns a 'Text' error message if the given 'Text' contains invalid characters+mkAnnotation :: Text -> Either Text (Annotation a)+mkAnnotation text+  -- TODO [#48] these are special annotations and should not be always allowed+  | text `elem` specialVarAnns = Right $ UnsafeAnnotation text+  | text == specialFieldAnn = Right $ UnsafeAnnotation text+  | otherwise = do+    suffix <- case T.uncons text of+      Just (h, tl) | isValidAnnStart h -> Right tl+      Just (h, _) -> Left $ "Invalid first character: '" <> one h <> "'"+      _ -> Right ""+    maybe (Right $ UnsafeAnnotation text) (\c -> Left $ "Invalid character: '" <> one c <> "'") $+      T.find (not . isValidAnnBodyChar) suffix++-- |+-- >>> :t [annQ|abc|]+-- ... :: forall k (tag :: k). Annotation tag+annQ :: TH.QuasiQuoter+annQ = annQImpl Nothing++-- |+-- >>> :t [typeAnnQ|abc|]+-- ...+-- ... :: TypeAnn+typeAnnQ :: TH.QuasiQuoter+typeAnnQ = annQImpl (Just [t|TypeAnn|])++-- |+-- >>> :t [fieldAnnQ|abc|]+-- ...+-- ... :: FieldAnn+fieldAnnQ :: TH.QuasiQuoter+fieldAnnQ = annQImpl (Just [t|FieldAnn|])++-- |+-- >>> :t [varAnnQ|abc|]+-- ...+-- ... :: VarAnn+varAnnQ :: TH.QuasiQuoter+varAnnQ = annQImpl (Just [t|VarAnn|])++annQImpl :: Maybe TH.TypeQ -> TH.QuasiQuoter+annQImpl annTypeMb = TH.QuasiQuoter+  {+    TH.quoteExp = \s ->+      case (mkAnnotation $ toText @String s) of+        Left err -> fail $ toString err+        Right _ -> case annTypeMb of+          Nothing -> [e| (UnsafeAnnotation s) |]+          Just annType -> [e| (UnsafeAnnotation s :: $(annType)) |]+  , TH.quotePat = \s ->+       case (mkAnnotation $ toText @String s) of+         Left err -> fail $ toString err+         Right _ -> case annTypeMb of+           Nothing -> [p| UnsafeAnnotation $(TH.litP $ TH.StringL s) |]+           Just annType -> [p| (UnsafeAnnotation $(TH.litP $ TH.StringL s) :: $(annType)) |]+  , TH.quoteType = \_ -> fail "Cannot use this QuasiQuoter at type position"+  , TH.quoteDec = \_  -> fail "Cannot use this QuasiQuoter at declaration position"+  }++-- | List of all the special Variable Annotations, only allowed in @CAR@ and @CDR@+-- instructions, prefix (@) excluded.+-- These do not respect the rules of `isValidAnnStart` and `isValidAnnBodyChar`.+specialVarAnns :: [Text]+specialVarAnns = ["%%","%"]++-- | The only special Field Annotation, only allowed in @PAIR@, @LEFT@ and+-- @RIGHT@ instructions, prefix (%) excluded.+-- This does not respect the rules of `isValidAnnStart` and `isValidAnnBodyChar`.+specialFieldAnn :: Text+specialFieldAnn = "@"+++-- | Checks if a `Char` is valid to be the first of an annotation, prefix+-- (%/@/:) excluded, the ones following should be checked with+-- `isValidAnnBodyChar` instead.+-- Note that this does not check Special Annotations, see `specialVarAnns`+-- and `specialFieldAnn`+isValidAnnStart :: Char -> Bool+isValidAnnStart x = (isAscii x && (isAlpha x || isDigit x)) || x == '_'++-- | Checks if a `Char` is valid to be part of an annotation, following a valid+-- first character (see `isValidAnnStart`) and the prefix (%/@/:).+-- Note that this does not check Special Annotations, see `specialVarAnns`+-- and `specialFieldAnn`+isValidAnnBodyChar :: Char -> Bool+isValidAnnBodyChar x =+  isValidAnnStart x || (isAscii x && isNumber x) ||  x `elem` (".%@" :: String)++instance Semigroup VarAnn where+  Annotation a <> Annotation b+    | a == "" || b == "" = UnsafeAnnotation $ a <> b+    | otherwise          = UnsafeAnnotation $ a <> "." <> b++instance Monoid VarAnn where+    mempty = noAnn++-- | Returns the first annotation if it's not empty, or the second one otherwise.+--+-- > "a" `orAnn` "b" == "a"+-- > "a" `orAnn` ""  == "a"+-- > ""  `orAnn` "b" == "b"+-- > ""  `orAnn` ""  == ""+orAnn :: Annotation t -> Annotation t -> Annotation t+orAnn a b = bool a b (a == def)++-- | Given two type or field annotations, attempt to converge them by joining+-- these annotations with the following rule:+-- 1. If either annotation is empty, an empty annotation is returned;+-- 2. If both annotations are equal, return this annotation;+-- 3. Otherwise, returns 'Nothing'.+--+-- This function is used primarily for type-checking and attempts to imitate the+-- reference implementation's observed behavior with annotations.+unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)+unifyAnn a@(Annotation ann1) (Annotation ann2)+  | ann1 == "" || ann2 == "" = Just noAnn+  | ann1 == ann2 = Just $ a+  | otherwise  = Nothing++-- | Given two field annotations where one of them is used in CAR or CDR,+-- attempt to converge them by joining these annotations with the following rule:+-- 1. If either annotation is empty, return the non-empty one (or empty if both are empty);+-- 2. If both annotations are equal, return this annotation;+-- 3. Otherwise, returns 'Nothing'.+--+-- This function is used primarily for type-checking and attempts to imitate the+-- reference implementation's observed behavior with field annotations when CAR+-- and CDR are used with pairs.+unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn+unifyPairFieldAnn a1@(Annotation ann1) a2@(Annotation ann2)+  | ann1 == "" || ann2 == "" = Just $ a1 `orAnn` a2+  | ann1 == ann2 = Just a1+  | otherwise = Nothing++-- | Keeps an annotation if and only if the two of them are equal and returns an+-- empty annotation otherwise.+convergeVarAnns :: VarAnn -> VarAnn -> VarAnn+convergeVarAnns ann1 ann2+  | ann1 == ann2 = ann1+  | otherwise    = noAnn++ifAnnUnified :: Annotation tag -> Annotation tag -> Bool+ifAnnUnified a1 a2 = isJust $ a1 `unifyAnn` a2++-- | Convert annotation from one type to another+convAnn :: Annotation tag1 -> Annotation tag2+convAnn (Annotation a) = UnsafeAnnotation a++-- | Unidirectional pattern synonym matching only non-empty annotations+pattern WithAnn :: Annotation tag -> Annotation tag+pattern WithAnn ann <- ann@(Annotation (toString -> _:_))++deriveJSON morleyAesonOptions ''Annotation+deriveLift ''Annotation

+ src/Morley/Michelson/Untyped/Contract.hs view

@@ -0,0 +1,138 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Michelson contract in untyped model.++module Morley.Michelson.Untyped.Contract+  ( EntriesOrder (..)+  , canonicalEntriesOrder+  , entriesOrderToInt+  , mapEntriesOrdered++  , ContractBlock (..)+  , orderContractBlock++  , Contract' (..)+  , Storage+  ) where++import Data.Aeson.TH (deriveJSON)+import Data.Data (Data(..))+import Data.Default (Default(..))+import Fmt (Buildable(build))+import Text.PrettyPrint.Leijen.Text (nest, semi, text, (<$$>), (<+>))++import Morley.Michelson.Printer.Util+  (Prettier(..), RenderDoc(..), assertParensNotNeeded, buildRenderDoc, needsParens, renderOpsList)+import Morley.Michelson.Untyped.Type (ParameterType(..), Ty(..))+import Morley.Util.Aeson++-- | Top-level entries order of the contract.+-- This is preserved due to the fact that it affects+-- the output of pretty-printing and serializing contract.++-- Each constructors is created by the order of the first letter of+-- @parameter@, @storage@, and @code@.+--+-- For example, @PSC@ would be @parameter@, @storage@ and @code@,+-- @CPS@ would be @code@, @parameter@,and @storage@, and so on.+data EntriesOrder+  = PSC+  | PCS+  | SPC+  | SCP+  | CSP+  | CPS+  deriving stock (Bounded, Data, Enum, Eq, Generic, Show)++instance Default EntriesOrder where+  def = canonicalEntriesOrder+instance NFData EntriesOrder++-- | The canonical entries order which is ordered as follow:+-- @parameter@, @storage@, and @code@.+canonicalEntriesOrder :: EntriesOrder+canonicalEntriesOrder = PSC++-- | @(Int, Int, Int)@ is the positions of @parameter@, @storage@, and @code@+-- respectively.+entriesOrderToInt :: EntriesOrder -> (Int, Int, Int)+entriesOrderToInt = \case+  PSC -> (0, 1, 2)+  PCS -> (0, 2, 1)+  SPC -> (1, 0, 2)+  SCP -> (1, 2, 0)+  CSP -> (2, 1, 0)+  CPS -> (2, 0, 1)++-- | Contract block, convenient when parsing+data ContractBlock op+  = CBParam ParameterType+  | CBStorage Ty+  | CBCode [op]+  deriving stock (Eq, Show)++-- | Construct a contract representation from three different contract blocks (i.e. parameters,+-- storage and code blocks) in arbitrary order. This saves the order in the contract so that+-- it can print the contract blocks in the same order it was parsed.+orderContractBlock :: (ContractBlock op, ContractBlock op, ContractBlock op) -> Maybe (Contract' op)+orderContractBlock = \case+  (CBParam   p, CBStorage s, CBCode    c) -> Just $ Contract p s c PSC+  (CBParam   p, CBCode    c, CBStorage s) -> Just $ Contract p s c PCS+  (CBStorage s, CBParam   p, CBCode    c) -> Just $ Contract p s c SPC+  (CBStorage s, CBCode    c, CBParam   p) -> Just $ Contract p s c SCP+  (CBCode    c, CBStorage s, CBParam   p) -> Just $ Contract p s c CSP+  (CBCode    c, CBParam   p, CBStorage s) -> Just $ Contract p s c CPS+  _                                       -> Nothing++-- | Map each contract fields by the given function and sort the output+-- based on the 'EntriesOrder'.+mapEntriesOrdered+  :: Contract' op+  -> (ParameterType -> a)+  -> (Storage -> a)+  -> ([op] -> a)+  -> [a]+mapEntriesOrdered Contract{..} fParam fStorage fCode =+  fmap snd+    $ sortWith fst+        [ (paramPos, fParam contractParameter)+        , (storagePos, fStorage contractStorage)+        , (codePos, fCode contractCode)+        ]+  where+    (paramPos, storagePos, codePos) = entriesOrderToInt entriesOrder++-- | Convenience synonym for 'Ty' representing the storage type+type Storage = Ty++-- | General untyped contract representation.+data Contract' op = Contract+  { contractParameter :: ParameterType+    -- ^ Contract parameter type+  , contractStorage :: Storage+    -- ^ Contract storage type+  , contractCode :: [op]+    -- ^ Contract code as a list of operations+  , entriesOrder :: EntriesOrder+    -- ^ Original order of contract blocks, so that we can print them+    -- in the same order they were read+  } deriving stock (Eq, Show, Functor, Data, Generic)++instance NFData op => NFData (Contract' op)++instance (RenderDoc op) => RenderDoc (Contract' op) where+  renderDoc pn contract =+    assertParensNotNeeded pn+      $ foldr (<$$>) (text "")+      $ mapEntriesOrdered contract+        (\parameter -> "parameter" <+> renderDoc needsParens (Prettier parameter) <> semi)+        (\storage -> "storage" <+> renderDoc needsParens (Prettier storage) <> semi)+        (\code -> "code" <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi))++instance RenderDoc op => Buildable (Contract' op) where+  build = buildRenderDoc++deriveJSON morleyAesonOptions ''EntriesOrder+deriveJSON morleyAesonOptions ''Contract'

+ src/Morley/Michelson/Untyped/Entrypoints.hs view

@@ -0,0 +1,184 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Michelson.Untyped.Entrypoints+  ( EpName (..)+  , pattern DefEpName+  , isDefEpName+  , epNameFromParamAnn+  , epNameToParamAnn+  , epNameFromRefAnn+  , epNameFromSelfAnn+  , epNameToRefAnn+  , EpNameFromRefAnnError (..)+  , buildEpName+  , unsafeBuildEpName+  , mkEntrypointsMap+  ) where++import Data.Aeson.TH (deriveJSON)+import qualified Data.Map as Map+import Fmt (Buildable(..), pretty)++import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)+import Morley.Michelson.Untyped.Annotation+import Morley.Michelson.Untyped.Type+import Morley.Util.Aeson+import Morley.Util.CLI+import Text.PrettyPrint.Leijen.Text (enclose, (<+>))++-- | Entrypoint name.+--+-- There are two properties we care about:+--+-- 1. Special treatment of the @default@ entrypoint name.+-- @default@ is prohibited in the @CONTRACT@ instruction and in+-- values of @address@ and @contract@ types.+-- However, it is not prohibited in the @SELF@ instruction.+-- Hence, the value inside @EpName@ __can__ be @"default"@, so that+-- we can distinguish @SELF@ and @SELF %default@. It is important+-- to distinguish them because their binary representation that is+-- inserted into blockchain is different. For example, typechecking+-- @SELF %default@ consumes more gas than @SELF@.+-- In this module, we provide several smart constructors with different+-- handling of @default@, please use the appropriate one for your use case.+-- 2. The set of permitted characters. Intuitively, an entrypoint name should+-- be valid only if it is a valid annotation (because entrypoints are defined+-- using field annotations). However, it is not enforced in Tezos.+-- It is not clear whether this behavior is intended. There is an upstream+-- [issue](https://gitlab.com/tezos/tezos/-/issues/851) which received @bug@+-- label, so probably it is considered a bug. Currently we treat it as a bug+-- and deviate from upstream implementation by probiting entrypoint names that+-- are not valid annotations. If Tezos developers fix it soon, we will be happy.+-- If they don't, we should (maybe temporarily) remove this limitation from our+-- code. There is an+-- [issue](https://gitlab.com/morley-framework/morley/-/issues/275) in our+-- repo as well.+newtype EpName = UnsafeEpName { unEpName :: Text }+  deriving stock (Show, Eq, Ord, Generic)++instance NFData EpName++deriveJSON morleyAesonOptions ''EpName++-- | This is a bidirectional pattern that can be used for two purposes:+--+-- 1. Construct an 'EpName' referring to the default entrypoint.+-- 2. Use it in pattern-matching or in equality comparison to check whether+-- 'EpName' refers to the default entrypoint. This is trickier because there+-- are two possible 'EpName' values referring to the default entrypoints.+-- 'DefEpName' will match only the most common one (no entrypoint).+-- However, there is a special case: @SELF@ instruction can have explicit+-- @%default@ reference. For this reason, it is recommended to use+-- 'isDefEpName' instead. Pattern-matching on 'DefEpName' is still permitted+-- for backwards compatibility and for the cases when you are sure that+-- 'EpName' does not come from the @SELF@ instruction.+pattern DefEpName :: EpName+pattern DefEpName = UnsafeEpName ""++-- | Check whether given 'EpName' refers to the default entrypoint.+-- Unlike 'DefEpName' pattern, this function correctly handles all cases,+-- including the @SELF@ instruction.+isDefEpName :: EpName -> Bool+isDefEpName epName = epName == DefEpName || epName == UnsafeEpName "default"++instance Buildable EpName where+  build = \case+    DefEpName -> "<default>"+    UnsafeEpName name -> build name++-- | Make up 'EpName' from annotation in parameter type declaration.+--+-- Returns 'Nothing' if no entrypoint is assigned here.+epNameFromParamAnn :: FieldAnn -> Maybe EpName+epNameFromParamAnn an@(Annotation a)+  | an == noAnn = Nothing+  | a == "default" = Just (UnsafeEpName "")+  | otherwise = Just $ UnsafeEpName a++-- | Turn entrypoint name into annotation for contract parameter declaration.+epNameToParamAnn :: EpName -> FieldAnn+epNameToParamAnn (UnsafeEpName name)+  | name == "" = [annQ|default|]+  | otherwise = unsafeMkAnnotation name++data EpNameFromRefAnnError+  = InEpNameBadAnnotation FieldAnn+  deriving stock (Show, Eq, Generic)++instance NFData EpNameFromRefAnnError++instance Buildable EpNameFromRefAnnError where+  build = buildRenderDoc++instance RenderDoc EpNameFromRefAnnError where+  renderDoc _ = \case+    InEpNameBadAnnotation (Annotation an) ->+      "Invalid entrypoint reference" <+> (enclose "`" "`" $ renderAnyBuildable an)++-- | Make up 'EpName' from annotation which is reference to an entrypoint.+-- Note that it's more common for Michelson to prohibit explicit @default@+-- entrypoint reference.+--+-- Specifically, @%default@ annotation is probitited in values of @address@+-- and @contract@ types. It's also prohibited in the @CONTRACT@ instruction.+-- However, there is an exception: @SELF %default@ is a perfectly valid+-- instruction. Hence, when you construct an 'EpName' from an annotation+-- that's part of @SELF@, you should use 'epNameFromSelfAnn' instead.+epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName+epNameFromRefAnn an@(Annotation a)+  | a == "default" = Left $ InEpNameBadAnnotation an+  | otherwise = Right $ UnsafeEpName a++-- | Make up an 'EpName' from an annotation which is part of the+-- @SELF@ instruction.+epNameFromSelfAnn :: FieldAnn -> EpName+epNameFromSelfAnn (Annotation a) = UnsafeEpName a++-- | Turn entrypoint name into annotation used as reference to entrypoint.+epNameToRefAnn :: EpName -> FieldAnn+epNameToRefAnn (UnsafeEpName name) = unsafeMkAnnotation name++-- | Make a valid entrypoint name from an arbitrary text. This+-- function prohibits explicit @default@ entrypoint name which is+-- permitted by Michelson inside the @SELF@ instruction. This+-- limitation shouldn't be restrictive because @SELF@ is equivalent to+-- @SELF %default@.+buildEpName :: Text -> Either String EpName+buildEpName txt = do+  annotation <-+    mkAnnotation txt+    & first (mappend "Failed to parse entrypoint: " . pretty)+  epNameFromRefAnn annotation+    & first pretty++-- | Partial version of 'buildEpName'.+unsafeBuildEpName :: HasCallStack => Text -> EpName+unsafeBuildEpName = either (error . pretty) id . buildEpName++instance HasCLReader EpName where+  getReader = eitherReader (buildEpName . toText)+  getMetavar = "ENTRYPOINT"++-- | Given an untyped parameter type, extract a map that maps entrypoint names+-- to the their parameter types. If there are duplicate entrypoints in the+-- given Type then the duplicate entrypoints at a deeper nesting level will get+-- overwritten with the ones that are on top.+mkEntrypointsMap :: ParameterType -> Map EpName Ty+mkEntrypointsMap (ParameterType ty rootAnn) = mkEntrypointsMapRec rootAnn ty++-- | Version of 'mkEntrypointsMap' for plain untyped type.+mkEntrypointsMapRec :: FieldAnn -> Ty -> Map EpName Ty+mkEntrypointsMapRec curRootAnn ty =+  accountRoot curRootAnn <> accountTree ty+  where+    accountRoot rootAnn = Map.fromList $ do+      Just rootEp <- pure $ epNameFromParamAnn rootAnn+      return (rootEp, ty)++    accountTree (Ty t _) = case t of+      -- We are only interested in `Or` branches to extract entrypoint+      -- annotations.+      TOr f1 f2 t1 t2 -> mkEntrypointsMapRec f1 t1 <> mkEntrypointsMapRec f2 t2+      _ -> mempty

+ src/Morley/Michelson/Untyped/Ext.hs view

@@ -0,0 +1,167 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Morley extensions to the Michelson language+module Morley.Michelson.Untyped.Ext+  ( ExtInstrAbstract (..)+  , StackRef (..)+  , PrintComment (..)+  , TestAssert (..)+  , Var (..)+  , TyVar (..)+  , StackTypePattern (..)+  , StackFn (..)+  , varSet+  , stackTypePatternToList+  ) where++import Data.Aeson.TH (deriveJSON)+import Data.Data (Data(..))+import qualified Data.Set as Set+import qualified Data.Text as T+import Fmt (Buildable(build), Builder, GenericBuildable(..), listF)+import Text.PrettyPrint.Leijen.Text (textStrict)++import Morley.Michelson.Printer.Util (RenderDoc(..), renderOpsList)+import Morley.Michelson.Untyped.Type+import Morley.Util.Aeson++-- | Implementation-specific instructions embedded in a @NOP@ primitive, which+-- mark a specific point during a contract's typechecking or execution.+--+-- These instructions are not allowed to modify the contract's stack, but may+-- impose additional constraints that can cause a contract to report errors in+-- type-checking or testing.+--+-- Additionaly, some implementation-specific language features such as+-- type-checking of @LetMacro@s are implemented using this mechanism+-- (specifically @FN@ and @FN_END@).+data ExtInstrAbstract op =+    STACKTYPE StackTypePattern -- ^ Matches current stack against a type-pattern+  | FN T.Text StackFn [op]     -- ^ A typed stack function (push and pop a @TcExtFrame@)+  | UTEST_ASSERT (TestAssert op)   -- ^ Copy the current stack and run an inline assertion on it+  | UPRINT PrintComment         -- ^ Print a comment with optional embedded @StackRef@s+  | UCOMMENT Text        -- ^ A comment in Michelson code+  deriving stock (Eq, Show, Data, Generic, Functor)++deriving via GenericBuildable (ExtInstrAbstract op) instance Buildable op => Buildable (ExtInstrAbstract op)++instance NFData op => NFData (ExtInstrAbstract op)++instance RenderDoc op => RenderDoc (ExtInstrAbstract op) where+  renderDoc _ =+    \case+      FN _ _ ops -> renderOpsList False ops+      UCOMMENT t  -> textStrict ("/* " <> t <> " */")+      _ -> mempty+  isRenderable =+    \case+      FN {} -> True+      UCOMMENT{} -> True+      _ -> False++-- | A reference into the stack.+newtype StackRef = StackRef Natural+  deriving stock (Eq, Show, Data, Generic)++instance NFData StackRef++instance Buildable StackRef where+  build (StackRef i) = "%[" <> show i <> "]"++-- | A (named) type variable+newtype Var = Var T.Text+  deriving stock (Eq, Show, Ord, Data, Generic)+  deriving Buildable via GenericBuildable Var++instance NFData Var++-- | A type-variable or a type-constant+data TyVar =+    VarID Var+  | TyCon Ty+  deriving stock (Eq, Show, Data, Generic)+  deriving Buildable via GenericBuildable TyVar++instance NFData TyVar++-- | A stack pattern-match+data StackTypePattern+ = StkEmpty+ | StkRest+ | StkCons TyVar StackTypePattern+  deriving stock (Eq, Show, Data, Generic)++instance NFData StackTypePattern++-- | Convert 'StackTypePattern' to a list of types. Also returns+-- 'Bool' which is 'True' if the pattern is a fixed list of types and+-- 'False' if it's a pattern match on the head of the stack.+stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)+stackTypePatternToList StkEmpty = ([], True)+stackTypePatternToList StkRest = ([], False)+stackTypePatternToList (StkCons t pat) =+  first (t :) $ stackTypePatternToList pat++instance Buildable StackTypePattern where+  build = listF . pairToList . stackTypePatternToList+    where+      pairToList :: ([TyVar], Bool) -> [Builder]+      pairToList (types, fixed)+        | fixed = map build types+        | otherwise = map build types ++ ["..."]++-- | A stack function that expresses the type signature of a @LetMacro@+data StackFn = StackFn+  { sfnQuantifiedVars :: Maybe (Set Var)+  , sfnInPattern :: StackTypePattern+  , sfnOutPattern :: StackTypePattern+  }+  deriving stock (Eq, Show, Data, Generic)+  deriving Buildable via GenericBuildable StackFn++instance NFData StackFn++-- | Get the set of variables in a stack pattern+varSet :: StackTypePattern -> Set Var+varSet = \case+  StkEmpty -> Set.empty+  StkRest -> Set.empty+  (StkCons (VarID v) stk) -> v `Set.insert` (varSet stk)+  (StkCons _ stk) -> varSet stk++-- | A comment with optional embedded 'StackRef's. Used with @PRINT@ extended instruction.+newtype PrintComment = PrintComment+  { unUPrintComment :: [Either T.Text StackRef]+  } deriving stock (Eq, Show, Data, Generic)++instance NFData PrintComment++instance Buildable PrintComment where+  build = foldMap (either build build) . unUPrintComment++-- | An inline test assertion+data TestAssert op = TestAssert+  { tassName :: T.Text+  , tassComment :: PrintComment+  , tassInstrs :: [op]+  } deriving stock (Eq, Show, Functor, Data, Generic)++instance NFData op => NFData (TestAssert op)++deriving via GenericBuildable (TestAssert op) instance Buildable op => Buildable (TestAssert op)+++-------------------------------------+-- Aeson instances+-------------------------------------++deriveJSON morleyAesonOptions ''ExtInstrAbstract+deriveJSON morleyAesonOptions ''PrintComment+deriveJSON morleyAesonOptions ''StackTypePattern+deriveJSON morleyAesonOptions ''StackRef+deriveJSON morleyAesonOptions ''StackFn+deriveJSON morleyAesonOptions ''Var+deriveJSON morleyAesonOptions ''TyVar+deriveJSON morleyAesonOptions ''TestAssert

+ src/Morley/Michelson/Untyped/Instr.hs view

@@ -0,0 +1,362 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Michelson instructions in untyped model.++module Morley.Michelson.Untyped.Instr+  ( InstrAbstract (..)+  , ExpandedOp (..)+  , ExpandedInstr+  , flattenExpandedOp+  ) where++import Prelude hiding (EQ, GT, LT)++import Data.Aeson.TH (deriveJSON)+import Data.Data (Data(..))+import Fmt (Buildable(build), (+|), (|+))+import Generics.SYB (everywhere, mkT)+import Text.PrettyPrint.Leijen.Text+  (Doc, align, braces, enclose, indent, line, nest, space, text, (<$$>), (<+>))+import qualified Text.Show++import Morley.Michelson.ErrorPos (InstrCallStack)+import Morley.Michelson.Printer.Util+  (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, printDocS, renderOpsList, spaces)+import Morley.Michelson.Untyped.Annotation+  (Annotation, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, singleAnnSet)+import Morley.Michelson.Untyped.Contract (Contract'(..))+import Morley.Michelson.Untyped.Ext (ExtInstrAbstract)+import Morley.Michelson.Untyped.Type (Ty)+import Morley.Michelson.Untyped.Value (Value'(..))+import Morley.Util.Aeson++-------------------------------------+-- Types after macroexpander+-------------------------------------++type ExpandedInstr = InstrAbstract ExpandedOp++data ExpandedOp+  = PrimEx ExpandedInstr+  | SeqEx [ExpandedOp]+  | WithSrcEx InstrCallStack ExpandedOp+  deriving stock (Show, Eq, Data, Generic)++instance NFData ExpandedOp++instance RenderDoc ExpandedOp where+  renderDoc pn (WithSrcEx _ op) = renderDoc pn op+  renderDoc pn (PrimEx i) = renderDoc pn i+  renderDoc _  (SeqEx i) = renderOpsList False i+  isRenderable =+    \case PrimEx i -> isRenderable i+          WithSrcEx _ op -> isRenderable op+          _ -> True++instance Buildable ExpandedOp where+  build (WithSrcEx _ op) = build op+  build (PrimEx expandedInstr) = "<PrimEx: "+|expandedInstr|+">"+  build (SeqEx expandedOps)    = "<SeqEx: "+|expandedOps|+">"++-- | Flatten all 'SeqEx' in 'ExpandedOp'. This function is mostly for+-- testing. It returns instructions with the same logic, but they are+-- not strictly equivalent, because they are serialized differently+-- (grouping instructions into sequences affects the way they are+-- PACK'ed).+flattenExpandedOp :: ExpandedOp -> [ExpandedInstr]+flattenExpandedOp =+  \case+    PrimEx i -> [flattenInstr i]+    SeqEx ops -> concatMap flattenExpandedOp ops+    WithSrcEx _ op -> flattenExpandedOp op+  where+    flattenInstr :: ExpandedInstr -> ExpandedInstr+    flattenInstr = everywhere (mkT flattenOps)++    flattenOps :: [ExpandedOp] -> [ExpandedOp]+    flattenOps [] = []+    flattenOps (SeqEx s : xs) = s ++ flattenOps xs+    flattenOps (x@(PrimEx _) : xs) = x : flattenOps xs+    flattenOps (WithSrcEx _ op : xs) = op : flattenOps xs++-------------------------------------+-- Abstract instruction+-------------------------------------++-- | Michelson instruction with abstract parameter @op@.  This+-- parameter is necessary, because at different stages of our pipeline+-- it will be different. Initially it can contain macros and+-- non-flattened instructions, but then it contains only vanilla+-- Michelson instructions.+data InstrAbstract op+  = EXT               (ExtInstrAbstract op)+  | DROPN              Word+  -- ^ "DROP n" instruction.+  -- Note: reference implementation permits int16 here.+  -- Negative numbers are parsed successfully there, but rejected later.+  -- Morley is more permissive, so we use 'Word' here,+  -- i. e. permit more positive numbers. We do not permit negative numbers+  -- at type level.+  -- In practice, probably nobody will ever have numbers greater than ≈1000+  -- here, at least due to gas limits.+  -- Same reasoning applies to other instructions which have a numeric+  -- parameter representing number of elements on stack.+  | DROP+  -- ^ 'DROP' is essentially as special case for 'DROPN', but we need+  -- both because they are packed differently.+  | DUP               VarAnn+  | DUPN              VarAnn Word+  | SWAP+  | DIG               Word+  | DUG               Word+  | PUSH              VarAnn Ty (Value' op)+  | SOME              TypeAnn VarAnn+  | NONE              TypeAnn VarAnn Ty+  | UNIT              TypeAnn VarAnn+  | IF_NONE           [op] [op]+  | PAIR              TypeAnn VarAnn FieldAnn FieldAnn+  | UNPAIR            VarAnn VarAnn FieldAnn FieldAnn+  | PAIRN             VarAnn Word+  | UNPAIRN           Word+  | CAR               VarAnn FieldAnn+  | CDR               VarAnn FieldAnn+  | LEFT              TypeAnn VarAnn FieldAnn FieldAnn Ty+  | RIGHT             TypeAnn VarAnn FieldAnn FieldAnn Ty+  | IF_LEFT           [op] [op]+  | NIL               TypeAnn VarAnn Ty+  | CONS              VarAnn+  | IF_CONS           [op] [op]+  | SIZE              VarAnn+  | EMPTY_SET         TypeAnn VarAnn Ty+  | EMPTY_MAP         TypeAnn VarAnn Ty Ty+  | EMPTY_BIG_MAP     TypeAnn VarAnn Ty Ty+  | MAP               VarAnn [op]+  | ITER              [op]+  | MEM               VarAnn+  | GET               VarAnn+  | GETN              VarAnn Word+  | UPDATE            VarAnn+  | UPDATEN           VarAnn Word+  | GET_AND_UPDATE    VarAnn+  | IF                [op] [op]+  | LOOP              [op]+  | LOOP_LEFT         [op]+  | LAMBDA            VarAnn Ty Ty [op]+  | EXEC              VarAnn+  | APPLY             VarAnn+  | DIP               [op]+  | DIPN              Word [op]+  | FAILWITH+  | CAST              VarAnn Ty+  | RENAME            VarAnn+  | PACK              VarAnn+  | UNPACK            TypeAnn VarAnn Ty+  | CONCAT            VarAnn+  | SLICE             VarAnn+  | ISNAT             VarAnn+  | ADD               VarAnn+  | SUB               VarAnn+  | MUL               VarAnn+  | EDIV              VarAnn+  | ABS               VarAnn+  | NEG               VarAnn+  | LSL               VarAnn+  | LSR               VarAnn+  | OR                VarAnn+  | AND               VarAnn+  | XOR               VarAnn+  | NOT               VarAnn+  | COMPARE           VarAnn+  | EQ                VarAnn+  | NEQ               VarAnn+  | LT                VarAnn+  | GT                VarAnn+  | LE                VarAnn+  | GE                VarAnn+  | INT               VarAnn+  | SELF              VarAnn FieldAnn+  | CONTRACT          VarAnn FieldAnn Ty+  | TRANSFER_TOKENS   VarAnn+  | SET_DELEGATE      VarAnn+  | CREATE_CONTRACT   VarAnn VarAnn (Contract' op)+  | IMPLICIT_ACCOUNT  VarAnn+  | NOW               VarAnn+  | AMOUNT            VarAnn+  | BALANCE           VarAnn+  | VOTING_POWER      VarAnn+  | TOTAL_VOTING_POWER VarAnn+  | CHECK_SIGNATURE   VarAnn+  | SHA256            VarAnn+  | SHA512            VarAnn+  | BLAKE2B           VarAnn+  | SHA3              VarAnn+  | KECCAK            VarAnn+  | HASH_KEY          VarAnn+  | PAIRING_CHECK     VarAnn+  | SOURCE            VarAnn+  | SENDER            VarAnn+  | ADDRESS           VarAnn+  | CHAIN_ID          VarAnn+  | LEVEL             VarAnn+  | SELF_ADDRESS      VarAnn+  | NEVER+  | TICKET            VarAnn+  | READ_TICKET       VarAnn+  | SPLIT_TICKET      VarAnn+  | JOIN_TICKETS      VarAnn+  deriving stock (Eq, Functor, Data, Generic)++instance RenderDoc (InstrAbstract op) => Show (InstrAbstract op) where+  show = printDocS True . renderDoc doesntNeedParens++instance NFData op => NFData (InstrAbstract op)++instance (RenderDoc op) => RenderDoc (InstrAbstract op) where+  renderDoc pn = \case+    EXT extInstr            -> renderDoc pn extInstr+    DROP                    -> "DROP"+    DROPN n                 -> "DROP" <+> text (show n)+    DUP va                  -> "DUP" <+> renderAnnot va+    DUPN va n               -> "DUP" <+> renderAnnot va <+> text (show n)+    SWAP                    -> "SWAP"+    DIG n                   -> "DIG" <+> text (show n)+    DUG n                   -> "DUG" <+> text (show n)+    PUSH va t v             ->+      let renderConsecutively =+            "PUSH" <+> renderAnnot va <+> renderTy t <+> renderDoc needsParens v+          renderAligned = "PUSH" <+> renderAnnot va <$$> (spaces 2 <> renderTy t)+                                <$$> spaces 2 <> nest 3 (renderDoc needsParens v)+      in case v of+        ValueNil      -> renderConsecutively+        ValueInt{}    -> renderConsecutively+        ValueString{} -> renderConsecutively+        ValueBytes{}  -> renderConsecutively+        ValueUnit     -> renderConsecutively+        ValueTrue     -> renderConsecutively+        ValueFalse    -> renderConsecutively+        ValueNone     -> renderConsecutively+        _             -> renderAligned+    SOME ta va              -> "SOME" <+> renderAnnots [ta] [] [va]+    NONE ta va t            -> "NONE" <+> renderAnnots [ta] [] [va] <+> renderTy t+    UNIT ta va              -> "UNIT" <+> renderAnnots [ta] [] [va]+    IF_NONE x y             -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)+    PAIR ta va fa1 fa2      -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va]+    UNPAIR va1 va2 fa1 fa2  -> "UNPAIR" <+> renderAnnots [] [fa1, fa2] [va1, va2]+    PAIRN va n              -> "PAIR" <+> renderAnnots [] [] [va] <+> text (show n)+    UNPAIRN n               -> "UNPAIR" <+> text (show n)+    CAR va fa               -> "CAR" <+> renderAnnots [] [fa] [va]+    CDR va fa               -> "CDR" <+> renderAnnots [] [fa] [va]+    LEFT ta va fa1 fa2 t    -> "LEFT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t+    RIGHT ta va fa1 fa2 t   -> "RIGHT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t+    IF_LEFT x y             -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)+    NIL ta va t             -> "NIL" <+> renderAnnots [ta] [] [va] <+> renderTy t+    CONS va                 -> "CONS" <+> renderAnnot va+    IF_CONS x y             -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)+    SIZE va                 -> "SIZE" <+> renderAnnot va+    EMPTY_SET ta va t       -> "EMPTY_SET" <+> renderAnnots [ta] [] [va] <+> renderComp t+    EMPTY_MAP ta va c t     -> "EMPTY_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t+    EMPTY_BIG_MAP ta va c t -> "EMPTY_BIG_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t+    MAP va s                -> "MAP" <+> renderAnnot va <$$> spaces 4 <> nest 5 (renderOps s)+    ITER s                  -> "ITER" <+> nest 6 (renderOps s)+    MEM va                  -> "MEM" <+> renderAnnot va+    GET va                  -> "GET" <+> renderAnnot va+    GETN va n               -> "GET" <+> renderAnnot va <+> text (show n)+    UPDATE va               -> "UPDATE" <+> renderAnnot va+    UPDATEN va n            -> "UPDATE" <+> renderAnnot va <+> text (show n)+    GET_AND_UPDATE va       -> "GET_AND_UPDATE" <+> renderAnnot va+    IF x y                  -> "IF" <+> nest 4 (renderOps x) <$$> spaces 3 <> nest 4 (renderOps y)+    LOOP s                  -> "LOOP" <+> nest 6 (renderOps s)+    LOOP_LEFT s             -> "LOOP_LEFT" <+> nest 11 (renderOps s)+    LAMBDA va t r s         -> "LAMBDA" <+> renderAnnot va <$$> (spaces 2 <> renderTy t) <$$> (spaces 2 <> renderTy r) <$$> spaces 2 <> nest 3 (renderOps s)+    EXEC va                 -> "EXEC" <+> renderAnnot va+    APPLY va                -> "APPLY" <+> renderAnnot va+    DIP s                   -> "DIP" <+> nest 5 (renderOps s)+    DIPN n s                -> "DIP" <+> text (show n) <> line <> indent 4 (renderOps s)+    FAILWITH                -> "FAILWITH"+    CAST va t               -> "CAST" <+> renderAnnot va <+> renderTy t+    RENAME va               -> "RENAME" <+> renderAnnot va+    PACK va                 -> "PACK" <+> renderAnnot va+    UNPACK ta va t          -> "UNPACK" <+> renderAnnots [ta] [] [va] <+> renderTy t+    CONCAT va               -> "CONCAT" <+> renderAnnot va+    SLICE va                -> "SLICE" <+> renderAnnot va+    ISNAT va                -> "ISNAT" <+> renderAnnot va+    ADD va                  -> "ADD" <+> renderAnnot va+    SUB va                  -> "SUB" <+> renderAnnot va+    MUL va                  -> "MUL" <+> renderAnnot va+    EDIV va                 -> "EDIV" <+> renderAnnot va+    ABS va                  -> "ABS" <+> renderAnnot va+    NEG va                  -> "NEG" <+> renderAnnot va+    LSL va                  -> "LSL" <+> renderAnnot va+    LSR va                  -> "LSR" <+> renderAnnot va+    OR  va                  -> "OR" <+> renderAnnot va+    AND va                  -> "AND" <+> renderAnnot va+    XOR va                  -> "XOR" <+> renderAnnot va+    NOT va                  -> "NOT" <+> renderAnnot va+    COMPARE va              -> "COMPARE" <+> renderAnnot va+    EQ va                   -> "EQ" <+> renderAnnot va+    NEQ va                  -> "NEQ" <+> renderAnnot va+    LT va                   -> "LT" <+> renderAnnot va+    GT va                   -> "GT" <+> renderAnnot va+    LE va                   -> "LE" <+> renderAnnot va+    GE va                   -> "GE" <+> renderAnnot va+    INT va                  -> "INT" <+> renderAnnot va+    SELF va fa              -> "SELF" <+> renderAnnots [] [fa] [va]+    CONTRACT va fa t        -> "CONTRACT" <+> renderAnnots [] [fa] [va] <+> renderTy t+    TRANSFER_TOKENS va      -> "TRANSFER_TOKENS" <+> renderAnnot va+    SET_DELEGATE va         -> "SET_DELEGATE" <+> renderAnnot va+    CREATE_CONTRACT va1 va2 contract -> let+      body = enclose space space $ align $ (renderDoc doesntNeedParens contract)+      in "CREATE_CONTRACT" <+> renderAnnots [] [] [va1, va2] <$$> (indent 2 $ braces $ body)+    IMPLICIT_ACCOUNT va     -> "IMPLICIT_ACCOUNT" <+> renderAnnot va+    NOW va                  -> "NOW" <+> renderAnnot va+    AMOUNT va               -> "AMOUNT" <+> renderAnnot va+    BALANCE va              -> "BALANCE" <+> renderAnnot va+    VOTING_POWER va         -> "VOTING_POWER" <+> renderAnnot va+    TOTAL_VOTING_POWER va   -> "TOTAL_VOTING_POWER" <+> renderAnnot va+    CHECK_SIGNATURE va      -> "CHECK_SIGNATURE" <+> renderAnnot va+    SHA256 va               -> "SHA256" <+> renderAnnot va+    SHA512 va               -> "SHA512" <+> renderAnnot va+    BLAKE2B va              -> "BLAKE2B" <+> renderAnnot va+    SHA3 va                 -> "SHA3" <+> renderAnnot va+    KECCAK va               -> "KECCAK" <+> renderAnnot va+    HASH_KEY va             -> "HASH_KEY" <+> renderAnnot va+    PAIRING_CHECK va        -> "PAIRING_CHECK" <+> renderAnnot va+    SOURCE va               -> "SOURCE" <+> renderAnnot va+    SENDER va               -> "SENDER" <+> renderAnnot va+    ADDRESS va              -> "ADDRESS" <+> renderAnnot va+    CHAIN_ID va             -> "CHAIN_ID" <+> renderAnnot va+    LEVEL va                -> "LEVEL" <+> renderAnnot va+    SELF_ADDRESS va         -> "SELF_ADDRESS" <+> renderAnnot va+    NEVER                   -> "NEVER"+    TICKET va               -> "TICKET" <+> renderAnnot va+    READ_TICKET va          -> "READ_TICKET" <+> renderAnnot va+    SPLIT_TICKET va         -> "SPLIT_TICKET" <+> renderAnnot va+    JOIN_TICKETS va         -> "JOIN_TICKETS" <+> renderAnnot va+    where+      renderTy = renderDoc @Ty needsParens+      renderComp = renderDoc @Ty needsParens+      renderOps = renderOpsList False++      renderAnnot :: KnownAnnTag tag => Annotation tag -> Doc+      renderAnnot = renderDoc doesntNeedParens . singleAnnSet++      renderAnnots :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> Doc+      renderAnnots ts fs vs = renderDoc doesntNeedParens $ fullAnnSet ts fs vs++  isRenderable = \case+    EXT extInstr -> isRenderable extInstr+    _ -> True++instance (RenderDoc op, Buildable op) => Buildable (InstrAbstract op) where+  build = \case+    EXT ext -> build ext+    mi -> buildRenderDoc mi++----------------------------------------------------------------------------+-- JSON serialization+----------------------------------------------------------------------------++deriveJSON morleyAesonOptions ''ExpandedOp+deriveJSON morleyAesonOptions ''InstrAbstract

+ src/Morley/Michelson/Untyped/OpSize.hs view

@@ -0,0 +1,284 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Measuring operation size.+--+-- When originating a contract or making a transfer, tezos node forms operation+-- which is submitted over network. Size of this operation depends on content+-- of originated contract or transfer parameter resp., and tezos has a hard+-- limit on operation size thus it has to be accounted.+--+-- Functions declared in this module allow assessing size of origination or+-- transfer operation with up to constant precision because it yet accounts only+-- for Michelson primitives participating in the operation.+-- Other stuff which affects op size include parameters which user passes to+-- origination or transfer themselves, for instance, amount of mutez carried+-- to the contract. ATM we don't have necessary primitives in Haskell to be+-- able to handle those parameters here, probably waiting for [TM-89].+-- Currently, we can assess overall transfer size only approximately, like+-- in 'smallTransferOpSize'.+module Morley.Michelson.Untyped.OpSize+  ( OpSize (..)+  , opSizeHardLimit+  , smallTransferOpSize++  , instrOpSize+  , expandedInstrsOpSize+  , valueOpSize+  ) where++import Fmt (Buildable(..))+import Prelude hiding (Ordering(..))+import qualified Unsafe (fromIntegral)++import Morley.Michelson.Interpret.Utils+import Morley.Michelson.Untyped.Aliases+import Morley.Michelson.Untyped.Annotation+import Morley.Michelson.Untyped.Contract+import Morley.Michelson.Untyped.Instr+import Morley.Michelson.Untyped.Type+import Morley.Michelson.Untyped.Value++-- | Operation size in bytes.+--+-- We use newtype wrapper because there are different units of measure+-- (another one is gas, and we don't want to confuse them).+newtype OpSize = OpSize { unOpSize :: Word }+  deriving stock (Show, Eq, Ord)++instance Buildable OpSize where+  build = build . unOpSize++instance Semigroup OpSize where+  OpSize a <> OpSize b = OpSize (a + b)+instance Monoid OpSize where+  mempty = OpSize 0++-- | Maximal operation size allowed by Tezos production nodes.+opSizeHardLimit :: OpSize+opSizeHardLimit = OpSize 16384++-- | Base cost of any transfer of 0 mutez with no extra parameters.+-- (Add @valueOpSize \<param\>@ to it to get assessment of actual transfer op size)+smallTransferOpSize :: OpSize+smallTransferOpSize = OpSize 162++instrOpSize :: InstrAbstract ExpandedOp -> OpSize+instrOpSize = (OpSize 2 <>) . \case+  EXT{} -> mempty+  DROPN n -> stackDepthOpSize n+  DROP -> mempty+  DUP va -> annsOpSize va+  DUPN va n -> annsOpSize va <> stackDepthOpSize n+  SWAP -> mempty+  DIG n -> stackDepthOpSize n+  DUG n -> stackDepthOpSize n+  PUSH va t v -> annsOpSize va <> typeOpSize t <> valueOpSize v+  SOME ta va -> annsOpSize ta va+  NONE ta va t -> annsOpSize ta va <> typeOpSize t+  UNIT ta va -> annsOpSize ta va+  IF_NONE l r -> ifOpSize l r+  PAIR ta va fal far -> annsOpSize ta va fal far+  UNPAIR va1 va2 fal far -> annsOpSize va1 va2 fal far+  PAIRN va n -> annsOpSize va <> stackDepthOpSize n+  UNPAIRN n -> stackDepthOpSize n+  CAR va fa -> annsOpSize va fa+  CDR va fa -> annsOpSize va fa+  LEFT ta va fal far t -> annsOpSize ta va fal far <> typeOpSize t+  RIGHT ta va fal far t -> annsOpSize ta va fal far <> typeOpSize t+  IF_LEFT l r -> ifOpSize l r+  NIL ta va t -> annsOpSize ta va <> typeOpSize t+  CONS va -> annsOpSize va+  IF_CONS l r -> ifOpSize l r+  SIZE va -> annsOpSize va+  EMPTY_SET ta va ct -> annsOpSize ta va <> innerOpSize ct+  EMPTY_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t+  EMPTY_BIG_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t+  MAP va is -> annsOpSize va <> subcodeOpSize is+  ITER is -> subcodeOpSize is+  MEM va -> annsOpSize va+  GET va -> annsOpSize va+  GETN va n -> annsOpSize va <> stackDepthOpSize n+  UPDATE va -> annsOpSize va+  UPDATEN va n -> annsOpSize va <> stackDepthOpSize n+  GET_AND_UPDATE va -> annsOpSize va+  IF l r -> ifOpSize l r+  LOOP is -> expandedInstrsOpSize is+  LOOP_LEFT is -> expandedInstrsOpSize is+  LAMBDA va ti to is ->+    annsOpSize va <> typeOpSize ti <> typeOpSize to <> expandedInstrsOpSize is+  EXEC va -> annsOpSize va+  APPLY va -> annsOpSize va+  DIP is -> subcodeOpSize is+  DIPN n is -> stackDepthOpSize n <> subcodeOpSize is+  FAILWITH -> mempty+  CAST va t -> annsOpSize va <> typeOpSize t+  RENAME va -> annsOpSize va+  PACK va -> annsOpSize va+  UNPACK ta va t -> annsOpSize ta va <> typeOpSize t+  CONCAT va -> annsOpSize va+  SLICE va -> annsOpSize va+  ISNAT va -> annsOpSize va+  ADD va -> annsOpSize va+  SUB va -> annsOpSize va+  MUL va -> annsOpSize va+  EDIV va -> annsOpSize va+  ABS va -> annsOpSize va+  NEG va -> annsOpSize va+  LSL va -> annsOpSize va+  LSR va -> annsOpSize va+  OR va -> annsOpSize va+  AND va -> annsOpSize va+  XOR va -> annsOpSize va+  NOT va -> annsOpSize va+  COMPARE va -> annsOpSize va+  EQ va -> annsOpSize va+  NEQ va -> annsOpSize va+  LT va -> annsOpSize va+  LE va -> annsOpSize va+  GT va -> annsOpSize va+  GE va -> annsOpSize va+  INT va -> annsOpSize va+  SELF va fa -> annsOpSize va fa+  CONTRACT va fa t -> annsOpSize va fa <> typeOpSize t+  TRANSFER_TOKENS va -> annsOpSize va+  SET_DELEGATE va -> annsOpSize va+  CREATE_CONTRACT va1 va2 c -> annsOpSize va1 va2 <> contractOpSize c+  IMPLICIT_ACCOUNT va -> annsOpSize va+  NOW va -> annsOpSize va+  AMOUNT va -> annsOpSize va+  BALANCE va -> annsOpSize va+  VOTING_POWER va -> annsOpSize va+  TOTAL_VOTING_POWER va -> annsOpSize va+  CHECK_SIGNATURE va -> annsOpSize va+  SHA256 va -> annsOpSize va+  SHA512 va -> annsOpSize va+  BLAKE2B va -> annsOpSize va+  SHA3 va -> annsOpSize va+  KECCAK va -> annsOpSize va+  HASH_KEY va -> annsOpSize va+  PAIRING_CHECK va -> annsOpSize va+  SOURCE va -> annsOpSize va+  SENDER va -> annsOpSize va+  ADDRESS va -> annsOpSize va+  CHAIN_ID va -> annsOpSize va+  LEVEL va -> annsOpSize va+  SELF_ADDRESS va -> annsOpSize va+  NEVER -> mempty+  TICKET va -> annsOpSize va+  READ_TICKET va -> annsOpSize va+  SPLIT_TICKET va -> annsOpSize va+  JOIN_TICKETS va -> annsOpSize va+  where+    subcodeOpSize is = expandedInstrOpSize (SeqEx is)+    ifOpSize l r = expandedInstrOpSize (SeqEx l) <> expandedInstrOpSize (SeqEx r)+    stackDepthOpSize n = OpSize 1 <> numOpSize n++expandedInstrOpSize :: ExpandedOp -> OpSize+expandedInstrOpSize = \case+  PrimEx i -> instrOpSize i+  SeqEx is -> OpSize 5 <> expandedInstrsOpSize is+  WithSrcEx _ i -> expandedInstrOpSize i++expandedInstrsOpSize :: [ExpandedOp] -> OpSize+expandedInstrsOpSize = foldMap expandedInstrOpSize++contractOpSize :: Contract -> OpSize+contractOpSize (Contract (ParameterType cp rootAnn) st is _) =+  OpSize 16 <> typeOpSize' [rootAnn] cp <> typeOpSize st <> expandedInstrsOpSize is++numOpSize :: Integral i => i -> OpSize+numOpSize = OpSize . Unsafe.fromIntegral @Int @Word . length . encodeZarithNumber . fromIntegral++valueOpSize :: Value -> OpSize+valueOpSize = (OpSize 1 <>) . \case+  ValueInt i -> numOpSize i+  ValueString s -> (seqOpSize <>) . OpSize . Unsafe.fromIntegral @Int @Word $ length s+  ValueBytes (InternalByteString b) -> (seqOpSize <>) . OpSize . Unsafe.fromIntegral @Int @Word $ length b+  ValueUnit -> baseOpSize+  ValueTrue -> baseOpSize+  ValueFalse -> baseOpSize+  ValuePair l r -> baseOpSize <> valueOpSize l <> valueOpSize r+  ValueLeft x -> baseOpSize <> valueOpSize x+  ValueRight x -> baseOpSize <> valueOpSize x+  ValueSome x -> baseOpSize <> valueOpSize x+  ValueNone -> baseOpSize+  ValueNil -> seqOpSize+  ValueSeq l -> seqOpSize <> foldMap valueOpSize l+  ValueMap m -> seqOpSize <> foldMap eltOpSize m+  ValueLambda m -> seqOpSize <> foldMap expandedInstrOpSize m+  where+    baseOpSize = OpSize 1+    seqOpSize = OpSize 4+    eltOpSize (Elt k v) = OpSize 2 <> valueOpSize k <> valueOpSize v++typeOpSize :: Ty -> OpSize+typeOpSize = typeOpSize' []++typeOpSize' :: [FieldAnn] -> Ty -> OpSize+typeOpSize' anns (Ty t ta) =+  tOpSize t <> annsOpSize ta anns++tOpSize :: T -> OpSize+tOpSize t =+  OpSize 2 <> case t of+    TKey -> mempty+    TUnit -> mempty+    TSignature -> mempty+    TChainId -> mempty+    TOption a -> typeOpSize a+    TList a -> typeOpSize a+    TSet a -> innerOpSize a+    TOperation -> mempty+    TTicket a -> typeOpSize a+    TContract a -> typeOpSize a+    -- Nested variable annotations don't use any extra operation size.+    TPair al ar _ _ l r -> typeOpSize' [al] l <> typeOpSize' [ar] r+    TOr al ar l r -> typeOpSize' [al] l <> typeOpSize' [ar] r+    TLambda i o -> typeOpSize i <> typeOpSize o+    TMap k v -> innerOpSize k <> typeOpSize v+    TBigMap k v -> innerOpSize k <> typeOpSize v+    TInt -> mempty+    TNat -> mempty+    TString -> mempty+    TBytes -> mempty+    TMutez -> mempty+    TBool -> mempty+    TKeyHash -> mempty+    TBls12381Fr -> mempty+    TBls12381G1 -> mempty+    TBls12381G2 -> mempty+    TTimestamp -> mempty+    TAddress -> mempty+    TNever -> mempty++innerOpSize :: Ty -> OpSize+innerOpSize (Ty _ a) =+  (OpSize 2) <> annsOpSize a++-- | Accepts an arbitrary number of 'TypeAnn' 'FieldAnn' and/or 'VarAnn' that+-- belong to the same entity and returns their total operation size.+--+-- Note that annotations which belong to the same entity (type or instruction)+-- __must be__ considered in aggregate using one call of this function and to be+-- specified in order. See 'AnnotationSet' for details.+annsOpSize :: AnnsOpSizeVararg x => x+annsOpSize = annsOpSizeVararg emptyAnnSet++class AnnsOpSizeVararg x where+  annsOpSizeVararg :: AnnotationSet -> x++instance (KnownAnnTag t, AnnsOpSizeVararg x) => AnnsOpSizeVararg (Annotation t -> x) where+  annsOpSizeVararg acc an = annsOpSizeVararg (acc <> singleAnnSet an)++instance (KnownAnnTag t, AnnsOpSizeVararg x) => AnnsOpSizeVararg ([Annotation t] -> x) where+  annsOpSizeVararg acc ans = annsOpSizeVararg (acc <> singleGroupAnnSet ans)++instance AnnsOpSizeVararg OpSize where+  annsOpSizeVararg = annsOpSizeImpl++annsOpSizeImpl :: AnnotationSet -> OpSize+annsOpSizeImpl annSet+  | isNoAnnSet annSet = mempty+  | otherwise = OpSize . Unsafe.fromIntegral @Int @Word $ 3 * (minAnnSetSize annSet + 1)

+ src/Morley/Michelson/Untyped/Type.hs view

@@ -0,0 +1,392 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Michelson types represented in untyped model.++module Morley.Michelson.Untyped.Type+  ( Ty (..)+  , T (..)+  , ParameterType (..)+  , toption+  , tpair+  , tor+  , tyint+  , tynat+  , tyunit+  , tybool+  , typair+  , tyor+  , tyImplicitAccountParam+  , isAtomicType+  , isKey+  , isSignature+  , isComparable+  , isMutez+  , isKeyHash+  , isBool+  , isString+  , isInteger+  , isTimestamp+  , isNat+  , isInt+  , isBytes+  , renderType+  , unwrapT+  ) where++import Data.Aeson.TH (deriveJSON)+import Data.Data (Data(..))+import Data.List.NonEmpty ((<|))+import Fmt (Buildable(build))+import Language.Haskell.TH.Lift (deriveLift)+import Prelude hiding ((<$>))+import Text.PrettyPrint.Leijen.Text (Doc, align, softbreak, (<$>), (<+>))++import Morley.Michelson.Printer.Util+  (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens,+  needsParens, wrapInParens)+import Morley.Michelson.Untyped.Annotation+  (AnnotationSet, FieldAnn, RootAnn, TypeAnn, VarAnn, emptyAnnSet, fullAnnSet, noAnn,+  pattern Annotation, singleAnnSet)+import Morley.Util.Aeson++-- | Annotated Michelson type.+-- We don't name it 'Type' to avoid conflicts with 'Data.Kind.Type'.+data Ty+  = Ty ~T TypeAnn+  deriving stock (Eq, Show, Data, Generic)++-- | Extract a raw Michelson type from an annotated one+unwrapT :: Ty -> T+unwrapT (Ty t _) = t++instance NFData Ty++instance RenderDoc (Prettier Ty) where+  renderDoc pn (Prettier w) = case w of+    (Ty t ta) -> renderType t False pn (singleAnnSet ta)++instance RenderDoc Ty where+  renderDoc pn (Ty t ta) = renderType t True pn (singleAnnSet ta)++instance RenderDoc T where+  renderDoc pn t = renderType t True pn emptyAnnSet++-- | Since Babylon parameter type can have special root annotation.+data ParameterType = ParameterType Ty RootAnn+  deriving stock (Eq, Show, Data, Generic)++instance NFData ParameterType++instance RenderDoc (Prettier ParameterType) where+  renderDoc pn (Prettier w) = case w of+    ParameterType (Ty t ta) ra ->+      renderType t False pn (fullAnnSet [ta] [ra] [])++instance RenderDoc ParameterType where+  renderDoc pn (ParameterType (Ty t ta) ra) =+    renderType t True pn (fullAnnSet [ta] [ra] [])++-- | Render a type representation+--+-- Ordering between different kinds of annotations is not significant,+-- but ordering among annotations of the same kind is. Annotations+-- of a same kind must be grouped together.+--+-- > (prim @v :t %x arg1 arg2 ...)+--+-- these are equivalent+--+-- > PAIR :t @my_pair %x %y+-- > PAIR %x %y :t @my_pair+renderType+  :: T+  -> Bool+  -> RenderContext+  -> AnnotationSet+  -> Doc+renderType t forceSingleLine pn annSet =+  let annDoc = renderDoc doesntNeedParens annSet+      recRenderer t' annSet' = renderType t' forceSingleLine needsParens annSet'+      renderBranches :: NonEmpty Doc -> Doc+      renderBranches ds =+        if forceSingleLine+        then foldl1 (<+>) ds+        else align $ softbreak <> foldl1 (<$>) ds++      collectBranches :: T -> TypeAnn -> FieldAnn -> NonEmpty Doc+      collectBranches (TPair fa1 fa2 va1 _ (Ty t1 ta1) (Ty t2 ta2)) _ (Annotation "")+        = (recRenderer t1 $ (fullAnnSet [ta1] [fa1] [va1])) <| collectBranches t2 ta2 fa2+      collectBranches t' ta fa = (recRenderer t' $ fullAnnSet [ta] [fa] []) :| []++  in+  case t of+    TInt              -> wrapInParens pn $ "int" :| [annDoc]+    TNat              -> wrapInParens pn $ "nat" :| [annDoc]+    TString           -> wrapInParens pn $ "string" :| [annDoc]+    TMutez            -> wrapInParens pn $ "mutez" :| [annDoc]+    TBool             -> wrapInParens pn $ "bool" :| [annDoc]+    TKeyHash          -> wrapInParens pn $ "key_hash" :| [annDoc]+    TTimestamp        -> wrapInParens pn $ "timestamp" :| [annDoc]+    TBytes            -> wrapInParens pn $ "bytes" :| [annDoc]+    TAddress          -> wrapInParens pn $ "address" :| [annDoc]+    TKey              -> wrapInParens pn $ "key" :| [annDoc]+    TBls12381Fr       -> wrapInParens pn $ "bls12_381_fr" :| [annDoc]+    TBls12381G1       -> wrapInParens pn $ "bls12_381_g1" :| [annDoc]+    TBls12381G2       -> wrapInParens pn $ "bls12_381_g2" :| [annDoc]+    TUnit             -> wrapInParens pn $ "unit" :| [annDoc]+    TSignature        -> wrapInParens pn $ "signature" :| [annDoc]+    TChainId          -> wrapInParens pn $ "chain_id" :| [annDoc]+    TOperation        -> wrapInParens pn $ "operation" :| [annDoc]+    TNever            -> wrapInParens pn $ "never" :| [annDoc]++    TOption (Ty t1 ta1) ->+      addParens pn $+      "option" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)++    TList (Ty t1 ta1) ->+      addParens pn $+      "list" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)++    TSet (Ty t1 ta1) ->+      addParens pn $+      "set" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)++    TContract (Ty t1 ta1) ->+      addParens pn $+      "contract" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)++    TTicket (Ty t1 ta1) ->+      addParens pn $+      "ticket" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)++    -- Optimize in comb pair rendering: `pair x y z` instead of `pair x (pair y z)`+    -- Works only if there is no field annotation on nested pair+    p@(TPair _ (Annotation "") _ _ (Ty _ _) (Ty (TPair {}) _)) ->+       let branches = collectBranches p noAnn noAnn+       in+        addParens pn $+          "pair" <+> annDoc <+>+            renderBranches branches++    TPair fa1 fa2 va1 va2 (Ty t1 ta1) (Ty t2 ta2) ->+      addParens pn $+        "pair" <+> annDoc <+>+          renderBranches (+            (recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1]) :|+            [ recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2]+            ])++    TOr fa1 fa2 (Ty t1 ta1) (Ty t2 ta2) ->+      addParens pn $+        "or" <+> annDoc <+>+          renderBranches (+            (recRenderer t1 $ fullAnnSet [ta1] [fa1] []) :|+            [ recRenderer t2 $ fullAnnSet [ta2] [fa2] []+            ])++    TLambda (Ty t1 ta1) (Ty t2 ta2) ->+      addParens pn $+        "lambda" <+> annDoc <+>+          renderBranches (+            (recRenderer t1 $ singleAnnSet ta1) :|+            [ recRenderer t2 $ singleAnnSet ta2+            ])++    TMap (Ty t1 ta1) (Ty t2 ta2) ->+      addParens pn $+        "map" <+> annDoc <+>+          renderBranches (+            (recRenderer t1 $ singleAnnSet ta1) :|+            [ recRenderer t2 $ singleAnnSet ta2+            ])++    TBigMap (Ty t1 ta1) (Ty t2 ta2) ->+      addParens pn $+        "big_map" <+> annDoc <+>+          renderBranches (+            (recRenderer t1 $ singleAnnSet ta1) :|+            [ recRenderer t2 $ singleAnnSet ta2+            ])++instance Buildable Ty where+  build = buildRenderDoc++instance Buildable ParameterType where+  build = buildRenderDoc++-- | Michelson Type+data T =+    TKey+  | TUnit+  | TSignature+  | TChainId+  | TOption Ty+  | TList Ty+  | TSet Ty+  | TOperation+  | TContract Ty+  | TTicket Ty+  | TPair FieldAnn FieldAnn VarAnn VarAnn Ty Ty+  | TOr FieldAnn FieldAnn Ty Ty+  | TLambda Ty Ty+  | TMap Ty Ty+  | TBigMap Ty Ty+  | TInt+  | TNat+  | TString+  | TBytes+  | TMutez+  | TBool+  | TKeyHash+  | TBls12381Fr+  | TBls12381G1+  | TBls12381G2+  | TTimestamp+  | TAddress+  | TNever+  deriving stock (Eq, Show, Data, Generic)++instance Buildable T where+  build = buildRenderDoc++instance NFData T++-- | Construct non-annotated @option@ type from an annotated type+toption :: Ty -> T+toption t = TOption t++-- | Construct non-annotated @pair@ type from two annotated types+tpair :: Ty -> Ty -> T+tpair l r = TPair noAnn noAnn noAnn noAnn l r++-- | Construct non-annotated @or@ type from two annotated types+tor :: Ty -> Ty -> T+tor l r = TOr noAnn noAnn l r++-- | Construct annotated @int@ type with an empty annotation+tyint :: Ty+tyint = Ty TInt noAnn++-- | Construct annotated @nat@ type with an empty annotation+tynat :: Ty+tynat = Ty TNat noAnn++-- | Construct annotated @unit@ type with an empty annotation+tyunit :: Ty+tyunit = Ty TUnit noAnn++-- | Construct annotated @bool@ type with an empty annotation+tybool :: Ty+tybool = Ty TBool noAnn++-- | Construct annotated @pair@ type with an empty annotation+typair :: Ty -> Ty -> Ty+typair l r = Ty (tpair l r) noAnn++-- | Construct annotated @or@ type with an empty annotation+tyor :: Ty -> Ty -> Ty+tyor l r = Ty (tor l r) noAnn++-- | For implicit account, which Ty its parameter seems to have+-- from outside.+tyImplicitAccountParam :: Ty+tyImplicitAccountParam = Ty TUnit noAnn++-- | Check if type is atomic.+isAtomicType :: Ty -> Bool+isAtomicType t@(Ty _ tAnn) | tAnn == noAnn =+    isComparable t || isKey t || isUnit t || isSignature t || isOperation t+isAtomicType _ = False++-- | Predicate checking if type is @key@+isKey :: Ty -> Bool+isKey (Ty TKey _) = True+isKey _ = False++-- | Predicate checking if type is @unit@+isUnit :: Ty -> Bool+isUnit (Ty TUnit _) = True+isUnit _ = False++-- | Predicate checking if type is @signature@+isSignature :: Ty -> Bool+isSignature (Ty TSignature _) = True+isSignature _ = False++-- | Predicate checking if type is @operation@+isOperation :: Ty -> Bool+isOperation (Ty TOperation _) = True+isOperation _ = False++-- | Predicate checking if type is comparable, i.e. true for @int@, @nat@, @string@, etc.+-- see <https://tezos.gitlab.io/michelson-reference/> for a complete list of comparable types.+isComparable :: Ty -> Bool+isComparable (Ty t _) = case t of+  TInt -> True+  TNat -> True+  TString -> True+  TBytes -> True+  TMutez -> True+  TBool -> True+  TKeyHash -> True+  TTimestamp -> True+  TAddress -> True+  _ -> False++-- | Predicate checking if type is @mutez@+isMutez :: Ty -> Bool+isMutez (Ty TMutez _) = True+isMutez _ = False++-- | Predicate checking if type is @timestamp@+isTimestamp :: Ty -> Bool+isTimestamp (Ty TTimestamp _) = True+isTimestamp _ = False++-- | Predicate checking if type is @keyhash@+isKeyHash :: Ty -> Bool+isKeyHash (Ty TKeyHash _) = True+isKeyHash _ = False++-- | Predicate checking if type is @bool@+isBool :: Ty -> Bool+isBool (Ty TBool _) = True+isBool _ = False++-- | Predicate checking if type is @string@+isString :: Ty -> Bool+isString (Ty TString _) = True+isString _ = False++-- | Predicate checking if type is integral, i.e. @nat@, @int@, @mutez@, or @timestamp@+isInteger :: Ty -> Bool+isInteger a = isNat a || isInt a || isMutez a || isTimestamp a++-- | Predicate checking if type is @nat@+isNat :: Ty -> Bool+isNat (Ty TNat _) = True+isNat _ = False++-- | Predicate checking if type is @int@+isInt :: Ty -> Bool+isInt (Ty TInt _) = True+isInt _ = False++-- | Predicate checking if type is @bytes@+isBytes :: Ty -> Bool+isBytes (Ty TBytes _) = True+isBytes _ = False++----------------------------------------------------------------------------+-- TH derivations+----------------------------------------------------------------------------++deriveJSON morleyAesonOptions ''Ty+deriveJSON morleyAesonOptions ''T+deriveJSON morleyAesonOptions ''ParameterType++deriveLift ''Ty+deriveLift ''T+deriveLift ''ParameterType

+ src/Morley/Michelson/Untyped/Value.hs view

@@ -0,0 +1,158 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Untyped Michelson values (i. e. type of a value is not statically known).++module Morley.Michelson.Untyped.Value+  ( Value' (..)+  , Elt (..)+  -- Internal types to avoid orphan instances+  , InternalByteString(..)+  , unInternalByteString+  , linearizeRightCombValuePair+  , renderValuesList+  , renderSome+  , renderNone+  , renderLeft+  , renderRight+  , renderPair+  , renderElt'+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..), withText)+import Data.Aeson.TH (deriveJSON)+import Data.Data (Data(..))+import Data.List.NonEmpty ((<|))+import Fmt (Buildable(build))+import Text.Hex (decodeHex, encodeHex)+import Text.PrettyPrint.Leijen.Text+  (Doc, braces, dquotes, enclose, semi, space, text, textStrict, (<+>))++import Morley.Michelson.Printer.Util+  (RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens,+  renderOps)+import Morley.Michelson.Text+import Morley.Util.Aeson++data Value' op =+    ValueInt     Integer+  | ValueString  MText+  | ValueBytes   InternalByteString+  | ValueUnit+  | ValueTrue+  | ValueFalse+  | ValuePair    (Value' op) (Value' op)+  | ValueLeft    (Value' op)+  | ValueRight   (Value' op)+  | ValueSome    (Value' op)+  | ValueNone+  | ValueNil+  | ValueSeq     (NonEmpty $ Value' op)+  -- ^ A sequence of elements: can be a list, a set or a pair.+  -- We can't distinguish lists and sets during parsing.+  | ValueMap     (NonEmpty $ Elt op)+  | ValueLambda  (NonEmpty op)+  deriving stock (Eq, Show, Functor, Data, Generic)++instance NFData op => NFData (Value' op)++data Elt op = Elt (Value' op) (Value' op)+  deriving stock (Eq, Show, Functor, Data, Generic)++instance NFData op => NFData (Elt op)++-- | ByteString does not have an instance for ToJSON and FromJSON, to+-- avoid orphan type class instances, make a new type wrapper around it.+newtype InternalByteString = InternalByteString ByteString+  deriving stock (Data, Eq, Show, Generic)++instance NFData InternalByteString++unInternalByteString :: InternalByteString -> ByteString+unInternalByteString (InternalByteString bs) = bs++instance RenderDoc op => RenderDoc (Value' op) where+  renderDoc pn =+    \case+      ValueNil       -> "{ }"+      ValueInt x     -> text . show $ x+      ValueString x  -> dquotes (textStrict $ writeMText x)+      ValueBytes xs  -> "0x" <> (textStrict . encodeHex . unInternalByteString $ xs)+      ValueUnit      -> "Unit"+      ValueTrue      -> "True"+      ValueFalse     -> "False"+      p@(ValuePair _ (ValuePair _ _))  ->+        let encodedValues = linearizeRightCombValuePair p+        in renderValuesList (renderDoc doesntNeedParens) encodedValues+      ValuePair l r  -> renderPair  pn (flip renderDoc l) (flip renderDoc r)+      ValueLeft l    -> renderLeft  pn $ flip renderDoc l+      ValueRight r   -> renderRight pn $ flip renderDoc r+      ValueSome x    -> renderSome  pn $ flip renderDoc x+      ValueNone      -> renderNone+      ValueSeq xs    -> renderValuesList (renderDoc doesntNeedParens) xs+      ValueMap xs    -> renderValuesList renderElt xs+      ValueLambda xs -> renderOps False xs++-- | Helper function to render @None@ @Value@+renderNone :: Doc+renderNone = "None"++-- | Helper functions to render @Value@s+renderSome, renderLeft, renderRight :: RenderContext -> (RenderContext -> Doc) -> Doc+renderSome  pn render = addParens pn $ "Some"  <+> render needsParens+renderLeft  pn render = addParens pn $ "Left"  <+> render needsParens+renderRight pn render = addParens pn $ "Right" <+> render needsParens++-- | Helper function to render @Pair@ @Value@+renderPair :: RenderContext -> (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc+renderPair pn l r = addParens pn $ "Pair" <+> l needsParens <+> r needsParens++-- | Helper function to render @Elt@+renderElt' :: (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc+renderElt' l r = "Elt" <+> l needsParens <+> r needsParens++-- | Converts @Pair a (Pair b c)@ to @[a, b, c]@.+linearizeRightCombValuePair :: (Value' op) -> NonEmpty (Value' op)+linearizeRightCombValuePair (ValuePair l r) = l <| linearizeRightCombValuePair r+linearizeRightCombValuePair v = v :| []++renderElt :: RenderDoc op => Elt op -> Doc+renderElt (Elt k v) = renderElt' (flip renderDoc k) (flip renderDoc v)++instance RenderDoc op => RenderDoc (Elt op) where+  renderDoc _ = renderElt++-- | A helper function that renders a 'NonEmpty' list of items in Michelson-readable format,+-- given a rendering function for a single item.+renderValuesList :: (e -> Doc) -> NonEmpty e -> Doc+renderValuesList renderElem (toList -> es) =+  braces . enclose space space $+    mconcat . intersperse (semi <> space) $+      renderElem <$> es++instance (RenderDoc op) => Buildable (Value' op) where+  build = buildRenderDoc++instance (RenderDoc op) => Buildable (Elt op) where+  build = buildRenderDoc++----------------------------------------------------------------------------+-- JSON serialization+----------------------------------------------------------------------------++-- it is not possible to derives these automatically because+-- ByteString does not have a ToJSON or FromJSON instance++instance ToJSON InternalByteString where+  toJSON = toJSON . encodeHex . unInternalByteString++instance FromJSON InternalByteString where+  parseJSON =+    withText "Hex-encoded bytestring" $ \t ->+      case decodeHex t of+        Nothing -> fail "Invalid hex encoding"+        Just res -> pure (InternalByteString res)++deriveJSON morleyAesonOptions ''Value'+deriveJSON morleyAesonOptions ''Elt

+ src/Morley/Tezos/Address.hs view

@@ -0,0 +1,338 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Address in Tezos.++{-# LANGUAGE DeriveLift #-}++module Morley.Tezos.Address+  ( ContractHash (..)+  , Address (..)+  , mkKeyAddress+  , detGenKeyAddress+  , isKeyAddress++  , GlobalCounter(..)+  , mkContractHashHack++  -- * Formatting+  , ParseAddressError (..)+  , ParseAddressRawError (..)+  , ParseContractAddressError (..)+  , formatAddress+  , mformatAddress+  , parseAddressRaw+  , parseContractHash+  , parseAddress+  , ta+  , unsafeParseAddressRaw+  , unsafeParseAddress+  , unsafeParseContractHash+  ) where++import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Aeson+import qualified Data.Aeson.Types as AesonTypes+import qualified Data.ByteString as BS+import Data.Text (strip)+import Fmt (Buildable(build), hexF, pretty)+import Instances.TH.Lift ()+import qualified Language.Haskell.TH.Quote as TH+import Language.Haskell.TH.Syntax (Lift)+import qualified Language.Haskell.TH.Syntax as TH+import Text.PrettyPrint.Leijen.Text (backslash, dquotes, int, parens, (<+>))++import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)+import Morley.Michelson.Text+import Morley.Tezos.Crypto+import Morley.Util.CLI+import Morley.Util.TypeLits++-- TODO: we should probably have a `Hash` type.+-- | Hash of origination command for some contract.+newtype ContractHash = ContractHash ByteString+  deriving stock (Show, Eq, Ord, Generic, Lift)++instance NFData ContractHash++-- We know that the length must be 20.+-- Currently it's hardcoded here, later we'll probably have a `Hash` type.+-- | Length of contract hash in bytes (only hash itself, no tags, checksums+-- or anything).+contractHashLengthBytes :: Integral n => n+contractHashLengthBytes = 20++-- | Data type corresponding to address structure in Tezos.+data Address+  = KeyAddress KeyHash+  -- ^ @tz@ address which is a hash of a public key.+  | ContractAddress ContractHash+  -- ^ @KT@ address which corresponds to a callable contract.+  deriving stock (Show, Eq, Ord, Generic, Lift)++instance NFData Address++-- | Returns @True@ if given address is implicit.+isKeyAddress :: Address -> Bool+isKeyAddress = \case+  KeyAddress _      -> True+  ContractAddress _ -> False++-- | Smart constructor for 'KeyAddress'.+mkKeyAddress :: PublicKey -> Address+mkKeyAddress = KeyAddress . hashKey++-- | Deterministically generate a random 'KeyAddress' and discard its+-- secret key.+detGenKeyAddress :: ByteString -> Address+detGenKeyAddress = mkKeyAddress . toPublic . detSecretKey++-- | Represents the network's global counter.+--+-- We store the current value of this counter in the operation at the time of its creation+-- for the following reasons:+-- * to guarantee the uniqueness of contract addresses upon origination+--   (see 'Morley.Michelson.Typed.Operation.mkContractAddress)+-- * to prevent replay attacks by checking that an operation with the same counter value+--   con't be performed twice.+--+-- The counter is incremented after every operation execution and interpretation of instructions+-- @CREATE_CONTRACT@ and @TRANSFER_TOKENS@, and thus ensures that these addresses are unique+-- (i.e. origination of identical contracts with identical metadata will result in+-- different addresses.)+--+-- Our counter is represented as 'Word64', while in Tezos it is unbounded. We believe that+-- for our interpreter it should not matter.+newtype GlobalCounter = GlobalCounter { unGlobalCounter :: Word64 }+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)+  deriving newtype (ToJSON, FromJSON, Num, Buildable, Hashable)++-- | Create a dummy 'ContractHash' value by hashing given 'ByteString'.+--+-- Use in tests **only**.+mkContractHashHack :: ByteString -> ContractHash+mkContractHashHack = ContractHash . blake2b160++----------------------------------------------------------------------------+-- Formatting/parsing+----------------------------------------------------------------------------++-- It's a magic constant used by Tezos to encode a contract address.+-- It was deduced empirically.+contractAddressPrefix :: ByteString+contractAddressPrefix = "\2\90\121"++formatContractHash :: ContractHash -> Text+formatContractHash (ContractHash bs) =+  encodeBase58Check (contractAddressPrefix <> bs)++formatAddress :: Address -> Text+formatAddress =+  \case+    KeyAddress h -> formatKeyHash h+    ContractAddress h -> formatContractHash h++mformatAddress :: Address -> MText+mformatAddress = unsafeMkMText . formatAddress++instance Buildable Address where+  build = build . formatAddress++-- | Errors that can happen during address parsing.+data ParseAddressError+  = ParseAddressWrongBase58Check+  -- ^ Address is not in Base58Check format.+  | ParseAddressBothFailed CryptoParseError ParseContractAddressError+  -- ^ Both address parsers failed with some error.+  deriving stock (Show, Eq, Generic)++instance NFData ParseAddressError++instance Buildable ParseAddressError where+  build = buildRenderDoc++instance RenderDoc ParseAddressError where+  renderDoc context =+    \case+      ParseAddressWrongBase58Check -> "Wrong base58check format"+      ParseAddressBothFailed pkErr contractErr ->+        mconcat+        [ "Address is neither `KeyAddress` "+        , parens $ renderDoc context pkErr+        , ", nor `ContractAddress` "+        , parens $ renderDoc context contractErr+        ]++-- | Parse an address from its human-readable textual representation+-- used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"). Or+-- fail if it's invalid.+parseAddress :: Text -> Either ParseAddressError Address+parseAddress addressText =+  case parseKeyHash addressText of+    Left CryptoParseWrongBase58Check -> Left ParseAddressWrongBase58Check+    Left keyAddrErr -> first (ParseAddressBothFailed keyAddrErr) $+      ContractAddress <$> parseContractHash addressText+    Right keyHash -> Right (KeyAddress keyHash)++data ParseAddressRawError+  = ParseAddressRawWrongSize ByteString+  -- ^ Raw bytes representation of an address has invalid length.+  | ParseAddressRawInvalidPrefix ByteString+  -- ^ Raw bytes representation of an address has incorrect prefix.+  | ParseAddressRawMalformedSeparator ByteString+  -- ^ Raw bytes representation of an address does not end with "\00".+  deriving stock (Eq, Show, Generic)++instance NFData ParseAddressRawError++instance RenderDoc ParseAddressRawError where+  renderDoc _ =+    \case+      ParseAddressRawInvalidPrefix prefix ->+        "Invalid prefix for raw address" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"+      ParseAddressRawWrongSize addr -> "Given raw address+" <+>+        (renderAnyBuildable $ hexF addr) <+> "has invalid length" <+> int (length addr)+      ParseAddressRawMalformedSeparator addr -> "Given raw address+" <+> (renderAnyBuildable $ hexF addr) <+>+        "does not end with" <+> dquotes (backslash <> "00")++instance Buildable ParseAddressRawError where+  build = buildRenderDoc++-- | Parse the given address in its raw byte form used by Tezos+-- (e.g "01521139f84791537d54575df0c74a8084cc68861c00")) . Or fail otherwise+-- if it's invalid.+parseAddressRaw :: ByteString -> Either ParseAddressRawError Address+parseAddressRaw (BS.splitAt 2 -> (prefix, address)) =+  case BS.take 1 prefix of+    "\00" -> parseKeyAddressRaw (BS.tail prefix) address+    "\01" -> parseContractAddressRaw prefix address+    _ -> Left $ ParseAddressRawInvalidPrefix prefix+  where+    parseKeyAddressRaw keyPrefix keyAddress+      | length keyAddress /= keyHashLengthBytes+          = Left $ ParseAddressRawWrongSize keyAddress+      | otherwise = do+        matchedPrefix <- case keyPrefix of+          "\00" -> Right KeyHashEd25519+          "\01" -> Right KeyHashSecp256k1+          "\02" -> Right KeyHashP256+          _ -> Left $ ParseAddressRawInvalidPrefix keyPrefix+        pure $ KeyAddress (KeyHash matchedPrefix keyAddress)++    parseContractAddressRaw contractPrefix contractAddress+      | length contractAddress /= contractHashLengthBytes+          = Left $ ParseAddressRawWrongSize contractAddress+      | BS.last contractAddress /= 0x00+          = Left $ ParseAddressRawMalformedSeparator contractAddress+      | otherwise = do+        let contractAddress' = BS.drop 1 contractPrefix <> BS.init contractAddress -- drop last "\00" of contract address+        pure $ ContractAddress (ContractHash contractAddress')++data ParseContractAddressError+  = ParseContractAddressWrongBase58Check+  | ParseContractAddressWrongSize ByteString+  | ParseContractAddressWrongPrefix ByteString+  deriving stock (Show, Eq, Generic)++instance NFData ParseContractAddressError++instance Buildable ParseContractAddressError where+  build = buildRenderDoc++instance RenderDoc ParseContractAddressError where+  renderDoc _ =+    \case+      ParseContractAddressWrongBase58Check ->+        "Wrong base58check format"+      ParseContractAddressWrongSize bs ->+        "Wrong size for a contract address:" <+> (renderAnyBuildable $ hexF bs) <+>+        (parens $ int (length bs))+      ParseContractAddressWrongPrefix prefix ->+        "Invalid prefix" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"++parseContractHash :: Text -> Either ParseContractAddressError ContractHash+parseContractHash text =+  case decodeBase58CheckWithPrefix contractAddressPrefix text of+    Left (B58CheckWithPrefixWrongPrefix prefix) ->+      Left (ParseContractAddressWrongPrefix prefix)+    Left B58CheckWithPrefixWrongEncoding ->+      Left ParseContractAddressWrongBase58Check+    Right bs | length bs == contractHashLengthBytes -> Right (ContractHash bs)+             | otherwise -> Left $ ParseContractAddressWrongSize bs++-- | QuasyQuoter for constructing Tezos addresses.+--+-- Validity of result will be checked at compile time.+ta :: TH.QuasiQuoter+ta = TH.QuasiQuoter+  { TH.quoteExp = \s ->+      case parseAddress . strip $ toText s of+        Left   err -> fail $ pretty err+        Right addr -> TH.lift addr+  , TH.quotePat = \_ ->+      fail "Cannot use this QuasyQuotation at pattern position"+  , TH.quoteType = \_ ->+      fail "Cannot use this QuasyQuotation at type position"+  , TH.quoteDec = \_ ->+      fail "Cannot use this QuasyQuotation at declaration position"+  }+++instance+    TypeError ('Text "There is no instance defined for (IsString Address)" ':$$:+               'Text "Consider using QuasiQuotes: `[ta|some text...|]`"+              ) =>+    IsString Address where+  fromString = error "impossible"+++----------------------------------------------------------------------------+-- Unsafe+----------------------------------------------------------------------------++-- | Parse a @KT1@ contract address, fail if address does not match+-- the expected format.+unsafeParseContractHash :: HasCallStack => Text -> ContractHash+unsafeParseContractHash = either (error . pretty) id . parseContractHash++-- | Partial version of 'parseAddress' which assumes that the address+-- is correct. Can be used in tests.+unsafeParseAddress :: HasCallStack => Text -> Address+unsafeParseAddress = either (error . pretty) id . parseAddress++-- | Partially parse raw bytes representation of an address and assume that+-- it is correct from the beginning. Can be used in tests.+unsafeParseAddressRaw :: ByteString -> Address+unsafeParseAddressRaw = either (error . pretty) id . parseAddressRaw++instance HasCLReader Address where+  getReader = eitherReader parseAddrDo+    where+      parseAddrDo addr =+        either (Left . mappend "Failed to parse address: " . pretty) Right $+        parseAddress $ toText addr+  getMetavar = "ADDRESS"++----------------------------------------------------------------------------+-- Aeson instances+----------------------------------------------------------------------------++instance ToJSON Address where+  toJSON = Aeson.String . formatAddress+  toEncoding = Aeson.text . formatAddress++instance ToJSONKey Address where+  toJSONKey = AesonTypes.toJSONKeyText formatAddress++instance FromJSON Address where+  parseJSON =+    Aeson.withText "Address" $+    either (fail . pretty) pure . parseAddress++instance FromJSONKey Address where+  fromJSONKey =+    AesonTypes.FromJSONKeyTextParser+      (either (fail . pretty) pure . parseAddress)

+ src/Morley/Tezos/Core.hs view

@@ -0,0 +1,384 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Core primitive Tezos types.++module Morley.Tezos.Core+  (+    -- * Mutez+    Mutez (..)+  , mkMutez+  , unsafeMkMutez+  , toMutez+  , addMutez+  , unsafeAddMutez+  , subMutez+  , unsafeSubMutez+  , mulMutez+  , unsafeMulMutez+  , divModMutez+  , divModMutezInt+  , zeroMutez+  , oneMutez+  , prettyTez++    -- * Timestamp+  , Timestamp (..)+  , timestampToSeconds+  , timestampFromSeconds+  , timestampFromUTCTime+  , timestampToUTCTime+  , timestampPlusSeconds+  , formatTimestamp+  , parseTimestamp+  , timestampQuote+  , getCurrentTime+  , farFuture+  , farPast++    -- * ChainId+  , ChainId (..)+  , mkChainId+  , unsafeMkChainId+  , dummyChainId+  , formatChainId+  , mformatChainId+  , parseChainId+  , chainIdLength+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..))+import qualified Data.Aeson as Aeson+import Data.Aeson.TH (deriveJSON)+import Data.Bits (Bits)+import Data.Data (Data(..))+import Data.Scientific+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Data.Time.Format (defaultTimeLocale, parseTimeM)+import Data.Time.LocalTime (utc, utcToZonedTime)+import Data.Time.RFC3339 (formatTimeRFC3339)+import Fmt (Buildable(build), fmt, hexF, pretty)+import qualified Language.Haskell.TH.Quote as TH+import Language.Haskell.TH.Syntax (liftData)+import qualified Options.Applicative as Opt++import Morley.Michelson.Text+import Morley.Tezos.Crypto+import Morley.Util.Aeson+import Morley.Util.CLI++----------------------------------------------------------------------------+-- Mutez+----------------------------------------------------------------------------++-- | Mutez is a wrapper over integer data type. 1 mutez is 1 token (μTz).+newtype Mutez = UnsafeMutez+  { unMutez :: Word64+  } deriving stock (Show, Eq, Ord, Data, Generic)+    deriving newtype Enum++instance Buildable Mutez where+  build (UnsafeMutez w) = build w <> " μꜩ"++instance Bounded Mutez where+  minBound = UnsafeMutez 0+  -- 2⁶³ - 1+  -- This value was checked against the reference implementation.+  maxBound = UnsafeMutez 9223372036854775807++instance HasCLReader Mutez where+  getReader = either (readerError . toString) pure . mkMutez @Word64 =<< Opt.auto+  getMetavar = "MUTEZ"++instance NFData Mutez++-- | Safely creates 'Mutez' checking for+-- overflow and underflow. Accepts a number of any type.+mkMutez :: (Integral i, Bits i) => i -> Either Text Mutez+mkMutez i = case fromIntegralMaybe i of+  Just n | n <= unMutez maxBound -> Right (UnsafeMutez n)+  _ | i < 0 -> Left "Mutez underflow"+  _ -> Left "Mutez overflow"++-- | Partial function for 'Mutez' creation, it's pre-condition is that+-- the argument must not exceed bounds of the 'Mutez'.+unsafeMkMutez :: HasCallStack => Word64 -> Mutez+unsafeMkMutez n =+  either (error . ("mkMutez: " <>)) id $ mkMutez n+{-# INLINE unsafeMkMutez #-}++-- | Safely create 'Mutez'.+--+-- This is recommended way to create @Mutez@ from a numeric literal;+-- you can't construct all valid @Mutez@ values using this function+-- but for small values it works neat.+--+-- Warnings displayed when trying to construct invalid 'Natural' or 'Word'+-- literal are hardcoded for these types in GHC implementation, so we can only+-- exploit these existing rules.+toMutez :: Word32 -> Mutez+toMutez = unsafeMkMutez . fromIntegral+{-# INLINE toMutez #-}++-- | Addition of 'Mutez' values. Returns 'Nothing' in case of overflow.+addMutez :: Mutez -> Mutez -> Maybe Mutez+addMutez (unMutez -> a) (unMutez -> b) =+  rightToMaybe $ mkMutez (a + b) -- (a + b) can't overflow if 'Mutez' values are valid+{-# INLINE addMutez #-}++-- | Partial addition of 'Mutez', should be used only if you're+-- sure there'll be no overflow.+unsafeAddMutez :: HasCallStack => Mutez -> Mutez -> Mutez+unsafeAddMutez = fromMaybe (error "unsafeAddMutez: overflow") ... addMutez++-- | Subtraction of 'Mutez' values. Returns 'Nothing' when the+-- subtrahend is greater than the minuend, and 'Just' otherwise.+subMutez :: Mutez -> Mutez -> Maybe Mutez+subMutez (unMutez -> a) (unMutez -> b)+  | a >= b = Just (UnsafeMutez (a - b))+  | otherwise = Nothing+{-# INLINE subMutez #-}++-- | Partial subtraction of 'Mutez', should be used only if you're+-- sure there'll be no underflow.+unsafeSubMutez :: HasCallStack => Mutez -> Mutez -> Mutez+unsafeSubMutez = fromMaybe (error "unsafeSubMutez: underflow") ... subMutez++-- | Multiplication of 'Mutez' and an integral number. Returns+-- 'Nothing' in case of overflow.+mulMutez :: Integral a => Mutez -> a -> Maybe Mutez+mulMutez (unMutez -> a) b+    | res <= toInteger (unMutez maxBound) = Just (UnsafeMutez (fromInteger res))+    | otherwise = Nothing+  where+    res = toInteger a * toInteger b+{-# INLINE mulMutez #-}++-- | Partial multiplication of 'Mutez' and an Natural number.+-- Should be used only if you're sure there'll be no overflow.+unsafeMulMutez :: Mutez -> Natural -> Mutez+unsafeMulMutez = fromMaybe (error "unsafeMulMutez: overflow") ... mulMutez++-- | Euclidian division of two 'Mutez' values.+divModMutez :: Mutez -> Mutez -> Maybe (Word64, Mutez)+divModMutez a (unMutez -> b) = first unMutez <$> divModMutezInt a b++-- | Euclidian division of  'Mutez' and a number.+divModMutezInt :: Integral a => Mutez -> a -> Maybe (Mutez, Mutez)+divModMutezInt (toInteger . unMutez -> a) (toInteger -> b)+  | b <= 0 = Nothing+  | otherwise = Just $ bimap toMutez' toMutez' (a `divMod` b)+  where+    toMutez' :: Integer -> Mutez+    toMutez' = UnsafeMutez . fromInteger++zeroMutez :: Mutez+zeroMutez = UnsafeMutez minBound++oneMutez :: Mutez+oneMutez = UnsafeMutez 1++-- |+-- >>> putTextLn $ prettyTez (toMutez 420)+-- 0.00042 ꜩ+--+-- >>> putTextLn $ prettyTez (toMutez 42000000)+-- 42 ꜩ+prettyTez :: Mutez -> Text+prettyTez ((/ 1000000) . fromIntegralToRealFrac . unMutez -> s) =+  case floatingOrInteger s of+    Left (_ :: Float)    -> toText $ formatScientific Fixed Nothing s+    Right (n :: Integer) -> pretty n+  <> " ꜩ"++----------------------------------------------------------------------------+-- Timestamp+----------------------------------------------------------------------------++-- | Time in the real world.+-- Use the functions below to convert it to/from Unix time in seconds.+newtype Timestamp = Timestamp+  { unTimestamp :: POSIXTime+  } deriving stock (Show, Eq, Ord, Data, Generic)++instance NFData Timestamp++timestampToSeconds :: Integral a => Timestamp -> a+timestampToSeconds = round . unTimestamp+{-# INLINE timestampToSeconds #-}++timestampFromSeconds :: Integer -> Timestamp+timestampFromSeconds = Timestamp . fromIntegralToRealFrac+{-# INLINE timestampFromSeconds #-}++timestampFromUTCTime :: UTCTime -> Timestamp+timestampFromUTCTime = Timestamp . utcTimeToPOSIXSeconds+{-# INLINE timestampFromUTCTime #-}++timestampToUTCTime :: Timestamp -> UTCTime+timestampToUTCTime = posixSecondsToUTCTime . unTimestamp+{-# INLINE timestampToUTCTime #-}++-- | Add given amount of seconds to a 'Timestamp'.+timestampPlusSeconds :: Timestamp -> Integer -> Timestamp+timestampPlusSeconds ts sec = timestampFromSeconds (timestampToSeconds ts + sec)++-- | Display timestamp in human-readable way as used by Michelson.+-- Uses UTC timezone, though maybe we should take it as an argument.+--+-- NB: this will render timestamp with up to seconds precision.+formatTimestamp :: Timestamp -> Text+formatTimestamp =+  formatTimeRFC3339 . utcToZonedTime utc . posixSecondsToUTCTime . unTimestamp++instance Buildable Timestamp where+  build = build . formatTimestamp++-- | Parse textual representation of 'Timestamp'.+parseTimestamp :: Text -> Maybe Timestamp+parseTimestamp t+  -- `parseTimeM` does not allow to match on a single whitespace exclusively+  | T.isInfixOf "  " t = Nothing+  | otherwise = fmap timestampFromUTCTime . asum $ map parse formatsRFC3339+  where+    parse :: Text -> Maybe UTCTime+    parse frmt = parseTimeM False defaultTimeLocale (toString frmt) (toString t)++    formatsRFC3339 :: [Text]+    formatsRFC3339 = do+      divider <- ["T", " "]+      fraction <- ["%Q", ""]+      zone <- ["Z", "%z"]+      return $ "%-Y-%m-%d" <> divider <> "%T" <> fraction <> zone++-- | Quote a value of type 'Timestamp' in @yyyy-mm-ddThh:mm:ss[.sss]Z@ format.+--+-- >>> formatTimestamp [timestampQuote| 2019-02-21T16:54:12.2344523Z |]+-- "2019-02-21T16:54:12Z"+--+-- Inspired by 'time-quote' library.+timestampQuote :: TH.QuasiQuoter+timestampQuote =+  TH.QuasiQuoter+  { quoteExp = \str ->+      case parseTimestamp . T.strip $ toText str of+        Nothing -> fail "Invalid timestamp, \+                        \example of valid value: `2019-02-21T16:54:12.2344523Z`"+        Just ts -> liftData ts+  , quotePat = \_ -> fail "timestampQuote: cannot quote pattern!"+  , quoteType = \_ -> fail "timestampQuote: cannot quote type!"+  , quoteDec = \_ -> fail "timestampQuote: cannot quote declaration!"+  }++-- | Return current time as 'Timestamp'.+getCurrentTime :: IO Timestamp+getCurrentTime = Timestamp <$> getPOSIXTime++-- | Timestamp which is always greater than result of 'getCurrentTime'.+farFuture :: Timestamp+farFuture = timestampFromSeconds 1e12  -- 33658-09-27T01:46:40Z++-- | Timestamp which is always less than result of 'getCurrentTime'.+farPast :: Timestamp+farPast = timestampFromSeconds 0++----------------------------------------------------------------------------+-- Chain ID+----------------------------------------------------------------------------++{- Chain id in Tezos sources:+* https://gitlab.com/tezos/tezos/blob/de5c80b360aa396114be92a3a2e2ff2087190a61/src/lib_crypto/chain_id.ml+-}++-- | Identifier of a network (babylonnet, mainnet, test network or other).+-- Evaluated as hash of the genesis block.+--+-- The only operation supported for this type is packing.+-- Use case: multisig contract, for instance, now includes chain ID into+-- signed data "in order to add extra replay protection between the main+-- chain and the test chain".+newtype ChainId = UnsafeChainId { unChainId :: ByteString }+  deriving stock (Show, Eq, Ord, Generic)++instance NFData ChainId++-- | Construct chain ID from raw bytes.+mkChainId :: ByteString -> Maybe ChainId+mkChainId bs =+  guard (length bs == chainIdLength) $> UnsafeChainId bs++-- | Construct chain ID from raw bytes or fail otherwise.+-- Expects exactly 4 bytes.+unsafeMkChainId :: HasCallStack => ByteString -> ChainId+unsafeMkChainId = fromMaybe (error "Bad chain id") . mkChainId++-- | Identifier of a pseudo network.+dummyChainId :: ChainId+dummyChainId = UnsafeChainId "\0\0\0\0"++-- | Pretty print 'ChainId' as it is displayed e.g. in+-- @tezos-client rpc get /chains/main/chain_id@ call.+--+-- Example of produced value: @NetXUdfLh6Gm88t@.+formatChainId :: ChainId -> Text+formatChainId (unChainId -> bs) = encodeBase58Check (chainIdPrefix <> bs)++mformatChainId :: ChainId -> MText+mformatChainId = unsafeMkMText . formatChainId++instance Buildable ChainId where+  build = build . formatChainId++data ParseChainIdError+  = ParseChainIdWrongBase58Check+  | ParseChainIdWrongTag ByteString+  | ParseChainIdWrongSize Int+  deriving stock (Show, Eq)++instance Buildable ParseChainIdError where+  build =+    \case+      ParseChainIdWrongBase58Check ->+        "Wrong base58check format"+      ParseChainIdWrongTag tag ->+        "Wrong tag for a chain id: " <> fmt (hexF tag)+      ParseChainIdWrongSize s ->+        "Wrong size for a chain id: " <> build s++instance Exception ParseChainIdError where+  displayException = pretty++parseChainId :: Text -> Either ParseChainIdError ChainId+parseChainId text =+  case decodeBase58CheckWithPrefix chainIdPrefix text of+    Left (B58CheckWithPrefixWrongPrefix prefix) ->+      Left (ParseChainIdWrongTag prefix)+    Left B58CheckWithPrefixWrongEncoding ->+      Left ParseChainIdWrongBase58Check+    Right bs -> case mkChainId bs of+      Just ci -> Right ci+      Nothing -> Left $ ParseChainIdWrongSize (length bs)++chainIdLength :: Int+chainIdLength = 4++-- | It's a magic constant used by Tezos to encode a chain ID.+-- Corresponds to "Net" part.+chainIdPrefix :: ByteString+chainIdPrefix = "\87\82\0"++----------------------------------------------------------------------------+-- JSON+----------------------------------------------------------------------------++deriveJSON morleyAesonOptions ''Mutez+deriveJSON morleyAesonOptions ''Timestamp++instance ToJSON ChainId where+  toJSON = Aeson.String . formatChainId+instance FromJSON ChainId where+  parseJSON = Aeson.withText "chain id" $+    either (fail . pretty) pure . parseChainId

+ src/Morley/Tezos/Crypto.hs view

@@ -0,0 +1,532 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Cryptographic primitives used in Tezos.+--+-- WARNING: some functions may be vulnerable to timing attacks.+-- Also, this code was not reviewed by cryptography/security experts.+-- Do not use it with secret keys that have some value.+-- We provide 'SecretKey' type and (limited) signing functionality only+-- for testing.+-- If you need to sign something in production, use something else+-- (e. g. `tezos-client`).+--+-- Tezos supports 3 cryptographic curves that are denoted by the+-- number after tz in the public key hash: tz1, tz2 or tz3.+-- • tz1 — ed25519+-- • tz2 — secp256k1+-- • tz3 — P256+-- We have Morley.Tezos.Crypto.Curve module for each of these curves.+-- They expose very similar functionality and their main purpose is to hide+-- implementation details for each curve as well as some other specifics (e. g.+-- prefixes that are used for human-readable representation).+--+-- This module serves two purposes:+-- 1. It is an umbrella module that re-exports some stuff from other modules.+-- 2. Michelson types such as @key@ and @signature@ may store primitive of any+-- curve, so we need "union" types in Haskell as well.+--+-- During conversion to human-readable representation usually some magical+-- prefix is used. They have been found in source code in some repos (e. g.+-- <https://gitlab.com/tezos/tezos/blob/c52ee69231c5ae4d9cec1f3c8aba0c3573922e2a/src/lib_crypto/base58.ml>)+-- and checked manually. Existing tests confirm they are correct.++{-# LANGUAGE DeriveLift #-}++module Morley.Tezos.Crypto+  ( -- * Cryptographic primitive types+    PublicKey (..)+  , SecretKey (..) -- Currently we need to differentiate secret keys in morley-client+  , Signature (..)+  , KeyHashTag (..)+  , KeyHash (..)+  , BLS12381.Bls12381Fr+  , BLS12381.Bls12381G1+  , BLS12381.Bls12381G2++  -- * Public/secret key functions+  , detSecretKey+  , toPublic++  -- * Signature+  , signatureToBytes+  , mkSignature+  , parseSignatureRaw+  , signatureLengthBytes+  , checkSignature+  , sign++  -- * Formatting+  , CryptoParseError (..)+  , formatPublicKey+  , mformatPublicKey+  , parsePublicKey+  , parsePublicKeyRaw+  , formatSignature+  , mformatSignature+  , parseSignature+  , formatKeyHash+  , mformatKeyHash+  , parseKeyHash+  , unsafeParseKeyHash+  , parseKeyHashRaw+  , keyHashLengthBytes+  , formatSecretKey+  , parseSecretKey++  -- * Hashing+  , hashKey+  , blake2b+  , blake2b160+  , keccak+  , sha256+  , sha3+  , sha512++  -- * Utilities+  , encodeBase58Check+  , decodeBase58Check+  , B58CheckWithPrefixError (..)+  , decodeBase58CheckWithPrefix+  , keyDecoders+  , keyHashDecoders+  ) where++import Crypto.Random (MonadRandom)+import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Aeson+import qualified Data.Aeson.Types as AesonTypes+import qualified Data.Binary.Get as Get+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Fmt (Buildable, build, hexF, pretty)+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax (Lift)++import Morley.Michelson.Text+import qualified Morley.Tezos.Crypto.BLS12381 as BLS12381+import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519+import Morley.Tezos.Crypto.Hash+import qualified Morley.Tezos.Crypto.P256 as P256+import qualified Morley.Tezos.Crypto.Secp256k1 as Secp256k1+import Morley.Tezos.Crypto.Util+import Morley.Util.Binary+import Morley.Util.CLI++----------------------------------------------------------------------------+-- Types, instances, conversions+----------------------------------------------------------------------------++-- | Public cryptographic key used by Tezos.+-- There are three cryptographic curves each represented by its own constructor.+data PublicKey+  = PublicKeyEd25519 Ed25519.PublicKey+  -- ^ Public key that uses the ed25519 cryptographic curve.+  | PublicKeySecp256k1 Secp256k1.PublicKey+  -- ^ Public key that uses the secp256k1 cryptographic curve.+  | PublicKeyP256 P256.PublicKey+  -- ^ Public key that uses the NIST P-256 cryptographic curve.+  deriving stock (Show, Eq, Ord, Generic)++instance NFData PublicKey++-- | Secret cryptographic key used by Tezos.+-- Constructors correspond to 'PublicKey' constructors.+data SecretKey+  = SecretKeyEd25519 Ed25519.SecretKey+  -- ^ Secret key that uses the ed25519 cryptographic curve.+  | SecretKeySecp256k1 Secp256k1.SecretKey+  -- ^ Secret key that uses the secp256k1 cryptographic curve.+  | SecretKeyP256 P256.SecretKey+  -- ^ Secret key that uses the NIST P-256 cryptographic curve.+  deriving stock (Show, Eq, Generic)++instance NFData SecretKey++instance HasCLReader SecretKey where+  getReader = eitherReader (first pretty . parseSecretKey . toText)+  getMetavar = "SECRET_KEY"++-- | Deterministicaly generate a secret key from seed.+-- Type of the key depends on seed length.+detSecretKey :: HasCallStack => ByteString -> SecretKey+detSecretKey seed = seed & case (length seed + 2) `mod` 3 of+  0 -> SecretKeyEd25519 . Ed25519.detSecretKey+  1 -> SecretKeySecp256k1 . Secp256k1.detSecretKey+  2 -> SecretKeyP256 . P256.detSecretKey+  _ -> error "detSecretKey: unexpected happened"++-- | Create a public key from a secret key.+toPublic :: SecretKey -> PublicKey+toPublic = \case+  SecretKeyEd25519 sk -> PublicKeyEd25519 . Ed25519.toPublic $ sk+  SecretKeySecp256k1 sk -> PublicKeySecp256k1 . Secp256k1.toPublic $ sk+  SecretKeyP256 sk -> PublicKeyP256 . P256.toPublic $ sk++-- | Cryptographic signatures used by Tezos.+-- Constructors correspond to 'PublicKey' constructors.+--+-- Tezos distinguishes signatures for different curves.+-- For instance, ed25519 signatures and secp256k1 signatures+-- are printed differently (have different prefix).+-- However, signatures are packed without information about the+-- curve. For this purpose there is a generic signature which+-- only stores bytes and doesn't carry information about the curve.+-- Apparently unpacking from bytes always produces such signature.+-- Unpacking from string produces a signature with curve information.+data Signature+  = SignatureEd25519 Ed25519.Signature+  -- ^ Signature that uses the ed25519 cryptographic curve.+  | SignatureSecp256k1 Secp256k1.Signature+  -- ^ Siganture that uses the secp256k1 cryptographic curve.+  | SignatureP256 P256.Signature+  -- ^ Signature that uses the NIST P-256 cryptographic curve.+  | SignatureGeneric ByteString+  -- ^ Generic signature for which curve is unknown.+  deriving stock (Show, Generic)++instance NFData Signature++-- This instance slightly differs from the default one. If one+-- signature is generic and the other one is not, they still may be+-- equal if they have the same byte representation.+-- With default instance packing a signature and unpacking it would produce+-- a different (with respect to 'Eq') signature which is inconvenient.+instance Eq Signature where+  sig1 == sig2 = case (sig1, sig2) of+    (SignatureGeneric bytes1, SignatureGeneric bytes2) -> bytes1 == bytes2+    (SignatureGeneric bytes1, SignatureEd25519 (Ed25519.signatureToBytes -> bytes2)) ->+      bytes1 == bytes2+    (SignatureGeneric bytes1, SignatureSecp256k1 (Secp256k1.signatureToBytes -> bytes2)) ->+      bytes1 == bytes2+    (SignatureGeneric bytes1, SignatureP256 (P256.signatureToBytes -> bytes2)) ->+      bytes1 == bytes2++    (_, SignatureGeneric {}) -> sig2 == sig1++    (SignatureEd25519 s1, SignatureEd25519 s2) -> s1 == s2+    (SignatureEd25519 {}, _) -> False++    (SignatureSecp256k1 s1, SignatureSecp256k1 s2) -> s1 == s2+    (SignatureSecp256k1 {}, _) -> False++    (SignatureP256 s1, SignatureP256 s2) -> s1 == s2+    (SignatureP256 {}, _) -> False++instance Ord Signature where+  compare = compare `on` (signatureToBytes :: Signature -> ByteString)++----------------------------------------------------------------------------+-- Signature+----------------------------------------------------------------------------++-- | Convert a 'Signature' to raw bytes.+signatureToBytes :: BA.ByteArray ba => Signature -> ba+signatureToBytes = \case+  SignatureEd25519 sig -> Ed25519.signatureToBytes sig+  SignatureSecp256k1 sig -> Secp256k1.signatureToBytes sig+  SignatureP256 sig -> P256.signatureToBytes sig+  SignatureGeneric bytes -> BA.convert bytes++-- | Make a 'Signature' from raw bytes.+-- Can return only generic signature.+mkSignature :: BA.ByteArray ba => ba -> Maybe Signature+mkSignature ba =+  SignatureGeneric (BA.convert ba) <$ guard (l == signatureLengthBytes)+  where+    l = BA.length ba++parseSignatureRaw :: ByteString -> Either ParseSignatureRawError Signature+parseSignatureRaw ba = maybeToRight (ParseSignatureRawWrongSize ba) $ mkSignature ba++data ParseSignatureRawError+  = ParseSignatureRawWrongSize ByteString+  deriving stock (Eq, Show, Generic)++instance Buildable ParseSignatureRawError where+  build =+    \case+      ParseSignatureRawWrongSize ba -> "Given raw signature " <>+        hexF ba <> " has invalid length " <> show (length ba)++-- Apparently Tezos relies on the fact that in all schemes signature+-- size is 64 bytes, so it also has generic signature and always reads+-- 64 bytes during unpack.+-- So we can have one 'signatureLengthBytes' and do not have to+-- distinguish between curves.+-- However, we still have such a check here just in case as a precaution.+signatureLengthBytes :: HasCallStack => Integral n => n+signatureLengthBytes+  | all is64+    [ Ed25519.signatureLengthBytes+    , P256.signatureLengthBytes+    , Secp256k1.signatureLengthBytes+    ] = 64+  | otherwise =+    error "Apparently our understanding of signatures in Tezos is broken"+  where+    is64 :: Int -> Bool+    is64 = (== 64)++genericSignatureTag :: ByteString+genericSignatureTag = "\004\130\043"++-- | Check that a sequence of bytes has been signed with a given key.+checkSignature :: PublicKey -> Signature -> ByteString -> Bool+checkSignature pk0 sig0 bytes =+  case (pk0, sig0) of+    (PublicKeyEd25519 pk, SignatureEd25519 sig) ->+      Ed25519.checkSignature pk sig bytes+    (PublicKeySecp256k1 pk, SignatureSecp256k1 sig) ->+      Secp256k1.checkSignature pk sig bytes+    (PublicKeyP256 pk, SignatureP256 sig) ->+      P256.checkSignature pk sig bytes+    (PublicKeyEd25519 pk, SignatureGeneric sBytes) ->+      case Ed25519.mkSignature sBytes of+        Right sig -> Ed25519.checkSignature pk sig bytes+        Left _ -> False+    (PublicKeySecp256k1 pk, SignatureGeneric sBytes) ->+      case Secp256k1.mkSignature sBytes of+        Right sig -> Secp256k1.checkSignature pk sig bytes+        Left _ -> False+    (PublicKeyP256 pk, SignatureGeneric sBytes) ->+      case P256.mkSignature sBytes of+        Right sig -> P256.checkSignature pk sig bytes+        Left _ -> False+    _ -> False++sign :: MonadRandom m => SecretKey -> ByteString -> m Signature+sign sk bs =+  case sk of+    SecretKeyEd25519 sk'   -> pure $ SignatureEd25519 $ Ed25519.sign sk' bs+    SecretKeySecp256k1 sk' -> SignatureSecp256k1 <$> Secp256k1.sign sk' bs+    SecretKeyP256 sk'      -> SignatureP256 <$> P256.sign sk' bs++----------------------------------------------------------------------------+-- Formatting+----------------------------------------------------------------------------++formatPublicKey :: PublicKey -> Text+formatPublicKey = \case+  PublicKeyEd25519 pk -> Ed25519.formatPublicKey pk+  PublicKeySecp256k1 pk -> Secp256k1.formatPublicKey pk+  PublicKeyP256 pk -> P256.formatPublicKey pk++mformatPublicKey :: PublicKey -> MText+mformatPublicKey = unsafeMkMText . formatPublicKey++instance Buildable PublicKey where+  build = build . formatPublicKey++parsePublicKey :: Text -> Either CryptoParseError PublicKey+parsePublicKey txt =+  firstRight $ map ($ txt)+    ( fmap PublicKeyEd25519 . Ed25519.parsePublicKey :|+    [ fmap PublicKeySecp256k1 . Secp256k1.parsePublicKey+    , fmap PublicKeyP256 . P256.parsePublicKey+    ])++parsePublicKeyRaw :: ByteString -> Either Text PublicKey+parsePublicKeyRaw ba =+  case Get.runGetOrFail (decodeWithTag "key" keyDecoders) (LBS.fromStrict ba) of+    Right (_, _, result) -> Right result+    Left (_, _, err) -> Left (toText err)++formatSignature :: Signature -> Text+formatSignature = \case+  SignatureEd25519 sig -> Ed25519.formatSignature sig+  SignatureSecp256k1 sig -> Secp256k1.formatSignature sig+  SignatureP256 sig -> P256.formatSignature sig+  SignatureGeneric sig -> formatImpl genericSignatureTag sig++mformatSignature :: Signature -> MText+mformatSignature = unsafeMkMText . formatSignature++instance Buildable Signature where+  build = build . formatSignature++parseSignature :: Text -> Either CryptoParseError Signature+parseSignature txt =+  firstRight $ map ($ txt)+    ( fmap SignatureEd25519 . Ed25519.parseSignature :|+    [ fmap SignatureSecp256k1 . Secp256k1.parseSignature+    , fmap SignatureP256 . P256.parseSignature+    , parseImpl genericSignatureTag (pure . SignatureGeneric)+    ])++formatSecretKey :: SecretKey -> Text+formatSecretKey key = "unencrypted:" <> case key of+  SecretKeyEd25519 sig -> Ed25519.formatSecretKey sig+  SecretKeySecp256k1 sig -> Secp256k1.formatSecretKey sig+  SecretKeyP256 sig -> P256.formatSecretKey sig++instance Buildable SecretKey where+  build = build . formatSecretKey++-- | Parse __unencrypted__ secret key. It accepts formats containing+-- either with or without the @unecrypted@ prefix.+parseSecretKey :: Text -> Either CryptoParseError SecretKey+parseSecretKey txt =+  firstRight $ map (\f -> f $ removePrefix txt)+    ( fmap SecretKeyEd25519 . Ed25519.parseSecretKey :|+    [ fmap SecretKeySecp256k1 . Secp256k1.parseSecretKey+    , fmap SecretKeyP256 . P256.parseSecretKey+    ])+  where+    removePrefix :: Text -> Text+    removePrefix input =+      let unencrypted = "unencrypted:"+          (prefix, payload) = T.splitAt (length unencrypted) input+      in case prefix == unencrypted of+        True -> payload+        False -> input++----------------------------------------------------------------------------+-- JSON encoding/decoding+----------------------------------------------------------------------------++-- If you ever need these instances for any particular 'PublicKey' or+-- 'Signature', you can define them in respective modules the same+-- way.++instance ToJSON PublicKey where+  toJSON = Aeson.String . formatPublicKey+  toEncoding = Aeson.text . formatPublicKey++instance FromJSON PublicKey where+  parseJSON =+    Aeson.withText "PublicKey" $+    either (fail . pretty) pure . parsePublicKey++instance ToJSON Signature where+  toJSON = Aeson.String . formatSignature+  toEncoding = Aeson.text . formatSignature++instance FromJSON Signature where+  parseJSON =+    Aeson.withText "Signature" $+    either (fail . pretty) pure . parseSignature++instance ToJSON KeyHash where+  toJSON = Aeson.String . formatKeyHash+  toEncoding = Aeson.text . formatKeyHash++instance ToJSONKey KeyHash where+  toJSONKey = AesonTypes.toJSONKeyText formatKeyHash++instance FromJSON KeyHash where+  parseJSON =+    Aeson.withText "KeyHash" $+    either (fail . pretty) pure . parseKeyHash++instance FromJSONKey KeyHash where+  fromJSONKey =+    AesonTypes.FromJSONKeyTextParser $+    either (fail . pretty) pure . parseKeyHash++----------------------------------------------------------------------------+-- KeyHash+----------------------------------------------------------------------------++-- | Which curve was used for the hashed public key inside 'KeyHash'.+data KeyHashTag+  = KeyHashEd25519+  | KeyHashSecp256k1+  | KeyHashP256+  deriving stock (Show, Eq, Ord, Bounded, Enum, Generic, Lift)++instance NFData KeyHashTag++-- | Blake2b_160 hash of a public key.+data KeyHash = KeyHash+  { khTag :: KeyHashTag+  -- ^ We store which curve was used because it affects formatting.+  , khBytes :: ByteString+  -- ^ Hash itself.+  } deriving stock (Show, Eq, Ord, Generic, Lift)++instance NFData KeyHash++-- | Length of key hash in bytes (only hash itself, no tags, checksums+-- or anything).+keyHashLengthBytes :: Integral n => n+keyHashLengthBytes = 20++-- | Compute the b58check of a public key hash.+hashKey :: PublicKey -> KeyHash+hashKey =+  \case+    PublicKeyEd25519 pk ->+      KeyHash KeyHashEd25519 (blake2b160 $ Ed25519.publicKeyToBytes pk)+    PublicKeySecp256k1 pk ->+      KeyHash KeyHashSecp256k1 (blake2b160 $ Secp256k1.publicKeyToBytes pk)+    PublicKeyP256 pk ->+      KeyHash KeyHashP256 (blake2b160 $ P256.publicKeyToBytes pk)++formatKeyHash :: KeyHash -> Text+formatKeyHash (KeyHash tag bytes) = formatImpl (keyHashTagBytes tag) bytes++mformatKeyHash :: KeyHash -> MText+mformatKeyHash = unsafeMkMText . formatKeyHash++instance Buildable KeyHash where+  build = build . formatKeyHash++parseKeyHash :: Text -> Either CryptoParseError KeyHash+parseKeyHash txt =+  let+    mkKeyHash tag bs =+      KeyHash tag bs <$+        unless (length bs == keyHashLengthBytes)+        (Left $ CryptoParseUnexpectedLength "KeyHash" (length bs))++    parse :: KeyHashTag -> Either CryptoParseError KeyHash+    parse tag = mkKeyHash tag =<< parseImpl (keyHashTagBytes tag) pure txt++  in firstRight $ map parse $ minBound :| [succ minBound ..]++unsafeParseKeyHash :: HasCallStack => Text -> KeyHash+unsafeParseKeyHash = either (error . pretty) id . parseKeyHash++parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash+parseKeyHashRaw ba =+  if (BS.length ba - 1 == keyHashLengthBytes) then+    case Get.runGetOrFail (decodeWithTag "key_hash" keyHashDecoders) (LBS.fromStrict ba) of+      Right (_, _, result) -> Right result+      Left (_, _, err) -> Left $ CryptoParseBinaryError (toText err)+  else+    Left $ CryptoParseUnexpectedLength "key_hash" (BS.length ba)++keyHashTagBytes :: KeyHashTag -> ByteString+keyHashTagBytes =+  \case+    KeyHashEd25519 -> "\006\161\159"+    KeyHashSecp256k1 -> "\006\161\161"+    KeyHashP256 -> "\006\161\164"++instance HasCLReader KeyHash where+  getReader = eitherReader (first pretty . parseKeyHash . toText)+  getMetavar = "KEY_HASH"++keyDecoders :: [TaggedDecoder PublicKey]+keyDecoders =+  [ 0x00 #: decodeBytesLike "key Ed25519"+      (fmap PublicKeyEd25519 . Ed25519.mkPublicKey)+  , 0x01 #: decodeBytesLike "key Secp256k1"+      (fmap PublicKeySecp256k1 . Secp256k1.mkPublicKey)+  , 0x02 #: decodeBytesLike "key P256"+      (fmap PublicKeyP256 . P256.mkPublicKey)+  ]++keyHashDecoders :: [TaggedDecoder KeyHash]+keyHashDecoders =+  [ 0x00 #: KeyHash KeyHashEd25519 <$> getPayload+  , 0x01 #: KeyHash KeyHashSecp256k1 <$> getPayload+  , 0x02 #: KeyHash KeyHashP256 <$> getPayload+  ]+  where+    getPayload = getByteStringCopy keyHashLengthBytes

+ src/Morley/Tezos/Crypto/BLS12381.hs view

@@ -0,0 +1,454 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Support for BLS12-381 elliptic curve.+--+-- Some general hints on the implementation can be found in this python+-- re-implementation used by Tezos for testing:+-- <https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3>.+-- And it uses this library inside: <https://github.com/ethereum/py_ecc/tree/master/py_ecc/optimized_bls12_381>.+module Morley.Tezos.Crypto.BLS12381+  ( Bls12381Fr+  , Bls12381G1+  , Bls12381G2+  , CurveObject (..)+  , unsafeFromMichelsonBytes+  , MultiplyPoint (..)+  , DeserializationError (..)+  , checkPairing++    -- * Playground+  , unsafeReadFromHex+  , generateFrom+  , g1One+  , g2One+  ) where++import Prelude hiding (negate, one)+import qualified Prelude++import Control.Exception (assert)+import Control.Lens (each, toListOf)+import Control.Monad.Random (MonadRandom, evalRand, getRandom, mkStdGen)+import Data.Bits (bit, complement, setBit, testBit, (.&.))+import qualified Data.ByteString as BS+import qualified Data.Curve as C+import qualified Data.Curve.Weierstrass as CW+import qualified Data.Curve.Weierstrass.BLS12381 as CW.BLS+import qualified Data.Field.Galois as GF+import qualified Data.Pairing.BLS12381 as BLS+import Fmt (Buildable(..), pretty)+import Morley.Util.Instances ()+import Morley.Util.Named+import Text.Hex (decodeHex, encodeHex)+import Text.PrettyPrint.Leijen.Text (int, integer, (<+>))+import qualified Unsafe (fromIntegral)++import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)++-- | Methods common for all BLS12-381 primitives.+class CurveObject a where+  -- | Representation of @0@, aka additive identity.+  zero :: a++  -- | Negate a value.+  negate :: a -> a++  -- | Add up two values.+  add :: a -> a -> a++  -- | Generate a random value.+  generate :: MonadRandom m => m a++  -- | Read a value from Michelson's bytes form.+  --+  -- Michelson tends to represent all BLS12-381 types in bytes form,+  -- some special types also allow other forms.+  fromMichelsonBytes :: ByteString -> Either DeserializationError a++  -- | Produce Michelson's bytes representation.+  toMichelsonBytes :: a -> ByteString++-- | Generate a random value from given seed.+generateFrom :: (CurveObject a) => Int -> a+generateFrom = evalRand generate . mkStdGen++-- | Read a value from Michelson's bytes form assuming that it is correct.+unsafeFromMichelsonBytes :: (CurveObject a, HasCallStack) => ByteString -> a+unsafeFromMichelsonBytes = either (error . pretty) id . fromMichelsonBytes++-- | Reads an object from hex string.+--+-- To be used only in playground and tests.+unsafeReadFromHex :: (CurveObject a, HasCallStack) => String -> a+unsafeReadFromHex hex =+  let bs = decodeHex (toText hex) ?: error "bad hex"+  in unsafeFromMichelsonBytes bs++-- | Multiplication operations on BLS12-381 objects.+class MultiplyPoint scalar point where+  -- | Multiply point value by scalar value.+  multiply :: scalar -> point -> point++-- | G1 point on the curve.+newtype Bls12381G1 = Bls12381G1 { unBls12381G1 :: BLS.G1' }+  deriving stock (Show, Eq)+  deriving newtype (NFData)++instance CurveObject Bls12381G1 where+  zero = Bls12381G1 C.id+  negate (Bls12381G1 v) = Bls12381G1 (C.inv v)+  add (Bls12381G1 a) (Bls12381G1 b) = Bls12381G1 (C.add a b)+  generate = Bls12381G1 <$> C.rnd+  fromMichelsonBytes =+    let bsToCoord = toPrime . fromBigEndian+    in fmap Bls12381G1 . parseJA2WAPoint g1CoordLen bsToCoord+  toMichelsonBytes =+    let coordToBs = toBigEndian g1CoordLen . fromPrime+    in convertWA2JAPoint g1CoordLen coordToBs . unBls12381G1++instance MultiplyPoint Integer Bls12381G1 where+  multiply s (Bls12381G1 p) = Bls12381G1 (C.mul' p s)++-- | G2 point on the curve.+newtype Bls12381G2 = Bls12381G2 { unBls12381G2 :: BLS.G2' }+  deriving stock (Show, Eq)+  deriving newtype (NFData)++instance CurveObject Bls12381G2 where+  zero = Bls12381G2 C.id+  negate (Bls12381G2 v) = Bls12381G2 (C.inv v)+  add (Bls12381G2 a) (Bls12381G2 b) = Bls12381G2 (C.add a b)+  generate = Bls12381G2 <$> C.rnd+  fromMichelsonBytes =+    let fromBsPair = map fromBigEndian . toListOf each . BS.splitAt (g2CoordLen `div` 2)+        bsToCoord = GF.toE . reverse . map toPrime . fromBsPair+    in fmap Bls12381G2 . parseJA2WAPoint g2CoordLen bsToCoord+  toMichelsonBytes =+    let toBsPair = foldMap (toBigEndian $ g2CoordLen `div` 2)+        coordToBs = toBsPair . map fromPrime . reverse . GF.fromE+    in convertWA2JAPoint g1CoordLen coordToBs . unBls12381G2++instance MultiplyPoint Integer Bls12381G2 where+  multiply s (Bls12381G2 p) = Bls12381G2 (C.mul' p s)++-- | An element of an algebraic number field (scalar), used for multiplying+-- 'Bls12381G1' and 'Bls12381G2'.+newtype Bls12381Fr = Bls12381Fr { unBls12381Fr :: BLS.Fr }+  deriving stock (Show, Eq, Ord)+  deriving newtype (Num, Enum, Bounded, Real, Integral, Fractional, NFData)++instance CurveObject Bls12381Fr where+  zero = Bls12381Fr 0+  negate = Prelude.negate+  add = (+)+  generate = Bls12381Fr <$> getRandom+  fromMichelsonBytes bs =+    if length bs > frLen+    then Left $ TooLargeLength ! #limit frLen ! #given (length bs)+    else+      let num = fromLittleEndian bs+      in fromIntegralNoOverflow num+           & first (\_ -> ValueOutsideOfField $ toInteger num)+  toMichelsonBytes = toLittleEndian frLen . fromPrime . unBls12381Fr++instance MultiplyPoint Bls12381Fr Bls12381G1 where+  multiply (Bls12381Fr s) (Bls12381G1 p) = Bls12381G1 (C.mul p s)++instance MultiplyPoint Bls12381Fr Bls12381G2 where+  multiply (Bls12381Fr s) (Bls12381G2 p) = Bls12381G2 (C.mul p s)++-- | Checks that product of pairings of points in the list is equal to 1 in+-- Fq12 field.+checkPairing :: [(Bls12381G1, Bls12381G2)] -> Bool+checkPairing pairs =+  -- Some hints for implementation of this function:+  -- https://gitlab.com/metastatedev/tezos/-/commit/bb2cda17d48a52ce854e027f0222a0463e0e66f0#af97cb649204420968454a94e7bfaa6a6e27195a_1285_1330+  -- https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3_0_172++  -- Monoid instance on GT' has the desired multiplicative semantics+  foldMap pairing pairs == mempty+  where+    pairing :: (Bls12381G1, Bls12381G2) -> BLS.GT'+    pairing (Bls12381G1 g1, Bls12381G2 g2) =+      BLS.finalExponentiationBLS12 BLS.parameterHex+        (BLS.millerAlgorithmBLS12 BLS.parameterBin g1 g2)++----------------------------------------------------------------------------+-- Serialization helpers+----------------------------------------------------------------------------++-- | All kinds of errors that can occur when reading a Michelson value.+data DeserializationError+  = CompressedFormIsNotSupported+  | UnexpectedLength ("expected" :! Int) ("given" :! Int)+  | TooLargeLength ("limit" :! Int) ("given" :! Int)+  | ValueOutsideOfField Integer+  | PointNotOnCurve ByteString+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)++instance Buildable DeserializationError where+  build = buildRenderDoc++instance RenderDoc DeserializationError where+  renderDoc _ = \case+    CompressedFormIsNotSupported ->+      "Compressed form of BLS12-381 point is not supported by Tezos"+    UnexpectedLength (N expected) (N given) ->+      "Unexpected length of BLS12-381 primitive: \+      \expected" <+> (int expected) <> ", but given" <+> (int given)+    TooLargeLength (N limit) (N given) ->+      "Too large length of BLS12-381 primitive: \+      \limit is" <+> (int limit) <+> ", but given" <+> (int given)+    ValueOutsideOfField v ->+      "Value is too large for the given field of values:" <+> (integer v)+    PointNotOnCurve bs ->+      "Point is not on curve: 0x" <> (renderAnyBuildable $ encodeHex bs)++{- Note on serialization:++In BLS12-381, "381" stands for the number of bits necessary to represent a+coordinate of a point on a curve, i.e. we have to use 48 bytes, getting 3 extra+bits. In the BLS12-381 library used by Tezos, those bits are exploited to carry+some meta information.++More info can be found here:+<https://github.com/zkcrypto/pairing/blob/307aa1f29dccaed09abe774d2027cad57fc5d0b4/src/bls12_381/README.md#serialization>.++So Fr is just a scalar (but a pretty big one), represented in little-endian+as said in the Michelson docs.++G1 and G2 represent a point on curve and have the following form:++      X coordinate         Y coordinate+ |!___________________|____________________|+   \  (big-endian)         (big-endian)+    \+     `- bits with meta info++Generally, various coordinate systems may be used to represent a point on curve,+and the library picked by Tezos uses Jacobian coordinates, probably assuming+that the third @Z@ coordinate is always @1@.+Note that we use 'Data.Pairing.BLS12381' which by default picks Weierstrass+coordinates (it has two, not three coordinates, and an "infinity point" which+is kept as a special case), but it also provides methods for converting between+different coordinate systems.++Coordinates take a different amount of space in G1 and G2:+* In G1 both X and Y are from a so-called "Fr" field, where numbers take+  48 bytes (without the leading 3 bits).+* In G2 both coordinates are from "Fr2" field which is a two-dimensional field+  over "Fr", i.e. X and Y themselves contain two 48-byte coordinates each.++Note that this is correct for the "uncompressed" form, and there is a different+"compressed" form that, fortunately, seems to be not supported by Michelson.+They initially planned to have @COMPRESS@ and @UNCOMPRESS@ instructions, perhaps+for manual conversions, but those instructions didn't appear in Edonet+eventually.++-}++-- | A helper datatype for representing points in raw bytes form.+data RawPoint+  = Infinity+    -- ^ Point at infinity.+  | RawPoint ByteString+    -- ^ Bytes representing the payload.++-- | Given the Michelson representation of a point, interpret flags+-- and return the bare payload.+--+-- This assumes that a proper number of bytes is provided.+parsePointFlags+  :: HasCallStack+  => ByteString -> Either DeserializationError RawPoint+parsePointFlags bsFull =+  case BS.uncons bsFull of+    Nothing -> error "Empty byte sequence"+    Just (b, bs)+      | b `testBit` compressionBit ->+          Left CompressedFormIsNotSupported+      | b `testBit` infinityBit ->+          return Infinity+      | otherwise -> do+          let+            b' = b .&. complement+              (sum $ map bit [compressionBit, infinityBit, flag3Bit])+          return $ RawPoint (BS.cons b' bs)++-- | Fill a point in raw bytes form with the necessary flags.+fillPointFlags :: HasCallStack => Int -> RawPoint -> ByteString+fillPointFlags 0 = error "Coordinates are unexpectedly empty"+fillPointFlags len = \case+  Infinity -> BS.cons (0 `setBit` infinityBit) (BS.replicate (len - 1) 0)+  RawPoint bs -> bs++-- | Get a bytestring containing coordinates of a point and split it,+-- checking that each coordinate occupies the given number of bytes.+splitUncompressedPoint+  :: Int -> ByteString -> Either DeserializationError (ByteString, ByteString)+splitUncompressedPoint coordLen bs+  | length bs /= coordLen * 2 =+      Left $ UnexpectedLength ! #expected (coordLen * 2) ! #given (length bs)+  | otherwise =+      Right $ BS.splitAt coordLen bs++-- | Parse a point in Weierstrass form and Affine coordinates,+-- assuming that in the provided bytestring the point is given in Jacobian+-- coordinates (the library used by Tezos operates in Jacobian coordinates).+parseJA2WAPoint+  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr+     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr+     )+  => Int+  -> (ByteString -> fq)+  -> ByteString+  -> Either DeserializationError (CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr)+parseJA2WAPoint coordLen toCoord full = do+  (xRawWithFlags, yRaw) <- splitUncompressedPoint coordLen full+  xRawPoint <- parsePointFlags xRawWithFlags+  case xRawPoint of+    Infinity -> return CW.O+    RawPoint xRaw ->+      let point = C.toA $ CW.J (toCoord xRaw) (toCoord yRaw) 1+      in if C.def point+         then return point+         else Left $ PointNotOnCurve full++-- | Turn a Weierstrass Affine point into Jacobian coordinates and represent+-- those as bytes.+convertWA2JAPoint+  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr+     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr+     )+  => Int+  -> (fq -> ByteString)+  -> CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr+  -> ByteString+convertWA2JAPoint coordLen toRawCoord point =+  let+    rawPoint = case point of+      CW.O -> Infinity+      p@CW.A{} -> RawPoint $+        let CW.J x y z = C.fromA p+           -- Conversion from Affine coordinates used to produce an already+           -- normalized value.+           -- In case this turns out to be incorrect, probably @x / z@ and @y / z@+           -- are just what we want.+        in assert (z == 1) $+            toRawCoord x <> toRawCoord y+  in fillPointFlags (coordLen * 2) rawPoint++-- | Interpret a byte sequence as a number in big-endian.+fromBigEndian :: ByteString -> Natural+fromBigEndian bs =+  foldl' (\acc byte -> acc * 0x100 + fromIntegral @Word8 @Natural byte) 0 $+  BS.unpack bs++-- | Interpret a byte sequence as a number in little-endian.+fromLittleEndian :: ByteString -> Natural+fromLittleEndian bs =+  sum . zipWith (*) (iterate (* 0x100) 1) . map (fromIntegral @Word8 @Natural) $+  BS.unpack bs++-- | Represent a number in a big-endian byte sequence, padding the output+-- to the expected length.+--+-- We assert that the length is sufficient for representing the given number.+toBigEndian :: Int -> Natural -> ByteString+toBigEndian len num =+  BS.pack $+  let+    (remainder, bytes) = mapAccumR+      (\x _ -> second (Unsafe.fromIntegral @Natural @Word8) $ x `divMod` 0x100)+      num [1 .. len]+  in assert (remainder == 0) bytes++-- | Represent a number in a little-endian byte sequence, padding the output+-- to the expected length.+--+-- We assert that the length is sufficient for representing the given number.+toLittleEndian :: Int -> Natural -> ByteString+toLittleEndian len num =+  BS.pack $+  let+    (remainder, bytes) = mapAccumL+      (\x _ -> second (Unsafe.fromIntegral @Natural @Word8) $ x `divMod` 0x100)+      num [1 .. len]+  in assert (remainder == 0) bytes++-- | Turn a prime field element into a natural.+fromPrime :: KnownNat p => GF.Prime p -> Natural+fromPrime p =+  -- This should be safe, since 'Prime's exist in modular arithmetics,+  -- so its conversion to an integer should produce non-negative elements.+  -- In fact, 'GF.Prime' is a newtype wrapper over 'Natural', but+  -- its constructor is not exported :/+  assert (p >= 0) $+    Unsafe.fromIntegral p++-- | The inverse to 'fromPrime'.+toPrime :: KnownNat p => Natural -> GF.Prime p+toPrime = fromIntegralOverflowing++-- Primitives' lengths+----------------------------------------------------------------------------++-- | Length of a single coordinate of a point in raw bytes form.+g1CoordLen, g2CoordLen :: Int+g1CoordLen = 48+g2CoordLen = 96  -- each coordinate is an element of two-dimensional field Fr2++-- | Length of 'Bls12381Fr' in raw bytes form.+frLen :: Int+frLen = 32++-- Meta bits+----------------------------------------------------------------------------++-- | This bit designates whether the point is represented in compressed form+-- (only X coordinate), or uncompressed form (both X and Y coordinates).+compressionBit :: Int+compressionBit = 7++-- | This bit designates whether the given point is at infinity.+--+-- If so, all other bytes should be zeros.+infinityBit :: Int+infinityBit = 6++-- | This bit is set iff "this point is in compressed form /and/ it is not the+-- point at infinity /and/ its y-coordinate is the lexicographically largest of+-- the two associated with the encoded x-coordinate".+--+-- Fortunatelly, this flag seems to be not relevant for us at the moment.+flag3Bit :: Int+flag3Bit = 5++----------------------------------------------------------------------------+-- Other constants+----------------------------------------------------------------------------++-- | @1@ represented in G1 - as the libraries used by Tezos see it.+--+-- Taken from here: <https://github.com/ethereum/py_ecc/blob/3f644b4c07c8270b8fbe989eb799766aca66face/py_ecc/optimized_bls12_381/optimized_curve.py#L34>.+g1One :: Bls12381G1+g1One = Bls12381G1 $ CW.toA $ CW.J+  3685416753713387016781088315183077757961620795782546409894578378688607592378376318836054947676345821548104185464507+  1339506544944476473020471379941921221584933875938349620426543736416511423956333506472724655353366534992391756441569+  1++-- | @1@ represented in G2.+g2One :: Bls12381G2+g2One = Bls12381G2 $ CW.toA $ CW.J+  (GF.toE+    [ 352701069587466618187139116011060144890029952792775240219908644239793785735715026873347600343865175952761926303160+    , 3059144344244213709971259814753781636986470325476647558659373206291635324768958432433509563104347017837885763365758+    ])+  (GF.toE+    [ 1985150602287291935568054521177171638300868978215655730859378665066344726373823718423869104263333984641494340347905+    , 927553665492332455747201965776037880757740193453592970025027978793976877002675564980949289727957565575433344219582+    ])+  (GF.toE [1, 0])

+ src/Morley/Tezos/Crypto/Ed25519.hs view

@@ -0,0 +1,180 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Ed25519 cryptographic primitives.++module Morley.Tezos.Crypto.Ed25519+  ( -- * Cryptographic primitive types+    PublicKey (..)+  , SecretKey+  , Signature (..)+  , detSecretKey+  , toPublic++  -- * Raw bytes (no checksums, tags or anything)+  , publicKeyToBytes+  , mkPublicKey+  , publicKeyLengthBytes+  , signatureToBytes+  , mkSignature+  , signatureLengthBytes++  -- * Formatting and parsing+  , formatPublicKey+  , mformatPublicKey+  , parsePublicKey+  , formatSecretKey+  , parseSecretKey+  , formatSignature+  , mformatSignature+  , parseSignature++  -- * Signing+  , sign+  , checkSignature+  ) where++import Crypto.Error (onCryptoFailure)+import qualified Crypto.PubKey.Ed25519 as Ed25519+import Data.ByteArray (ByteArray, ByteArrayAccess, convert)+import Fmt (Buildable, build)++import Morley.Michelson.Text+import Morley.Tezos.Crypto.Hash+import Morley.Tezos.Crypto.Util++----------------------------------------------------------------------------+-- Types, instances, conversions+----------------------------------------------------------------------------++-- | ED25519 public cryptographic key.+newtype PublicKey = PublicKey+  { unPublicKey :: Ed25519.PublicKey+  } deriving stock (Show, Eq, Generic)++instance NFData PublicKey++instance Ord PublicKey where+  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)++-- | ED25519 secret cryptographic key.+newtype SecretKey = SecretKey+  { unSecretKey :: Ed25519.SecretKey+  } deriving stock (Show, Eq, Generic)++instance NFData SecretKey++-- | Deterministicaly generate a secret key from seed.+detSecretKey :: ByteString -> SecretKey+detSecretKey seed = SecretKey $ deterministic seed Ed25519.generateSecretKey++-- | Create a public key from a secret key.+toPublic :: SecretKey -> PublicKey+toPublic = PublicKey . Ed25519.toPublic . unSecretKey++-- | ED25519 cryptographic signature.+newtype Signature = Signature+  { unSignature :: Ed25519.Signature+  } deriving stock (Show, Eq, Generic)++instance NFData Signature++----------------------------------------------------------------------------+-- Conversion to/from raw bytes (no checksums, tags or anything)+----------------------------------------------------------------------------++-- | Convert a 'PublicKey' to raw bytes.+publicKeyToBytes :: ByteArray ba => PublicKey -> ba+publicKeyToBytes = convert . unPublicKey++-- | Make a 'PublicKey' from raw bytes.+mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey+mkPublicKey =+  onCryptoFailure (Left . CryptoParseCryptoError) (Right . PublicKey) .+  Ed25519.publicKey++publicKeyLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n+publicKeyLengthBytes = fromIntegral Ed25519.publicKeySize++-- | Convert a 'Signature' to raw bytes.+signatureToBytes :: ByteArray ba => Signature -> ba+signatureToBytes = convert . unSignature++-- | Make a 'Signature' from raw bytes.+mkSignature :: ByteArrayAccess ba => ba -> Either CryptoParseError Signature+mkSignature =+  onCryptoFailure (Left . CryptoParseCryptoError) (Right . Signature) .+  Ed25519.signature++signatureLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n+signatureLengthBytes = fromIntegral Ed25519.signatureSize++mkSecretKey :: ByteArrayAccess ba => ba -> Either CryptoParseError SecretKey+mkSecretKey = onCryptoFailure (Left . CryptoParseCryptoError) (Right . SecretKey) .+  Ed25519.secretKey++----------------------------------------------------------------------------+-- Magic bytes+----------------------------------------------------------------------------++publicKeyTag :: ByteString+publicKeyTag = "\13\15\37\217"++secretKeyTag :: ByteString+secretKeyTag = "\13\15\58\7"++signatureTag :: ByteString+signatureTag = "\9\245\205\134\18"++----------------------------------------------------------------------------+-- Formatting+----------------------------------------------------------------------------++formatPublicKey :: PublicKey -> Text+formatPublicKey = formatImpl publicKeyTag . unPublicKey++mformatPublicKey :: PublicKey -> MText+mformatPublicKey = unsafeMkMText . formatPublicKey++instance Buildable PublicKey where+  build = build . formatPublicKey++parsePublicKey :: Text -> Either CryptoParseError PublicKey+parsePublicKey = parseImpl publicKeyTag mkPublicKey++formatSecretKey :: SecretKey -> Text+formatSecretKey = formatImpl secretKeyTag . unSecretKey++instance Buildable SecretKey where+  build = build . formatSecretKey++parseSecretKey :: Text -> Either CryptoParseError SecretKey+parseSecretKey = parseImpl secretKeyTag mkSecretKey++formatSignature :: Signature -> Text+formatSignature = formatImpl signatureTag . unSignature++mformatSignature :: Signature -> MText+mformatSignature = unsafeMkMText . formatSignature++instance Buildable Signature where+  build = build . formatSignature++parseSignature :: Text -> Either CryptoParseError Signature+parseSignature = parseImpl signatureTag mkSignature++----------------------------------------------------------------------------+-- Signing+----------------------------------------------------------------------------++-- | Sign a message using the secret key.+sign :: SecretKey -> ByteString -> Signature+sign sk =+  Signature .+  Ed25519.sign (unSecretKey sk) (unPublicKey (toPublic sk)) . blake2b++-- | Check that a sequence of bytes has been signed with a given key.+checkSignature :: PublicKey -> Signature -> ByteString -> Bool+checkSignature (PublicKey pk) (Signature sig) bytes =+  Ed25519.verify pk (blake2b bytes) sig

+ src/Morley/Tezos/Crypto/Hash.hs view

@@ -0,0 +1,51 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Cryptographic primitives related to hashing.++module Morley.Tezos.Crypto.Hash+  ( blake2b+  , blake2b160+  , keccak+  , sha256+  , sha3+  , sha512+  ) where++import Crypto.Hash (Blake2b_160, Blake2b_256, Digest, Keccak_256, SHA256, SHA3_256, SHA512, hash)+import qualified Data.ByteArray as ByteArray++-- | Compute a cryptographic hash of a bytestring using the+-- Blake2b_256 cryptographic hash function. It's used by the BLAKE2B+-- instruction in Michelson.+blake2b :: ByteString -> ByteString+blake2b = fromDigest @Blake2b_256 . hash++-- | Compute a cryptographic hash of a bytestring using the+-- Blake2b_160 cryptographic hash function.+blake2b160 :: ByteString -> ByteString+blake2b160 = fromDigest @Blake2b_160 . hash++-- | Compute a cryptographic hash of a bytestring using the+-- Sha256 cryptographic hash function.+sha256 :: ByteString -> ByteString+sha256 = fromDigest @SHA256 . hash++-- | Compute a cryptographic hash of a bytestring using the+-- Sha512 cryptographic hash function.+sha512 :: ByteString -> ByteString+sha512 = fromDigest @SHA512 . hash++-- | Compute a cryptographic hash of a bytestring using the Sha3_256+-- cryptographic hash function. It is used by the SHA3 Michelson instruction.+sha3 :: ByteString -> ByteString+sha3 = fromDigest @SHA3_256 . hash++-- | Compute a cryptographic hash of a bytestring using the Keccak_256+-- cryptographic hash function. It is used by the KECCAK Michelson instruction.+keccak :: ByteString -> ByteString+keccak = fromDigest @Keccak_256 . hash++fromDigest :: forall a. Digest a -> ByteString+fromDigest = ByteArray.convert

+ src/Morley/Tezos/Crypto/P256.hs view

@@ -0,0 +1,201 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | P256 cryptographic primitives.++module Morley.Tezos.Crypto.P256+  ( -- * Cryptographic primitive types+    PublicKey (..)+  , SecretKey+  , Signature (..)+  , detSecretKey+  , detSecretKeyDo+  , toPublic++  -- * Raw bytes (no checksums, tags or anything)+  , publicKeyToBytes+  , mkPublicKey+  , publicKeyLengthBytes+  , signatureToBytes+  , mkSignature+  , signatureLengthBytes++  -- * Formatting and parsing+  , formatPublicKey+  , mformatPublicKey+  , parsePublicKey+  , formatSignature+  , mformatSignature+  , parseSignature+  , formatSecretKey+  , parseSecretKey++  -- * Signing+  , sign+  , checkSignature+  ) where++import Crypto.Hash (Blake2b_256(..))+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Generate as ECC.Generate+import Crypto.PubKey.ECC.Types (Curve(..), CurveName(..), getCurveByName)+import Crypto.Random (MonadRandom)+import Data.ByteArray (ByteArray, ByteArrayAccess)+import Fmt (Buildable, build)++import Morley.Michelson.Text+import Morley.Tezos.Crypto.Util++curve :: Curve+curve = getCurveByName SEC_p256r1++----------------------------------------------------------------------------+-- Types, instances, conversions+----------------------------------------------------------------------------++-- | P256 public cryptographic key.+newtype PublicKey = PublicKey+  { unPublicKey :: ECDSA.PublicKey+  } deriving stock (Eq, Show, Generic)++instance NFData PublicKey where+  rnf (PublicKey (ECDSA.PublicKey cu q))+    = rnfCurve cu `seq` rnf q++instance Ord PublicKey where+  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)++-- | P256 secret cryptographic key.+newtype SecretKey = SecretKey+  { unSecretKey :: ECDSA.KeyPair+  } deriving stock (Show, Eq, Generic)++instance NFData SecretKey where+  rnf (SecretKey (ECDSA.KeyPair cu pp pn)) =+    rnfCurve cu `seq` rnf (pp, pn)++-- | Deterministicaly generate a secret key from seed.+detSecretKey :: ByteString -> SecretKey+detSecretKey seed = deterministic seed $ detSecretKeyDo++detSecretKeyDo :: MonadRandom m => m SecretKey+detSecretKeyDo = SecretKey <$> do+  (publicKey, privateKey) <- ECC.Generate.generate curve+  return $+    ECDSA.KeyPair curve (ECDSA.public_q publicKey) (ECDSA.private_d privateKey)++-- | Create a public key from a secret key.+toPublic :: SecretKey -> PublicKey+toPublic =+  PublicKey .+  ECDSA.PublicKey curve . (\(ECDSA.KeyPair _ pp _) -> pp) . unSecretKey++-- | P256 cryptographic signature.+newtype Signature = Signature+  { unSignature :: ECDSA.Signature+  } deriving stock (Show, Eq, Generic)++instance NFData Signature where+  rnf (Signature (ECDSA.Signature a b)) = rnf a `seq` rnf b++----------------------------------------------------------------------------+-- Conversion to/from raw bytes (no checksums, tags or anything)+----------------------------------------------------------------------------++-- | Convert a 'PublicKey' to raw bytes.+publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba+publicKeyToBytes (PublicKey p) =+  publicKeyToBytes_ curve p++-- | Make a 'PublicKey' from raw bytes.+mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey+mkPublicKey ba = PublicKey <$> mkPublicKey_ curve ba++publicKeyLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n+publicKeyLengthBytes = publicKeyLengthBytes_ curve++-- | Convert a 'PublicKey' to raw bytes.+signatureToBytes :: ByteArray ba => Signature -> ba+signatureToBytes (Signature sig) =+  signatureToBytes_ curve sig++-- | Make a 'Signature' from raw bytes.+mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature+mkSignature ba = Signature <$> mkSignature_ curve ba++signatureLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n+signatureLengthBytes = signatureLengthBytes_ curve++mkSecretKey :: ByteArray ba => ba -> Either CryptoParseError SecretKey+mkSecretKey = Right . SecretKey . mkSecretKey_ curve++-- | Convert a 'PublicKey' to raw bytes.+secretKeyToBytes :: ByteArray ba => SecretKey -> ba+secretKeyToBytes (SecretKey kp) =+  secretKeyToBytes_ kp++----------------------------------------------------------------------------+-- Magic bytes+----------------------------------------------------------------------------++publicKeyTag :: ByteString+publicKeyTag = "\003\178\139\127"++-- | Base16 format is @1051eebd@+secretKeyTag :: ByteString+secretKeyTag = "\016\081\238\189"++signatureTag :: ByteString+signatureTag = "\054\240\044\052"++----------------------------------------------------------------------------+-- Formatting+----------------------------------------------------------------------------++formatPublicKey :: PublicKey -> Text+formatPublicKey = formatImpl @ByteString publicKeyTag . publicKeyToBytes++mformatPublicKey :: PublicKey -> MText+mformatPublicKey = unsafeMkMText . formatPublicKey++instance Buildable PublicKey where+  build = build . formatPublicKey++parsePublicKey :: Text -> Either CryptoParseError PublicKey+parsePublicKey = parseImpl publicKeyTag mkPublicKey++formatSignature :: Signature -> Text+formatSignature = formatImpl @ByteString signatureTag . signatureToBytes++mformatSignature :: Signature -> MText+mformatSignature = unsafeMkMText . formatSignature++instance Buildable Signature where+  build = build . formatSignature++parseSignature :: Text -> Either CryptoParseError Signature+parseSignature = parseImpl signatureTag mkSignature++formatSecretKey :: SecretKey -> Text+formatSecretKey = formatImpl @ByteString secretKeyTag . secretKeyToBytes++instance Buildable SecretKey where+  build = build . formatSecretKey++parseSecretKey :: Text -> Either CryptoParseError SecretKey+parseSecretKey = parseImpl secretKeyTag mkSecretKey++----------------------------------------------------------------------------+-- Signing+----------------------------------------------------------------------------++-- | Sign a message using the secret key.+sign :: MonadRandom m => SecretKey -> ByteString -> m Signature+sign (SecretKey keyPair) =+  fmap Signature . ECDSA.sign (ECDSA.toPrivateKey keyPair) Blake2b_256++-- | Check that a sequence of bytes has been signed with a given key.+checkSignature :: PublicKey -> Signature -> ByteString -> Bool+checkSignature (PublicKey pk) (Signature sig) =+  ECDSA.verify Blake2b_256 pk sig

+ src/Morley/Tezos/Crypto/Secp256k1.hs view

@@ -0,0 +1,201 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Secp256k1 cryptographic primitives.++module Morley.Tezos.Crypto.Secp256k1+  ( -- * Cryptographic primitive types+    PublicKey (..)+  , SecretKey+  , Signature (..)+  , detSecretKey+  , detSecretKeyDo+  , toPublic++  -- * Raw bytes (no checksums, tags or anything)+  , publicKeyToBytes+  , mkPublicKey+  , publicKeyLengthBytes+  , signatureToBytes+  , mkSignature+  , signatureLengthBytes++  -- * Formatting and parsing+  , formatPublicKey+  , mformatPublicKey+  , parsePublicKey+  , formatSignature+  , mformatSignature+  , parseSignature+  , formatSecretKey+  , parseSecretKey++  -- * Signing+  , sign+  , checkSignature+  ) where++import Crypto.Hash (Blake2b_256(..))+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Generate as ECC.Generate+import Crypto.PubKey.ECC.Types (Curve(..), CurveName(..), getCurveByName)+import Crypto.Random (MonadRandom)+import Data.ByteArray (ByteArray, ByteArrayAccess)+import Fmt (Buildable, build)++import Morley.Michelson.Text+import Morley.Tezos.Crypto.Util++curve :: Curve+curve = getCurveByName SEC_p256k1++----------------------------------------------------------------------------+-- Types, instances, conversions+----------------------------------------------------------------------------++-- | Secp256k1 public cryptographic key.+newtype PublicKey = PublicKey+  { unPublicKey :: ECDSA.PublicKey+  } deriving stock (Eq, Show, Generic)++instance NFData PublicKey where+  rnf (PublicKey (ECDSA.PublicKey cu q))+    = rnfCurve cu `seq` rnf q++instance Ord PublicKey where+  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)++-- | Secp256k1 secret cryptographic key.+newtype SecretKey = SecretKey+  { unSecretKey :: ECDSA.KeyPair+  } deriving stock (Show, Eq, Generic)++instance NFData SecretKey where+  rnf (SecretKey (ECDSA.KeyPair cu pp pn)) =+    rnfCurve cu `seq` rnf (pp, pn)++-- | Deterministicaly generate a secret key from seed.+detSecretKey :: ByteString -> SecretKey+detSecretKey seed = deterministic seed $ detSecretKeyDo++detSecretKeyDo :: MonadRandom m => m SecretKey+detSecretKeyDo = SecretKey <$> do+  (publicKey, privateKey) <- ECC.Generate.generate curve+  return $+    ECDSA.KeyPair curve (ECDSA.public_q publicKey) (ECDSA.private_d privateKey)++-- | Create a public key from a secret key.+toPublic :: SecretKey -> PublicKey+toPublic =+  PublicKey .+  ECDSA.PublicKey curve . (\(ECDSA.KeyPair _ pp _) -> pp) . unSecretKey++-- | Secp256k1 cryptographic signature.+newtype Signature = Signature+  { unSignature :: ECDSA.Signature+  } deriving stock (Show, Eq, Generic)++instance NFData Signature where+  rnf (Signature (ECDSA.Signature a b)) = rnf a `seq` rnf b++----------------------------------------------------------------------------+-- Conversion to/from raw bytes (no checksums, tags or anything)+----------------------------------------------------------------------------++-- | Convert a 'PublicKey' to raw bytes.+publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba+publicKeyToBytes (PublicKey p) =+  publicKeyToBytes_ curve p++-- | Make a 'PublicKey' from raw bytes.+mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey+mkPublicKey ba = PublicKey <$> mkPublicKey_ curve ba++publicKeyLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n+publicKeyLengthBytes = publicKeyLengthBytes_ curve++-- | Convert a 'PublicKey' to raw bytes.+signatureToBytes :: ByteArray ba => Signature -> ba+signatureToBytes (Signature sig) =+  signatureToBytes_ curve sig++-- | Make a 'Signature' from raw bytes.+mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature+mkSignature ba = Signature <$> mkSignature_ curve ba++signatureLengthBytes :: (Integral n, IsIntSubType Int n ~ 'True) => n+signatureLengthBytes = signatureLengthBytes_ curve++mkSecretKey :: ByteArray ba => ba -> Either CryptoParseError SecretKey+mkSecretKey = Right . SecretKey . mkSecretKey_ curve++-- | Convert a 'PublicKey' to raw bytes.+secretKeyToBytes :: ByteArray ba => SecretKey -> ba+secretKeyToBytes (SecretKey kp) =+  secretKeyToBytes_ kp++----------------------------------------------------------------------------+-- Magic bytes+----------------------------------------------------------------------------++publicKeyTag :: ByteString+publicKeyTag = "\003\254\226\086"++-- | Base16 format is @11a2e0c9@+secretKeyTag :: ByteString+secretKeyTag = "\017\162\224\201"++signatureTag :: ByteString+signatureTag = "\013\115\101\019\063"++----------------------------------------------------------------------------+-- Formatting+----------------------------------------------------------------------------++formatPublicKey :: PublicKey -> Text+formatPublicKey = formatImpl @ByteString publicKeyTag . publicKeyToBytes++mformatPublicKey :: PublicKey -> MText+mformatPublicKey = unsafeMkMText . formatPublicKey++instance Buildable PublicKey where+  build = build . formatPublicKey++parsePublicKey :: Text -> Either CryptoParseError PublicKey+parsePublicKey = parseImpl publicKeyTag mkPublicKey++formatSignature :: Signature -> Text+formatSignature = formatImpl @ByteString signatureTag . signatureToBytes++mformatSignature :: Signature -> MText+mformatSignature = unsafeMkMText . formatSignature++instance Buildable Signature where+  build = build . formatSignature++parseSignature :: Text -> Either CryptoParseError Signature+parseSignature = parseImpl signatureTag mkSignature++formatSecretKey :: SecretKey -> Text+formatSecretKey = formatImpl @ByteString secretKeyTag . secretKeyToBytes++instance Buildable SecretKey where+  build = build . formatSecretKey++parseSecretKey :: Text -> Either CryptoParseError SecretKey+parseSecretKey = parseImpl secretKeyTag mkSecretKey++----------------------------------------------------------------------------+-- Signing+----------------------------------------------------------------------------++-- | Sign a message using the secret key.+sign :: MonadRandom m => SecretKey -> ByteString -> m Signature+sign (SecretKey keyPair) =+  fmap Signature . ECDSA.sign (ECDSA.toPrivateKey keyPair) Blake2b_256++-- | Check that a sequence of bytes has been signed with a given key.+checkSignature :: PublicKey -> Signature -> ByteString -> Bool+checkSignature (PublicKey pk) (Signature sig) =+  ECDSA.verify Blake2b_256 pk sig

+ src/Morley/Tezos/Crypto/Util.hs view

@@ -0,0 +1,256 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities shared by multiple cryptographic primitives.++module Morley.Tezos.Crypto.Util+  ( CryptoParseError (..)+  , encodeBase58Check+  , decodeBase58Check+  , B58CheckWithPrefixError (..)+  , decodeBase58CheckWithPrefix+  , formatImpl+  , parseImpl+  , firstRight+  , deterministic++  -- * ECDSA Utils+  , rnfCurve+  , publicKeyLengthBytes_+  , mkSignature_+  , mkSecretKey_+  , secretKeyToBytes_+  , signatureToBytes_+  , mkPublicKey_+  , publicKeyToBytes_+  , signatureLengthBytes_+  ) where++import Crypto.Error (CryptoError)+import Crypto.Number.ModArithmetic (squareRoot)+import Crypto.Number.Serialize (i2ospOf_, os2ip)+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Generate as ECC.Generate+import Crypto.PubKey.ECC.Types+  (Curve(..), CurveCommon(..), CurvePrime(..), Point(..), curveSizeBits)+import Crypto.Random (ChaChaDRG, MonadPseudoRandom, drgNewSeed, seedFromInteger, withDRG)+import qualified Data.Binary.Get as Get+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base58 as Base58+import qualified Data.ByteString.Lazy as LBS+import Fmt (Buildable, Builder, build, hexF)+import Text.PrettyPrint.Leijen.Text (int, textStrict, (<+>))++import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended, renderAnyBuildable)+import Morley.Tezos.Crypto.Hash+import Morley.Util.Binary (getRemainingByteStringCopy)+++-- | Error that can happen during parsing of cryptographic primitive types.+data CryptoParseError+  = CryptoParseWrongBase58Check+  | CryptoParseWrongTag ByteString+  | CryptoParseCryptoError CryptoError+  | CryptoParseUnexpectedLength Builder Int+  | CryptoParseBinaryError Text+  deriving stock (Show, Eq)++instance NFData CryptoParseError where+  rnf = rnf @String . show++instance Buildable CryptoParseError where+  build = buildRenderDocExtended++instance RenderDoc CryptoParseError where+  renderDoc _ = \case+    CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"+    CryptoParseWrongTag tag -> "Prefix is wrong tag:" <+> (renderAnyBuildable $ hexF tag)+    CryptoParseCryptoError err ->+      "Cryptographic library reported an error: " <>+        (renderAnyBuildable $ (displayException err))+    CryptoParseUnexpectedLength what l ->+      "Unexpected length of" <+> renderAnyBuildable what <> ":" <+> int l+    CryptoParseBinaryError err -> textStrict err++++-- | Encode a bytestring in Base58Check format.+encodeBase58Check :: ByteString -> Text+encodeBase58Check =+  decodeUtf8 . Base58.encodeBase58 Base58.bitcoinAlphabet . withCheckSum+  where+    withCheckSum :: ByteString -> ByteString+    withCheckSum bs = bs <> checkSum bs++-- | Decode a bytestring from Base58Check format.+decodeBase58Check :: Text -> Maybe ByteString+decodeBase58Check base58text = do+  bytes <- Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 base58text)+  let (payload, chk) = BS.splitAt (length bytes - 4) bytes+  guard $ chk == checkSum payload+  return payload++checkSum :: ByteString -> ByteString+checkSum = BS.take 4 . (sha256 . sha256)++data B58CheckWithPrefixError+  = B58CheckWithPrefixWrongPrefix ByteString+  | B58CheckWithPrefixWrongEncoding+  deriving stock (Show)++-- | Parse a base58check encoded value expecting some prefix. If the+-- actual prefix matches the expected one, it's stripped of and the+-- resulting payload is returned.+decodeBase58CheckWithPrefix ::+  ByteString -> Text -> Either B58CheckWithPrefixError ByteString+decodeBase58CheckWithPrefix prefix base58text =+  case decodeBase58Check base58text of+    Nothing -> Left B58CheckWithPrefixWrongEncoding+    Just bs ->+      let (actualPrefix, payload) = BS.splitAt (length prefix) bs+       in if actualPrefix == prefix+          then Right payload+          else Left (B58CheckWithPrefixWrongPrefix actualPrefix)++-- | Template for 'format*' functions.+formatImpl :: BA.ByteArrayAccess x => ByteString -> x -> Text+formatImpl tag = encodeBase58Check . mappend tag . BA.convert++-- | Template for 'parse*' functions.+parseImpl+  :: ByteString+  -> (ByteString -> Either CryptoParseError res)+  -> Text+  -> Either CryptoParseError res+parseImpl expectedTag constructor textToParse = do+  let convertErr :: B58CheckWithPrefixError -> CryptoParseError+      convertErr =+        \case B58CheckWithPrefixWrongPrefix prefix -> CryptoParseWrongTag prefix+              B58CheckWithPrefixWrongEncoding -> CryptoParseWrongBase58Check+  payload <- first convertErr $ decodeBase58CheckWithPrefix expectedTag textToParse+  constructor payload++-- | Returns first encountered 'Right' in a list. If there are none,+-- returns arbitrary 'Left'.+-- It is useful to implement parsing.+firstRight :: NonEmpty (Either e a) -> Either e a+firstRight (h :| rest) =+  case h of+    Left e -> maybe (Left e) firstRight $ nonEmpty rest+    Right a -> Right a++-- | Do randomized action using specified seed.+deterministic :: ByteString -> MonadPseudoRandom ChaChaDRG a -> a+deterministic seed = fst . withDRG chachaSeed+  where+    chachaSeed = drgNewSeed . seedFromInteger . os2ip $ seed++---------------------------------------------------------+-- Utilities shared by @Secp256k1@ and @P256@.+---------------------------------------------------------++rnfCurve :: Curve -> ()+rnfCurve cu =+  case cu of+    CurveF2m c -> rnf c+    CurveFP (CurvePrime i (CurveCommon a b c d e)) ->+      rnf (i, a, b, c, d, e)++curveSizeBytes :: Curve -> Int+curveSizeBytes curve = curveSizeBits curve `div` 8++signatureLengthBytes_ :: (Integral n, IsIntSubType Int n ~ 'True) => Curve -> n+signatureLengthBytes_ curve = fromIntegral $ 2 * (curveSizeBytes curve)++coordToBytes :: BA.ByteArray ba => Curve -> Integer -> ba+coordToBytes curve = i2ospOf_ (curveSizeBytes curve)++publicKeyLengthBytes_ :: (Integral n, IsIntSubType Int n ~ 'True) => Curve -> n+publicKeyLengthBytes_ curve = fromIntegral $ 1 + (curveSizeBytes curve)++-- | Make a 'ECDSA.PublicKey' from raw bytes.+--+-- Raw bytes are in the format of Compressed SEC Format. Refer to this article on how this is parsed:+-- <https://www.oreilly.com/library/view/programming-bitcoin/9781492031482/ch04.html>+--+mkPublicKey_ :: BA.ByteArrayAccess ba => Curve -> ba -> Either CryptoParseError ECDSA.PublicKey+mkPublicKey_ curve ba+  | l == (publicKeyLengthBytes_ curve) = do+      (isYEven, x) <- toCryptoEither $ Get.runGetOrFail getX+          (LBS.fromStrict $ BA.convert ba)+      (p, a, b) <- fromCurveFP curve+      let alpha = x ^ (3 :: Integer) + a * x + b+      beta <- squareRoot p alpha+                & maybeToRight (CryptoParseBinaryError "Could not find square root.")+      let (evenBeta, oddBeta) =+            if even beta then+              (beta, p - beta)+            else+              (p - beta, beta)+      let y = if isYEven then evenBeta+                         else oddBeta+      pure $ ECDSA.PublicKey curve $ Point x y+  | otherwise =+    Left $ CryptoParseUnexpectedLength "public key" l+  where+    l = BA.length ba++    getX :: Get.Get (Bool, Integer)+    getX = do+      yPrefix <- Get.getWord8+      xBytes <- getRemainingByteStringCopy+      return (even yPrefix, os2ip xBytes)++    fromCurveFP :: Curve -> Either CryptoParseError (Integer, Integer, Integer)+    fromCurveFP = \case+      CurveFP (CurvePrime p (CurveCommon a b _ _ _)) -> Right (p, a, b)+      CurveF2m _ -> Left $ CryptoParseBinaryError+        "Should not happen. Expect `curve` to be `CurveFP` but got `CurveF2m` instead."++    toCryptoEither :: Either (_a, _b, String) (_c, _d, a) -> Either CryptoParseError a+    toCryptoEither g =+      case g of+        Right (_, _, a) -> Right a+        Left (_, _, err) -> Left $ CryptoParseBinaryError $ toText err++-- | Convert a 'ECDSA.PublicKey' to raw bytes.+publicKeyToBytes_ :: forall ba. (BA.ByteArray ba, HasCallStack) => Curve -> ECDSA.PublicKey -> ba+publicKeyToBytes_ curve (ECDSA.PublicKey _ publicPoint) =+  case publicPoint of+    Point x y -> prefix y `BA.append` coordToBytes curve x+    PointO -> error "PublicKey somehow contains infinity point"+  where+    prefix :: Integer -> ba+    prefix y+      | odd y = BA.singleton 0x03+      | otherwise = BA.singleton 0x02++-- | Convert a 'ECDSA.PublicKey' to raw bytes.+signatureToBytes_ :: BA.ByteArray ba => Curve -> ECDSA.Signature -> ba+signatureToBytes_ curve (ECDSA.Signature r s) =+  coordToBytes curve r <> coordToBytes curve s++-- | Convert a 'ECDSA.PublicKey' to raw bytes.+secretKeyToBytes_ :: BA.ByteArray ba => ECDSA.KeyPair -> ba+secretKeyToBytes_ (ECDSA.KeyPair c _ s) =+  coordToBytes c s++-- | Make a 'ECDSA.Signature' from raw bytes.+mkSignature_ :: BA.ByteArray ba => Curve -> ba -> Either CryptoParseError ECDSA.Signature+mkSignature_ curve ba+  | l == (signatureLengthBytes_ curve)+  , (rBytes, sBytes) <- BA.splitAt (curveSizeBytes curve) ba =+    Right $ ECDSA.Signature (os2ip rBytes) (os2ip sBytes)+  | otherwise =+    Left $ CryptoParseUnexpectedLength "signature" l+  where+    l = BA.length ba++-- | Make a 'ECDSA.KeyPair' from raw bytes representing a secret key.+mkSecretKey_ :: BA.ByteArray ba => Curve -> ba -> ECDSA.KeyPair+mkSecretKey_ c ba =+  let s = os2ip ba+      p = ECC.Generate.generateQ c s+  in ECDSA.KeyPair c p s

+ src/Morley/Util/Aeson.hs view

@@ -0,0 +1,17 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities related to the @aeson@ package.++module Morley.Util.Aeson+  ( morleyAesonOptions+  ) where++import Data.Aeson.Casing (aesonPrefix, camelCase)+import Data.Aeson.TH (Options)++-- | Options that we use in @morley@-based packages (including+-- @morley@) by default.+morleyAesonOptions :: Options+morleyAesonOptions = aesonPrefix camelCase

+ src/Morley/Util/Binary.hs view

@@ -0,0 +1,113 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | This module contains helper functions to deal with encoding+-- and decoding of binary data.+module Morley.Util.Binary+  ( UnpackError (..)+  , ensureEnd+  , launchGet+  , TaggedDecoder(..)+  , (#:)+  , decodeBytesLike+  , decodeWithTag+  , getByteStringCopy+  , getRemainingByteStringCopy+  , unknownTag+  ) where++import Prelude hiding (EQ, Ordering(..), get)++import Data.Binary (Get)+import qualified Data.Binary.Get as Get+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as List+import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (+||), (|+), (||+))+import Text.Hex (encodeHex)++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Any decoding error.+newtype UnpackError = UnpackError { unUnpackError :: Text }+  deriving stock (Show, Eq)++instance Buildable UnpackError where+  build (UnpackError msg) = build msg++instance Exception UnpackError where+  displayException = pretty++ensureEnd :: Get ()+ensureEnd =+  unlessM Get.isEmpty $ do+    remainder <- Get.getRemainingLazyByteString+    fail $ "Expected end of entry, unconsumed bytes \+           \(" +| length remainder |+ "): "+           +|| encodeHex (LBS.toStrict remainder) ||+ ""++launchGet :: Get a -> LByteString -> Either UnpackError a+launchGet decoder bs =+  case Get.runGetOrFail decoder bs of+    Left (_remainder, _offset, err) -> Left . UnpackError $ toText err+    Right (_remainder, _offset, res) -> Right res++-- | Describes how 'decodeWithTag' should decode tag-dependent data.+-- We expect bytes of such structure: 'tdTag' followed by a bytestring+-- which will be parsed with 'tdDecoder'.+data TaggedDecoder a = TaggedDecoder+  { tdTag :: Word8+  , tdDecoder :: Get a+  }++-- | Alias for 'TaggedDecoder' constructor.+(#:) :: Word8 -> Get a -> TaggedDecoder a+(#:) = TaggedDecoder+infixr 0 #:++-- | Get a bytestring of the given length leaving no references to the+-- original data in serialized form.+getByteStringCopy :: Int -> Get ByteString+getByteStringCopy = fmap BS.copy . Get.getByteString++-- | Get remaining available bytes.+--+-- Note that reading all remaining decoded input may be expensive and is thus+-- discouraged, use can use this function only when you know that amount+-- of data to be consumed is limited, e.g. within 'decodeBytesLike' call.+getRemainingByteStringCopy :: Get ByteString+getRemainingByteStringCopy = do+  lbs <- Get.getRemainingLazyByteString+  -- Avoiding memory overflows in case bad length to 'Get.isolate' was provided.+  -- Normally this function is used only to decode primitives, 'Signature' in+  -- the worst case, so we could set little length, but since this is a hack+  -- anyway let's make sure it never obstructs our work.+  when (length lbs > 640000) $ fail "Too big length for an entity"+  return (LBS.toStrict lbs)++-- | Fail with "unknown tag" error.+unknownTag :: String -> Word8 -> Get a+unknownTag desc tag =+  fail . fmt $ "Unknown " <> build desc <> " tag: 0x" <> hexF tag++-- Common decoder for the case when packed data starts with a tag (1+-- byte) that specifies how to decode remaining data.+decodeWithTag :: String -> [TaggedDecoder a] -> Get a+decodeWithTag what decoders = do+  tag <- Get.label (what <> " tag") Get.getWord8+  -- Number of decoders is usually small, so linear runtime lookup should be ok.+  case List.find ((tag ==) . tdTag) decoders of+    Nothing -> unknownTag what tag+    Just TaggedDecoder{..} -> tdDecoder++decodeBytesLike+  :: (Buildable err)+  => String -> (ByteString -> Either err a) -> Get a+decodeBytesLike what constructor = do+  bs <- getRemainingByteStringCopy+  case constructor bs of+    Left err -> fail $ "Wrong " +| what |+ ": " +| err |+ ""+    Right res -> pure res

+ src/Morley/Util/ByteString.hs view

@@ -0,0 +1,26 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.ByteString+  ( HexJSONByteString(..)+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..), withText)+import Text.Hex (decodeHex, encodeHex)++-- | Newtype wrapper for ByteString which uses hexadecimal representation+-- for JSON serialization.+newtype HexJSONByteString = HexJSONByteString { unHexJSONByteString :: ByteString }+  deriving stock (Eq, Ord, Show, Generic)+  deriving newtype (NFData, Hashable)++instance ToJSON HexJSONByteString where+  toJSON = toJSON . encodeHex . unHexJSONByteString++instance FromJSON HexJSONByteString where+  parseJSON =+    withText "Hex-encoded bytestring" $ \t ->+      case decodeHex t of+        Nothing -> fail "Invalid hex encoding"+        Just res -> pure (HexJSONByteString res)

+ src/Morley/Util/CLI.hs view

@@ -0,0 +1,228 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities for command line options parsing+-- (we use @optparse-applicative@).+--+-- Some names exported from this module are quite general when if you+-- do not assume @optparse-applicative@ usage, so consider using+-- explicit imports for it.++module Morley.Util.CLI+  ( -- * General helpers+    maybeAddDefault+  , outputOption++  -- * Named and type class based parsing+  , HasCLReader (..)+  , mkCLOptionParser+  , mkCLOptionParserExt+  , mkCLArgumentParser+  , mkCLArgumentParserExt+  , mkCommandParser+  , namedParser++  -- ** Helpers for defining 'HasCLReader'+  , eitherReader+  , readerError+  , integralReader+  ) where++import Data.Bits (Bits)+import Data.Text.Manipulate (toSpinal)+import Fmt (Buildable, pretty)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Options.Applicative+  (eitherReader, help, long, metavar, option, readerError, showDefaultWith, strOption, value)+import qualified Options.Applicative as Opt++import Morley.Util.Instances ()+import Morley.Util.Named++-- | Maybe add the default value and make sure it will be shown in+-- help message.+maybeAddDefault :: Opt.HasValue f => (a -> String) -> Maybe a -> Opt.Mod f a+maybeAddDefault printer = maybe mempty addDefault+  where+    addDefault v = value v <> showDefaultWith printer++-- | Parser for path to a file where output will be writen.+outputOption :: Opt.Parser (Maybe FilePath)+outputOption = optional . strOption $+  Opt.short 'o' <>+  long "output" <>+  metavar "FILEPATH" <>+  help "Write output to the given file. If not specified, stdout is used."++----------------------------------------------------------------------------+-- Named parsing+----------------------------------------------------------------------------++-- | Supporting typeclass for 'namedParser'.+-- It specifies how a value should be parsed from command line.+-- Even though the main purpose of this class is to implement+-- helpers below, feel free to use it for other goals.+class HasCLReader a where+  getReader :: Opt.ReadM a+  -- | This string will be passed to the 'metavar' function, hence we+  -- use 'String' type rather 'Text' (even though we use 'Text' almost+  -- everywhere).+  getMetavar :: String++-- Let's add instances when the need arises.+-- The downside of having 'getMetavar' is that there is no instance+-- 'HasCLReader' for 'String' (aka 'FilePath') because we want+-- different metavars for filepaths and other strings.  We can define+-- it as @FILEPATH@ because we normally use 'Text' for everything+-- else, but it still sounds a bit dangerous.++instance HasCLReader Natural where+  getReader = integralReader+  getMetavar = "NATURAL NUMBER"++instance HasCLReader Word64 where+  getReader = integralReader+  -- ↓ Same as for 'Natural', the user usually does not care whether+  -- the number is bounded (reasonable values should fit anyway).+  -- We will apply the same rule for other numeric instances.+  getMetavar = "NATURAL NUMBER"++instance HasCLReader Word32 where+  getReader = integralReader+  getMetavar = "NATURAL NUMBER"++instance HasCLReader Word16 where+  getReader = integralReader+  getMetavar = "NATURAL NUMBER"++instance HasCLReader Word8 where+  getReader = integralReader+  getMetavar = "NATURAL NUMBER"++instance HasCLReader Word where+  getReader = integralReader+  getMetavar = "NATURAL NUMBER"++instance HasCLReader Integer where+  getReader = integralReader+  getMetavar = "INTEGER"++instance HasCLReader Int64 where+  getReader = integralReader+  getMetavar = "INTEGER"++instance HasCLReader Int32 where+  getReader = integralReader+  getMetavar = "INTEGER"++instance HasCLReader Int16 where+  getReader = integralReader+  getMetavar = "INTEGER"++instance HasCLReader Int8 where+  getReader = integralReader+  getMetavar = "INTEGER"++instance HasCLReader Int where+  getReader = integralReader+  getMetavar = "INTEGER"++instance HasCLReader Text where+  getReader = Opt.str+  getMetavar = "STRING"++instance HasCLReader String where+  getReader = Opt.str+  getMetavar = "STRING"++-- | Parse a number, checking for overflows and other stuff.+integralReader :: (Integral a, Bits a) => Opt.ReadM a+integralReader = do+  int <- Opt.auto @Integer+  fromIntegralMaybe int+    & maybe (readerError errorMsg) pure+  where+    errorMsg = "failed to parse command-line numeric argument due to overflow/underflow"++-- | Create a 'Opt.Parser' for a value using 'HasCLReader' instance+-- (hence @CL@ in the name). It uses reader and metavar from that+-- class, the rest should be supplied as arguments.+--+-- We expect some common modifiers to be always provided, a list of+-- extra modifies can be provided as well.+mkCLOptionParser ::+     forall a. (Buildable a, HasCLReader a)+  => Maybe a+  -> "name" :! String+  -> "help" :! String+  -> Opt.Parser a+mkCLOptionParser defValue name hInfo =+  mkCLOptionParserExt defValue name hInfo []++-- | A more general version of 'mkCLOptionParser' which takes a list+-- of extra (not as widely used) modifiers.+mkCLOptionParserExt ::+     forall a. (Buildable a, HasCLReader a)+  => Maybe a+  -> "name" :! String+  -> "help" :! String+  -> [Opt.Mod Opt.OptionFields a]+  -> Opt.Parser a+mkCLOptionParserExt defValue (N name) (N hInfo) mods =+  option getReader $ mconcat $+    metavar (getMetavar @a) :+    long name :+    help hInfo :+    maybeAddDefault pretty defValue :+    mods++-- | Akin to 'mkCLOptionParser', but for arguments rather than options.+mkCLArgumentParser ::+     forall a. (Buildable a, HasCLReader a)+  => Maybe a+  -> "help" :! String+  -> Opt.Parser a+mkCLArgumentParser defValue hInfo = mkCLArgumentParserExt defValue hInfo []++-- | Akin to 'mkCLOptionParserExt', but for arguments rather than options.+mkCLArgumentParserExt ::+     forall a. (Buildable a, HasCLReader a)+  => Maybe a+  -> "help" :! String+  -> [Opt.Mod Opt.ArgumentFields a]+  -> Opt.Parser a+mkCLArgumentParserExt defValue (N hInfo) mods =+  Opt.argument getReader $ mconcat $+    metavar (getMetavar @a) :+    help hInfo :+    maybeAddDefault pretty defValue :+    mods++-- | Parser for command options+mkCommandParser :: String -> Opt.Parser a -> String -> Opt.Mod Opt.CommandFields a+mkCommandParser commandName parser desc =+  Opt.command commandName $+  Opt.info (Opt.helper <*> parser) $+  Opt.progDesc desc++-- | Create a 'Opt.Parser' for a value using its type-level name.+--+-- This expects type-level name to be in camelCase as appropriate for Haskell+-- and transforms the variable inside.+namedParser ::+     forall (a :: Type) (name :: Symbol).+     (Buildable a, HasCLReader a, KnownSymbol name)+  => Maybe a+  -> String+  -> Opt.Parser (name :! a)+namedParser defValue hInfo =+  option ((Name @name) <:!> getReader) $+    mconcat+    [ long (toString . toSpinal . toText $ name)+    , metavar (getMetavar @a)+    , help hInfo+    , maybeAddDefault pretty (Name @name <:!> defValue)+    ]+  where+    name = symbolVal (Proxy @name)

+ src/Morley/Util/CustomGeneric.hs view

@@ -0,0 +1,597 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ+--+-- | Generic deriving with unbalanced trees.++module Morley.Util.CustomGeneric+  ( -- * Custom Generic strategies+    GenericStrategy+  , withDepths+  , rightBalanced+  , leftBalanced+  , rightComb+  , leftComb+  , haskellBalanced+    -- ** Entries reordering+  , reorderingConstrs+  , reorderingFields+  , reorderingData+  , alphabetically+  , leaveUnnamedFields+  , forbidUnnamedFields+    -- * Depth usage helpers+  , cstr+  , fld+    -- * Instance derivation+  , customGeneric++    -- * Helpers+  , fromDepthsStrategy++    -- * Internals+  , reifyDataType+  , deriveFullType+  , customGeneric'+  ) where++import Prelude hiding (Type)++import Control.Lens (traversed)+import qualified GHC.Generics as G+import Generics.Deriving.TH (makeRep0Inline)+import Language.Haskell.TH+import Morley.Util.Generic (mkGenericTree)+import Morley.Util.TH (lookupTypeNameOrFail)+import qualified Unsafe (fromIntegral)++----------------------------------------------------------------------------+-- Simple type synonyms+----------------------------------------------------------------------------++-- | Simple tuple specifying the depth of a constuctor and a list of depths+-- for its fields.+--+-- This is used as a way to specify the tree topology of the Generic instance+-- to derive.+type CstrDepth = (Natural, [Natural])++-- | Simple tuple that defines the "shape" of a constructor: it's name and number+-- of fields. Used only in this module.+type CstrShape = (Name, Int)++-- | Simple tuple that carries basic info about a constructor: it's name,+-- number of its fields and their names. Used only in this module.+type CstrNames = (Name, Int, Maybe [Name])++-- | Type of a strategy to derive 'G.Generic' instances.+data GenericStrategy = GenericStrategy+  { gsEvalDepths :: [CstrShape] -> Q [CstrDepth]+    -- ^ Given the 'CstrShape's for given datatype,+    -- return the 'CstrDepth's for it.+    -- This function should when possible make checks and 'fail', using the+    -- constructors' 'Name' provided by the 'CstrShape'.+  , gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]+    -- ^ Reorder constructors given their names.+  , gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]+    -- ^ Reorder fields given their names, the argument depends on whether+    -- fields are part of record (and thus named) or not (unnamed).+  }++-- | Defines how to reorder fields or constructors.+type EntriesReorder = forall a. [(Text, a)] -> Q [a]++-- | Defines how to reorder fields when their names are unknown.+type UnnamedEntriesReorder = forall a. [a] -> Q [a]++-- | Simple type synonym used (internally) between functions, basically extending+-- 'CstrDepth' with the 'Name's of the constructor and its fields.+-- For fields it carries both names in the original order and in the order specified+-- by the strategy (and the latter is paired with depths).+data NamedCstrDepths = NCD+  { ncdCstrDepth :: Natural+    -- ^ Constructor's depth+  , ncdCstrName :: Name+    -- ^ Constructor's name+  , ncdOrigFieldNames :: [Name]+    -- ^ Names of constructor fields in the original order.+  , ncdFields :: [(Natural, Name)]+    -- ^ Names and depths of constructor fields after the reordering.+  }++-- | Reorders entries corresponding to constructors (@a@) and fields (@b@)+-- according to some rule.+type EntriesTransp = forall a b. [a] -> Q [([b] -> Q [b], a)]++----------------------------------------------------------------------------+-- Generic strategies+----------------------------------------------------------------------------++-- | In this strategy the desired depths of contructors (in the type tree) and+-- fields (in each constructor's tree) are provided manually and simply checked+-- against the number of actual constructors and fields.+withDepths :: [CstrDepth] -> GenericStrategy+withDepths treeDepths = simpleGenericStrategy $ \cstrShape -> do+  when (length treeDepths /= length cstrShape) $ fail+    "Number of contructors' depths does not match number of data contructors."+  forM_ (zip (map snd treeDepths) cstrShape) $ \(fDepths, (constrName, fldNum)) ->+    when (length fDepths /= fldNum) . fail $+    "Number of fields' depths does not match number of field for data " <>+    "constructor: " <> show constrName+  return treeDepths++-- | Strategy to make right-balanced instances (both in constructors and fields).+--+-- This will try its best to produce a flat tree:+--+-- * the balances of all leaves differ no more than by 1;+-- * leaves at left will have equal or lesser depth than leaves at right.+rightBalanced :: GenericStrategy+rightBalanced = fromDepthsStrategy makeRightBalDepths++-- | Strategy to make left-balanced instances (both in constructors and fields).+--+-- This is the same as symmetrically mapped 'rightBalanced'.+leftBalanced :: GenericStrategy+leftBalanced = fromDepthsStrategy (reverse . makeRightBalDepths)++-- | Strategy to make fully right-leaning instances (both in constructors and fields).+rightComb :: GenericStrategy+rightComb = fromDepthsStrategy (reverse . makeLeftCombDepths)++-- | Strategy to make fully left-leaning instances (both in constructors and fields).+leftComb :: GenericStrategy+leftComb = fromDepthsStrategy makeLeftCombDepths++-- | Strategy to make Haskell's Generics-like instances+-- (both in constructors and fields).+--+-- This is similar to 'rightBalanced', except for the "flat" part:+--+-- * for each node, size of the left subtree is equal or less by one than+-- size of the right subtree.+--+-- This strategy matches A1.1.+--+-- @customGeneric \"T\" haskellBalanced@ is equivalent to mere+-- @deriving stock Generic T@.+haskellBalanced :: GenericStrategy+haskellBalanced = fromDepthsStrategy makeHaskellDepths++-- Order modifiers+----------------------------------------------------------------------------++-- | Modify given strategy to reorder constructors.+--+-- The reordering will take place before depths are evaluated and structure+-- of generic representation is formed.+--+-- Example: @reorderingConstrs alphabetically rightBalanced@.+reorderingConstrs :: EntriesReorder -> GenericStrategy -> GenericStrategy+reorderingConstrs reorder gs = gs+  { gsReorderCstrsOn = reorder+  }++-- | Modify given strategy to reorder fields.+--+-- Same notes as for 'reorderingConstrs' apply here.+--+-- Example: @reorderingFields forbidUnnamedFields alphabetically rightBalanced@.+reorderingFields+  :: UnnamedEntriesReorder+  -> EntriesReorder+  -> GenericStrategy -> GenericStrategy+reorderingFields reorderUnnamed reorder gs = gs+  { gsReorderFieldsOn = either reorderUnnamed reorder+  }++-- | Modify given strategy to reorder constructors and fields.+--+-- Same notes as for 'reorderingConstrs' apply here.+--+-- Example: @reorderingData forbidUnnamedFields alphabetically rightBalanced@.+reorderingData+  :: UnnamedEntriesReorder+  -> EntriesReorder+  -> GenericStrategy -> GenericStrategy+reorderingData reorderUnnamed reorder =+  reorderingFields reorderUnnamed reorder . reorderingConstrs reorder++-- | Sort entries by name alphabetically.+alphabetically :: EntriesReorder+alphabetically = pure . map snd . sortWith fst++-- | Leave unnamed fields intact, without any reordering.+leaveUnnamedFields :: UnnamedEntriesReorder+leaveUnnamedFields = pure++-- | Fail in case records are unnamed and we cannot figure+-- out the necessary reordering.+forbidUnnamedFields :: UnnamedEntriesReorder+forbidUnnamedFields fields =+  if length fields <= 1+  then return fields+  else fail "Encountered unnamed fields, cannot apply reordering"++----------------------------------------------------------------------------+-- Generic strategies' builders+----------------------------------------------------------------------------++-- | Construct a strategy that only constructs Generic instance of given+-- form, without e.g. changing the order of entries.+simpleGenericStrategy :: ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy+simpleGenericStrategy mkDepths = GenericStrategy+  { gsEvalDepths = mkDepths+  , gsReorderCstrsOn = pure . map snd+  , gsReorderFieldsOn = pure . either id (map snd)+  }++-- | Helper to make a strategy that created depths for constructor and fields+-- in the same way, just from their number.+--+-- The provided function @f@ must satisfy the following rules:+--+-- * @length (f n) ≡ n@+-- * @sum $ (\x -> 2 ^^ (-x)) \<$\> f n ≡ 1@ (unless @n = 0@)+fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy+fromDepthsStrategy dStrategy = simpleGenericStrategy $ \cShapes -> return $+  zip (dStrategy $ length cShapes) $ map (dStrategy . view _2) cShapes++makeRightBalDepths :: Int -> [Natural]+makeRightBalDepths n = foldr (const addRightBalDepth) [] [1..n]+  where+    addRightBalDepth :: [Natural] -> [Natural]+    addRightBalDepth = \case+      [] -> [0]+      [x] -> [x + 1, x + 1]+      (x : y : xs) | x == y -> x : addRightBalDepth (x : xs)+      (_ : y : xs) -> y : y : y : xs++makeLeftCombDepths :: Int -> [Natural]+makeLeftCombDepths 0 = []+makeLeftCombDepths n = map (Unsafe.fromIntegral @Int @Natural) $ (n - 1) : [n - 1, n - 2..1]++makeHaskellDepths :: Int -> [Natural]+makeHaskellDepths n =+  case nonEmpty (replicate n [0]) of+    Nothing -> []+    Just leaves -> mkGenericTree (\_ l r -> map succ (l ++ r)) leaves++----------------------------------------------------------------------------+-- Depth usage helpers+----------------------------------------------------------------------------++-- | Helper for making a constructor depth.+--+-- Note that this is only intended to be more readable than directly using a+-- tuple with 'withDepths' and for the ability to be used in places where+-- @RebindableSyntax@ overrides the number literal resolution.+cstr :: forall n. KnownNat n => [Natural] -> CstrDepth+cstr flds = (natVal (Proxy @n), flds)++-- | Helper for making a field depth.+--+-- Note that this is only intended to be more readable than directly using a+-- tuple with 'withDepths' and for the ability to be used in places where+-- @RebindableSyntax@ overrides the number literal resolution.+fld :: forall n. KnownNat n => Natural+fld = natVal $ Proxy @n++----------------------------------------------------------------------------+-- Instance derivation+----------------------------------------------------------------------------++{-# ANN module ("HLint: ignore Use snd" :: Text) #-}++-- | Derives the 'G.Generic' instance for a type given its name and a+-- 'GenericStrategy' to use.+--+-- The strategy is used to calculate the depths of the data-type constructors+-- and each constructors' fields.+--+-- The depths are used to generate the tree of the 'G.Generic' representation,+-- allowing for a custom one, in contrast with the one derived automatically.+--+-- This only supports "plain" @data@ types (no GADTs, no @newtype@s, etc.) and+-- requires the depths to describe a fully and well-defined tree (see 'unbalancedFold').+--+-- For example, this is valid (and uses the 'withDepths' strategy with the 'cstr'+-- and 'fld' helpers) and results in a balanced instance, equivalent to the+-- auto-derived one:+--+-- @@@+-- data CustomType a+--   = CustomUp Integer Integer+--   | CustomMid {unMid :: Natural}+--   | CustomDown a+--   | CustomNone+--+-- $(customGeneric "CustomType" $ withDepths+--   [ cstr @2 [fld @1, fld @1]+--   , cstr @2 [fld @0]+--   , cstr @2 [fld @0]+--   , cstr @2 []+--   ])+-- @@@+--+-- and this is a valid, but fully left-leaning one:+--+-- @@@+-- $(customGeneric "CustomType" $ withDepths+--   [ cstr @3 [fld @1, fld @1]+--   , cstr @3 [fld @0]+--   , cstr @2 [fld @0]+--   , cstr @1 []+--   ])+-- @@@+--+-- and, just as a demonstration, this is the same fully left-leaning one, but+-- made using the simpler 'leftComb' strategy:+--+-- @@@+-- $(customGeneric "CustomType" leftComb)+-- @@@+--+-- Developers are welcome to provide their own derivation strategies,+-- and some useful strategies can be found outside of this module by+-- 'GenericStrategy' signature.+customGeneric :: String -> GenericStrategy -> Q [Dec]+customGeneric typeStr genStrategy = do+  -- Implementor's note:+  --+  -- Instead of using a name literal (@customGeneric ''T@), we use a string (@customGeneric \"T\"@)+  -- and then 'lookupTypeName' for the following reasons:+  --+  -- 1. We can control the error message when 'lookupTypeName' doesn't find the type in scope (as opposed to @''T@)+  -- 2. Most importantly, this was made with Indigo in mind, where we try as much as+  --    possible to use a simple syntax (to appeal to a broader audience) and so to avoid+  --    using more obscure Haskell syntax (like @''T@).++  -- reify the data type+  (typeName, _, mKind, vars, constructors) <- lookupTypeNameOrFail typeStr >>= reifyDataType+  -- obtain info about its constructor and desired tree+  derivedType <- deriveFullType typeName mKind vars+  customGeneric' Nothing typeName derivedType  constructors genStrategy++-- | If a 'Type' type is given, this function will generate a new 'Generic' instance with it,+-- and generate the appropriate "to" and "from" methods.+--+-- Otherwise, it'll generate a new 'Type' instance as well.+customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]+customGeneric' maybeRepType typeName derivedType constructors genStrategy = do+  cNames <- cstrNames constructors+  let cReordering :: EntriesTransp+      cReordering = reorderCstrs genStrategy cNames+  let cShapes = cNames <&> \(name, fNum, _) -> (name, fNum)+  cShapesSorted <- cReordering cShapes <&> map \(_fReorder, cShape) -> cShape+  treeDepths <- gsEvalDepths genStrategy cShapesSorted+  weightedConstrs <- makeWeightedConstrs cReordering treeDepths cShapes++  -- If no 'Rep' type was given, derive one.+  let repType =+        maybe+          (makeUnbalancedRep typeName treeDepths cReordering (pure derivedType))+          pure+          maybeRepType++  -- produce the Generic instance+  res <- instanceD (pure []) (conT ''G.Generic `appT` pure derivedType)+    [ tySynInstD . tySynEqn Nothing (conT ''G.Rep `appT` pure derivedType) $+        repType+    , makeUnbalancedFrom weightedConstrs+    , makeUnbalancedTo weightedConstrs+    ]+  return [res]++-- | Apply a reordering strategy.+--+-- This uses given @[CstrNames]@ to understand how constructors and their+-- fields should be reordered, and applies the same transposition to entries+-- within 'EntriesTransp'.+reorderCstrs :: GenericStrategy -> [CstrNames] -> EntriesTransp+reorderCstrs GenericStrategy{..} cNames = \cstrEntries ->+  gsReorderCstrsOn $+    zip cNames cstrEntries <&> \(cstrName@(name, _, _), cstrEntry) ->+      (origName name, (fieldsReorder cstrName, cstrEntry))+  where+    fieldsReorder :: CstrNames -> [b] -> Q [b]+    fieldsReorder (_, _, mFieldNames) = \fieldEntries -> do+      gsReorderFieldsOn $+        maybe Left (Right ... zip . map origName) mFieldNames fieldEntries++-- | Reifies info from a type name (given as a 'String').+-- The lookup happens from the current splice's scope (see 'lookupTypeName') and+-- the only accepted result is a "plain" data type (no GADTs).+reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])+reifyDataType typeName = do+  typeInfo <- reify typeName+  case typeInfo of+    TyConI (DataD decCxt typeName' vars mKind constrs _) ->+      return (typeName', decCxt, mKind, vars, constrs)+    TyConI (NewtypeD decCxt typeName' vars mKind constr _) ->+      return (typeName', decCxt, mKind, vars, [constr])+    _ -> fail $+      "Only plain datatypes are supported for derivation, but '" <>+      show typeName <> "' instead reifies to:\n" <> show typeInfo++-- | Derives, as well as possible, a type definition from its name, its kind+-- (where known) and its variables.+deriveFullType :: Name -> Maybe Kind -> [TyVarBndr] -> TypeQ+deriveFullType tName mKind = addTypeSig . foldl appT (conT tName) . makeVarsType+  where+    addTypeSig :: TypeQ -> TypeQ+    addTypeSig = flip sigT $ fromMaybe StarT mKind++    makeVarsType :: [TyVarBndr] -> [TypeQ]+    makeVarsType = map $ \case+      PlainTV vName       -> varT vName+      KindedTV vName kind -> sigT (varT vName) kind++-- | Extract the info for each of the given constructors.+cstrNames :: [Con] -> Q [CstrNames]+cstrNames constructors = forM constructors $ \case+  NormalC name lst -> return (name, length lst, Nothing)+  RecC name lst    -> return (name, length lst, Just $ lst ^.. traversed . _1)+  InfixC _ name _  -> return (name, 2, Nothing)+  constr           -> fail $ "Unsupported constructor: " <> show constr++-- | Combines depths with constructors, 'fail'ing in case of mismatches, and+-- generates 'Name's for the constructors' arguments.+makeWeightedConstrs+  :: EntriesTransp -> [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]+makeWeightedConstrs cReorder treeDepths cShapes = do+  reorderedShapes <- cReorder cShapes+  forM (zip treeDepths reorderedShapes) $+    \((cDepth, fDepths), (fReorder, (cName, fNum))) -> do+      fieldVarsNames <- forM [0 .. fNum - 1] \i -> newName ("v" <> show i)+      reorderedFieldVarNames <- fReorder fieldVarsNames+      return NCD+        { ncdCstrDepth = cDepth+        , ncdCstrName = cName+        , ncdOrigFieldNames = fieldVarsNames+        , ncdFields = zip fDepths reorderedFieldVarNames+        }++-- | Creates the 'G.Rep' type for an unbalanced 'G.Generic' instance, for a type+-- given its name, constructors' depths and derived full type.+--+-- Note: given that these types definition can be very complex to generate,+-- especially in the metadata, here we let @generic-deriving@ make a balanced+-- value first (see 'makeRep0Inline') and then de-balance the result.+makeUnbalancedRep :: Name -> [CstrDepth] -> EntriesTransp -> TypeQ -> TypeQ+makeUnbalancedRep typeName treeDepths reorderConstrs derivedType = do+  -- let generic-deriving create the balanced type first+  balRep <- makeRep0Inline typeName derivedType+  -- separate the top-most type metadata from the constructors' trees+  (typeMd, constrTypes) <- dismantleGenericTree [t| G.C1 |] balRep+  -- for each of the constructor's trees+  reorderedConstrTypes <- reorderConstrs constrTypes+  unbalConstrs <- forM (zip reorderedConstrTypes treeDepths) $+    \((reorderFields, constrType), treeDepth) ->+    case treeDepth of+      (n, []) ->+        -- when there are no fields there is no tree to unbalance+        return (n, constrType)+      (n, fieldDepths) -> do+        -- separate the top-most constructor metadata from the fields' trees+        (constrMd, fieldTypes) <- dismantleGenericTree [t| G.S1 |] constrType+        -- build the unbalanced tree of fields+        reorderedFieldTypes <- reorderFields fieldTypes+        unbalConstRes <- unbalancedFold (zip fieldDepths reorderedFieldTypes)+                                        (appT . appT (conT ''(G.:*:)))+        -- return the new unbalanced constructor+        return (n, AppT constrMd unbalConstRes)+  -- build the unbalanced tree of constructors and rebuild the type+  appT (pure typeMd) $ unbalancedFold unbalConstrs (appT . appT (conT ''(G.:+:)))++-- | Breaks down a tree of @Generic@ types from the contructor of "nodes" and+-- the constructor for "leaves" metadata.+--+-- This expects (and should always be the case) the "root" to be a @Generic@+-- metadata contructor, which is returned in the result alongside the list of+-- leaves (in order).+dismantleGenericTree :: TypeQ -> Type -> Q (Type, [Type])+dismantleGenericTree leafMetaQ (AppT meta nodes) = do+  leafMeta <- leafMetaQ+  let collectLeafsTypes :: Type -> [Type]+      collectLeafsTypes tp =+        case tp of+          f `AppT` _ `AppT` _ | f == leafMeta -> [tp]+          AppT a b -> collectLeafsTypes a <> collectLeafsTypes b+          _ -> []+  return (meta, collectLeafsTypes nodes)+dismantleGenericTree _ x = fail $+  "Unexpected lack of Generic Metadata: " <> show x++-- | Create the unbalanced 'G.from' fuction declaration for a type starting from+-- its list of weighted constructors.+makeUnbalancedFrom :: [NamedCstrDepths] -> DecQ+makeUnbalancedFrom wConstrs = do+  (cPatts, cDepthExp) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do+    fDepthExp <- forM wFields $ \(fDepth, fName) -> do+      -- make expression to asseble a Generic Field from its variable+      fExpr <- appE [| G.M1 |] . appE [| G.K1 |] $ varE fName+      return (fDepth, fExpr)+    -- make pattern for this constructor+    fPatts <- mapM varP wOrigFields+    let cPatt = ConP cName fPatts+    -- make expression to assemble its fields as an isolated Generic Constructor+    cExp <- appE [| G.M1 |] $ case fDepthExp of+      [] -> conE 'G.U1+      _  -> unbalancedFold fDepthExp (appE . appE [| (G.:*:) |])+    return (cPatt, (cDepth, [cExp]))+  -- make expressions to assemble all Generic Constructors+  cExps <- mapQ (appE [| G.M1 |]) $ unbalancedFold cDepthExp $ \xs ys ->+    (<>) <$> mapQ (appE [| G.L1 |]) xs <*> mapQ (appE [| G.R1 |]) ys+  -- make function definition+  funD 'G.from $ zipWith (\p e -> clause [pure p] (normalB $ pure e) []) cPatts cExps++-- | Create the unbalanced 'G.to' fuction declaration for a type starting from+-- its list of weighted constructors.+makeUnbalancedTo :: [NamedCstrDepths] -> DecQ+makeUnbalancedTo wConstrs = do+  (cExps, cDepthPat) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do+    fDepthPat <- forM wFields $ \(fDepth, fName) -> do+      -- make pattern for a Generic Field from its variable+      fPatt <- conP1 'G.M1 . conP1 'G.K1 $ varP fName+      return (fDepth, fPatt)+    -- make pattern for this isolated Generic Constructor+    cPatt <- conP1 'G.M1 $ case fDepthPat of+      [] -> conP 'G.U1 []+      _  -> unbalancedFold fDepthPat (conP2 '(G.:*:))+    -- make expression to assemble this constructor+    fExps <- mapM varE wOrigFields+    let cExp = foldl AppE (ConE cName) fExps+    return (cExp, (cDepth, [cPatt]))+  -- make patterns for all Generic Constructors+  cPatts <- mapQ (conP1 'G.M1) $ unbalancedFold cDepthPat $ \xs ys ->+    (<>) <$> mapQ (conP1 'G.L1) xs <*> mapQ (conP1 'G.R1) ys+  -- make function definition+  funD 'G.to $ zipWith (\p e -> clause [pure p] (normalB $ pure e) []) cPatts cExps++-- | Recursively aggregates the values in the given list by merging (with the+-- given function) the ones that are adjacent and with the same depth.+--+-- This will fail for every case in which the list cannot be folded into a single+-- 0-depth value.+unbalancedFold :: forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a+unbalancedFold lst f = unbalancedFoldRec lst >>= \case+  [(0, result)] -> return result+  [(n, _)] -> fail $+    "Resulting unbalanced tree has a single root, but of depth " <> show n <>+    " instead of 0. Check your depths definitions."+  _ -> fail $+    "Cannot create a tree from nodes of depths: " <> show (map fst lst) <>+    ". Check your depths definitions."+  where+    unbalancedFoldRec :: [(Natural, a)] -> Q [(Natural, a)]+    unbalancedFoldRec xs = do+      ys <- unbalancedFoldSingle xs+      if xs == ys then return xs else unbalancedFoldRec ys++    unbalancedFoldSingle :: [(Natural, a)] -> Q [(Natural, a)]+    unbalancedFoldSingle = \case+      [] -> return []+      (dx, x) : (dy, y) : xs | dx == dy -> do+        dxy <- f (pure x) (pure y)+        return $ (dx - 1, dxy) : xs+      x : xs -> do+        ys <- unbalancedFoldSingle xs+        return (x : ys)++----------------------------------------------------------------------------+-- Utility functions+----------------------------------------------------------------------------++conP1 :: Name -> PatQ -> PatQ+conP1 name pat = conP name [pat]++conP2 :: Name -> PatQ -> PatQ -> PatQ+conP2 name pat1 pat2 = conP name [pat1, pat2]++mapQ :: (Q a -> Q a) -> Q [a] -> Q [a]+mapQ f qlst = qlst >>= mapM (f . pure)++-- | Original name of a constructor or field.+origName :: Name -> Text+origName = toText . nameBase

+ src/Morley/Util/Default.hs view

@@ -0,0 +1,25 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.Default+  ( permute2Def , permute3Def+  , Default (..)+  ) where++import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)+import Data.Default (Default, def)++{- Permutation Parsers -}++permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a,b)+permute2Def a b = runPermutation $+  (,) <$> toPermutationWithDefault def a+      <*> toPermutationWithDefault def b++permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) =>+                f a -> f b -> f c -> f (a,b,c)+permute3Def a b c = runPermutation $+  (,,) <$> toPermutationWithDefault def a+       <*> toPermutationWithDefault def b+       <*> toPermutationWithDefault def c

+ src/Morley/Util/Exception.hs view

@@ -0,0 +1,16 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.Exception+  ( -- * General simple helpers+    throwLeft+  ) where++-- | If monadic action returns a 'Left' value, it will be+-- thrown. Otherwise the returned value will be returned as is.+throwLeft :: (MonadThrow m, Exception e) => m (Either e a) -> m a+throwLeft =+  (>>= \case+      Left e -> throwM e+      Right x -> return x)

+ src/Morley/Util/Fcf.hs view

@@ -0,0 +1,31 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.Fcf+  ( Over2+  , type (<|>)+  , TyEqSing+  , ApplyConstraints+  , Eval+  ) where++import Data.Singletons.Prelude.Eq (DefaultEq)+import Fcf++data Over2 :: (a -> b -> Exp r) -> (x -> Exp a) -> (x -> Exp b) -> x -> Exp r+type instance Eval (Over2 f g h x) = Eval (LiftM2 f (g x) (h x))++data (<|>) :: f a -> f a -> Exp (f a)+type instance Eval ('Nothing <|> m) = m+type instance Eval ('Just x <|> _) = 'Just x++-- | Similar to 'TyEq', but compares types via @DefaultEq@ used in singletons+-- comparisons (see "Data.Singletons.Prelude.Eq" module).+data TyEqSing :: a -> b -> Exp Bool+type instance Eval (TyEqSing a b) = DefaultEq a b++data ApplyConstraints :: [a -> Constraint] -> a -> Exp Constraint+type instance Eval (ApplyConstraints '[] _) = (() :: Constraint)+type instance Eval (ApplyConstraints (c ': cs) a) =+  (c a, Eval (ApplyConstraints cs a))

+ src/Morley/Util/Generic.hs view

@@ -0,0 +1,49 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Generic-related utils.+module Morley.Util.Generic+  ( mkGenericTree+  , mkGenericTreeVec++  , GenericTypeName+  ) where++import Control.Exception (assert)+import qualified Data.Vector as V+import qualified GHC.Generics as G+import GHC.TypeLits (Symbol)+import qualified Unsafe (fromIntegral)++-- | Rebuild a list into a binary tree of exactly the same form which+-- "Data.Generics" uses to represent datatypes.+--+-- Along with the original list you have to provide constructor for intermediate+-- nodes - it accepts zero-based index of the leftmost element of the right tree+-- and merged trees themselves.+mkGenericTree :: (Natural -> a -> a -> a) -> NonEmpty a -> a+mkGenericTree mkNode = mkGenericTreeVec id mkNode . V.fromList . toList++mkGenericTreeVec+  :: HasCallStack+  => (a -> b) -> (Natural -> b -> b -> b) -> V.Vector a -> b+mkGenericTreeVec mkLeaf mkNode vector+  | V.null vector = error "Empty vector"+  | otherwise = mkTreeDo 0 vector+  where+    mkTreeDo idxBase es+      | V.length es == 1 = mkLeaf $ V.head es+      | otherwise = assert (V.length es > 1) $+          let mid = V.length es `div` 2+              mid' = idxBase + mid+              (h, t) = V.splitAt mid es+          in mkNode (Unsafe.fromIntegral @Int @Natural mid') (mkTreeDo idxBase h) (mkTreeDo mid' t)++-- | Extract datatype name via its Generic representation.+--+-- For polymorphic types this throws away all type arguments.+type GenericTypeName a = GTypeName (G.Rep a)++type family GTypeName (x :: Type -> Type) :: Symbol where+  GTypeName (G.D1 ('G.MetaData tyName _ _ _) _) = tyName

+ src/Morley/Util/Instances.hs view

@@ -0,0 +1,20 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Missing instances from libraries.+module Morley.Util.Instances () where++import Data.Default (Default(..))+import Fmt (Buildable(..))++instance Default Natural where+  def = 0++instance Buildable Natural where+  build = build @Integer . fromIntegral++instance Buildable a => (Buildable (Identity a)) where+  build (Identity x) = build x

+ src/Morley/Util/Interpolate.hs view

@@ -0,0 +1,315 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{- |+String interpolation quasi-quoters. The most basic version is 'i', it returns anything that+has a 'Fmt.FromBuilder' instance: 'Text', 'ByteString', 'String', 'Builder'.++In some cases, it is more convenient to return a lazy @Text@ 'Builder', in that case 'ib', which+returns a non-polymorphic result, can be helpful, for instance, if you want to use one interpolated+string inside another one. Using 'Builder' is also more efficient in this case.++>>> let splice = [i|some text|]+>>> [i|larger text with #{splice}|] :: Text+...+... error:+... Ambiguous type variable ...+...++>>> let splice = [ib|some text|]+>>> [i|larger text with #{splice}|] :: Text+"larger text with some text"++There are also unindenting versions, i.e. those stripping the longest common indentation from each+line (note those do not consider indentation inside splices!), and trimming versions, i.e.+those that remove whitespace-only lines from beginning and end of the quote.++The mnemonic is @i@nterpolate @t@rimming @u@nindenting returning @b@uilder, i.e. 'itub' is+the trimming, unindenting version returning 'Builder'.++Versions not interpreting Haskell escape sequences additionally start with @l@, e.g. 'litu' is+@l@iteral @i@nterpolation @t@trimming @u@nindenting.++>>> [i|\955\x1F600\\|]+λ😀\++>>> [li|\955\x1F600\\|]+\955\x1F600\\++Splices are specified in the form @#{variableName}@. Note that expressions are not supported.+You can add @\@ before @#@, e.g. @\#{variableName}@, to interpret it as literal text. All the usual+Haskell string escapes also work, unless using "literal" versions. A warning will be issued if an+escape is not recognized, however the code will still compile, ignoring the backslash, e.g.+@\{@ will be treated as @{@.++All splices will be indented exactly to their column position in the original text, e.g.++>>> let splice = "multi\nline" :: Text+>>> [i|Some text #{splice}|]+Some text multi+          line++Multi-line splices will not automatically add any newlines after them, be mindful of that:++>>> let splice = "multi\nline" :: Text+>>> [i|Some text #{splice} trailing text|]+Some text multi+          line trailing text++If you wish to avoid that, either include the final newline in the splice explicitly (but be aware+that indentation of the trailing text won't be auto-adjusted, not even the leading spaces are+removed!), or include it in the quote:++>>> let splice = "multi\nline" :: Text+>>> :{+[itu|+  Some text #{splice}+  trailing text+  |]+:}+Some text multi+          line+trailing text++>>> let splice = "multi\nline\n" :: Text+>>> :{+[itu|+  Some text+    Some indented text #{splice} trailing text+  |]+:}+Some text+  Some indented text multi+                     line+ trailing text++Empty lines are never indented:++>>> let splice = "multi\n\nline" :: Text+>>> :{+print [itu|+  Some text #{splice}+  |]+:}+"Some text multi\n\n          line"++Unindenting versions will drop the first newline if the first line is empty, i.e.++>>> :{+print [iu|+There will be no leading newline here, but there will be a trailing one.+|]+:}+"There will be no leading newline here, but there will be a trailing one.\n"++but++>>> :{+print [iu|There will be a newline+here+|]+:}+"There will be a newline\nhere\n"++Unindent does not consider empty lines for finding common indentation, but it does consider+whitespace-only lines. As a result, one can control overall indentation by the indentation of the+last line:++>>> :{+let splice = "multi\nline" :: Text+in [itu|+    Some text #{splice}+    trailing text+  |]+:}+  Some text multi+            line+  trailing text+-}+module Morley.Util.Interpolate (+    i+  , ib+  , iu+  , iub+  , it+  , itb+  , itu+  , itub+  , li+  , lib+  , liu+  , liub+  , lit+  , litb+  , litu+  , litub+  ) where++import Prelude hiding (lift)++import Data.Char (isSpace)+import qualified Data.List as List+import qualified Data.Set as S+import Data.Text.Internal.Builder (Builder, fromLazyText, toLazyText)+import qualified Data.Text.Lazy as TL+import Fmt (build, fmt)+import Language.Haskell.TH (Exp, Q, lookupValueName, reportWarning, varE)+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Text.ParserCombinators.ReadP (readP_to_S)+import Text.Read.Lex (lexChar)++-- | Datatype encoding transformations we apply to a quoter input and output.+-- Note the order is important! We first unescape, then unindent, then trim.+data Transformation+  = Unescaping+  | Unindenting+  | Trimming+  | Polymorphic+  deriving stock (Eq, Ord, Enum, Bounded)++-- | A 'Set' of 'Transformation'+type Transformations = Set Transformation++-- | Actual quasi-quoters+i, ib, iu, iub, it, itb, itu, itub, li, lib, liu, liub, lit, litb, litu, litub :: QuasiQuoter++-- | 'Transformations' singletons+trimming, unindenting, unescaping, polymorphic :: Transformations+trimming = S.singleton Trimming+unindenting = S.singleton Unindenting+unescaping = S.singleton Unescaping+polymorphic = S.singleton Polymorphic++lib = mkQuoter mempty+liub = mkQuoter unindenting+litb = mkQuoter trimming+litub = mkQuoter $ trimming <> unindenting++ib = mkQuoter unescaping+iub = mkQuoter $ unindenting <> unescaping+itb = mkQuoter $ trimming <> unescaping+itub = mkQuoter $ trimming <> unindenting <> unescaping++li = mkQuoter polymorphic+liu = mkQuoter $ unindenting <> polymorphic+lit = mkQuoter $ trimming <> polymorphic+litu = mkQuoter $ trimming <> unindenting <> polymorphic++i = mkQuoter $ unescaping <> polymorphic+iu = mkQuoter $ unindenting <> unescaping <> polymorphic+it = mkQuoter $ trimming <> unescaping <> polymorphic+itu = mkQuoter $ trimming <> unindenting <> unescaping <> polymorphic++mkQuoter :: Transformations -> QuasiQuoter+mkQuoter ts = QuasiQuoter+  { quoteExp = foldr go makeBuilder $ toList ts+  , quotePat = \_ -> fail "Cannot be used at pattern position"+  , quoteType = \_ -> fail "Cannot be used at type position"+  , quoteDec = \_ -> fail "Cannot be used as declaration"+  }+  where+    go Unescaping  f = f <=< unescape+    go Unindenting f = f . unindent . dropLeadingNewline+    go Trimming    f = f . trim+    go Polymorphic f = \s -> [| fmt $(f s) |]++unescape :: String -> Q String+unescape ('\\':'#':xs) = ('\\':) . ('#':) <$> unescape xs+unescape xs@('\\':c:cs) = case readP_to_S lexChar xs of+  (ch, rest):_ -> (ch :) <$> unescape rest+  [] -> do+    reportWarning $ "Unrecognized escape sequence near '" <> takeWhile (not . isSpace) xs <> "'"+    (c :) <$> unescape cs+unescape (c:cs) = (c :) <$> unescape cs+unescape [] = pure []++makeBuilder :: String -> Q Exp+makeBuilder = go mempty+  where+    go tacc ('\\':'#':xs) = go (tacc <> "#") xs+    go tacc ('#':'{':xs)+      | (expr, '}':ys) <- List.span (/='}') xs+      = lookupValueName expr >>= \case+          Just valueName ->+            let txt = fmt tacc+                ls = splitTextLazy (=='\n') txt+                indent = length . last $ ls+            in [| build txt <> indentF'' indent (build $(varE valueName)) <> $(go mempty ys) |]+          Nothing -> fail $ "Variable '" ++ expr ++ "' is not in scope"+    go tacc (c:cs) = case List.span (`notElem` ['\\', '#']) cs of+      (str, rest) -> go (tacc <> build (c:str)) rest+    go tacc [] = let txt = fmt @Text tacc in [| build txt |]++-- | A version of @Fmt.indentF'@ that doesn't indent the first line, and keeps the final line break+-- intact.+indentF'' :: Int -> Builder -> Builder+indentF'' indent bld = case splitTextLazy (=='\n') $ toLazyText bld of+  (x :| xs) -> fromLazyText . TL.intercalate "\n" $ x : map addIndent xs+  where+    addIndent str | null str = str+                  | otherwise = spaces <> str+    spaces = TL.replicate (fromIntegral indent) " "++splitTextLazy :: (Char -> Bool) -> TL.Text -> NonEmpty TL.Text+splitTextLazy p t = case nonEmpty $ TL.split p t of+  Just ne -> ne+  Nothing -> error "Morley.Util.Interpolate.splitTextLazy: the impossible happened"++dropLeadingNewline :: String -> String+dropLeadingNewline ('\n':xs) = xs+dropLeadingNewline xs = xs++unindent :: String -> String+unindent s =+  case nonEmpty (filter (not . null) ls) of+    Just ne ->+      let minIndent = minimum $ indentOf <$> ne+      -- See Note [lines/unlines] below about the use of 'intercalate'+      in intercalate "\n" $ drop minIndent <$> ls+    Nothing -> s+  where+    ls = split (=='\n') s+    indentOf = length . takeWhile (== ' ')++-- See Note [lines/unlines] below about the use of this function+split :: (Char -> Bool) -> String -> [String]+split cond s = case break cond s of+  (pfx, _:suf) -> pfx : split cond suf+  (pfx, "") -> [pfx]++trim :: String -> String+trim = intercalate "\n" . List.dropWhileEnd (all (== ' '))+     -- See Note [lines/unlines] below about the use of 'intercalate'+     . dropWhile (all (== ' ')) . split (=='\n')++{- Note [lines/unlines]+   ~~~~~~~~~~~~~~~~~~~~++lines/unlines don't actually satisfy our requirements here due to+some edge case behaviour.++First of all, `lines` and `unlines` aren't strictly speaking inverse+of each other: `unlines` always adds a trailing newline. Consider:++>>> unlines . lines $ "hello\nworld"+"hello\nworld\n"++Furthermore, `lines` itself does "gobble" the trailing empty line, consider:++>>> lines $ "hello\nworld\n"+["hello","world"]++We actually need this to be `["hello","world",""]` for the unindenting+algorithm to work correctly (i.e. not unindent anything if the last indent is 0),+but that doesn't work with `lines` (also we either lose a trailing newline+or get an extra one with `unlines`). I could use `lines` with `trim`,+but for consistency chose not to.++Long story short, I use `split (=='\n')` and `Text.Lazy.split (=='\n')`+to get a list of lines, and `intercalate "\n"` to glue them back.+This has the behaviour we need.++- @lierdakil++-}

+ src/Morley/Util/Label.hs view

@@ -0,0 +1,47 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Definition of the Label type and utilities+module Morley.Util.Label+  ( -- * Definitions+    Label (..)++  -- * Utilities+  , labelToText++  -- * Re-exports+  , IsLabel (..)+  ) where++import Fmt (Buildable(..), pretty)+import Text.Show (Show(..))++import Morley.Util.TypeLits++--------------------------------------------------------------------------------+-- Definitions+--------------------------------------------------------------------------------++-- | Proxy for a label type that includes the 'KnownSymbol' constraint+data Label (name :: Symbol) where+  Label :: KnownSymbol name => Label name++deriving stock instance Eq (Label name)++instance Show (Label name) where+  show label = "Label " <> pretty label++instance (KnownSymbol name, s ~ name) => IsLabel s (Label name) where+  fromLabel = Label++instance Buildable (Label name) where+  build Label = build $ symbolVal (Proxy @name)++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++-- | Utility function to get the t'Text' representation of a 'Label'+labelToText :: Label name -> Text+labelToText = pretty

+ src/Morley/Util/Lens.hs view

@@ -0,0 +1,16 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Morley.Util.Lens+  ( postfixLFields+  , makeLensesWith+  ) where++import Control.Lens (LensRules, lensField, lensRules, makeLensesWith, mappingNamer)++-- | For datatype with "myNyan" field it will create "myNyanL" lens.+postfixLFields :: LensRules+postfixLFields = lensRules & lensField .~ mappingNamer (\s -> [s++"L"])

+ src/Morley/Util/Main.hs view

@@ -0,0 +1,25 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Functions supposed to be used in the @Main@ module.++module Morley.Util.Main+  ( wrapMain+  ) where++import Control.Exception.Uncaught (withDisplayExceptionHandler)+import Main.Utf8 (withUtf8)++-- | Some defaults in Haskell are debatable and we typically want+-- to customize them in our applications.+-- Some customizations are done at the level of @main@.+-- Currently we have two of them:+--+-- 1. 'withUtf8' from the @with-utf8@ package.+-- 2. 'withDisplayExceptionHandler' from the @uncaught-exception@ package.+--+-- This function is supposed to apply all @main@ customizations that we+-- typcally want to do.+wrapMain :: IO () -> IO ()+wrapMain = withUtf8 . withDisplayExceptionHandler

+ src/Morley/Util/Markdown.hs view

@@ -0,0 +1,158 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | A small Markdown eDSL.+module Morley.Util.Markdown+  ( Markdown+  , HeaderLevel (..)+  , Anchor (..)+  , ToAnchor (..)+  , nextHeaderLevel+  , mdHeader+  , mdToc+  , mdSubsection+  , mdSubsectionTitle+  , mdBold+  , mdItalic+  , mdTicked+  , mdRef+  , mdLocalRef+  , mdEscapeAnchor+  , mdAnchor+  , mdSeparator+  , mdSpoiler+  , mdComment+  , md+  ) where++import Prelude hiding (try)++import Data.Char (isAscii)+import Fmt (Builder, build, (+|), (|+))+import Language.Haskell.TH.Quote (QuasiQuoter)++import Morley.Util.Interpolate (iub)++-- | A piece of markdown document.+--+-- This is opposed to 'Text' type, which in turn is not supposed to contain+-- markup elements.+type Markdown = Builder++-- | Level of header, starting from 1.+newtype HeaderLevel = HeaderLevel Int++-- | Anchor with given text.+newtype Anchor = Anchor { unAnchor :: Text }++instance IsString Anchor where+  -- Avoiding collision with names assigned by autodoc engine+  fromString = Anchor . fromString . ("manual-" <>)++-- | Picking anchor for various things.+--+-- What you want here is potentially adding some prefix to ensure anchors uniqueness.+-- It is not necessary to preprocess the text to fit anchor format - that will happen+-- when the anchor is embedded into 'Markdown'.+class ToAnchor anchor where+  toAnchor :: anchor -> Anchor++instance ToAnchor Anchor where+  toAnchor = id++instance ToAnchor Text where+  toAnchor = Anchor++nextHeaderLevel :: HeaderLevel -> HeaderLevel+nextHeaderLevel (HeaderLevel l) = HeaderLevel (l + 1)++mdHeader :: HeaderLevel -> Markdown -> Markdown+mdHeader (HeaderLevel lvl) text =+  mconcat (replicate lvl "#") +| " " +| text |+ "\n\n"++mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown+mdToc (HeaderLevel lvl) text anchor =+  mconcat (replicate (lvl - 2) "  ") +|+    "- " +| mdLocalRef text anchor |+ "\n"++mdSubsectionTitle :: Markdown -> Markdown+mdSubsectionTitle title = mdBold (title <> ":")++mdSubsection :: Markdown -> Markdown -> Markdown+mdSubsection name txt = mdSubsectionTitle name <> " " <> txt++mdBold :: Markdown -> Markdown+mdBold x = "**" <> x <> "**"++mdItalic :: Markdown -> Markdown+mdItalic x = "*" <> x <> "*"++mdTicked :: Markdown -> Markdown+mdTicked x = "`" +| x |+ "`"++mdEscapeAnchorS :: String -> Markdown+mdEscapeAnchorS = \case+  [] -> ""+  c : s -> escapeChar c <> mdEscapeAnchorS s+  where+    escapeChar = \case+      ' ' -> "-"+      '(' -> "lparen"+      ')' -> "rparen"+      '[' -> "lbracket"+      ']' -> "rbracket"+      '{' -> "lbrace"+      '}' -> "rbrace"+      ',' -> "comma"+      ';' -> "semicolon"+      ':' -> "colon"+      '#' -> "hash"+      c | not (isAscii c) -> "c" <> build (fromEnum c)+        | otherwise -> build [c]++-- | Turn text into valid anchor. Human-readability is not preserved.+mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown+mdEscapeAnchor = mdEscapeAnchorS . toString . unAnchor . toAnchor++mdRef :: Markdown -> Markdown -> Markdown+mdRef txt ref = "[" <> txt <> "](" <> ref <> ")"++mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown+mdLocalRef txt anchor = mdRef txt ("#" <> mdEscapeAnchor anchor)++mdAnchor :: ToAnchor anchor => anchor -> Markdown+mdAnchor name = "<a name=\"" <> mdEscapeAnchor name <> "\"></a>\n\n"++mdSeparator :: Markdown+mdSeparator = "---\n\n"++-- | Text which is hidden until clicked.+mdSpoiler :: Markdown -> Markdown -> Markdown+mdSpoiler name contents =+  mconcat $ intersperse "\n"+    [ "<details>"+    , "  <summary>" <> htmlBold (build name) <> "</summary>"+    , contents+    , "</details>"+    , "<p>"+    ]+  where+    -- Markdown's bold does not always work within spoiler header+    htmlBold txt = "<b>" <> txt <> "</b>"++mdComment :: Builder -> Builder+mdComment commentText =+  "<!---\n" +| commentText |+ "\n-->"++-- | Quasi quoter for Markdown.+--+-- This supports interpolation via @#{name}@ syntax.+--+-- Please note that we previously supported expressions inside interpolated splices. This is+-- no longer the case. Only literal variable names can be used.+--+-- 'md' is implemented in terms of 'iub', see "Morley.Util.Interpolate" for more+-- information on how interpolation works.+md :: QuasiQuoter+md = iub

+ src/Morley/Util/Named.hs view

@@ -0,0 +1,125 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Additional functionality for @named@ package.+module Morley.Util.Named+  ( (!)+  , (:!)+  , (:?)+  , (<:!>)+  , (<:?>)+  , ApplyNamedFunctor+  , NamedInner+  , KnownNamedFunctor (..)+  , NamedF (.., (:!), (:?), N, M, SomeArg, NoArg)+  , Name (..)+  , argDef+  ) where++import Control.Lens (Iso', Wrapped(..), iso)+import Data.Aeson (FromJSON, ToJSON)+import Data.Data (Data)+import Fmt (Buildable(..))+import GHC.TypeLits (KnownSymbol, symbolVal)+import Named (Name(..), NamedF(..), argDef, (!), (:!), (:?))+import qualified Text.Show++import Morley.Util.Label (Label)++-- | Convenience pattern synonym, use this instead of 'Named.arg' with @ViewPatterns@.+pattern (:!) :: Name name -> a -> NamedF Identity a name+pattern (:!) n v <- (decomposeNamedF -> (n, Identity v))+  where (:!) _ v = ArgF (Identity v)+{-# COMPLETE (:!) #-}++-- | Convenience pattern synonym, use this instead of 'Named.argF' with @ViewPatterns@.+pattern (:?) :: Name name -> Maybe a -> NamedF Maybe a name+pattern (:?) n v <- (decomposeNamedF -> (n, v))+  where (:?) _ v = ArgF v+{-# COMPLETE (:?) #-}++decomposeNamedF :: NamedF f a name -> (Name name, f a)+decomposeNamedF (ArgF fa) = (Name, fa)++-- | Convenience pattern synonym, use this instead of 'Named.arg' with @ViewPatterns@+-- when the @name@ can be inferred.+pattern N :: a -> NamedF Identity a name+pattern N a = ArgF (Identity a)+{-# COMPLETE N #-}++-- | Convenience pattern synonym, use this instead of 'Named.argF' with @ViewPatterns@+-- when the @name@ can be inferred. Matches only on @Just@ values+pattern SomeArg :: a -> NamedF Maybe a name+pattern SomeArg a = ArgF (Just a)++-- | Convenience pattern synonym, use this instead of 'Named.argF' with @ViewPatterns@+-- when the @name@ can be inferred. Matches only on @Nothing@ values+pattern NoArg :: NamedF Maybe a name+pattern NoArg = ArgF Nothing+{-# COMPLETE NoArg, SomeArg #-}++-- | Convenience pattern synonym for @NamedF Maybe name a@, use this instead of 'Named.argF' with @ViewPatterns@+-- when the @name@ can be inferred.+pattern M :: Maybe a -> NamedF Maybe a name+pattern M a = ArgF a+{-# COMPLETE M #-}++-- | Special version of 'Morley.Util.Named.(:!)' for monadic operations+(<:!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)+(<:!>) name = fmap (name :!)+infixl 4 <:!>++-- | Special version of 'Morley.Util.Named.(:?)' for monadic operations+(<:?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)+(<:?>) name = fmap (name :?)+infixl 4 <:?>++type family ApplyNamedFunctor (f :: Type -> Type) (a :: Type) where+  ApplyNamedFunctor Identity a = a+  ApplyNamedFunctor Maybe a = Maybe a++type family NamedInner (n :: Type) where+  NamedInner (NamedF f a _) = ApplyNamedFunctor f a++-- | Isomorphism between named entity and the entity itself wrapped into the+-- respective functor.+namedFL :: Label name -> Iso' (NamedF f a name) (f a)+namedFL _ = iso (\(ArgF x) -> x) ArgF++class KnownNamedFunctor f where+  -- | Isomorphism between named entity and the entity itself.+  namedL :: Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a)++instance KnownNamedFunctor Identity where+  namedL l = namedFL l . _Wrapped'++instance KnownNamedFunctor Maybe where+  namedL l = namedFL l++----------------------------------------------------------------------------+-- Instances+----------------------------------------------------------------------------++deriving stock instance Eq (f a) => Eq (NamedF f a name)+deriving stock instance Ord (f a) => Ord (NamedF f a name)++instance (Show a, KnownSymbol name) => Show (NamedF Identity a name) where+  show (ArgF a) = symbolVal (Proxy @name) <> " :! " <> show a++instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where+  build (ArgF a) = build (symbolVal (Proxy @name)) <> ": " <> build a++instance (NFData (f a)) => NFData (NamedF f a name) where+  rnf (ArgF a) = rnf a++deriving stock instance+  (Typeable f, Typeable a, KnownSymbol name, Data (f a)) =>+  Data (NamedF f a name)++deriving newtype instance ToJSON a => ToJSON (NamedF Identity a name)+deriving newtype instance ToJSON a => ToJSON (NamedF Maybe a name)+deriving newtype instance FromJSON a => FromJSON (NamedF Identity a name)+deriving newtype instance FromJSON a => FromJSON (NamedF Maybe a name)

+ src/Morley/Util/Peano.hs view

@@ -0,0 +1,316 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Type-nat utilities.+--+-- We take Peano numbers as base for operations because they make it+-- much easer to prove things to compiler. Their performance does not+-- seem to introduce a problem, because we use nats primarily along with+-- stack which is a linked list with similar performance characteristics.+--+-- Many of things we introduce here are covered in @type-natural@ package,+-- but unfortunatelly it does not work with GHC 8.6 at the moment of writing+-- this module. We use "Data.Vinyl" as source of Peano @Nat@ for now.+module Morley.Util.Peano+  ( -- * General+    Peano+    -- @gromak: I think we should not export Nat, but we want to+    -- export `Z` and `S` and I do not know how to do it without+    -- exporting `Nat`.+  , Nat (Z, S)+  , ToPeano+  , FromPeano+  , SingNat (SZ, SS)++  , Decrement+  , type (>)+  , peanoSing++  -- * Peano Arithmetic+  , type (>=)+  , peanoSingDecrement++  -- * Lists+  , Length+  , At+  , Drop+  , Take++    -- * Morley-specific utils+  , IsLongerThan+  , LongerThan+  , RequireLongerThan+  , IsLongerOrSameLength+  , LongerOrSameLength+  , RequireLongerOrSameLength++  -- * Length constraints 'Dict'ionaries+  , requireLongerThan+  , requireLongerOrSameLength++  -- * Length constraints 'Dict'ionaries+  , isGreaterThan+  , isGreaterEqualThan+  ) where++import Data.Constraint (Dict(..))+import Data.Singletons (Sing, SingI(..))+import Data.Vinyl (Rec(..))+import Data.Vinyl.TypeLevel (Nat(..), RLength)+import GHC.TypeLits (ErrorMessage(..), TypeError)+import GHC.TypeNats (type (+), type (-))+import qualified GHC.TypeNats as GHC+import Unsafe.Coerce (unsafeCoerce)++import Morley.Util.Type++----------------------------------------------------------------------------+-- General+----------------------------------------------------------------------------++-- | A convenient alias.+--+-- We are going to use 'Peano' numbers for type-dependent logic and+-- normal 'Nat's in user API, need to distinguish them somehow.+type Peano = Nat++type family ToPeano (n :: GHC.Nat) :: Peano where+  ToPeano 0 = 'Z+  ToPeano a = 'S (ToPeano (a - 1))++type family FromPeano (n :: Peano) :: GHC.Nat where+  FromPeano 'Z = 0+  FromPeano ('S a) = 1 + FromPeano a++-- | Get the peano singleton for a given type-level nat literal.+--+-- >>> peanoSing @2+-- SS (SS SZ)+peanoSing :: forall (n :: GHC.Nat). SingI (ToPeano n) => SingNat (ToPeano n)+peanoSing = sing @(ToPeano n)++data SingNat (n :: Nat) where+  SZ :: SingNat 'Z+  SS :: !(SingNat n) -> SingNat ('S n)++deriving stock instance Show (SingNat (n :: Nat))+deriving stock instance Eq (SingNat (n :: Nat))+instance NFData (SingNat (n :: Nat)) where+  rnf SZ = ()+  rnf (SS n) = rnf n++type instance Sing = SingNat++instance SingI 'Z where+  sing = SZ+instance SingI n => SingI ('S n) where+  sing = SS (sing @n)++----------------------------------------------------------------------------+-- Peano Arithmetic+----------------------------------------------------------------------------++type family Decrement (a :: Peano) :: Peano where+  Decrement 'Z = TypeError ('Text "Expected n > 0")+  Decrement ('S n) = n++-- | Utility to 'Decrement' a Peano 'Sing'leton.+--+-- Useful when dealing with the constraint+peanoSingDecrement :: Sing n -> Maybe (Sing (Decrement n))+peanoSingDecrement = \case+  SZ -> Nothing+  SS n -> pure n++type family (>) (x :: Peano) (y :: Peano) :: Bool where+  'Z   > _    = 'False+  'S _ > 'Z   = 'True+  'S x > 'S y = x > y++type family (>=) (x :: Peano) (y :: Peano) :: Bool where+  _      >= 'Z     = 'True+  'Z     >= _      = 'False+  ('S x) >= ('S y) = x >= y++----------------------------------------------------------------------------+-- Lists+----------------------------------------------------------------------------++type family Length l :: Peano where+  Length l = RLength l++type family At (n :: Peano) s where+  At 'Z (x ': _) = x+  At ('S n) (_ ': xs) = At n xs+  At a '[] =+    TypeError+      ('Text "You tried to access a non-existing element of the stack, n = " ':<>:+         'ShowType (FromPeano a))++type family Drop (n :: Peano) (s :: [k]) :: [k] where+  Drop  'Z s = s+  Drop ('S _) '[] = '[]+  Drop ('S n) (_ ': s) = Drop n s++type family Take (n :: Peano) (s :: [k]) :: [k] where+  Take  'Z _ = '[]+  Take _ '[] = '[]+  Take ('S n) (a ': s) = a ': Take n s++----------------------------------------------------------------------------+-- Morley-specific utils+----------------------------------------------------------------------------++-- Note that we could define type families to return 'Constraint' instead+-- of defining standalone constraint in form `c ~ 'True`, but apparently+-- such constraint would be weaker, e. g. there is an example when with+-- current approach there is no warning, but if we change the approach+-- to return 'Constraint' from type family then GHC complains about+-- non-exhaustive patterns (@gromak).+-- Also we use these `Bool` type families in more than one place, we generate+-- two constraints: one gives more information to GHC and another one produces+-- better error messages on failure.++-- | Comparison of type-level naturals, as a function.+--+-- It is as lazy on the list argument as possible - there is no+-- need to know the whole list if the natural argument is small enough.+-- This property is important if we want to be able to extract reusable+-- parts of code which are aware only of relevant part of stack.+type family IsLongerThan (l :: [k]) (a :: Peano) :: Bool where+  IsLongerThan (_ ': _) 'Z = 'True+  IsLongerThan (_ ': xs) ('S a) = IsLongerThan xs a+  IsLongerThan '[] _ = 'False++-- | Comparison of type-level naturals, as a constraint.+type LongerThan l a = IsLongerThan l a ~ 'True++-- | Similar to 'IsLongerThan', but returns 'True' when list length+-- equals to the passed number.+type family IsLongerOrSameLength (l :: [k]) (a :: Peano) :: Bool where+  IsLongerOrSameLength _ 'Z = 'True+  IsLongerOrSameLength (_ ': xs) ('S a) = IsLongerOrSameLength xs a+  IsLongerOrSameLength '[] ('S _) = 'False++-- | 'IsLongerOrSameLength' in form of constraint that gives most+-- information to GHC.+type LongerOrSameLength l a = IsLongerOrSameLength l a ~ 'True++{- | Evaluates list length.++This type family is a best-effort attempt to display neat error messages+when list is known only partially.++For instance, when called on @Int ': Int ': s@, the result will be+@OfLengthWithTail 2 s@ - compare with result of simple 'Length' -+@1 + 1 + Length s@.++For concrete types this will be identical to calling @FromPeano (Length l)@.+-}+type family OfLengthWithTail (acc :: GHC.Nat) (l :: [k]) :: GHC.Nat where+  OfLengthWithTail a '[] = a+  OfLengthWithTail a (_ ': xs) = OfLengthWithTail (a + 1) xs++type LengthWithTail l = OfLengthWithTail 0 l++-- | Comparison of type-level naturals, raises human-readable compile error+-- when does not hold.+--+-- Here we use the same approach as for 'RequireLongerOrSameLength', this+-- type family is internal.+type family RequireLongerThan' (l :: [k]) (a :: Nat) :: Constraint where+  RequireLongerThan' l a =+    If (IsLongerThan l a)+       (() :: Constraint)+       (TypeError+          ('Text "Stack element #" ':<>: 'ShowType (FromPeano a) ':<>:+           'Text " is not accessible" ':$$:+           'Text "Current stack has size of only " ':<>:+           'ShowType (LengthWithTail l) ':<>:+           'Text ":" ':$$: 'ShowType l+           ))++class (RequireLongerThan' l a, LongerThan l a) =>+  RequireLongerThan (l :: [k]) (a :: Peano)+instance (RequireLongerThan' l a, LongerThan l a) =>+  RequireLongerThan l a++-- | 'IsLongerOrSameLength' in form of constraint that produces+-- good error message. Should be used together with 'LongerThan'+-- because 'LongerThan' gives GHC more information.+-- We use it in combination, so that it gives enough information to+-- GHC and also producess good error messages.+type family RequireLongerOrSameLength' (l :: [k]) (a :: Peano) :: Constraint where+  RequireLongerOrSameLength' l a =+    If (IsLongerOrSameLength l a)+       (() :: Constraint)+       (TypeError+          ('Text "Expected stack with length >= " ':<>: 'ShowType (FromPeano a) ':$$:+           'Text "Current stack has size of only " ':<>:+           'ShowType (LengthWithTail l) ':<>:+           'Text ":" ':$$: 'ShowType l+           ))++-- | We can have+-- `RequireLongerOrSameLength = (RequireLongerOrSameLength' l a, LongerOrSameLength l a)`,+-- but apparently the printed error message can be caused by `LongerOrSameLength`+-- rather than `RequireLongerOrSameLength'`.+-- We do not know for sure how it all works, but we think that if we require constraint X before+-- Y (using multiple `=>`s) then X will always be evaluated first.+class (RequireLongerOrSameLength' l a, LongerOrSameLength l a) =>+  RequireLongerOrSameLength (l :: [k]) (a :: Peano)+instance (RequireLongerOrSameLength' l a, LongerOrSameLength l a) =>+  RequireLongerOrSameLength l a++instance MockableConstraint (RequireLongerOrSameLength l a) where+  unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerOrSameLength '[] 'Z)++instance MockableConstraint (RequireLongerThan l a) where+  unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerThan '[()] 'Z)++----------------------------------------------------------------------------+-- Length constraints 'Dict'ionaries+----------------------------------------------------------------------------++requireLongerThan+  :: Rec any stk+  -> Sing n+  -> Maybe (Dict (RequireLongerThan stk n))+requireLongerThan RNil _           = Nothing+requireLongerThan (_ :& _xs) SZ    = Just Dict+requireLongerThan (_ :& xs) (SS n) = do+  Dict <- requireLongerThan xs n+  return Dict++requireLongerOrSameLength+  :: Rec any stk+  -> Sing n+  -> Maybe (Dict (RequireLongerOrSameLength stk n))+requireLongerOrSameLength _ SZ             = Just Dict+requireLongerOrSameLength RNil (SS _)      = Nothing+requireLongerOrSameLength (_ :& xs) (SS n) = do+  Dict <- requireLongerOrSameLength xs n+  return Dict++----------------------------------------------------------------------------+-- Arith constraints 'Dict'ionaries+----------------------------------------------------------------------------++isGreaterThan+  :: Sing a -> Sing b+  -> Maybe (Dict ((a > b) ~ 'True))+isGreaterThan SZ _          = Nothing+isGreaterThan (SS _) SZ     = pure Dict+isGreaterThan (SS a) (SS b) = isGreaterThan a b++isGreaterEqualThan+  :: Sing a -> Sing b+  -> Maybe (Dict ((a >= b) ~ 'True))+isGreaterEqualThan _ SZ          = pure Dict+isGreaterEqualThan SZ _          = Nothing+isGreaterEqualThan (SS a) (SS b) = isGreaterEqualThan a b

+ src/Morley/Util/PeanoNatural.hs view

@@ -0,0 +1,90 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utility for 'PeanoNatural'+--+-- At the moment, we have no other libriaries with that would+-- provide effective implementation of type-level natural+-- numbers. So we define our own data type called @PeanoNatural@.+-- Using this type one may extract a term-level natural number+-- from a type-level one quite simply.+module Morley.Util.PeanoNatural+  ( PeanoNatural (Zero, Succ, One, Two)+  , toPeanoNatural+  , toPeanoNatural'+  , fromPeanoNatural+  , singPeanoVal+  ) where++import Data.Singletons (SingI(..))+import qualified GHC.TypeNats as GHC (Nat)+import Morley.Util.Peano (Nat(S, Z), SingNat(..), ToPeano)+import Text.PrettyPrint.Leijen.Text (integer)++import Morley.Michelson.Printer.Util++-- | PeanoNatural data type+--+-- The @PN@ constructor stores @s :: SingNat n@ and @k :: Natural@+-- with the following invariant:+-- if @PN s k :: PeanoNatural n@, then @k == n@.+-- This definition allows extracting values of Natural+-- without O(n) conversion from @SingNat n@.+data PeanoNatural (n :: Nat) = PN !(SingNat n) !Natural++deriving stock instance Show (PeanoNatural n)+deriving stock instance Eq (PeanoNatural n)++instance RenderDoc (PeanoNatural n) where+  renderDoc _ = integer . toInteger . fromPeanoNatural++instance NFData (PeanoNatural n) where+  rnf (PN s _) = rnf s++data MatchPS n where+  PS_Match :: PeanoNatural n -> MatchPS ('S n)+  PS_Mismatch :: MatchPS n++matchPS :: PeanoNatural n -> MatchPS n+matchPS (PN (SS m) k) = PS_Match (PN m (k - 1))+matchPS _ = PS_Mismatch++-- | Patterns 'Zero' and 'Succ'+-- We introduce pattern synonyms 'Zero' and 'Succ' assuming that+-- 'Zero' and 'Succ' cover all possible cases that satisfy the invariant.+-- Using these patterns, we also avoid cases when `k /= peanoValSing @n s`+pattern Zero :: () => (n ~ 'Z) => PeanoNatural n+pattern Zero = PN SZ 0++pattern Succ :: () => (n ~ 'S m) => PeanoNatural m -> PeanoNatural n+pattern Succ s <- (matchPS -> PS_Match s) where+  Succ (PN n k) = PN (SS n) (k+1)+{-# COMPLETE Zero, Succ #-}++-- | The following patterns are introduced for convenience.+-- This allow us to avoid writing @Succ (Succ Zero)@ in+-- several places.+pattern One :: () => (n ~ ('S 'Z)) => PeanoNatural n+pattern One = Succ Zero++pattern Two :: () => (n ~ ('S ('S 'Z))) => PeanoNatural n+pattern Two = Succ One++fromPeanoNatural :: forall n. PeanoNatural n -> Natural+fromPeanoNatural (PN _ n) = n++-- | toPeanoNatural and toPeanoNatural' connect PeanoNatural with+-- natural numbers known at run-time.+singPeanoVal :: forall (n :: Nat). SingNat n -> Natural+singPeanoVal = \case+  SZ   -> 0+  SS a -> 1 + singPeanoVal a++toPeanoNatural :: forall n. SingI n => PeanoNatural n+toPeanoNatural = let pSing = sing @n in+  PN pSing $ singPeanoVal pSing++toPeanoNatural'+  :: forall (n :: GHC.Nat). SingI (ToPeano n) => PeanoNatural (ToPeano n)+toPeanoNatural' = toPeanoNatural @(ToPeano n)

+ src/Morley/Util/Positive.hs view

@@ -0,0 +1,41 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Definition of 'Positive' type and related utilities.+module Morley.Util.Positive+  ( Positive (..)+  , mkPositive+  , lengthNE+  , replicateNE+  ) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Data (Data)+import Fmt (Buildable, pretty)+import qualified Unsafe (fromIntegral)++import Morley.Util.Instances ()++-- | Integer values starting from 1.+--+-- We define our own datatype in order to have 'Data' instance for it,+-- which can not be derived for third-party types without exported constructor.+newtype Positive = UnsafePositive { unPositive :: Natural }+  deriving stock (Eq, Ord, Data, Generic)+  deriving newtype (Show, Buildable, ToJSON, FromJSON)++instance NFData Positive++mkPositive :: forall i. (Integral i, Buildable i) => i -> Either Text Positive+mkPositive a+  | a > 0     = Right $ UnsafePositive (Unsafe.fromIntegral @i @Natural a)+  | otherwise = Left $ "Number is not positive: " <> pretty a++-- | Count length of non-empty list.+lengthNE :: NonEmpty a -> Positive+lengthNE = UnsafePositive . Unsafe.fromIntegral @Int @Natural . length++-- | Produce a non empty list consisting of the given value.+replicateNE :: Positive -> a -> NonEmpty a+replicateNE (UnsafePositive i) a = a :| replicate (Unsafe.fromIntegral @Natural @Int i - 1) a

+ src/Morley/Util/Sing.hs view

@@ -0,0 +1,93 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.Sing+  ( eqI+  , eqParamSing+  , eqParamSing2+  , eqParamSing3+  , castSing+  , SingI1(..)+  ) where++import Data.Singletons (KindOf, Sing, SingI, sing)+import Data.Singletons.Decide (SDecide, decideEquality)+import Data.Type.Equality (TestEquality(..), (:~:)(..))+import Data.Typeable (eqT)++-- | Version of 'testEquality' that uses 'SingI'+eqI :: forall a b. (SingI a, SingI b, TestEquality (Sing @(KindOf a))) => Maybe (a :~: b)+eqI = testEquality (sing @a) (sing @b)++-- | Suppose you have a data type @X@ with parameter @a@ and you have+-- two values: @x1 :: X a1@ and @x2 :: X a2@. You can't compare them+-- using '==', because they have different types. However, you can+-- compare them using 'eqParamSing' as long as both parameters have+-- SingI instances and their kind is `SDecide`.+eqParamSing ::+  forall a1 a2 t.+  ( SingI a1+  , SingI a2+  , SDecide (KindOf a1)+  , Eq (t a1)+  )+  => t a1+  -> t a2+  -> Bool+eqParamSing t1 t2 = isJust @() $ do+  Refl <- sing @a1 `decideEquality` sing @a2+  guard (t1 == t2)++-- | Version of 'eqParamSing' for types with 2 parameters.+eqParamSing2 ::+  forall a1 a2 b1 b2 t.+  ( SingI a1+  , SingI a2+  , SingI b1+  , SingI b2+  , SDecide (KindOf a1)+  , SDecide (KindOf b1)+  , Eq (t a1 b2)+  )+  => t a1 b1+  -> t a2 b2+  -> Bool+eqParamSing2 t1 t2 = isJust @() $ do+  Refl <- sing @a1 `decideEquality` sing @a2+  Refl <- sing @b1 `decideEquality` sing @b2+  guard (t1 == t2)++-- | Version of 'eqParamSing' for types with 3 parameters.+eqParamSing3 ::+  forall instr1 instr2 a1 a2 b1 b2 t.+  ( Typeable instr1+  , Typeable instr2+  , SingI a1+  , SingI a2+  , SingI b1+  , SingI b2+  , SDecide (KindOf a1)+  , SDecide (KindOf b1)+  , Eq (t instr1 a1 b1)+  )+  => t instr1 a1 b1+  -> t instr2 a2 b2+  -> Bool+eqParamSing3 t1 t2 = isJust @() $ do+  Refl <- eqT @instr1 @instr2+  Refl <- sing @a1 `decideEquality` sing @a2+  Refl <- sing @b1 `decideEquality` sing @b2+  guard (t1 == t2)++castSing :: forall a b t.+  (SingI a, SingI b, SDecide (KindOf a))+  => t a+  -> Maybe (t b)+castSing ca = do+  Refl <- sing @a `decideEquality` sing @b+  return ca++-- Second-order analogue of 'SingI'+class SingI1 f where+  withSingI1 :: forall x r. SingI x => (SingI (f x) => r) -> r

+ src/Morley/Util/TH.hs view

@@ -0,0 +1,64 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.TH+  ( deriveGADTNFData+  , lookupTypeNameOrFail+  , isTypeAlias+  ) where++import Language.Haskell.TH++-- | Generates an NFData instance for a GADT. /Note:/ This will not generate+-- additional constraints to the generated instance if those are required.+deriveGADTNFData :: Name -> Q [Dec]+deriveGADTNFData name = do+  seqQ <- [| seq |]+  unit <- [| () |]+  (TyConI (DataD _ dataName vars _ cons _)) <- reify name+  let+    getNameFromVar (PlainTV n) = n+    getNameFromVar (KindedTV n _) = n++    -- Unfolds multiple constructors of form "A, B, C :: A -> Stuff"+    -- into a list of tuples of constructor names and their data+    unfoldConstructor (GadtC cs bangs _) = map (,bangs) cs+    unfoldConstructor (ForallC _ _ c) = unfoldConstructor c+    unfoldConstructor _ = fail "Non GADT constructors are not supported."++    -- Constructs a clause "rnf (ConName a1 a2 ...) = rnf a1 `seq` rnf a2 `seq` rnf a3 `seq` ..."+    makeClauses (conName, bangs) = do+        varNames <- traverse (\_ -> newName "a") bangs+        let rnfVar = VarE 'rnf+        let rnfExp = AppE rnfVar . VarE+        let infixSeq e1 e2 = InfixE (Just e1) seqQ (Just e2)+        return $+          (Clause+            [ConP conName $ map VarP varNames]+            (NormalB $ foldl' infixSeq unit (map rnfExp varNames))+            []+          )++    nfDataT =+      AppT (ConT $ mkName "NFData") . foldl' AppT (ConT dataName) $+        map (VarT . getNameFromVar) vars++    makeInstance clauses =+      InstanceD Nothing [] nfDataT [FunD (mkName "rnf") clauses]+++  clauses <- traverse makeClauses $ cons >>= unfoldConstructor+  return [makeInstance clauses]++lookupTypeNameOrFail :: String -> Q Name+lookupTypeNameOrFail typeStr =+  lookupTypeName typeStr >>= \case+    Nothing -> fail $ "Failed type name lookup for: '" <> typeStr <> "'."+    Just tn -> pure tn++-- | Check if name is a @type@+isTypeAlias :: Name -> Q Bool+isTypeAlias typeName = reify typeName <&> \case+  TyConI (TySynD {}) -> True+  _ -> False

+ src/Morley/Util/Text.hs view

@@ -0,0 +1,26 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.Text+  ( headToLower+  , surround+  , dquotes+  ) where++import Data.Char (toLower)+import qualified Data.Text as T++-- | Leads first character of text to lower case.+--+-- For empty text this will throw an error.+headToLower :: HasCallStack => Text -> Text+headToLower txt = case T.uncons txt of+  Nothing -> error "Empty text"+  Just (c, cs) -> T.cons (toLower c) cs++surround :: Semigroup a => a -> a -> a -> a+surround pre post content = pre <> content <> post++dquotes :: (Semigroup a, IsString a) => a -> a+dquotes = surround "\"" "\""

+ src/Morley/Util/Type.hs view

@@ -0,0 +1,239 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE QuantifiedConstraints #-}++-- | General type utilities.+module Morley.Util.Type+  ( type (==)+  , If+  , type (++)+  , IsElem+  , type (/)+  , type (//)+  , Guard+  , FailWhen+  , FailUnless+  , failUnlessEvi+  , failWhenEvi+  , AllUnique+  , RequireAllUnique+  , ReifyList (..)+  , PatternMatch+  , PatternMatchL+  , KnownList (..)+  , KList (..)+  , RSplit+  , rsplit+  , Some1 (..)+  , recordToSomeList++  , reifyTypeEquality++  , ConcatListOfTypesAssociativity+  , listOfTypesConcatAssociativityAxiom++  , MockableConstraint (..)++  , onFirst+  ) where++import Data.Constraint (Dict(..), (:-)(..), (\\))+import Data.Type.Bool (If, Not, type (&&))+import Data.Type.Equality (type (==))+import Data.Vinyl.Core (Rec(..))+import qualified Data.Vinyl.Functor as Vinyl+import Data.Vinyl.Recursive (recordToList, rmap)+import Data.Vinyl.TypeLevel (type (++))+import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)+import Unsafe.Coerce (unsafeCoerce)++type family IsElem (a :: k) (l :: [k]) :: Bool where+  IsElem _ '[] = 'False+  IsElem a (a ': _) = 'True+  IsElem a (_ ': as) = IsElem a as++-- | Remove all occurences of the given element.+type family (l :: [k]) / (a :: k) where+  '[] / _ = '[]+  (a ': xs) / a = xs / a+  (b ': xs) / a = b ': (xs / a)++-- | Difference between two lists.+type family (l1 :: [k]) // (l2 :: [k]) :: [k] where+  l // '[] = l+  l // (x ': xs) = (l / x) // xs++type family Guard (cond :: Bool) (a :: k) :: Maybe k where+  Guard 'False _ = 'Nothing+  Guard 'True a = 'Just a++-- | Fail with given error if the condition does not hold.+type family FailUnless (cond :: Bool) (msg :: ErrorMessage) :: Constraint where+  FailUnless 'True _ = ()+  FailUnless 'False msg = TypeError msg++-- | Fail with given error if the condition holds.+type FailWhen cond msg = FailUnless (Not cond) msg++-- | A natural conclusion from the fact that an error has not occurred.+failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True)+failUnlessEvi = Sub unsafeProvideConstraint++failWhenEvi :: forall cond msg. FailWhen cond msg :- (cond ~ 'False)+failWhenEvi = Sub unsafeProvideConstraint++type family AllUnique (l :: [k]) :: Bool where+  AllUnique '[] = 'True+  AllUnique (x : xs) = Not (IsElem x xs) && AllUnique xs++type RequireAllUnique desc l = RequireAllUnique' desc l l++type family RequireAllUnique' (desc :: Symbol) (l :: [k]) (origL ::[k]) :: Constraint where+  RequireAllUnique' _ '[] _ = ()+  RequireAllUnique' desc (x : xs) origL =+    If (IsElem x xs)+       (TypeError ('Text "Duplicated " ':<>: 'Text desc ':<>: 'Text ":" ':$$:+                   'ShowType x ':$$:+                   'Text "Full list: " ':<>:+                   'ShowType origL+                  )+       )+       (RequireAllUnique' desc xs origL)++-- | Make sure given type is evaluated.+-- This type family fits only for types of 'Type' kind.+type family PatternMatch (a :: Type) :: Constraint where+  PatternMatch Int = ((), ())+  PatternMatch _ = ()++type family PatternMatchL (l :: [k]) :: Constraint where+  PatternMatchL '[] = ((), ())+  PatternMatchL _ = ()++-- | Bring type-level list at term-level using given function+-- to demote its individual elements.+class ReifyList (c :: k -> Constraint) (l :: [k]) where+  reifyList :: (forall a. c a => Proxy a -> r) -> [r]++instance ReifyList c '[] where+  reifyList _ = []++instance (c x, ReifyList c xs) => ReifyList c (x ': xs) where+  reifyList reifyElem = reifyElem (Proxy @x) : reifyList @_ @c @xs reifyElem++-- | Reify type equality from boolean equality.+reifyTypeEquality :: forall a b x. (a == b) ~ 'True => (a ~ b => x) -> x+reifyTypeEquality x = x \\ unsafeProvideConstraint @(a ~ b)++-- | Similar to @SingI []@, but does not require individual elements to be also+-- instance of @SingI@.+class KnownList l where+  klist :: KList l+instance KnownList '[] where+  klist = KNil+instance KnownList xs => KnownList (x ': xs) where+  klist = KCons Proxy Proxy++-- | @Data.List.Singletons.SList@ analogue for 'KnownList'.+data KList (l :: [k]) where+  KNil :: KList '[]+  KCons :: KnownList xs => Proxy x -> Proxy xs -> KList (x ': xs)++type RSplit l r = KnownList l++-- | Split a record into two pieces.+rsplit+  :: forall k (l :: [k]) (r :: [k]) f.+      (RSplit l r)+  => Rec f (l ++ r) -> (Rec f l, Rec f r)+rsplit = case klist @l of+  KNil -> (RNil, )+  KCons{} -> \(x :& r) ->+    let (x1, r1) = rsplit r+    in (x :& x1, r1)++-- | A value of type parametrized with /some/ type parameter.+data Some1 (f :: k -> Type) =+  forall a. Some1 (f a)++deriving stock instance (forall a. Show (f a)) => Show (Some1 f)++recordToSomeList :: Rec f l -> [Some1 f]+recordToSomeList = recordToList . rmap (Vinyl.Const . Some1)++type ConcatListOfTypesAssociativity a b c = ((a ++ b) ++ c) ~ (a ++ (b ++ c))++-- | GHC can't deduce this itself because+-- in general a type family might be not associative,+-- what brings extra difficulties and redundant constraints,+-- especially if you have complex types.+-- But (++) type family is associative, so let's define this small hack.+listOfTypesConcatAssociativityAxiom :: forall a b c . Dict (ConcatListOfTypesAssociativity a b c)+listOfTypesConcatAssociativityAxiom = unsafeProvideConstraint++-- | Constaints that can be provided on demand.+--+-- Needless to say, this is a pretty unsafe operation. This typeclass makes+-- using it safer in a sense that getting a segfault becomes harder, but still+-- it deceives the type system and should be used only if providing a proper+-- proof would be too difficult.+class MockableConstraint (c :: Constraint) where+  -- | Produce a constraint out of thin air.+  unsafeProvideConstraint :: Dict c++instance MockableConstraint (a ~ b) where+  unsafeProvideConstraint = unsafeCoerce $ Dict @(Int ~ Int)++-- | In majority of the cases we don't want to mock typeclass constraints+-- since coercing instances of typeclasses with methods is utterly unsafe.+instance {-# OVERLAPPABLE #-} c a => MockableConstraint (c a) where+  unsafeProvideConstraint = Dict++instance ( MockableConstraint c1+         , MockableConstraint c2+         ) => MockableConstraint (c1, c2) where+  unsafeProvideConstraint = runIdentity $ do+    Dict <- pure $ unsafeProvideConstraint @c1+    Dict <- pure $ unsafeProvideConstraint @c2+    return Dict+  {-# INLINE unsafeProvideConstraint #-}++instance ( MockableConstraint c1+         , MockableConstraint c2+         , MockableConstraint c3+         ) => MockableConstraint (c1, c2, c3) where+  unsafeProvideConstraint = runIdentity $ do+    Dict <- pure $ unsafeProvideConstraint @(c1, c2)+    Dict <- pure $ unsafeProvideConstraint @c3+    return Dict+  {-# INLINE unsafeProvideConstraint #-}++instance ( MockableConstraint c1+         , MockableConstraint c2+         , MockableConstraint c3+         , MockableConstraint c4+         ) => MockableConstraint (c1, c2, c3, c4) where+  unsafeProvideConstraint = runIdentity $ do+    Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3)+    Dict <- pure $ unsafeProvideConstraint @c4+    return Dict+  {-# INLINE unsafeProvideConstraint #-}++instance ( MockableConstraint c1+         , MockableConstraint c2+         , MockableConstraint c3+         , MockableConstraint c4+         , MockableConstraint c5+         ) => MockableConstraint (c1, c2, c3, c4, c5) where+  unsafeProvideConstraint = runIdentity $ do+    Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3, c4)+    Dict <- pure $ unsafeProvideConstraint @c5+    return Dict+  {-# INLINE unsafeProvideConstraint #-}++-- | Utility function to help transform the first argument of a binfunctor.+onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c+onFirst = flip first

+ src/Morley/Util/TypeLits.hs view

@@ -0,0 +1,102 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Re-exports "GHC.TypeLits", modifying it considering our practices.+module Morley.Util.TypeLits+  ( Symbol+  , KnownSymbol+  , AppendSymbol+  , symbolVal+  , symbolValT+  , symbolValT'++  , TypeError+  , ErrorMessage (..)++  , TypeErrorUnless+  , AssertTypesEqual+  ) where++import Data.Type.Equality+import GHC.TypeLits++symbolValT :: forall s. KnownSymbol s => Proxy s -> Text+symbolValT = toText . symbolVal++symbolValT' :: forall s. KnownSymbol s => Text+symbolValT' = symbolValT (Proxy @s)++-- | Conditional type error.+--+-- There is a very subtle difference between 'TypeErrorUnless' and the following type family:+--+-- > type family TypeErrorUnlessAlternative (cond :: Bool) (err :: ErrorMessage) :: Constraint where+-- >   TypeErrorUnlessAlternative cond err =+-- >     ( If cond+-- >         (() :: Constraint)+-- >         (TypeError err)+-- >     , cond ~ 'True+-- >     )+--+-- If @cond@ cannot be fully reduced (e.g. it's a stuck type family), then:+--+-- * @TypeErrorUnless@ will state that the constraint cannot be deduced.+-- * @TypeErrorUnlessAlternative@ will fail with the given error message @err@.+--+-- For example:+--+-- > -- Partial function+-- > type family IsZero (n :: Peano) :: Bool where+-- >   IsZero ('S _) = 'False+-- >+-- > f1 :: TypeErrorUnless (IsZero n) ('Text "Expected zero") => ()+-- > f1 = ()+-- >+-- > f2 :: TypeErrorUnlessAlternative (IsZero n) ('Text "Expected zero") => ()+-- > f2 = ()+-- >+-- >+-- > f1res = f1 @'Z+-- > -- • Couldn't match type ‘IsZero 'Z’ with ‘'True’+-- >+-- > f2res = f2 @'Z+-- > -- • Expected zero+--+-- As you can see, the error message in @f2res@ is misleading (because the type argument+-- actually _is_ zero), so it's preferable to fail with the standard GHC error message.+type TypeErrorUnless (cond :: Bool) (err :: ErrorMessage) =+  ( TypeErrorUnlessHelper cond err+  -- Note: the '~' constraint below might seem redundant, but, without it,+  -- GHC would warn that the following pattern match is not exhaustive (even though it is):+  --+  -- > f :: TypeErrorUnless (n >= ToPeano 2) "some err msg" => Sing n -> ()+  -- > f = \case+  -- >   SS (SS SZ) -> ()+  -- >   SS (SS _) -> ()+  --+  -- GHC needs to "see" the type equality '~' in order to actually "learn" something from a+  -- type family's result.+  , cond ~ 'True+  )++type family TypeErrorUnlessHelper (cond :: Bool) (err :: ErrorMessage) :: Constraint where+  TypeErrorUnlessHelper 'True _ = ()+  TypeErrorUnlessHelper 'False err = TypeError err++-- | Condition Error helper to check if two types are equal+--+-- >>> :k! AssertTypesEqual Int Int ('Text "This should not result in a failure")+-- AssertTypesEqual Int Int ('Text "This should not result in a failure") :: Constraint+-- = (() :: Constraint, Int ~ Int)+--+-- >>> :k! AssertTypesEqual Bool Int ('Text "This should result in a failure")+-- AssertTypesEqual Bool Int ('Text "This should result in a failure") :: Constraint+-- = ((TypeError ...), Bool ~ Int)+type AssertTypesEqual a b (err :: ErrorMessage) =+  ( TypeErrorUnlessHelper (a == b) err+  -- The reasons for the constraint below are the same as those in @TypeErrorUnless@ constructor+  , a ~ b+  )

+ src/Morley/Util/TypeTuple.hs view

@@ -0,0 +1,11 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Conversions between tuples and list-like types.+module Morley.Util.TypeTuple+  ( RecFromTuple (..)+  ) where++import Morley.Util.TypeTuple.Class+import Morley.Util.TypeTuple.Instances ()

+ src/Morley/Util/TypeTuple/Class.hs view

@@ -0,0 +1,17 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.TypeTuple.Class+  ( RecFromTuple (..)+  ) where++-- | Building a record from tuple.+--+-- It differs from similar typeclass in "Data.Vinyl.FromTuple" module in that+-- it allows type inference outside-in - knowing desired 'Type' you know which+-- tuple should be provided - this improves error messages when constructing+-- concrete 'Type' objects.+class RecFromTuple r where+  type IsoRecTuple r :: Type+  recFromTuple :: IsoRecTuple r -> r

+ src/Morley/Util/TypeTuple/Instances.hs view

@@ -0,0 +1,19 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++module Morley.Util.TypeTuple.Instances () where++import Data.Vinyl.Core (Rec(..))++import Morley.Util.TypeTuple.Class+import Morley.Util.TypeTuple.TH++concatMapM deriveRecFromTuple (0 : [2..25])+-- ↑ We skip 1-ary tuple because it is GHC.Tuple.Unit, and we don't want it.++instance RecFromTuple (Rec f '[a]) where+  type IsoRecTuple (Rec f '[a]) = f a+  recFromTuple a = a :& RNil

+ src/Morley/Util/TypeTuple/TH.hs view

@@ -0,0 +1,39 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE QuasiQuotes #-}++-- | Template haskell generator for 'RecFromTuple', in a separate module+-- because of staging restrictions.+module Morley.Util.TypeTuple.TH+  ( deriveRecFromTuple+  ) where++import Data.Vinyl.Core (Rec(..))+import qualified Language.Haskell.TH as TH++import Morley.Util.TypeTuple.Class++-- | Produce 'RecFromTuple' instance for tuple of the given length.+deriveRecFromTuple :: Word16 -> TH.Q [TH.Dec]+deriveRecFromTuple (fromIntegral -> n) = do+  fVar <- TH.VarT <$> TH.newName "f"+  tyVars <- replicateM n $ TH.VarT <$> TH.newName "x"++  let consTy ty lty = TH.promotedConsT `TH.appT` pure ty `TH.appT` lty+  let tyList = foldr consTy TH.promotedNilT tyVars++  let tupleConsTy acc ty = acc `TH.appT` (pure fVar `TH.appT` pure ty)+  let tyTuple = foldl tupleConsTy (TH.tupleT n) tyVars++  vars <- replicateM n $ TH.newName "a"+  let tyPat = pure . TH.TupP $ map TH.VarP vars++  let consRec var acc = [e|(:&)|] `TH.appE` TH.varE var `TH.appE` acc+  let recRes = foldr consRec [e|RNil|] vars++  [d| instance RecFromTuple (Rec ($(pure fVar) :: u -> Type) $tyList) where+        type IsoRecTuple (Rec $(pure fVar) $tyList) = $tyTuple+        recFromTuple $tyPat = $recRes+    |]

+ src/Morley/Util/Typeable.hs view

@@ -0,0 +1,148 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE QuantifiedConstraints #-}++-- | Utility for 'Typeable'.+module Morley.Util.Typeable+  ( eqParam1+  , eqParam2+  , eqParam3+  , eqExt+  , compareExt+  , castIgnoringPhantom+  , eqTypeIgnoringPhantom+    -- * Re-exports+  , (:~:) (..)+  , eqT+  ) where++import Data.Coerce (coerce)+import Data.Typeable (eqT, typeRep, (:~:)(..))+import qualified Type.Reflection as Refl++-- | Suppose you have a data type @X@ with parameter @a@ and you have+-- two values: @x1 :: X a1@ and @x2 :: X a2@. You can't compare them+-- using '==', because they have different types. However, you can+-- compare them using 'eqParam1' as long as both parameters are+-- 'Typeable'.+eqParam1 ::+     forall a1 a2 t.+     ( Typeable a1+     , Typeable a2+     , Eq (t a1)+     )+  => t a1+  -> t a2+  -> Bool+eqParam1 t1 t2 = isJust @() $ do+  Refl <- eqT @a1 @a2+  guard (t1 == t2)++-- | Version of 'eqParam1' for types with 2 parameters.+eqParam2 ::+     forall a1 a2 b1 b2 t.+     ( Typeable a1+     , Typeable a2+     , Typeable b1+     , Typeable b2+     , Eq (t a1 b2)+     )+  => t a1 b1+  -> t a2 b2+  -> Bool+eqParam2 t1 t2 = isJust @() $ do+  Refl <- eqT @a1 @a2+  Refl <- eqT @b1 @b2+  guard (t1 == t2)++-- | Version of 'eqParam1' for types with 3 parameters.+eqParam3 ::+     forall a1 a2 b1 b2 c1 c2 t.+     ( Typeable a1+     , Typeable a2+     , Typeable b1+     , Typeable b2+     , Typeable c1+     , Typeable c2+     , Eq (t a1 b1 c1)+     )+  => t a1 b1 c1+  -> t a2 b2 c2+  -> Bool+eqParam3 t1 t2 = isJust @() $ do+  Refl <- eqT @a1 @a2+  Refl <- eqT @b1 @b2+  Refl <- eqT @c1 @c2+  guard (t1 == t2)++-- | Compare two entries of completely different types.+eqExt ::+     forall a1 a2.+     ( Typeable a1+     , Typeable a2+     , Eq a1+     )+  => a1+  -> a2+  -> Bool+eqExt a1 a2 = isJust @() $ do+  Refl <- eqT @a1 @a2+  guard (a1 == a2)++-- | Extension of 'eqExt' to 'compare' function.+compareExt ::+     forall a1 a2.+     ( Typeable a1+     , Typeable a2+     , Ord a1+     )+  => a1+  -> a2+  -> Ordering+compareExt t1 t2 =+  case eqT @a1 @a2 of+    Nothing -> typeRep (Proxy @a1) `compare` typeRep (Proxy @a2)+    Just Refl -> t1 `compare` t2++{- | Cast to a type with phantom type argument without matching this argument.+The phantom type must be the last type argument of the type.++Example of use: imagine a type++@+data MyType a = MyType+@++Normally, if object of this type was hidden under existential quantification with+'Typeable' constraint, then in order to get it back with 'Data.Typeable.cast' you need to know+the exact type of the hidden object, including its phantom type parameter.+With 'castIgnoringPhantom' you get a way to extract this object no matter which+phantom argument it had.+-}+castIgnoringPhantom+  :: forall c x.+     ( Typeable x, Typeable c+     , forall phantom1 phantom2. Coercible (c phantom1) (c phantom2)+     )+  => x -> Maybe (c DummyPhantomType)+castIgnoringPhantom x = do+  Refl.App x1Rep _ <- pure $ Refl.typeOf x+  let cRep = Refl.typeRep @c+  Refl.HRefl <- Refl.eqTypeRep x1Rep cRep+  return (coerce x)++type family DummyPhantomType :: k where++-- | Match given type against another type of @* -> *@ kind without caring+-- about its type argument.+eqTypeIgnoringPhantom+  :: forall c x r.+     (Typeable x, Typeable c)+  => (forall a. Typeable a => (c a :~: x) -> Proxy a -> r) -> Maybe r+eqTypeIgnoringPhantom cont = do+  Refl.App x1Rep xArgRep <- pure $ Refl.typeRep @x+  let cRep = Refl.typeRep @c+  Refl.HRefl <- Refl.eqTypeRep x1Rep cRep+  return $ Refl.withTypeable xArgRep (cont Refl Proxy)

− src/Tezos/Address.hs

@@ -1,347 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Address in Tezos.--{-# LANGUAGE DeriveLift #-}--module Tezos.Address-  ( ContractHash (..)-  , Address (..)-  , mkKeyAddress-  , detGenKeyAddress--  , OriginationIndex (..)-  , GlobalCounter(..)-  , mkContractHashHack--  -- * Formatting-  , ParseAddressError (..)-  , ParseAddressRawError (..)-  , ParseContractAddressError (..)-  , formatAddress-  , mformatAddress-  , parseAddressRaw-  , parseContractHash-  , parseAddress-  , ta-  , unsafeParseAddressRaw-  , unsafeParseAddress-  , unsafeParseContractHash-  ) where--import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encoding as Aeson-import qualified Data.Aeson.Types as AesonTypes-import qualified Data.ByteString as BS-import Data.Text (strip)-import Fmt (Buildable(build), hexF, pretty)-import Instances.TH.Lift ()-import qualified Language.Haskell.TH.Quote as TH-import qualified Language.Haskell.TH.Syntax as TH-import Language.Haskell.TH.Syntax (Lift)-import Text.PrettyPrint.Leijen.Text ((<+>), backslash, dquotes, int, parens)--import Michelson.Printer.Util (RenderDoc (..), buildRenderDoc, renderAnyBuildable)-import Michelson.Text-import Tezos.Crypto-import Util.CLI-import Util.TypeLits---- TODO: we should probably have a `Hash` type.--- | Hash of origination command for some contract.-newtype ContractHash = ContractHash ByteString-  deriving stock (Show, Eq, Ord, Generic, Lift)--instance NFData ContractHash---- We know that the length must be 20.--- Currently it's hardcoded here, later we'll probably have a `Hash` type.--- | Length of contract hash in bytes (only hash itself, no tags, checksums--- or anything).-contractHashLengthBytes :: Integral n => n-contractHashLengthBytes = 20---- | Data type corresponding to address structure in Tezos.-data Address-  = KeyAddress KeyHash-  -- ^ `tz` address which is a hash of a public key.-  | ContractAddress ContractHash-  -- ^ `KT` address which corresponds to a callable contract.-  deriving stock (Show, Eq, Ord, Generic, Lift)--instance NFData Address---- | Smart constructor for 'KeyAddress'.-mkKeyAddress :: PublicKey -> Address-mkKeyAddress = KeyAddress . hashKey---- | Deterministically generate a random 'KeyAddress' and discard its--- secret key.-detGenKeyAddress :: ByteString -> Address-detGenKeyAddress = mkKeyAddress . toPublic . detSecretKey---- | Represents the network's global counter.------ When a new contract is created (either via a "global" origination operation or--- via a @CREATE_CONTRACT@ instruction), this counter is used to create a new address for it--- (see 'mkContractAddress').------ The counter is incremented after every operation, and thus ensures that these--- addresses are unique (i.e. origination of identical contracts with identical metadata will--- result in different addresses.)------ In Tezos each operation has a special field called @counter@, see here:--- https://gitlab.com/tezos/tezos/-/blob/397dd233a10cc6df0df959e2a624c7947997dd0c/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L113-120------ This counter seems to be a part of global state of Tezos network. In fact, it may be observed--- in raw JSON representation of the operation in the network explorer.------ Our counter is represented as 'Word64', while in Tezos it is unbounded. We believe that--- for our interpreter it should not matter.-newtype GlobalCounter = GlobalCounter { unGlobalCounter :: Word64 }-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)-  deriving newtype (ToJSON, FromJSON, Num)---- | When a transfer operation triggers multiple @CREATE_CONTRACT@--- instructions, using 'GlobalCounter' to compute those contracts' addresses--- is not enough to ensure their uniqueness.------ For that reason, we also keep track of an 'OriginationIndex' that starts out as 0--- when a transfer is initiated, and is incremented every time a @CREATE_CONTRACT@--- instruction is interpreted.------ See 'mkContractAddress'.-newtype OriginationIndex = OriginationIndex { unOriginationIndex :: Int32 }-  deriving stock (Show, Eq, Ord, Generic)-  deriving anyclass (NFData)---- | Create a dummy 'ContractHash' value by hashing given 'ByteString'.------ Use in tests **only**.-mkContractHashHack :: ByteString -> ContractHash-mkContractHashHack = ContractHash . blake2b160--------------------------------------------------------------------------------- Formatting/parsing--------------------------------------------------------------------------------- It's a magic constant used by Tezos to encode a contract address.--- It was deduced empirically.-contractAddressPrefix :: ByteString-contractAddressPrefix = "\2\90\121"--formatContractHash :: ContractHash -> Text-formatContractHash (ContractHash bs) =-  encodeBase58Check (contractAddressPrefix <> bs)--formatAddress :: Address -> Text-formatAddress =-  \case-    KeyAddress h -> formatKeyHash h-    ContractAddress h -> formatContractHash h--mformatAddress :: Address -> MText-mformatAddress = unsafeMkMText . formatAddress--instance Buildable Address where-  build = build . formatAddress---- | Errors that can happen during address parsing.-data ParseAddressError-  = ParseAddressWrongBase58Check-  -- ^ Address is not in Base58Check format.-  | ParseAddressBothFailed CryptoParseError ParseContractAddressError-  -- ^ Both address parsers failed with some error.-  deriving stock (Show, Eq, Generic)--instance NFData ParseAddressError--instance Buildable ParseAddressError where-  build = buildRenderDoc--instance RenderDoc ParseAddressError where-  renderDoc context =-    \case-      ParseAddressWrongBase58Check -> "Wrong base58check format"-      ParseAddressBothFailed pkErr contractErr ->-        mconcat-        [ "Address is neither `KeyAddress` "-        , parens $ renderDoc context pkErr-        , ", nor `ContractAddress` "-        , parens $ renderDoc context contractErr-        ]---- | Parse an address from its human-readable textual representation--- used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"). Or--- fail if it's invalid.-parseAddress :: Text -> Either ParseAddressError Address-parseAddress addressText =-  case parseKeyHash addressText of-    Left CryptoParseWrongBase58Check -> Left ParseAddressWrongBase58Check-    Left keyAddrErr -> first (ParseAddressBothFailed keyAddrErr) $-      ContractAddress <$> parseContractHash addressText-    Right keyHash -> Right (KeyAddress keyHash)--data ParseAddressRawError-  = ParseAddressRawWrongSize ByteString-  -- ^ Raw bytes representation of an address has invalid length.-  | ParseAddressRawInvalidPrefix ByteString-  -- ^ Raw bytes representation of an address has incorrect prefix.-  | ParseAddressRawMalformedSeparator ByteString-  -- ^ Raw bytes representation of an address does not end with "\00".-  deriving stock (Eq, Show, Generic)--instance NFData ParseAddressRawError--instance RenderDoc ParseAddressRawError where-  renderDoc _ =-    \case-      ParseAddressRawInvalidPrefix prefix ->-        "Invalid prefix for raw address" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"-      ParseAddressRawWrongSize addr -> "Given raw address+" <+>-        (renderAnyBuildable $ hexF addr) <+> "has invalid length" <+> int (length addr)-      ParseAddressRawMalformedSeparator addr -> "Given raw address+" <+> (renderAnyBuildable $ hexF addr) <+>-        "does not end with" <+> dquotes (backslash <> "00")--instance Buildable ParseAddressRawError where-  build = buildRenderDoc---- | Parse the given address in its raw byte form used by Tezos--- (e.g "01521139f84791537d54575df0c74a8084cc68861c00")) . Or fail otherwise--- if it's invalid.-parseAddressRaw :: ByteString -> Either ParseAddressRawError Address-parseAddressRaw (BS.splitAt 2 -> (prefix, address)) =-  case BS.take 1 prefix of-    "\00" -> parseKeyAddressRaw (BS.tail prefix) address-    "\01" -> parseContractAddressRaw prefix address-    _ -> Left $ ParseAddressRawInvalidPrefix prefix-  where-    parseKeyAddressRaw keyPrefix keyAddress-      | length keyAddress /= keyHashLengthBytes-          = Left $ ParseAddressRawWrongSize keyAddress-      | otherwise = do-        matchedPrefix <- case keyPrefix of-          "\00" -> Right KeyHashEd25519-          "\01" -> Right KeyHashSecp256k1-          "\02" -> Right KeyHashP256-          _ -> Left $ ParseAddressRawInvalidPrefix keyPrefix-        pure $ KeyAddress (KeyHash matchedPrefix keyAddress)--    parseContractAddressRaw contractPrefix contractAddress-      | length contractAddress /= contractHashLengthBytes-          = Left $ ParseAddressRawWrongSize contractAddress-      | BS.last contractAddress /= 0x00-          = Left $ ParseAddressRawMalformedSeparator contractAddress-      | otherwise = do-        let contractAddress' = BS.drop 1 contractPrefix <> BS.init contractAddress -- drop last "\00" of contract address-        pure $ ContractAddress (ContractHash contractAddress')--data ParseContractAddressError-  = ParseContractAddressWrongBase58Check-  | ParseContractAddressWrongSize ByteString-  | ParseContractAddressWrongPrefix ByteString-  deriving stock (Show, Eq, Generic)--instance NFData ParseContractAddressError--instance Buildable ParseContractAddressError where-  build = buildRenderDoc--instance RenderDoc ParseContractAddressError where-  renderDoc _ =-    \case-      ParseContractAddressWrongBase58Check ->-        "Wrong base58check format"-      ParseContractAddressWrongSize bs ->-        "Wrong size for a contract address:" <+> (renderAnyBuildable $ hexF bs) <+>-        (parens $ int (length bs))-      ParseContractAddressWrongPrefix prefix ->-        "Invalid prefix" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"--parseContractHash :: Text -> Either ParseContractAddressError ContractHash-parseContractHash text =-  case decodeBase58CheckWithPrefix contractAddressPrefix text of-    Left (B58CheckWithPrefixWrongPrefix prefix) ->-      Left (ParseContractAddressWrongPrefix prefix)-    Left B58CheckWithPrefixWrongEncoding ->-      Left ParseContractAddressWrongBase58Check-    Right bs | length bs == contractHashLengthBytes -> Right (ContractHash bs)-             | otherwise -> Left $ ParseContractAddressWrongSize bs---- | QuasyQuoter for constructing Tezos addresses.------ Validity of result will be checked at compile time.-ta :: TH.QuasiQuoter-ta = TH.QuasiQuoter-  { TH.quoteExp = \s ->-      case parseAddress . strip $ toText s of-        Left   err -> fail $ pretty err-        Right addr -> TH.lift addr-  , TH.quotePat = \_ ->-      fail "Cannot use this QuasyQuotation at pattern position"-  , TH.quoteType = \_ ->-      fail "Cannot use this QuasyQuotation at type position"-  , TH.quoteDec = \_ ->-      fail "Cannot use this QuasyQuotation at declaration position"-  }---instance-    TypeError ('Text "There is no instance defined for (IsString Address)" ':$$:-               'Text "Consider using QuasiQuotes: `[ta|some text...|]`"-              ) =>-    IsString Address where-  fromString = error "impossible"---------------------------------------------------------------------------------- Unsafe--------------------------------------------------------------------------------- | Parse a @KT1@ contract address, fail if address does not match--- the expected format.-unsafeParseContractHash :: HasCallStack => Text -> ContractHash-unsafeParseContractHash = either (error . pretty) id . parseContractHash---- | Partial version of 'parseAddress' which assumes that the address--- is correct. Can be used in tests.-unsafeParseAddress :: HasCallStack => Text -> Address-unsafeParseAddress = either (error . pretty) id . parseAddress---- | Partially parse raw bytes representation of an address and assume that--- it is correct from the beginning. Can be used in tests.-unsafeParseAddressRaw :: ByteString -> Address-unsafeParseAddressRaw = either (error . pretty) id . parseAddressRaw--instance HasCLReader Address where-  getReader = eitherReader parseAddrDo-    where-      parseAddrDo addr =-        either (Left . mappend "Failed to parse address: " . pretty) Right $-        parseAddress $ toText addr-  getMetavar = "ADDRESS"--------------------------------------------------------------------------------- Aeson instances-------------------------------------------------------------------------------instance ToJSON Address where-  toJSON = Aeson.String . formatAddress-  toEncoding = Aeson.text . formatAddress--instance ToJSONKey Address where-  toJSONKey = AesonTypes.toJSONKeyText formatAddress--instance FromJSON Address where-  parseJSON =-    Aeson.withText "Address" $-    either (fail . pretty) pure . parseAddress--instance FromJSONKey Address where-  fromJSONKey =-    AesonTypes.FromJSONKeyTextParser-      (either (fail . pretty) pure . parseAddress)

− src/Tezos/Core.hs

@@ -1,398 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Core primitive Tezos types.--module Tezos.Core-  (-    -- * Mutez-    Mutez (..)-  , mkMutez-  , mkMutez'-  , unsafeMkMutez-  , toMutez-  , addMutez-  , unsafeAddMutez-  , subMutez-  , unsafeSubMutez-  , mulMutez-  , unsafeMulMutez-  , divModMutez-  , divModMutezInt-  , mutezToInt64-  , zeroMutez-  , oneMutez-  , prettyTez--    -- * Timestamp-  , Timestamp (..)-  , timestampToSeconds-  , timestampFromSeconds-  , timestampFromUTCTime-  , timestampToUTCTime-  , timestampPlusSeconds-  , formatTimestamp-  , parseTimestamp-  , timestampQuote-  , getCurrentTime-  , farFuture-  , farPast--    -- * ChainId-  , ChainId (..)-  , mkChainId-  , unsafeMkChainId-  , dummyChainId-  , formatChainId-  , mformatChainId-  , parseChainId-  , chainIdLength-  ) where--import Data.Aeson (FromJSON(..), ToJSON(..))-import qualified Data.Aeson as Aeson-import Data.Aeson.TH (deriveJSON)-import Data.Data (Data(..))-import Data.Scientific-import qualified Data.Text as T-import Data.Time.Clock (UTCTime)-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)-import Data.Time.Format (defaultTimeLocale, parseTimeM)-import Data.Time.LocalTime (utc, utcToZonedTime)-import Data.Time.RFC3339 (formatTimeRFC3339)-import Fmt (Buildable(build), fmt, hexF, pretty)-import qualified Language.Haskell.TH.Quote as TH-import Language.Haskell.TH.Syntax (liftData)-import qualified Options.Applicative as Opt--import Michelson.Text-import Tezos.Crypto-import Util.Aeson-import Util.CLI-import Util.Num--------------------------------------------------------------------------------- Mutez--------------------------------------------------------------------------------- | Mutez is a wrapper over integer data type. 1 mutez is 1 token (μTz).-newtype Mutez = UnsafeMutez-  { unMutez :: Word64-  } deriving stock (Show, Eq, Ord, Data, Generic)-    deriving newtype Enum--instance Buildable Mutez where-  build (UnsafeMutez w) = build w <> " μꜩ"--instance Bounded Mutez where-  minBound = UnsafeMutez 0-  -- 2⁶³ - 1-  -- This value was checked against the reference implementation.-  maxBound = UnsafeMutez 9223372036854775807--instance HasCLReader Mutez where-  getReader = maybe (readerError "Invalid mutez") pure . mkMutez =<< Opt.auto-  getMetavar = "MUTEZ"--instance NFData Mutez---- | Safely create 'Mutez' checking for overflow.-mkMutez :: Word64 -> Maybe Mutez-mkMutez n-  | n <= unMutez maxBound = Just (UnsafeMutez n)-  | otherwise = Nothing-{-# INLINE mkMutez #-}---- | Version of 'mkMutez' that accepts a number of any type.-mkMutez' :: Integral i => i -> Either Text Mutez-mkMutez' i = do-  w :: Word64 <- fromIntegralChecked i-  mkMutez w-    & maybeToRight "Mutez overflow"---- | Partial function for 'Mutez' creation, it's pre-condition is that--- the argument must not exceed the maximal 'Mutez' value.-unsafeMkMutez :: HasCallStack => Word64 -> Mutez-unsafeMkMutez n =-  fromMaybe (error $ "mkMutez: overflow (" <> show n <> ")") (mkMutez n)-{-# INLINE unsafeMkMutez #-}---- | Safely create 'Mutez'.------ This is recommended way to create @Mutez@ from a numeric literal;--- you can't construct all valid @Mutez@ values using this function--- but for small values it works neat.------ Warnings displayed when trying to construct invalid 'Natural' or 'Word'--- literal are hardcoded for these types in GHC implementation, so we can only--- exploit these existing rules.-toMutez :: Word32 -> Mutez-toMutez = unsafeMkMutez . fromIntegral-{-# INLINE toMutez #-}---- | Addition of 'Mutez' values. Returns 'Nothing' in case of overflow.-addMutez :: Mutez -> Mutez -> Maybe Mutez-addMutez (unMutez -> a) (unMutez -> b) =-  mkMutez (a + b) -- (a + b) can't overflow if 'Mutez' values are valid-{-# INLINE addMutez #-}---- | Partial addition of 'Mutez', should be used only if you're--- sure there'll be no overflow.-unsafeAddMutez :: HasCallStack => Mutez -> Mutez -> Mutez-unsafeAddMutez = fromMaybe (error "unsafeAddMutez: overflow") ... addMutez---- | Subtraction of 'Mutez' values. Returns 'Nothing' when the--- subtrahend is greater than the minuend, and 'Just' otherwise.-subMutez :: Mutez -> Mutez -> Maybe Mutez-subMutez (unMutez -> a) (unMutez -> b)-  | a >= b = Just (UnsafeMutez (a - b))-  | otherwise = Nothing-{-# INLINE subMutez #-}---- | Partial subtraction of 'Mutez', should be used only if you're--- sure there'll be no underflow.-unsafeSubMutez :: HasCallStack => Mutez -> Mutez -> Mutez-unsafeSubMutez = fromMaybe (error "unsafeSubMutez: underflow") ... subMutez---- | Multiplication of 'Mutez' and an integral number. Returns--- 'Nothing' in case of overflow.-mulMutez :: Integral a => Mutez -> a -> Maybe Mutez-mulMutez (unMutez -> a) b-    | res <= toInteger (unMutez maxBound) = Just (UnsafeMutez (fromInteger res))-    | otherwise = Nothing-  where-    res = toInteger a * toInteger b-{-# INLINE mulMutez #-}---- | Partial multiplication of 'Mutez' and an Natural number.--- Should be used only if you're sure there'll be no overflow.-unsafeMulMutez :: Mutez -> Natural -> Mutez-unsafeMulMutez = fromMaybe (error "unsafeMulMutez: overflow") ... mulMutez---- | Euclidian division of two 'Mutez' values.-divModMutez :: Mutez -> Mutez -> Maybe (Word64, Mutez)-divModMutez a (unMutez -> b) = first unMutez <$> divModMutezInt a b---- | Euclidian division of  'Mutez' and a number.-divModMutezInt :: Integral a => Mutez -> a -> Maybe (Mutez, Mutez)-divModMutezInt (toInteger . unMutez -> a) (toInteger -> b)-  | b <= 0 = Nothing-  | otherwise = Just $ bimap toMutez' toMutez' (a `divMod` b)-  where-    toMutez' :: Integer -> Mutez-    toMutez' = UnsafeMutez . fromInteger---- | Convert mutez to signed number.------ TODO [#423]: try to provide a generic safe conversion method-mutezToInt64 :: Mutez -> Int64-mutezToInt64 = fromIntegral . unMutez--zeroMutez :: Mutez-zeroMutez = UnsafeMutez minBound--oneMutez :: Mutez-oneMutez = UnsafeMutez 1---- |--- >>> putTextLn $ prettyTez (toMutez 420)--- 0.00042 ꜩ------ >>> putTextLn $ prettyTez (toMutez 42000000)--- 42 ꜩ-prettyTez :: Mutez -> Text-prettyTez ((/ 1000000) . fromIntegral . unMutez -> s) =-  case floatingOrInteger s of-    Left (_ :: Float)    -> toText $ formatScientific Fixed Nothing s-    Right (n :: Integer) -> pretty n-  <> " ꜩ"--------------------------------------------------------------------------------- Timestamp--------------------------------------------------------------------------------- | Time in the real world.--- Use the functions below to convert it to/from Unix time in seconds.-newtype Timestamp = Timestamp-  { unTimestamp :: POSIXTime-  } deriving stock (Show, Eq, Ord, Data, Generic)--instance NFData Timestamp--timestampToSeconds :: Integral a => Timestamp -> a-timestampToSeconds = round . unTimestamp-{-# INLINE timestampToSeconds #-}--timestampFromSeconds :: Integer -> Timestamp-timestampFromSeconds = Timestamp . fromIntegral-{-# INLINE timestampFromSeconds #-}--timestampFromUTCTime :: UTCTime -> Timestamp-timestampFromUTCTime = Timestamp . utcTimeToPOSIXSeconds-{-# INLINE timestampFromUTCTime #-}--timestampToUTCTime :: Timestamp -> UTCTime-timestampToUTCTime = posixSecondsToUTCTime . unTimestamp-{-# INLINE timestampToUTCTime #-}---- | Add given amount of seconds to a 'Timestamp'.-timestampPlusSeconds :: Timestamp -> Integer -> Timestamp-timestampPlusSeconds ts sec = timestampFromSeconds (timestampToSeconds ts + sec)---- | Display timestamp in human-readable way as used by Michelson.--- Uses UTC timezone, though maybe we should take it as an argument.------ NB: this will render timestamp with up to seconds precision.-formatTimestamp :: Timestamp -> Text-formatTimestamp =-  formatTimeRFC3339 . utcToZonedTime utc . posixSecondsToUTCTime . unTimestamp--instance Buildable Timestamp where-  build = build . formatTimestamp---- | Parse textual representation of 'Timestamp'.-parseTimestamp :: Text -> Maybe Timestamp-parseTimestamp t-  -- `parseTimeM` does not allow to match on a single whitespace exclusively-  | T.isInfixOf "  " t = Nothing-  | otherwise = fmap timestampFromUTCTime . asum $ map parse formatsRFC3339-  where-    parse :: Text -> Maybe UTCTime-    parse frmt = parseTimeM False defaultTimeLocale (toString frmt) (toString t)--    formatsRFC3339 :: [Text]-    formatsRFC3339 = do-      divider <- ["T", " "]-      fraction <- ["%Q", ""]-      zone <- ["Z", "%z"]-      return $ "%-Y-%m-%d" <> divider <> "%T" <> fraction <> zone---- | Quote a value of type 'Timestamp' in @yyyy-mm-ddThh:mm:ss[.sss]Z@ format.------ >>> formatTimestamp [timestampQuote| 2019-02-21T16:54:12.2344523Z |]--- "2019-02-21T16:54:12Z"------ Inspired by 'time-quote' library.-timestampQuote :: TH.QuasiQuoter-timestampQuote =-  TH.QuasiQuoter-  { quoteExp = \str ->-      case parseTimestamp . T.strip $ toText str of-        Nothing -> fail "Invalid timestamp, \-                        \example of valid value: `2019-02-21T16:54:12.2344523Z`"-        Just ts -> liftData ts-  , quotePat = \_ -> fail "timestampQuote: cannot quote pattern!"-  , quoteType = \_ -> fail "timestampQuote: cannot quote type!"-  , quoteDec = \_ -> fail "timestampQuote: cannot quote declaration!"-  }---- | Return current time as 'Timestamp'.-getCurrentTime :: IO Timestamp-getCurrentTime = Timestamp <$> getPOSIXTime---- | Timestamp which is always greater than result of 'getCurrentTime'.-farFuture :: Timestamp-farFuture = timestampFromSeconds 1e12  -- 33658-09-27T01:46:40Z---- | Timestamp which is always less than result of 'getCurrentTime'.-farPast :: Timestamp-farPast = timestampFromSeconds 0--------------------------------------------------------------------------------- Chain ID-------------------------------------------------------------------------------{- Chain id in Tezos sources:-* https://gitlab.com/tezos/tezos/blob/de5c80b360aa396114be92a3a2e2ff2087190a61/src/lib_crypto/chain_id.ml--}---- | Identifier of a network (babylonnet, mainnet, test network or other).--- Evaluated as hash of the genesis block.------ The only operation supported for this type is packing.--- Use case: multisig contract, for instance, now includes chain ID into--- signed data "in order to add extra replay protection between the main--- chain and the test chain".-newtype ChainId = UnsafeChainId { unChainId :: ByteString }-  deriving stock (Show, Eq, Ord, Generic)--instance NFData ChainId---- | Construct chain ID from raw bytes.-mkChainId :: ByteString -> Maybe ChainId-mkChainId bs =-  guard (length bs == chainIdLength) $> UnsafeChainId bs---- | Construct chain ID from raw bytes or fail otherwise.--- Expects exactly 4 bytes.-unsafeMkChainId :: HasCallStack => ByteString -> ChainId-unsafeMkChainId = fromMaybe (error "Bad chain id") . mkChainId---- | Identifier of a pseudo network.-dummyChainId :: ChainId-dummyChainId = UnsafeChainId "\0\0\0\0"---- | Pretty print 'ChainId' as it is displayed e.g. in--- @tezos-client rpc get /chains/main/chain_id@ call.------ Example of produced value: "NetXUdfLh6Gm88t".-formatChainId :: ChainId -> Text-formatChainId (unChainId -> bs) = encodeBase58Check (chainIdPrefix <> bs)--mformatChainId :: ChainId -> MText-mformatChainId = unsafeMkMText . formatChainId--instance Buildable ChainId where-  build = build . formatChainId--data ParseChainIdError-  = ParseChainIdWrongBase58Check-  | ParseChainIdWrongTag ByteString-  | ParseChainIdWrongSize Int-  deriving stock (Show, Eq)--instance Buildable ParseChainIdError where-  build =-    \case-      ParseChainIdWrongBase58Check ->-        "Wrong base58check format"-      ParseChainIdWrongTag tag ->-        "Wrong tag for a chain id: " <> fmt (hexF tag)-      ParseChainIdWrongSize s ->-        "Wrong size for a chain id: " <> build s--instance Exception ParseChainIdError where-  displayException = pretty--parseChainId :: Text -> Either ParseChainIdError ChainId-parseChainId text =-  case decodeBase58CheckWithPrefix chainIdPrefix text of-    Left (B58CheckWithPrefixWrongPrefix prefix) ->-      Left (ParseChainIdWrongTag prefix)-    Left B58CheckWithPrefixWrongEncoding ->-      Left ParseChainIdWrongBase58Check-    Right bs -> case mkChainId bs of-      Just ci -> Right ci-      Nothing -> Left $ ParseChainIdWrongSize (length bs)--chainIdLength :: Int-chainIdLength = 4---- | It's a magic constant used by Tezos to encode a chain ID.--- Corresponds to "Net" part.-chainIdPrefix :: ByteString-chainIdPrefix = "\87\82\0"--------------------------------------------------------------------------------- JSON-------------------------------------------------------------------------------deriveJSON morleyAesonOptions ''Mutez-deriveJSON morleyAesonOptions ''Timestamp--instance ToJSON ChainId where-  toJSON = Aeson.String . formatChainId-instance FromJSON ChainId where-  parseJSON = Aeson.withText "chain id" $-    either (fail . pretty) pure . parseChainId

− src/Tezos/Crypto.hs

@@ -1,532 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Cryptographic primitives used in Tezos.------ WARNING: some functions may be vulnerable to timing attacks.--- Also, this code was not reviewed by cryptography/security experts.--- Do not use it with secret keys that have some value.--- We provide 'SecretKey' type and (limited) signing functionality only--- for testing.--- If you need to sign something in production, use something else--- (e. g. `tezos-client`).------ Tezos supports 3 cryptographic curves that are denoted by the--- number after tz in the public key hash: tz1, tz2 or tz3.--- • tz1 — ed25519--- • tz2 — secp256k1--- • tz3 — P256--- We have Tezos.Crypto.Curve module for each of these curves.--- They expose very similar functionality and their main purpose is to hide--- implementation details for each curve as well as some other specifics (e. g.--- prefixes that are used for human-readable representation).------ This module serves two purposes:--- 1. It is an umbrella module that re-exports some stuff from other modules.--- 2. Michelson types such as `key` and `signature` may store primitive of any--- curve, so we need "union" types in Haskell as well.------ During conversion to human-readable representation usually some magical--- prefix is used. They have been found in source code in some repos (e. g.--- <https://gitlab.com/tezos/tezos/blob/c52ee69231c5ae4d9cec1f3c8aba0c3573922e2a/src/lib_crypto/base58.ml>)--- and checked manually. Existing tests confirm they are correct.--{-# LANGUAGE DeriveLift #-}--module Tezos.Crypto-  ( -- * Cryptographic primitive types-    PublicKey (..)-  , SecretKey (..) -- Currently we need to differentiate secret keys in morley-client-  , Signature (..)-  , KeyHashTag (..)-  , KeyHash (..)-  , BLS12381.Bls12381Fr-  , BLS12381.Bls12381G1-  , BLS12381.Bls12381G2--  -- * Public/secret key functions-  , detSecretKey-  , toPublic--  -- * Signature-  , signatureToBytes-  , mkSignature-  , parseSignatureRaw-  , signatureLengthBytes-  , checkSignature-  , sign--  -- * Formatting-  , CryptoParseError (..)-  , formatPublicKey-  , mformatPublicKey-  , parsePublicKey-  , parsePublicKeyRaw-  , formatSignature-  , mformatSignature-  , parseSignature-  , formatKeyHash-  , mformatKeyHash-  , parseKeyHash-  , unsafeParseKeyHash-  , parseKeyHashRaw-  , keyHashLengthBytes-  , formatSecretKey-  , parseSecretKey--  -- * Hashing-  , hashKey-  , blake2b-  , blake2b160-  , keccak-  , sha256-  , sha3-  , sha512--  -- * Utilities-  , encodeBase58Check-  , decodeBase58Check-  , B58CheckWithPrefixError (..)-  , decodeBase58CheckWithPrefix-  , keyDecoders-  , keyHashDecoders-  ) where--import Crypto.Random (MonadRandom)-import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encoding as Aeson-import qualified Data.Aeson.Types as AesonTypes-import qualified Data.Binary.Get as Get-import qualified Data.ByteArray as BA-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Text as T-import Fmt (Buildable, build, hexF, pretty)-import Instances.TH.Lift ()-import Language.Haskell.TH.Syntax (Lift)--import Michelson.Text-import qualified Tezos.Crypto.BLS12381 as BLS12381-import qualified Tezos.Crypto.Ed25519 as Ed25519-import Tezos.Crypto.Hash-import qualified Tezos.Crypto.P256 as P256-import qualified Tezos.Crypto.Secp256k1 as Secp256k1-import Tezos.Crypto.Util-import Util.Binary-import Util.CLI--------------------------------------------------------------------------------- Types, instances, conversions--------------------------------------------------------------------------------- | Public cryptographic key used by Tezos.--- There are three cryptographic curves each represented by its own constructor.-data PublicKey-  = PublicKeyEd25519 Ed25519.PublicKey-  -- ^ Public key that uses the ed25519 cryptographic curve.-  | PublicKeySecp256k1 Secp256k1.PublicKey-  -- ^ Public key that uses the secp256k1 cryptographic curve.-  | PublicKeyP256 P256.PublicKey-  -- ^ Public key that uses the NIST P-256 cryptographic curve.-  deriving stock (Show, Eq, Ord, Generic)--instance NFData PublicKey---- | Secret cryptographic key used by Tezos.--- Constructors correspond to 'PublicKey' constructors.-data SecretKey-  = SecretKeyEd25519 Ed25519.SecretKey-  -- ^ Secret key that uses the ed25519 cryptographic curve.-  | SecretKeySecp256k1 Secp256k1.SecretKey-  -- ^ Secret key that uses the secp256k1 cryptographic curve.-  | SecretKeyP256 P256.SecretKey-  -- ^ Secret key that uses the NIST P-256 cryptographic curve.-  deriving stock (Show, Eq, Generic)--instance NFData SecretKey--instance HasCLReader SecretKey where-  getReader = eitherReader (first pretty . parseSecretKey . toText)-  getMetavar = "SECRET_KEY"---- | Deterministicaly generate a secret key from seed.--- Type of the key depends on seed length.-detSecretKey :: HasCallStack => ByteString -> SecretKey-detSecretKey seed = seed & case (length seed + 2) `mod` 3 of-  0 -> SecretKeyEd25519 . Ed25519.detSecretKey-  1 -> SecretKeySecp256k1 . Secp256k1.detSecretKey-  2 -> SecretKeyP256 . P256.detSecretKey-  _ -> error "detSecretKey: unexpected happened"---- | Create a public key from a secret key.-toPublic :: SecretKey -> PublicKey-toPublic = \case-  SecretKeyEd25519 sk -> PublicKeyEd25519 . Ed25519.toPublic $ sk-  SecretKeySecp256k1 sk -> PublicKeySecp256k1 . Secp256k1.toPublic $ sk-  SecretKeyP256 sk -> PublicKeyP256 . P256.toPublic $ sk---- | Cryptographic signatures used by Tezos.--- Constructors correspond to 'PublicKey' constructors.------ Tezos distinguishes signatures for different curves.--- For instance, ed25519 signatures and secp256k1 signatures--- are printed differently (have different prefix).--- However, signatures are packed without information about the--- curve. For this purpose there is a generic signature which--- only stores bytes and doesn't carry information about the curve.--- Apparently unpacking from bytes always produces such signature.--- Unpacking from string produces a signature with curve information.-data Signature-  = SignatureEd25519 Ed25519.Signature-  -- ^ Signature that uses the ed25519 cryptographic curve.-  | SignatureSecp256k1 Secp256k1.Signature-  -- ^ Siganture that uses the secp256k1 cryptographic curve.-  | SignatureP256 P256.Signature-  -- ^ Signature that uses the NIST P-256 cryptographic curve.-  | SignatureGeneric ByteString-  -- ^ Generic signature for which curve is unknown.-  deriving stock (Show, Generic)--instance NFData Signature---- This instance slightly differs from the default one. If one--- signature is generic and the other one is not, they still may be--- equal if they have the same byte representation.--- With default instance packing a signature and unpacking it would produce--- a different (with respect to 'Eq') signature which is inconvenient.-instance Eq Signature where-  sig1 == sig2 = case (sig1, sig2) of-    (SignatureGeneric bytes1, SignatureGeneric bytes2) -> bytes1 == bytes2-    (SignatureGeneric bytes1, SignatureEd25519 (Ed25519.signatureToBytes -> bytes2)) ->-      bytes1 == bytes2-    (SignatureGeneric bytes1, SignatureSecp256k1 (Secp256k1.signatureToBytes -> bytes2)) ->-      bytes1 == bytes2-    (SignatureGeneric bytes1, SignatureP256 (P256.signatureToBytes -> bytes2)) ->-      bytes1 == bytes2--    (_, SignatureGeneric {}) -> sig2 == sig1--    (SignatureEd25519 s1, SignatureEd25519 s2) -> s1 == s2-    (SignatureEd25519 {}, _) -> False--    (SignatureSecp256k1 s1, SignatureSecp256k1 s2) -> s1 == s2-    (SignatureSecp256k1 {}, _) -> False--    (SignatureP256 s1, SignatureP256 s2) -> s1 == s2-    (SignatureP256 {}, _) -> False--instance Ord Signature where-  compare = compare `on` (signatureToBytes :: Signature -> ByteString)--------------------------------------------------------------------------------- Signature--------------------------------------------------------------------------------- | Convert a 'Signature' to raw bytes.-signatureToBytes :: BA.ByteArray ba => Signature -> ba-signatureToBytes = \case-  SignatureEd25519 sig -> Ed25519.signatureToBytes sig-  SignatureSecp256k1 sig -> Secp256k1.signatureToBytes sig-  SignatureP256 sig -> P256.signatureToBytes sig-  SignatureGeneric bytes -> BA.convert bytes---- | Make a 'Signature' from raw bytes.--- Can return only generic signature.-mkSignature :: BA.ByteArray ba => ba -> Maybe Signature-mkSignature ba =-  SignatureGeneric (BA.convert ba) <$ guard (l == signatureLengthBytes)-  where-    l = BA.length ba--parseSignatureRaw :: ByteString -> Either ParseSignatureRawError Signature-parseSignatureRaw ba = maybeToRight (ParseSignatureRawWrongSize ba) $ mkSignature ba--data ParseSignatureRawError-  = ParseSignatureRawWrongSize ByteString-  deriving stock (Eq, Show, Generic)--instance Buildable ParseSignatureRawError where-  build =-    \case-      ParseSignatureRawWrongSize ba -> "Given raw signature " <>-        hexF ba <> " has invalid length " <> show (length ba)---- Apparently Tezos relies on the fact that in all schemes signature--- size is 64 bytes, so it also has generic signature and always reads--- 64 bytes during unpack.--- So we can have one 'signatureLengthBytes' and do not have to--- distinguish between curves.--- However, we still have such a check here just in case as a precaution.-signatureLengthBytes :: HasCallStack => Integral n => n-signatureLengthBytes-  | all is64-    [ Ed25519.signatureLengthBytes-    , P256.signatureLengthBytes-    , Secp256k1.signatureLengthBytes-    ] = 64-  | otherwise =-    error "Apparently our understanding of signatures in Tezos is broken"-  where-    is64 :: Int -> Bool-    is64 = (== 64)--genericSignatureTag :: ByteString-genericSignatureTag = "\004\130\043"---- | Check that a sequence of bytes has been signed with a given key.-checkSignature :: PublicKey -> Signature -> ByteString -> Bool-checkSignature pk0 sig0 bytes =-  case (pk0, sig0) of-    (PublicKeyEd25519 pk, SignatureEd25519 sig) ->-      Ed25519.checkSignature pk sig bytes-    (PublicKeySecp256k1 pk, SignatureSecp256k1 sig) ->-      Secp256k1.checkSignature pk sig bytes-    (PublicKeyP256 pk, SignatureP256 sig) ->-      P256.checkSignature pk sig bytes-    (PublicKeyEd25519 pk, SignatureGeneric sBytes) ->-      Ed25519.mkSignature sBytes-        & fmap (\sig -> Ed25519.checkSignature pk sig bytes)-        & fromRight False-    (PublicKeySecp256k1 pk, SignatureGeneric sBytes) ->-      Secp256k1.mkSignature sBytes-        & fmap (\sig -> Secp256k1.checkSignature pk sig bytes)-        & fromRight False-    (PublicKeyP256 pk, SignatureGeneric sBytes) ->-      P256.mkSignature sBytes-        & fmap (\sig -> P256.checkSignature pk sig bytes)-        & fromRight False-    _ -> False--sign :: MonadRandom m => SecretKey -> ByteString -> m Signature-sign sk bs =-  case sk of-    SecretKeyEd25519 sk'   -> pure $ SignatureEd25519 $ Ed25519.sign sk' bs-    SecretKeySecp256k1 sk' -> SignatureSecp256k1 <$> Secp256k1.sign sk' bs-    SecretKeyP256 sk'      -> SignatureP256 <$> P256.sign sk' bs--------------------------------------------------------------------------------- Formatting-------------------------------------------------------------------------------formatPublicKey :: PublicKey -> Text-formatPublicKey = \case-  PublicKeyEd25519 pk -> Ed25519.formatPublicKey pk-  PublicKeySecp256k1 pk -> Secp256k1.formatPublicKey pk-  PublicKeyP256 pk -> P256.formatPublicKey pk--mformatPublicKey :: PublicKey -> MText-mformatPublicKey = unsafeMkMText . formatPublicKey--instance Buildable PublicKey where-  build = build . formatPublicKey--parsePublicKey :: Text -> Either CryptoParseError PublicKey-parsePublicKey txt =-  firstRight $ map ($ txt)-    ( fmap PublicKeyEd25519 . Ed25519.parsePublicKey :|-    [ fmap PublicKeySecp256k1 . Secp256k1.parsePublicKey-    , fmap PublicKeyP256 . P256.parsePublicKey-    ])--parsePublicKeyRaw :: ByteString -> Either Text PublicKey-parsePublicKeyRaw ba =-  case Get.runGetOrFail (decodeWithTag "key" keyDecoders) (LBS.fromStrict ba) of-    Right (_, _, result) -> Right result-    Left (_, _, err) -> Left (toText err)--formatSignature :: Signature -> Text-formatSignature = \case-  SignatureEd25519 sig -> Ed25519.formatSignature sig-  SignatureSecp256k1 sig -> Secp256k1.formatSignature sig-  SignatureP256 sig -> P256.formatSignature sig-  SignatureGeneric sig -> formatImpl genericSignatureTag sig--mformatSignature :: Signature -> MText-mformatSignature = unsafeMkMText . formatSignature--instance Buildable Signature where-  build = build . formatSignature--parseSignature :: Text -> Either CryptoParseError Signature-parseSignature txt =-  firstRight $ map ($ txt)-    ( fmap SignatureEd25519 . Ed25519.parseSignature :|-    [ fmap SignatureSecp256k1 . Secp256k1.parseSignature-    , fmap SignatureP256 . P256.parseSignature-    , parseImpl genericSignatureTag (pure . SignatureGeneric)-    ])--formatSecretKey :: SecretKey -> Text-formatSecretKey key = "unencrypted:" <> case key of-  SecretKeyEd25519 sig -> Ed25519.formatSecretKey sig-  SecretKeySecp256k1 sig -> Secp256k1.formatSecretKey sig-  SecretKeyP256 sig -> P256.formatSecretKey sig--instance Buildable SecretKey where-  build = build . formatSecretKey---- | Parse __unencrypted__ secret key. It accepts formats containing--- either with or without the @unecrypted@ prefix.-parseSecretKey :: Text -> Either CryptoParseError SecretKey-parseSecretKey txt =-  firstRight $ map (\f -> f $ removePrefix txt)-    ( fmap SecretKeyEd25519 . Ed25519.parseSecretKey :|-    [ fmap SecretKeySecp256k1 . Secp256k1.parseSecretKey-    , fmap SecretKeyP256 . P256.parseSecretKey-    ])-  where-    removePrefix :: Text -> Text-    removePrefix input =-      let unencrypted = "unencrypted:"-          (prefix, payload) = T.splitAt (length unencrypted) input-      in case prefix == unencrypted of-        True -> payload-        False -> input--------------------------------------------------------------------------------- JSON encoding/decoding--------------------------------------------------------------------------------- If you ever need these instances for any particular 'PublicKey' or--- 'Signature', you can define them in respective modules the same--- way.--instance ToJSON PublicKey where-  toJSON = Aeson.String . formatPublicKey-  toEncoding = Aeson.text . formatPublicKey--instance FromJSON PublicKey where-  parseJSON =-    Aeson.withText "PublicKey" $-    either (fail . pretty) pure . parsePublicKey--instance ToJSON Signature where-  toJSON = Aeson.String . formatSignature-  toEncoding = Aeson.text . formatSignature--instance FromJSON Signature where-  parseJSON =-    Aeson.withText "Signature" $-    either (fail . pretty) pure . parseSignature--instance ToJSON KeyHash where-  toJSON = Aeson.String . formatKeyHash-  toEncoding = Aeson.text . formatKeyHash--instance ToJSONKey KeyHash where-  toJSONKey = AesonTypes.toJSONKeyText formatKeyHash--instance FromJSON KeyHash where-  parseJSON =-    Aeson.withText "KeyHash" $-    either (fail . pretty) pure . parseKeyHash--instance FromJSONKey KeyHash where-  fromJSONKey =-    AesonTypes.FromJSONKeyTextParser $-    either (fail . pretty) pure . parseKeyHash--------------------------------------------------------------------------------- KeyHash--------------------------------------------------------------------------------- | Which curve was used for the hashed public key inside 'KeyHash'.-data KeyHashTag-  = KeyHashEd25519-  | KeyHashSecp256k1-  | KeyHashP256-  deriving stock (Show, Eq, Ord, Bounded, Enum, Generic, Lift)--instance NFData KeyHashTag---- | Blake2b_160 hash of a public key.-data KeyHash = KeyHash-  { khTag :: KeyHashTag-  -- ^ We store which curve was used because it affects formatting.-  , khBytes :: ByteString-  -- ^ Hash itself.-  } deriving stock (Show, Eq, Ord, Generic, Lift)--instance NFData KeyHash---- | Length of key hash in bytes (only hash itself, no tags, checksums--- or anything).-keyHashLengthBytes :: Integral n => n-keyHashLengthBytes = 20---- | Compute the b58check of a public key hash.-hashKey :: PublicKey -> KeyHash-hashKey =-  \case-    PublicKeyEd25519 pk ->-      KeyHash KeyHashEd25519 (blake2b160 $ Ed25519.publicKeyToBytes pk)-    PublicKeySecp256k1 pk ->-      KeyHash KeyHashSecp256k1 (blake2b160 $ Secp256k1.publicKeyToBytes pk)-    PublicKeyP256 pk ->-      KeyHash KeyHashP256 (blake2b160 $ P256.publicKeyToBytes pk)--formatKeyHash :: KeyHash -> Text-formatKeyHash (KeyHash tag bytes) = formatImpl (keyHashTagBytes tag) bytes--mformatKeyHash :: KeyHash -> MText-mformatKeyHash = unsafeMkMText . formatKeyHash--instance Buildable KeyHash where-  build = build . formatKeyHash--parseKeyHash :: Text -> Either CryptoParseError KeyHash-parseKeyHash txt =-  let-    mkKeyHash tag bs =-      KeyHash tag bs <$-        unless (length bs == keyHashLengthBytes)-        (Left $ CryptoParseUnexpectedLength "KeyHash" (length bs))--    parse :: KeyHashTag -> Either CryptoParseError KeyHash-    parse tag = mkKeyHash tag =<< parseImpl (keyHashTagBytes tag) pure txt--  in firstRight $ map parse $ minBound :| [succ minBound ..]--unsafeParseKeyHash :: HasCallStack => Text -> KeyHash-unsafeParseKeyHash = either (error . pretty) id . parseKeyHash--parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash-parseKeyHashRaw ba =-  if (BS.length ba - 1 == keyHashLengthBytes) then-    case Get.runGetOrFail (decodeWithTag "key_hash" keyHashDecoders) (LBS.fromStrict ba) of-      Right (_, _, result) -> Right result-      Left (_, _, err) -> Left $ CryptoParseBinaryError (toText err)-  else-    Left $ CryptoParseUnexpectedLength "key_hash" (BS.length ba)--keyHashTagBytes :: KeyHashTag -> ByteString-keyHashTagBytes =-  \case-    KeyHashEd25519 -> "\006\161\159"-    KeyHashSecp256k1 -> "\006\161\161"-    KeyHashP256 -> "\006\161\164"--instance HasCLReader KeyHash where-  getReader = eitherReader (first pretty . parseKeyHash . toText)-  getMetavar = "KEY_HASH"--keyDecoders :: [TaggedDecoder PublicKey]-keyDecoders =-  [ 0x00 #: decodeBytesLike "key Ed25519"-      (fmap PublicKeyEd25519 . Ed25519.mkPublicKey)-  , 0x01 #: decodeBytesLike "key Secp256k1"-      (fmap PublicKeySecp256k1 . Secp256k1.mkPublicKey)-  , 0x02 #: decodeBytesLike "key P256"-      (fmap PublicKeyP256 . P256.mkPublicKey)-  ]--keyHashDecoders :: [TaggedDecoder KeyHash]-keyHashDecoders =-  [ 0x00 #: KeyHash KeyHashEd25519 <$> getPayload-  , 0x01 #: KeyHash KeyHashSecp256k1 <$> getPayload-  , 0x02 #: KeyHash KeyHashP256 <$> getPayload-  ]-  where-    getPayload = getByteStringCopy keyHashLengthBytes

− src/Tezos/Crypto/BLS12381.hs

@@ -1,455 +0,0 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Support for BLS12-381 elliptic curve.------ Some general hints on the implementation can be found in this python--- re-implementation used by Tezos for testing:--- <https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3>.--- And it uses this library inside: <https://github.com/ethereum/py_ecc/tree/master/py_ecc/optimized_bls12_381>.-module Tezos.Crypto.BLS12381-  ( Bls12381Fr-  , Bls12381G1-  , Bls12381G2-  , CurveObject (..)-  , unsafeFromMichelsonBytes-  , MultiplyPoint (..)-  , DeserializationError (..)-  , checkPairing--    -- * Playground-  , unsafeReadFromHex-  , generateFrom-  , g1One-  , g2One-  ) where--import Prelude hiding (negate, one)-import qualified Prelude--import Control.Exception (assert)-import Control.Lens (each, toListOf)-import Control.Monad.Random (MonadRandom, evalRand, getRandom, mkStdGen)-import Data.Bits (bit, complement, setBit, testBit, (.&.))-import qualified Data.ByteString as BS-import qualified Data.Curve as C-import qualified Data.Curve.Weierstrass as CW-import qualified Data.Curve.Weierstrass.BLS12381 as CW.BLS-import qualified Data.Field.Galois as GF-import qualified Data.Pairing.BLS12381 as BLS-import Fmt (Buildable(..), pretty)-import Named (arg, type (:!), (!))-import Text.Hex (decodeHex, encodeHex)-import Text.PrettyPrint.Leijen.Text ((<+>), int, integer)-import Util.Instances ()-import Util.Named ()-import Util.Num--import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable, buildRenderDoc)---- | Methods common for all BLS12-381 primitives.-class CurveObject a where-  -- | Representation of @0@, aka additive identity.-  zero :: a--  -- | Negate a value.-  negate :: a -> a--  -- | Add up two values.-  add :: a -> a -> a--  -- | Generate a random value.-  generate :: MonadRandom m => m a--  -- | Read a value from Michelson's bytes form.-  ---  -- Michelson tends to represent all BLS12-381 types in bytes form,-  -- some special types also allow other forms.-  fromMichelsonBytes :: ByteString -> Either DeserializationError a--  -- | Produce Michelson's bytes representation.-  toMichelsonBytes :: a -> ByteString---- | Generate a random value from given seed.-generateFrom :: (CurveObject a) => Int -> a-generateFrom = evalRand generate . mkStdGen---- | Read a value from Michelson's bytes form assuming that it is correct.-unsafeFromMichelsonBytes :: (CurveObject a, HasCallStack) => ByteString -> a-unsafeFromMichelsonBytes = either (error . pretty) id . fromMichelsonBytes---- | Reads an object from hex string.------ To be used only in playground and tests.-unsafeReadFromHex :: (CurveObject a, HasCallStack) => String -> a-unsafeReadFromHex hex =-  let bs = decodeHex (toText hex) ?: error "bad hex"-  in unsafeFromMichelsonBytes bs---- | Multiplication operations on BLS12-381 objects.-class MultiplyPoint scalar point where-  -- | Multiply point value by scalar value.-  multiply :: scalar -> point -> point---- | G1 point on the curve.-newtype Bls12381G1 = Bls12381G1 { unBls12381G1 :: BLS.G1' }-  deriving stock (Show, Eq)-  deriving newtype (NFData)--instance CurveObject Bls12381G1 where-  zero = Bls12381G1 C.id-  negate (Bls12381G1 v) = Bls12381G1 (C.inv v)-  add (Bls12381G1 a) (Bls12381G1 b) = Bls12381G1 (C.add a b)-  generate = Bls12381G1 <$> C.rnd-  fromMichelsonBytes =-    let bsToCoord = toPrime . fromBigEndian-    in fmap Bls12381G1 . parseJA2WAPoint g1CoordLen bsToCoord-  toMichelsonBytes =-    let coordToBs = toBigEndian g1CoordLen . fromPrime-    in convertWA2JAPoint g1CoordLen coordToBs . unBls12381G1--instance MultiplyPoint Integer Bls12381G1 where-  multiply s (Bls12381G1 p) = Bls12381G1 (C.mul' p s)---- | G2 point on the curve.-newtype Bls12381G2 = Bls12381G2 { unBls12381G2 :: BLS.G2' }-  deriving stock (Show, Eq)-  deriving newtype (NFData)--instance CurveObject Bls12381G2 where-  zero = Bls12381G2 C.id-  negate (Bls12381G2 v) = Bls12381G2 (C.inv v)-  add (Bls12381G2 a) (Bls12381G2 b) = Bls12381G2 (C.add a b)-  generate = Bls12381G2 <$> C.rnd-  fromMichelsonBytes =-    let fromBsPair = map fromBigEndian . toListOf each . BS.splitAt (g2CoordLen `div` 2)-        bsToCoord = GF.toE . reverse . map toPrime . fromBsPair-    in fmap Bls12381G2 . parseJA2WAPoint g2CoordLen bsToCoord-  toMichelsonBytes =-    let toBsPair = foldMap (toBigEndian $ g2CoordLen `div` 2)-        coordToBs = toBsPair . map fromPrime . reverse . GF.fromE-    in convertWA2JAPoint g1CoordLen coordToBs . unBls12381G2--instance MultiplyPoint Integer Bls12381G2 where-  multiply s (Bls12381G2 p) = Bls12381G2 (C.mul' p s)---- | An element of an algebraic number field (scalar), used for multiplying--- 'Bls12381G1' and 'Bls12381G2'.-newtype Bls12381Fr = Bls12381Fr { unBls12381Fr :: BLS.Fr }-  deriving stock (Show, Eq, Ord)-  deriving newtype (Num, Enum, Bounded, Real, Integral, Fractional, NFData)--instance CurveObject Bls12381Fr where-  zero = Bls12381Fr 0-  negate = Prelude.negate-  add = (+)-  generate = Bls12381Fr <$> getRandom-  fromMichelsonBytes bs =-    if length bs > frLen-    then Left $ TooLargeLength ! #limit frLen ! #given (length bs)-    else-      let num = fromLittleEndian bs-      in fromIntegralChecked num-           & first (\_ -> ValueOutsideOfField $ toInteger num)-  toMichelsonBytes = toLittleEndian frLen . fromPrime . unBls12381Fr--instance MultiplyPoint Bls12381Fr Bls12381G1 where-  multiply (Bls12381Fr s) (Bls12381G1 p) = Bls12381G1 (C.mul p s)--instance MultiplyPoint Bls12381Fr Bls12381G2 where-  multiply (Bls12381Fr s) (Bls12381G2 p) = Bls12381G2 (C.mul p s)---- | Checks that product of pairings of points in the list is equal to 1 in--- Fq12 field.-checkPairing :: [(Bls12381G1, Bls12381G2)] -> Bool-checkPairing pairs =-  -- Some hints for implementation of this function:-  -- https://gitlab.com/metastatedev/tezos/-/commit/bb2cda17d48a52ce854e027f0222a0463e0e66f0#af97cb649204420968454a94e7bfaa6a6e27195a_1285_1330-  -- https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3_0_172--  -- Monoid instance on GT' has the desired multiplicative semantics-  foldMap pairing pairs == mempty-  where-    pairing :: (Bls12381G1, Bls12381G2) -> BLS.GT'-    pairing (Bls12381G1 g1, Bls12381G2 g2) =-      BLS.finalExponentiationBLS12 BLS.parameterHex-        (BLS.millerAlgorithmBLS12 BLS.parameterBin g1 g2)--------------------------------------------------------------------------------- Serialization helpers--------------------------------------------------------------------------------- | All kinds of errors that can occur when reading a Michelson value.-data DeserializationError-  = CompressedFormIsNotSupported-  | UnexpectedLength ("expected" :! Int) ("given" :! Int)-  | TooLargeLength ("limit" :! Int) ("given" :! Int)-  | ValueOutsideOfField Integer-  | PointNotOnCurve ByteString-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)--instance Buildable DeserializationError where-  build = buildRenderDoc--instance RenderDoc DeserializationError where-  renderDoc _ = \case-    CompressedFormIsNotSupported ->-      "Compressed form of BLS12-381 point is not supported by Tezos"-    UnexpectedLength (arg #expected -> expected) (arg #given -> given) ->-      "Unexpected length of BLS12-381 primitive: \-      \expected" <+> (int expected) <> ", but given" <+> (int given)-    TooLargeLength (arg #limit -> limit) (arg #given -> given) ->-      "Too large length of BLS12-381 primitive: \-      \limit is" <+> (int limit) <+> ", but given" <+> (int given)-    ValueOutsideOfField v ->-      "Value is too large for the given field of values:" <+> (integer v)-    PointNotOnCurve bs ->-      "Point is not on curve: 0x" <> (renderAnyBuildable $ encodeHex bs)--{- Note on serialization:--In BLS12-381, "381" stands for the number of bits necessary to represent a-coordinate of a point on a curve, i.e. we have to use 48 bytes, getting 3 extra-bits. In the BLS12-381 library used by Tezos, those bits are exploited to carry-some meta information.--More info can be found here:-<https://github.com/zkcrypto/pairing/blob/307aa1f29dccaed09abe774d2027cad57fc5d0b4/src/bls12_381/README.md#serialization>.--So Fr is just a scalar (but a pretty big one), represented in little-endian-as said in the Michelson docs.--G1 and G2 represent a point on curve and have the following form:--      X coordinate         Y coordinate- |!___________________|____________________|-   \  (big-endian)         (big-endian)-    \-     `- bits with meta info--Generally, various coordinate systems may be used to represent a point on curve,-and the library picked by Tezos uses Jacobian coordinates, probably assuming-that the third @Z@ coordinate is always @1@.-Note that we use 'Data.Pairing.BLS12381' which by default picks Weierstrass-coordinates (it has two, not three coordinates, and an "infinity point" which-is kept as a special case), but it also provides methods for converting between-different coordinate systems.--Coordinates take a different amount of space in G1 and G2:-* In G1 both X and Y are from a so-called "Fr" field, where numbers take-  48 bytes (without the leading 3 bits).-* In G2 both coordinates are from "Fr2" field which is a two-dimensional field-  over "Fr", i.e. X and Y themselves contain two 48-byte coordinates each.--Note that this is correct for the "uncompressed" form, and there is a different-"compressed" form that, fortunately, seems to be not supported by Michelson.-They initially planned to have @COMPRESS@ and @UNCOMPRESS@ instructions, perhaps-for manual conversions, but those instructions didn't appear in Edonet-eventually.---}---- | A helper datatype for representing points in raw bytes form.-data RawPoint-  = Infinity-    -- ^ Point at infinity.-  | RawPoint ByteString-    -- ^ Bytes representing the payload.---- | Given the Michelson representation of a point, interpret flags--- and return the bare payload.------ This assumes that a proper number of bytes is provided.-parsePointFlags-  :: HasCallStack-  => ByteString -> Either DeserializationError RawPoint-parsePointFlags bsFull =-  case BS.uncons bsFull of-    Nothing -> error "Empty byte sequence"-    Just (b, bs)-      | b `testBit` compressionBit ->-          Left CompressedFormIsNotSupported-      | b `testBit` infinityBit ->-          return Infinity-      | otherwise -> do-          let-            b' = b .&. complement-              (sum $ map bit [compressionBit, infinityBit, flag3Bit])-          return $ RawPoint (BS.cons b' bs)---- | Fill a point in raw bytes form with the necessary flags.-fillPointFlags :: HasCallStack => Int -> RawPoint -> ByteString-fillPointFlags 0 = error "Coordinates are unexpectedly empty"-fillPointFlags len = \case-  Infinity -> BS.cons (0 `setBit` infinityBit) (BS.replicate (len - 1) 0)-  RawPoint bs -> bs---- | Get a bytestring containing coordinates of a point and split it,--- checking that each coordinate occupies the given number of bytes.-splitUncompressedPoint-  :: Int -> ByteString -> Either DeserializationError (ByteString, ByteString)-splitUncompressedPoint coordLen bs-  | length bs /= coordLen * 2 =-      Left $ UnexpectedLength ! #expected (coordLen * 2) ! #given (length bs)-  | otherwise =-      Right $ BS.splitAt coordLen bs---- | Parse a point in Weierstrass form and Affine coordinates,--- assuming that in the provided bytestring the point is given in Jacobian--- coordinates (the library used by Tezos operates in Jacobian coordinates).-parseJA2WAPoint-  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr-     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr-     )-  => Int-  -> (ByteString -> fq)-  -> ByteString-  -> Either DeserializationError (CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr)-parseJA2WAPoint coordLen toCoord full = do-  (xRawWithFlags, yRaw) <- splitUncompressedPoint coordLen full-  xRawPoint <- parsePointFlags xRawWithFlags-  case xRawPoint of-    Infinity -> return CW.O-    RawPoint xRaw ->-      let point = C.toA $ CW.J (toCoord xRaw) (toCoord yRaw) 1-      in if C.def point-         then return point-         else Left $ PointNotOnCurve full---- | Turn a Weierstrass Affine point into Jacobian coordinates and represent--- those as bytes.-convertWA2JAPoint-  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr-     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr-     )-  => Int-  -> (fq -> ByteString)-  -> CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr-  -> ByteString-convertWA2JAPoint coordLen toRawCoord point =-  let-    rawPoint = case point of-      CW.O -> Infinity-      p@CW.A{} -> RawPoint $-        let CW.J x y z = C.fromA p-           -- Conversion from Affine coordinates used to produce an already-           -- normalized value.-           -- In case this turns out to be incorrect, probably @x / z@ and @y / z@-           -- are just what we want.-        in assert (z == 1) $-            toRawCoord x <> toRawCoord y-  in fillPointFlags (coordLen * 2) rawPoint---- | Interpret a byte sequence as a number in big-endian.-fromBigEndian :: ByteString -> Natural-fromBigEndian bs =-  foldl' (\acc byte -> acc * 0x100 + fromIntegral @Word8 @Natural byte) 0 $-  BS.unpack bs---- | Interpret a byte sequence as a number in little-endian.-fromLittleEndian :: ByteString -> Natural-fromLittleEndian bs =-  sum . zipWith (*) (iterate (* 0x100) 1) . map (fromIntegral @Word8 @Natural) $-  BS.unpack bs---- | Represent a number in a big-endian byte sequence, padding the output--- to the expected length.------ We assert that the length is sufficient for representing the given number.-toBigEndian :: Int -> Natural -> ByteString-toBigEndian len num =-  BS.pack $-  let-    (remainder, bytes) = mapAccumR-      (\x _ -> second (fromIntegral @Natural @Word8) $ x `divMod` 0x100)-      num [1 .. len]-  in assert (remainder == 0) bytes---- | Represent a number in a little-endian byte sequence, padding the output--- to the expected length.------ We assert that the length is sufficient for representing the given number.-toLittleEndian :: Int -> Natural -> ByteString-toLittleEndian len num =-  BS.pack $-  let-    (remainder, bytes) = mapAccumL-      (\x _ -> second (fromIntegral @Natural @Word8) $ x `divMod` 0x100)-      num [1 .. len]-  in assert (remainder == 0) bytes---- | Turn a prime field element into a natural.-fromPrime :: KnownNat p => GF.Prime p -> Natural-fromPrime p =-  -- This should be safe, since 'Prime's exist in modular arithmetics,-  -- so its conversion to an integer should produce non-negative elements.-  -- In fact, 'GF.Prime' is a newtype wrapper over 'Natural', but-  -- its constructor is not exported :/-  assert (p >= 0) $-    fromIntegral p---- | The inverse to 'fromPrime'.-toPrime :: KnownNat p => Natural -> GF.Prime p-toPrime = fromIntegral---- Primitives' lengths--------------------------------------------------------------------------------- | Length of a single coordinate of a point in raw bytes form.-g1CoordLen, g2CoordLen :: Int-g1CoordLen = 48-g2CoordLen = 96  -- each coordinate is an element of two-dimensional field Fr2---- | Length of 'Fr' in raw bytes form.-frLen :: Int-frLen = 32---- Meta bits--------------------------------------------------------------------------------- | This bit designates whether the point is represented in compressed form--- (only X coordinate), or uncompressed form (both X and Y coordinates).-compressionBit :: Int-compressionBit = 7---- | This bit designates whether the given point is at infinity.------ If so, all other bytes should be zeros.-infinityBit :: Int-infinityBit = 6---- | This bit is set iff "this point is in compressed form /and/ it is not the--- point at infinity /and/ its y-coordinate is the lexicographically largest of--- the two associated with the encoded x-coordinate".------ Fortunatelly, this flag seems to be not relevant for us at the moment.-flag3Bit :: Int-flag3Bit = 5--------------------------------------------------------------------------------- Other constants--------------------------------------------------------------------------------- | @1@ represented in G1 - as the libraries used by Tezos see it.------ Taken from here: <https://github.com/ethereum/py_ecc/blob/3f644b4c07c8270b8fbe989eb799766aca66face/py_ecc/optimized_bls12_381/optimized_curve.py#L34>.-g1One :: Bls12381G1-g1One = Bls12381G1 $ CW.toA $ CW.J-  3685416753713387016781088315183077757961620795782546409894578378688607592378376318836054947676345821548104185464507-  1339506544944476473020471379941921221584933875938349620426543736416511423956333506472724655353366534992391756441569-  1---- | @1@ represented in G2.-g2One :: Bls12381G2-g2One = Bls12381G2 $ CW.toA $ CW.J-  (GF.toE-    [ 352701069587466618187139116011060144890029952792775240219908644239793785735715026873347600343865175952761926303160-    , 3059144344244213709971259814753781636986470325476647558659373206291635324768958432433509563104347017837885763365758-    ])-  (GF.toE-    [ 1985150602287291935568054521177171638300868978215655730859378665066344726373823718423869104263333984641494340347905-    , 927553665492332455747201965776037880757740193453592970025027978793976877002675564980949289727957565575433344219582-    ])-  (GF.toE [1, 0])

− src/Tezos/Crypto/Ed25519.hs

@@ -1,180 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Ed25519 cryptographic primitives.--module Tezos.Crypto.Ed25519-  ( -- * Cryptographic primitive types-    PublicKey (..)-  , SecretKey-  , Signature (..)-  , detSecretKey-  , toPublic--  -- * Raw bytes (no checksums, tags or anything)-  , publicKeyToBytes-  , mkPublicKey-  , publicKeyLengthBytes-  , signatureToBytes-  , mkSignature-  , signatureLengthBytes--  -- * Formatting and parsing-  , formatPublicKey-  , mformatPublicKey-  , parsePublicKey-  , formatSecretKey-  , parseSecretKey-  , formatSignature-  , mformatSignature-  , parseSignature--  -- * Signing-  , sign-  , checkSignature-  ) where--import Crypto.Error (onCryptoFailure)-import qualified Crypto.PubKey.Ed25519 as Ed25519-import Data.ByteArray (ByteArray, ByteArrayAccess, convert)-import Fmt (Buildable, build)--import Michelson.Text-import Tezos.Crypto.Hash-import Tezos.Crypto.Util--------------------------------------------------------------------------------- Types, instances, conversions--------------------------------------------------------------------------------- | ED25519 public cryptographic key.-newtype PublicKey = PublicKey-  { unPublicKey :: Ed25519.PublicKey-  } deriving stock (Show, Eq, Generic)--instance NFData PublicKey--instance Ord PublicKey where-  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)---- | ED25519 secret cryptographic key.-newtype SecretKey = SecretKey-  { unSecretKey :: Ed25519.SecretKey-  } deriving stock (Show, Eq, Generic)--instance NFData SecretKey---- | Deterministicaly generate a secret key from seed.-detSecretKey :: ByteString -> SecretKey-detSecretKey seed = SecretKey $ deterministic seed Ed25519.generateSecretKey---- | Create a public key from a secret key.-toPublic :: SecretKey -> PublicKey-toPublic = PublicKey . Ed25519.toPublic . unSecretKey---- | ED25519 cryptographic signature.-newtype Signature = Signature-  { unSignature :: Ed25519.Signature-  } deriving stock (Show, Eq, Generic)--instance NFData Signature--------------------------------------------------------------------------------- Conversion to/from raw bytes (no checksums, tags or anything)--------------------------------------------------------------------------------- | Convert a 'PublicKey' to raw bytes.-publicKeyToBytes :: ByteArray ba => PublicKey -> ba-publicKeyToBytes = convert . unPublicKey---- | Make a 'PublicKey' from raw bytes.-mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey-mkPublicKey =-  onCryptoFailure (Left . CryptoParseCryptoError) (Right . PublicKey) .-  Ed25519.publicKey--publicKeyLengthBytes :: Integral n => n-publicKeyLengthBytes = fromIntegral Ed25519.publicKeySize---- | Convert a 'Signature' to raw bytes.-signatureToBytes :: ByteArray ba => Signature -> ba-signatureToBytes = convert . unSignature---- | Make a 'Signature' from raw bytes.-mkSignature :: ByteArrayAccess ba => ba -> Either CryptoParseError Signature-mkSignature =-  onCryptoFailure (Left . CryptoParseCryptoError) (Right . Signature) .-  Ed25519.signature--signatureLengthBytes :: Integral n => n-signatureLengthBytes = fromIntegral Ed25519.signatureSize--mkSecretKey :: ByteArrayAccess ba => ba -> Either CryptoParseError SecretKey-mkSecretKey = onCryptoFailure (Left . CryptoParseCryptoError) (Right . SecretKey) .-  Ed25519.secretKey--------------------------------------------------------------------------------- Magic bytes-------------------------------------------------------------------------------publicKeyTag :: ByteString-publicKeyTag = "\13\15\37\217"--secretKeyTag :: ByteString-secretKeyTag = "\13\15\58\7"--signatureTag :: ByteString-signatureTag = "\9\245\205\134\18"--------------------------------------------------------------------------------- Formatting-------------------------------------------------------------------------------formatPublicKey :: PublicKey -> Text-formatPublicKey = formatImpl publicKeyTag . unPublicKey--mformatPublicKey :: PublicKey -> MText-mformatPublicKey = unsafeMkMText . formatPublicKey--instance Buildable PublicKey where-  build = build . formatPublicKey--parsePublicKey :: Text -> Either CryptoParseError PublicKey-parsePublicKey = parseImpl publicKeyTag mkPublicKey--formatSecretKey :: SecretKey -> Text-formatSecretKey = formatImpl secretKeyTag . unSecretKey--instance Buildable SecretKey where-  build = build . formatSecretKey--parseSecretKey :: Text -> Either CryptoParseError SecretKey-parseSecretKey = parseImpl secretKeyTag mkSecretKey--formatSignature :: Signature -> Text-formatSignature = formatImpl signatureTag . unSignature--mformatSignature :: Signature -> MText-mformatSignature = unsafeMkMText . formatSignature--instance Buildable Signature where-  build = build . formatSignature--parseSignature :: Text -> Either CryptoParseError Signature-parseSignature = parseImpl signatureTag mkSignature--------------------------------------------------------------------------------- Signing--------------------------------------------------------------------------------- | Sign a message using the secret key.-sign :: SecretKey -> ByteString -> Signature-sign sk =-  Signature .-  Ed25519.sign (unSecretKey sk) (unPublicKey (toPublic sk)) . blake2b---- | Check that a sequence of bytes has been signed with a given key.-checkSignature :: PublicKey -> Signature -> ByteString -> Bool-checkSignature (PublicKey pk) (Signature sig) bytes =-  Ed25519.verify pk (blake2b bytes) sig

− src/Tezos/Crypto/Hash.hs

@@ -1,51 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Cryptographic primitives related to hashing.--module Tezos.Crypto.Hash-  ( blake2b-  , blake2b160-  , keccak-  , sha256-  , sha3-  , sha512-  ) where--import Crypto.Hash (Blake2b_160, Blake2b_256, Digest, Keccak_256, SHA256, SHA3_256, SHA512, hash)-import qualified Data.ByteArray as ByteArray---- | Compute a cryptographic hash of a bytestring using the--- Blake2b_256 cryptographic hash function. It's used by the BLAKE2B--- instruction in Michelson.-blake2b :: ByteString -> ByteString-blake2b = fromDigest @Blake2b_256 . hash---- | Compute a cryptographic hash of a bytestring using the--- Blake2b_160 cryptographic hash function.-blake2b160 :: ByteString -> ByteString-blake2b160 = fromDigest @Blake2b_160 . hash---- | Compute a cryptographic hash of a bytestring using the--- Sha256 cryptographic hash function.-sha256 :: ByteString -> ByteString-sha256 = fromDigest @SHA256 . hash---- | Compute a cryptographic hash of a bytestring using the--- Sha512 cryptographic hash function.-sha512 :: ByteString -> ByteString-sha512 = fromDigest @SHA512 . hash---- | Compute a cryptographic hash of a bytestring using the Sha3_256--- cryptographic hash function. It is used by the SHA3 Michelson instruction.-sha3 :: ByteString -> ByteString-sha3 = fromDigest @SHA3_256 . hash---- | Compute a cryptographic hash of a bytestring using the Keccak_256--- cryptographic hash function. It is used by the KECCAK Michelson instruction.-keccak :: ByteString -> ByteString-keccak = fromDigest @Keccak_256 . hash--fromDigest :: forall a. Digest a -> ByteString-fromDigest = ByteArray.convert

− src/Tezos/Crypto/P256.hs

@@ -1,201 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | P256 cryptographic primitives.--module Tezos.Crypto.P256-  ( -- * Cryptographic primitive types-    PublicKey (..)-  , SecretKey-  , Signature (..)-  , detSecretKey-  , detSecretKeyDo-  , toPublic--  -- * Raw bytes (no checksums, tags or anything)-  , publicKeyToBytes-  , mkPublicKey-  , publicKeyLengthBytes-  , signatureToBytes-  , mkSignature-  , signatureLengthBytes--  -- * Formatting and parsing-  , formatPublicKey-  , mformatPublicKey-  , parsePublicKey-  , formatSignature-  , mformatSignature-  , parseSignature-  , formatSecretKey-  , parseSecretKey--  -- * Signing-  , sign-  , checkSignature-  ) where--import Crypto.Hash (Blake2b_256(..))-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.ECC.Generate as ECC.Generate-import Crypto.PubKey.ECC.Types (Curve(..), CurveName(..), getCurveByName)-import Crypto.Random (MonadRandom)-import Data.ByteArray (ByteArray, ByteArrayAccess)-import Fmt (Buildable, build)--import Michelson.Text-import Tezos.Crypto.Util--curve :: Curve-curve = getCurveByName SEC_p256r1--------------------------------------------------------------------------------- Types, instances, conversions--------------------------------------------------------------------------------- | P256 public cryptographic key.-newtype PublicKey = PublicKey-  { unPublicKey :: ECDSA.PublicKey-  } deriving stock (Eq, Show, Generic)--instance NFData PublicKey where-  rnf (PublicKey (ECDSA.PublicKey cu q))-    = rnfCurve cu `seq` rnf q--instance Ord PublicKey where-  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)---- | P256 secret cryptographic key.-newtype SecretKey = SecretKey-  { unSecretKey :: ECDSA.KeyPair-  } deriving stock (Show, Eq, Generic)--instance NFData SecretKey where-  rnf (SecretKey (ECDSA.KeyPair cu pp pn)) =-    rnfCurve cu `seq` rnf (pp, pn)---- | Deterministicaly generate a secret key from seed.-detSecretKey :: ByteString -> SecretKey-detSecretKey seed = deterministic seed $ detSecretKeyDo--detSecretKeyDo :: MonadRandom m => m SecretKey-detSecretKeyDo = SecretKey <$> do-  (publicKey, privateKey) <- ECC.Generate.generate curve-  return $-    ECDSA.KeyPair curve (ECDSA.public_q publicKey) (ECDSA.private_d privateKey)---- | Create a public key from a secret key.-toPublic :: SecretKey -> PublicKey-toPublic =-  PublicKey .-  ECDSA.PublicKey curve . (\(ECDSA.KeyPair _ pp _) -> pp) . unSecretKey---- | P256 cryptographic signature.-newtype Signature = Signature-  { unSignature :: ECDSA.Signature-  } deriving stock (Show, Eq, Generic)--instance NFData Signature where-  rnf (Signature (ECDSA.Signature a b)) = rnf a `seq` rnf b--------------------------------------------------------------------------------- Conversion to/from raw bytes (no checksums, tags or anything)--------------------------------------------------------------------------------- | Convert a 'PublicKey' to raw bytes.-publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba-publicKeyToBytes (PublicKey p) =-  publicKeyToBytes_ curve p---- | Make a 'PublicKey' from raw bytes.-mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey-mkPublicKey ba = PublicKey <$> mkPublicKey_ curve ba--publicKeyLengthBytes :: Integral n => n-publicKeyLengthBytes = publicKeyLengthBytes_ curve---- | Convert a 'PublicKey' to raw bytes.-signatureToBytes :: ByteArray ba => Signature -> ba-signatureToBytes (Signature sig) =-  signatureToBytes_ curve sig---- | Make a 'Signature' from raw bytes.-mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature-mkSignature ba = Signature <$> mkSignature_ curve ba--signatureLengthBytes :: Integral n => n-signatureLengthBytes = signatureLengthBytes_ curve--mkSecretKey :: ByteArray ba => ba -> Either CryptoParseError SecretKey-mkSecretKey = Right . SecretKey . mkSecretKey_ curve---- | Convert a 'PublicKey' to raw bytes.-secretKeyToBytes :: ByteArray ba => SecretKey -> ba-secretKeyToBytes (SecretKey kp) =-  secretKeyToBytes_ kp--------------------------------------------------------------------------------- Magic bytes-------------------------------------------------------------------------------publicKeyTag :: ByteString-publicKeyTag = "\003\178\139\127"---- | Base16 format is @1051eebd@-secretKeyTag :: ByteString-secretKeyTag = "\016\081\238\189"--signatureTag :: ByteString-signatureTag = "\054\240\044\052"--------------------------------------------------------------------------------- Formatting-------------------------------------------------------------------------------formatPublicKey :: PublicKey -> Text-formatPublicKey = formatImpl @ByteString publicKeyTag . publicKeyToBytes--mformatPublicKey :: PublicKey -> MText-mformatPublicKey = unsafeMkMText . formatPublicKey--instance Buildable PublicKey where-  build = build . formatPublicKey--parsePublicKey :: Text -> Either CryptoParseError PublicKey-parsePublicKey = parseImpl publicKeyTag mkPublicKey--formatSignature :: Signature -> Text-formatSignature = formatImpl @ByteString signatureTag . signatureToBytes--mformatSignature :: Signature -> MText-mformatSignature = unsafeMkMText . formatSignature--instance Buildable Signature where-  build = build . formatSignature--parseSignature :: Text -> Either CryptoParseError Signature-parseSignature = parseImpl signatureTag mkSignature--formatSecretKey :: SecretKey -> Text-formatSecretKey = formatImpl @ByteString secretKeyTag . secretKeyToBytes--instance Buildable SecretKey where-  build = build . formatSecretKey--parseSecretKey :: Text -> Either CryptoParseError SecretKey-parseSecretKey = parseImpl secretKeyTag mkSecretKey--------------------------------------------------------------------------------- Signing--------------------------------------------------------------------------------- | Sign a message using the secret key.-sign :: MonadRandom m => SecretKey -> ByteString -> m Signature-sign (SecretKey keyPair) =-  fmap Signature . ECDSA.sign (ECDSA.toPrivateKey keyPair) Blake2b_256---- | Check that a sequence of bytes has been signed with a given key.-checkSignature :: PublicKey -> Signature -> ByteString -> Bool-checkSignature (PublicKey pk) (Signature sig) =-  ECDSA.verify Blake2b_256 pk sig

− src/Tezos/Crypto/Secp256k1.hs

@@ -1,201 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Secp256k1 cryptographic primitives.--module Tezos.Crypto.Secp256k1-  ( -- * Cryptographic primitive types-    PublicKey (..)-  , SecretKey-  , Signature (..)-  , detSecretKey-  , detSecretKeyDo-  , toPublic--  -- * Raw bytes (no checksums, tags or anything)-  , publicKeyToBytes-  , mkPublicKey-  , publicKeyLengthBytes-  , signatureToBytes-  , mkSignature-  , signatureLengthBytes--  -- * Formatting and parsing-  , formatPublicKey-  , mformatPublicKey-  , parsePublicKey-  , formatSignature-  , mformatSignature-  , parseSignature-  , formatSecretKey-  , parseSecretKey--  -- * Signing-  , sign-  , checkSignature-  ) where--import Crypto.Hash (Blake2b_256(..))-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.ECC.Generate as ECC.Generate-import Crypto.PubKey.ECC.Types (Curve(..), CurveName(..), getCurveByName)-import Crypto.Random (MonadRandom)-import Data.ByteArray (ByteArray, ByteArrayAccess)-import Fmt (Buildable, build)--import Michelson.Text-import Tezos.Crypto.Util--curve :: Curve-curve = getCurveByName SEC_p256k1--------------------------------------------------------------------------------- Types, instances, conversions--------------------------------------------------------------------------------- | Secp256k1 public cryptographic key.-newtype PublicKey = PublicKey-  { unPublicKey :: ECDSA.PublicKey-  } deriving stock (Eq, Show, Generic)--instance NFData PublicKey where-  rnf (PublicKey (ECDSA.PublicKey cu q))-    = rnfCurve cu `seq` rnf q--instance Ord PublicKey where-  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)---- | Secp256k1 secret cryptographic key.-newtype SecretKey = SecretKey-  { unSecretKey :: ECDSA.KeyPair-  } deriving stock (Show, Eq, Generic)--instance NFData SecretKey where-  rnf (SecretKey (ECDSA.KeyPair cu pp pn)) =-    rnfCurve cu `seq` rnf (pp, pn)---- | Deterministicaly generate a secret key from seed.-detSecretKey :: ByteString -> SecretKey-detSecretKey seed = deterministic seed $ detSecretKeyDo--detSecretKeyDo :: MonadRandom m => m SecretKey-detSecretKeyDo = SecretKey <$> do-  (publicKey, privateKey) <- ECC.Generate.generate curve-  return $-    ECDSA.KeyPair curve (ECDSA.public_q publicKey) (ECDSA.private_d privateKey)---- | Create a public key from a secret key.-toPublic :: SecretKey -> PublicKey-toPublic =-  PublicKey .-  ECDSA.PublicKey curve . (\(ECDSA.KeyPair _ pp _) -> pp) . unSecretKey---- | Secp256k1 cryptographic signature.-newtype Signature = Signature-  { unSignature :: ECDSA.Signature-  } deriving stock (Show, Eq, Generic)--instance NFData Signature where-  rnf (Signature (ECDSA.Signature a b)) = rnf a `seq` rnf b--------------------------------------------------------------------------------- Conversion to/from raw bytes (no checksums, tags or anything)--------------------------------------------------------------------------------- | Convert a 'PublicKey' to raw bytes.-publicKeyToBytes :: forall ba. ByteArray ba => PublicKey -> ba-publicKeyToBytes (PublicKey p) =-  publicKeyToBytes_ curve p---- | Make a 'PublicKey' from raw bytes.-mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey-mkPublicKey ba = PublicKey <$> mkPublicKey_ curve ba--publicKeyLengthBytes :: Integral n => n-publicKeyLengthBytes = publicKeyLengthBytes_ curve---- | Convert a 'PublicKey' to raw bytes.-signatureToBytes :: ByteArray ba => Signature -> ba-signatureToBytes (Signature sig) =-  signatureToBytes_ curve sig---- | Make a 'Signature' from raw bytes.-mkSignature :: ByteArray ba => ba -> Either CryptoParseError Signature-mkSignature ba = Signature <$> mkSignature_ curve ba--signatureLengthBytes :: Integral n => n-signatureLengthBytes = signatureLengthBytes_ curve--mkSecretKey :: ByteArray ba => ba -> Either CryptoParseError SecretKey-mkSecretKey = Right . SecretKey . mkSecretKey_ curve---- | Convert a 'PublicKey' to raw bytes.-secretKeyToBytes :: ByteArray ba => SecretKey -> ba-secretKeyToBytes (SecretKey kp) =-  secretKeyToBytes_ kp--------------------------------------------------------------------------------- Magic bytes-------------------------------------------------------------------------------publicKeyTag :: ByteString-publicKeyTag = "\003\254\226\086"---- | Base16 format is @11a2e0c9@-secretKeyTag :: ByteString-secretKeyTag = "\017\162\224\201"--signatureTag :: ByteString-signatureTag = "\013\115\101\019\063"--------------------------------------------------------------------------------- Formatting-------------------------------------------------------------------------------formatPublicKey :: PublicKey -> Text-formatPublicKey = formatImpl @ByteString publicKeyTag . publicKeyToBytes--mformatPublicKey :: PublicKey -> MText-mformatPublicKey = unsafeMkMText . formatPublicKey--instance Buildable PublicKey where-  build = build . formatPublicKey--parsePublicKey :: Text -> Either CryptoParseError PublicKey-parsePublicKey = parseImpl publicKeyTag mkPublicKey--formatSignature :: Signature -> Text-formatSignature = formatImpl @ByteString signatureTag . signatureToBytes--mformatSignature :: Signature -> MText-mformatSignature = unsafeMkMText . formatSignature--instance Buildable Signature where-  build = build . formatSignature--parseSignature :: Text -> Either CryptoParseError Signature-parseSignature = parseImpl signatureTag mkSignature--formatSecretKey :: SecretKey -> Text-formatSecretKey = formatImpl @ByteString secretKeyTag . secretKeyToBytes--instance Buildable SecretKey where-  build = build . formatSecretKey--parseSecretKey :: Text -> Either CryptoParseError SecretKey-parseSecretKey = parseImpl secretKeyTag mkSecretKey--------------------------------------------------------------------------------- Signing--------------------------------------------------------------------------------- | Sign a message using the secret key.-sign :: MonadRandom m => SecretKey -> ByteString -> m Signature-sign (SecretKey keyPair) =-  fmap Signature . ECDSA.sign (ECDSA.toPrivateKey keyPair) Blake2b_256---- | Check that a sequence of bytes has been signed with a given key.-checkSignature :: PublicKey -> Signature -> ByteString -> Bool-checkSignature (PublicKey pk) (Signature sig) =-  ECDSA.verify Blake2b_256 pk sig

− src/Tezos/Crypto/Util.hs

@@ -1,256 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities shared by multiple cryptographic primitives.--module Tezos.Crypto.Util-  ( CryptoParseError (..)-  , encodeBase58Check-  , decodeBase58Check-  , B58CheckWithPrefixError (..)-  , decodeBase58CheckWithPrefix-  , formatImpl-  , parseImpl-  , firstRight-  , deterministic--  -- * ECDSA Utils-  , rnfCurve-  , publicKeyLengthBytes_-  , mkSignature_-  , mkSecretKey_-  , secretKeyToBytes_-  , signatureToBytes_-  , mkPublicKey_-  , publicKeyToBytes_-  , signatureLengthBytes_-  ) where--import Crypto.Error (CryptoError)-import Crypto.Number.ModArithmetic (squareRoot)-import Crypto.Number.Serialize (i2ospOf_, os2ip)-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.ECC.Generate as ECC.Generate-import Crypto.PubKey.ECC.Types-  (Curve(..), CurveCommon(..), CurvePrime(..), Point(..), curveSizeBits)-import Crypto.Random (ChaChaDRG, MonadPseudoRandom, drgNewSeed, seedFromInteger, withDRG)-import qualified Data.Binary.Get as Get-import qualified Data.ByteArray as BA-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base58 as Base58-import qualified Data.ByteString.Lazy as LBS-import Fmt (Buildable, Builder, build, hexF)-import Text.PrettyPrint.Leijen.Text ((<+>), int, textStrict)--import Tezos.Crypto.Hash-import Util.Binary (getRemainingByteStringCopy)-import Michelson.Printer.Util (RenderDoc(..), renderAnyBuildable, buildRenderDocExtended)----- | Error that can happen during parsing of cryptographic primitive types.-data CryptoParseError-  = CryptoParseWrongBase58Check-  | CryptoParseWrongTag ByteString-  | CryptoParseCryptoError CryptoError-  | CryptoParseUnexpectedLength Builder Int-  | CryptoParseBinaryError Text-  deriving stock (Show, Eq)--instance NFData CryptoParseError where-  rnf = rnf @String . show--instance Buildable CryptoParseError where-  build = buildRenderDocExtended--instance RenderDoc CryptoParseError where-  renderDoc _ = \case-    CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"-    CryptoParseWrongTag tag -> "Prefix is wrong tag:" <+> (renderAnyBuildable $ hexF tag)-    CryptoParseCryptoError err ->-      "Cryptographic library reported an error: " <>-        (renderAnyBuildable $ (displayException err))-    CryptoParseUnexpectedLength what l ->-      "Unexpected length of" <+> renderAnyBuildable what <> ":" <+> int l-    CryptoParseBinaryError err -> textStrict err------ | Encode a bytestring in Base58Check format.-encodeBase58Check :: ByteString -> Text-encodeBase58Check =-  decodeUtf8 . Base58.encodeBase58 Base58.bitcoinAlphabet . withCheckSum-  where-    withCheckSum :: ByteString -> ByteString-    withCheckSum bs = bs <> checkSum bs---- | Decode a bytestring from Base58Check format.-decodeBase58Check :: Text -> Maybe ByteString-decodeBase58Check base58text = do-  bytes <- Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 base58text)-  let (payload, chk) = BS.splitAt (length bytes - 4) bytes-  guard $ chk == checkSum payload-  return payload--checkSum :: ByteString -> ByteString-checkSum = BS.take 4 . (sha256 . sha256)--data B58CheckWithPrefixError-  = B58CheckWithPrefixWrongPrefix ByteString-  | B58CheckWithPrefixWrongEncoding-  deriving stock (Show)---- | Parse a base58check encoded value expecting some prefix. If the--- actual prefix matches the expected one, it's stripped of and the--- resulting payload is returned.-decodeBase58CheckWithPrefix ::-  ByteString -> Text -> Either B58CheckWithPrefixError ByteString-decodeBase58CheckWithPrefix prefix base58text =-  case decodeBase58Check base58text of-    Nothing -> Left B58CheckWithPrefixWrongEncoding-    Just bs ->-      let (actualPrefix, payload) = BS.splitAt (length prefix) bs-       in if actualPrefix == prefix-          then Right payload-          else Left (B58CheckWithPrefixWrongPrefix actualPrefix)---- | Template for 'format*' functions.-formatImpl :: BA.ByteArrayAccess x => ByteString -> x -> Text-formatImpl tag = encodeBase58Check . mappend tag . BA.convert---- | Template for 'parse*' functions.-parseImpl-  :: ByteString-  -> (ByteString -> Either CryptoParseError res)-  -> Text-  -> Either CryptoParseError res-parseImpl expectedTag constructor textToParse = do-  let convertErr :: B58CheckWithPrefixError -> CryptoParseError-      convertErr =-        \case B58CheckWithPrefixWrongPrefix prefix -> CryptoParseWrongTag prefix-              B58CheckWithPrefixWrongEncoding -> CryptoParseWrongBase58Check-  payload <- first convertErr $ decodeBase58CheckWithPrefix expectedTag textToParse-  constructor payload---- | Returns first encountered 'Right' in a list. If there are none,--- returns arbitrary 'Left'.--- It is useful to implement parsing.-firstRight :: NonEmpty (Either e a) -> Either e a-firstRight (h :| rest) =-  case h of-    Left e -> maybe (Left e) firstRight $ nonEmpty rest-    Right a -> Right a---- | Do randomized action using specified seed.-deterministic :: ByteString -> MonadPseudoRandom ChaChaDRG a -> a-deterministic seed = fst . withDRG chachaSeed-  where-    chachaSeed = drgNewSeed . seedFromInteger . os2ip $ seed-------------------------------------------------------------- Utilities shared by @Secp256k1@ and @P256@.------------------------------------------------------------rnfCurve :: Curve -> ()-rnfCurve cu =-  case cu of-    CurveF2m c -> rnf c-    CurveFP (CurvePrime i (CurveCommon a b c d e)) ->-      rnf (i, a, b, c, d, e)--curveSizeBytes :: Curve -> Int-curveSizeBytes curve = curveSizeBits curve `div` 8--signatureLengthBytes_ :: Integral n => Curve -> n-signatureLengthBytes_ curve = fromIntegral $ (curveSizeBytes curve) + (curveSizeBytes curve)--coordToBytes :: BA.ByteArray ba => Curve -> Integer -> ba-coordToBytes curve = i2ospOf_ (curveSizeBytes curve)--publicKeyLengthBytes_ :: Integral n => Curve -> n-publicKeyLengthBytes_ curve = fromIntegral $ 1 + (curveSizeBytes curve)---- | Make a 'PublicKey' from raw bytes.------ Raw bytes are in the format of Compressed SEC Format. Refer to this article on how this is parsed:--- <https://www.oreilly.com/library/view/programming-bitcoin/9781492031482/ch04.html>----mkPublicKey_ :: BA.ByteArrayAccess ba => Curve -> ba -> Either CryptoParseError ECDSA.PublicKey-mkPublicKey_ curve ba-  | l == (publicKeyLengthBytes_ curve) = do-      (isYEven, x) <- toCryptoEither $ Get.runGetOrFail getX-          (LBS.fromStrict $ BA.convert ba)-      (p, a, b) <- fromCurveFP curve-      let alpha = x ^ (3 :: Integer) + a * x + b-      beta <- squareRoot p alpha-                & maybeToRight (CryptoParseBinaryError "Could not find square root.")-      let (evenBeta, oddBeta) =-            if even beta then-              (beta, p - beta)-            else-              (p - beta, beta)-      let y = if isYEven then evenBeta-                         else oddBeta-      pure $ ECDSA.PublicKey curve $ Point x y-  | otherwise =-    Left $ CryptoParseUnexpectedLength "public key" l-  where-    l = BA.length ba--    getX :: Get.Get (Bool, Integer)-    getX = do-      yPrefix <- Get.getWord8-      xBytes <- getRemainingByteStringCopy-      return (even yPrefix, os2ip xBytes)--    fromCurveFP :: Curve -> Either CryptoParseError (Integer, Integer, Integer)-    fromCurveFP = \case-      CurveFP (CurvePrime p (CurveCommon a b _ _ _)) -> Right (p, a, b)-      CurveF2m _ -> Left $ CryptoParseBinaryError-        "Should not happen. Expect `curve` to be `CurveFP` but got `CurveF2m` instead."--    toCryptoEither :: Either (_a, _b, String) (_c, _d, a) -> Either CryptoParseError a-    toCryptoEither g =-      case g of-        Right (_, _, a) -> Right a-        Left (_, _, err) -> Left $ CryptoParseBinaryError $ toText err---- | Convert a 'PublicKey' to raw bytes.-publicKeyToBytes_ :: forall ba. (BA.ByteArray ba, HasCallStack) => Curve -> ECDSA.PublicKey -> ba-publicKeyToBytes_ curve (ECDSA.PublicKey _ publicPoint) =-  case publicPoint of-    Point x y -> prefix y `BA.append` coordToBytes curve x-    PointO -> error "PublicKey somehow contains infinity point"-  where-    prefix :: Integer -> ba-    prefix y-      | odd y = BA.singleton 0x03-      | otherwise = BA.singleton 0x02---- | Convert a 'PublicKey' to raw bytes.-signatureToBytes_ :: BA.ByteArray ba => Curve -> ECDSA.Signature -> ba-signatureToBytes_ curve (ECDSA.Signature r s) =-  coordToBytes curve r <> coordToBytes curve s---- | Convert a 'PublicKey' to raw bytes.-secretKeyToBytes_ :: BA.ByteArray ba => ECDSA.KeyPair -> ba-secretKeyToBytes_ (ECDSA.KeyPair c _ s) =-  coordToBytes c s---- | Make a 'Signature' from raw bytes.-mkSignature_ :: BA.ByteArray ba => Curve -> ba -> Either CryptoParseError ECDSA.Signature-mkSignature_ curve ba-  | l == (signatureLengthBytes_ curve)-  , (rBytes, sBytes) <- BA.splitAt (curveSizeBytes curve) ba =-    Right $ ECDSA.Signature (os2ip rBytes) (os2ip sBytes)-  | otherwise =-    Left $ CryptoParseUnexpectedLength "signature" l-  where-    l = BA.length ba---- | Make a 'SecretKey' from raw bytes.-mkSecretKey_ :: BA.ByteArray ba => Curve -> ba -> ECDSA.KeyPair-mkSecretKey_ c ba =-  let s = os2ip ba-      p = ECC.Generate.generateQ c s-  in ECDSA.KeyPair c p s

− src/Util/Aeson.hs

@@ -1,17 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities related to the @aeson@ package.--module Util.Aeson-  ( morleyAesonOptions-  ) where--import Data.Aeson.Casing (aesonPrefix, camelCase)-import Data.Aeson.TH (Options)---- | Options that we use in @morley@-based packages (including--- @morley@) by default.-morleyAesonOptions :: Options-morleyAesonOptions = aesonPrefix camelCase

− src/Util/Alternative.hs

@@ -1,17 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities related to 'Alternative'.--module Util.Alternative-  ( someNE-  ) where--import qualified Data.List.NonEmpty as NE---- | This function is the same as 'some' except that it returns--- 'NonEmpty', because 'some' is guaranteed to return non-empty list,--- but it's not captured in types.-someNE :: Alternative f => f a -> f (NonEmpty a)-someNE = fmap NE.fromList . some

− src/Util/Binary.hs

@@ -1,113 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Module contains helper functions when dealing with encoding--- and decoding 'Binary'-module Util.Binary-  ( UnpackError (..)-  , ensureEnd-  , launchGet-  , TaggedDecoder(..)-  , (#:)-  , decodeBytesLike-  , decodeWithTag-  , getByteStringCopy-  , getRemainingByteStringCopy-  , unknownTag-  ) where--import Prelude hiding (EQ, Ordering(..), get)--import Data.Binary (Get)-import qualified Data.Binary.Get as Get-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.List as List-import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (+||), (|+), (||+))-import Text.Hex (encodeHex)--------------------------------------------------------------------------------- Helpers--------------------------------------------------------------------------------- | Any decoding error.-newtype UnpackError = UnpackError { unUnpackError :: Text }-  deriving stock (Show, Eq)--instance Buildable UnpackError where-  build (UnpackError msg) = build msg--instance Exception UnpackError where-  displayException = pretty--ensureEnd :: Get ()-ensureEnd =-  unlessM Get.isEmpty $ do-    remainder <- Get.getRemainingLazyByteString-    fail $ "Expected end of entry, unconsumed bytes \-           \(" +| length remainder |+ "): "-           +|| encodeHex (LBS.toStrict remainder) ||+ ""--launchGet :: Get a -> LByteString -> Either UnpackError a-launchGet decoder bs =-  case Get.runGetOrFail decoder bs of-    Left (_remainder, _offset, err) -> Left . UnpackError $ toText err-    Right (_remainder, _offset, res) -> Right res---- | Describes how 'decodeWithTag' should decode tag-dependent data.--- We expect bytes of such structure: 'tdTag' followed by a bytestring--- which will be parsed with 'tdDecoder'.-data TaggedDecoder a = TaggedDecoder-  { tdTag :: Word8-  , tdDecoder :: Get a-  }---- | Alias for 'TaggedDecoder' constructor.-(#:) :: Word8 -> Get a -> TaggedDecoder a-(#:) = TaggedDecoder-infixr 0 #:---- | Get a bytestring of the given length leaving no references to the--- original data in serialized form.-getByteStringCopy :: Int -> Get ByteString-getByteStringCopy = fmap BS.copy . Get.getByteString---- | Get remaining available bytes.------ Note that reading all remaining decoded input may be expensive and is thus--- discouraged, use can use this function only when you know that amount--- of data to be consumed is limited, e.g. within 'decodeAsBytes' call.-getRemainingByteStringCopy :: Get ByteString-getRemainingByteStringCopy = do-  lbs <- Get.getRemainingLazyByteString-  -- Avoiding memory overflows in case bad length to 'Get.isolate' was provided.-  -- Normally this function is used only to decode primitives, 'Signature' in-  -- the worst case, so we could set little length, but since this is a hack-  -- anyway let's make sure it never obstructs our work.-  when (length lbs > 640000) $ fail "Too big length for an entity"-  return (LBS.toStrict lbs)---- | Fail with "unknown tag" error.-unknownTag :: String -> Word8 -> Get a-unknownTag desc tag =-  fail . fmt $ "Unknown " <> build desc <> " tag: 0x" <> hexF tag---- Common decoder for the case when packed data starts with a tag (1--- byte) that specifies how to decode remaining data.-decodeWithTag :: String -> [TaggedDecoder a] -> Get a-decodeWithTag what decoders = do-  tag <- Get.label (what <> " tag") Get.getWord8-  -- Number of decoders is usually small, so linear runtime lookup should be ok.-  case List.find ((tag ==) . tdTag) decoders of-    Nothing -> unknownTag what tag-    Just TaggedDecoder{..} -> tdDecoder--decodeBytesLike-  :: (Buildable err)-  => String -> (ByteString -> Either err a) -> Get a-decodeBytesLike what constructor = do-  bs <- getRemainingByteStringCopy-  case constructor bs of-    Left err -> fail $ "Wrong " +| what |+ ": " +| err |+ ""-    Right res -> pure res

− src/Util/ByteString.hs

@@ -1,26 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.ByteString-  ( HexJSONByteString(..)-  ) where--import Data.Aeson (FromJSON(..), ToJSON(..), withText)-import Text.Hex (decodeHex, encodeHex)---- | Newtype wrapper for ByteString which uses hexadecimal representation--- for JSON serialization.-newtype HexJSONByteString = HexJSONByteString { unHexJSONByteString :: ByteString }-  deriving stock (Eq, Ord, Show, Generic)-  deriving newtype (NFData, Hashable)--instance ToJSON HexJSONByteString where-  toJSON = toJSON . encodeHex . unHexJSONByteString--instance FromJSON HexJSONByteString where-  parseJSON =-    withText "Hex-encoded bytestring" $ \t ->-      case decodeHex t of-        Nothing -> fail "Invalid hex encoding"-        Just res -> pure (HexJSONByteString res)

− src/Util/CLI.hs

@@ -1,229 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities for command line options parsing--- (we use @optparse-applicative@).------ Some names exported from this module are quite general when if you--- do not assume @optparse-applicative@ usage, so consider using--- explicit imports for it.--module Util.CLI-  ( -- * General helpers-    maybeAddDefault-  , outputOption--  -- * Named and type class based parsing-  , HasCLReader (..)-  , mkCLOptionParser-  , mkCLOptionParserExt-  , mkCLArgumentParser-  , mkCLArgumentParserExt-  , mkCommandParser-  , namedParser--  -- ** Helpers for defining 'HasCLReader'-  , eitherReader-  , readerError-  , integralReader-  ) where--import Data.Text.Manipulate (toSpinal)-import Fmt (Buildable, pretty)-import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)-import Named (Name(..), arg)-import Options.Applicative-  (eitherReader, help, long, metavar, option, readerError, showDefaultWith, strOption, value)-import qualified Options.Applicative as Opt--import Util.Instances ()-import Util.Named-import Util.Num---- | Maybe add the default value and make sure it will be shown in--- help message.-maybeAddDefault :: Opt.HasValue f => (a -> String) -> Maybe a -> Opt.Mod f a-maybeAddDefault printer = maybe mempty addDefault-  where-    addDefault v = value v <> showDefaultWith printer---- | Parser for path to a file where output will be writen.-outputOption :: Opt.Parser (Maybe FilePath)-outputOption = optional . strOption $-  Opt.short 'o' <>-  long "output" <>-  metavar "FILEPATH" <>-  help "Write output to the given file. If not specified, stdout is used."--------------------------------------------------------------------------------- Named parsing--------------------------------------------------------------------------------- | Supporting typeclass for 'namedParser'.--- It specifies how a value should be parsed from command line.--- Even though the main purpose of this class is to implement--- helpers below, feel free to use it for other goals.-class HasCLReader a where-  getReader :: Opt.ReadM a-  -- | This string will be passed to the 'metavar' function, hence we-  -- use 'String' type rather 'Text' (even though we use 'Text' almost-  -- everywhere).-  getMetavar :: String---- Let's add instances when the need arises.--- The downside of having 'getMetavar' is that there is no instance--- 'HasCLReader' for 'String' (aka 'FilePath') because we want--- different metavars for filepaths and other strings.  We can define--- it as @FILEPATH@ because we normally use 'Text' for everything--- else, but it still sounds a bit dangerous.--instance HasCLReader Natural where-  getReader = integralReader-  getMetavar = "NATURAL NUMBER"--instance HasCLReader Word64 where-  getReader = integralReader-  -- ↓ Same as for 'Natural', the user usually does not care whether-  -- the number is bounded (reasonable values should fit anyway).-  -- We will apply the same rule for other numeric instances.-  getMetavar = "NATURAL NUMBER"--instance HasCLReader Word32 where-  getReader = integralReader-  getMetavar = "NATURAL NUMBER"--instance HasCLReader Word16 where-  getReader = integralReader-  getMetavar = "NATURAL NUMBER"--instance HasCLReader Word8 where-  getReader = integralReader-  getMetavar = "NATURAL NUMBER"--instance HasCLReader Word where-  getReader = integralReader-  getMetavar = "NATURAL NUMBER"--instance HasCLReader Integer where-  getReader = integralReader-  getMetavar = "INTEGER"--instance HasCLReader Int64 where-  getReader = integralReader-  getMetavar = "INTEGER"--instance HasCLReader Int32 where-  getReader = integralReader-  getMetavar = "INTEGER"--instance HasCLReader Int16 where-  getReader = integralReader-  getMetavar = "INTEGER"--instance HasCLReader Int8 where-  getReader = integralReader-  getMetavar = "INTEGER"--instance HasCLReader Int where-  getReader = integralReader-  getMetavar = "INTEGER"--instance HasCLReader Text where-  getReader = Opt.str-  getMetavar = "STRING"--instance HasCLReader String where-  getReader = Opt.str-  getMetavar = "STRING"---- | Parse a number, checking for overflows and other stuff.-integralReader :: Integral a => Opt.ReadM a-integralReader = do-  int <- Opt.auto @Integer-  fromIntegralChecked int-    & either (readerError . addPrefix . toString) pure-  where-    addPrefix = ("failed to parse command-line numeric argument: " <>)---- | Create a 'Opt.Parser' for a value using 'HasCLReader' instance--- (hence @CL@ in the name). It uses reader and metavar from that--- class, the rest should be supplied as arguments.------ We expect some common modifiers to be always provided, a list of--- extra modifies can be provided as well.-mkCLOptionParser ::-     forall a. (Buildable a, HasCLReader a)-  => Maybe a-  -> "name" :! String-  -> "help" :! String-  -> Opt.Parser a-mkCLOptionParser defValue name hInfo =-  mkCLOptionParserExt defValue name hInfo []---- | A more general version of 'mkCLOptionParser' which takes a list--- of extra (not as widely used) modifiers.-mkCLOptionParserExt ::-     forall a. (Buildable a, HasCLReader a)-  => Maybe a-  -> "name" :! String-  -> "help" :! String-  -> [Opt.Mod Opt.OptionFields a]-  -> Opt.Parser a-mkCLOptionParserExt defValue (arg #name -> name) (arg #help -> hInfo) mods =-  option getReader $ mconcat $-    metavar (getMetavar @a) :-    long name :-    help hInfo :-    maybeAddDefault pretty defValue :-    mods---- | Akin to 'mkCLOptionParser', but for arguments rather than options.-mkCLArgumentParser ::-     forall a. (Buildable a, HasCLReader a)-  => Maybe a-  -> "help" :! String-  -> Opt.Parser a-mkCLArgumentParser defValue hInfo = mkCLArgumentParserExt defValue hInfo []---- | Akin to 'mkCLOptionParserExt', but for arguments rather than options.-mkCLArgumentParserExt ::-     forall a. (Buildable a, HasCLReader a)-  => Maybe a-  -> "help" :! String-  -> [Opt.Mod Opt.ArgumentFields a]-  -> Opt.Parser a-mkCLArgumentParserExt defValue (arg #help -> hInfo) mods =-  Opt.argument getReader $ mconcat $-    metavar (getMetavar @a) :-    help hInfo :-    maybeAddDefault pretty defValue :-    mods---- | Parser for command options-mkCommandParser :: String -> Opt.Parser a -> String -> Opt.Mod Opt.CommandFields a-mkCommandParser commandName parser desc =-  Opt.command commandName $-  Opt.info (Opt.helper <*> parser) $-  Opt.progDesc desc---- | Create a 'Opt.Parser' for a value using its type-level name.------ This expects type-level name to be in camelCase as appropriate for Haskell--- and transforms the variable inside.-namedParser ::-     forall (a :: Type) (name :: Symbol).-     (Buildable a, HasCLReader a, KnownSymbol name)-  => Maybe a-  -> String-  -> Opt.Parser (name :! a)-namedParser defValue hInfo =-  option ((Name @name) <.!> getReader) $-    mconcat-    [ long (toString . toSpinal . toText $ name)-    , metavar (getMetavar @a)-    , help hInfo-    , maybeAddDefault pretty (Name @name <.!> defValue)-    ]-  where-    name = symbolVal (Proxy @name)

− src/Util/CustomGeneric.hs

@@ -1,594 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ------ | Generic deriving with unbalanced trees.--module Util.CustomGeneric-  ( -- * Custom Generic strategies-    GenericStrategy-  , withDepths-  , rightBalanced-  , leftBalanced-  , rightComb-  , leftComb-  , haskellBalanced-    -- ** Entries reordering-  , reorderingConstrs-  , reorderingFields-  , reorderingData-  , alphabetically-  , leaveUnnamedFields-  , forbidUnnamedFields-    -- * Depth usage helpers-  , cstr-  , fld-    -- * Instance derivation-  , customGeneric--    -- * Helpers-  , fromDepthsStrategy--    -- * Internals-  , reifyDataType-  , deriveFullType-  , customGeneric'-  ) where--import Prelude hiding (Type)--import Control.Lens (traversed)-import Generics.Deriving.TH (makeRep0Inline)-import qualified GHC.Generics as G-import Language.Haskell.TH-import Util.Generic (mkGenericTree)-import Util.TH (lookupTypeNameOrFail)--------------------------------------------------------------------------------- Simple type synonyms--------------------------------------------------------------------------------- | Simple tuple specifying the depth of a constuctor and a list of depths--- for its fields.------ This is used as a way to specify the tree topology of the Generic instance--- to derive.-type CstrDepth = (Natural, [Natural])---- | Simple tuple that defines the "shape" of a constructor: it's name and number--- of fields. Used only in this module.-type CstrShape = (Name, Int)---- | Simple tuple that carries basic info about a constructor: it's name,--- number of its fields and their names. Used only in this module.-type CstrNames = (Name, Int, Maybe [Name])---- | Type of a strategy to derive 'G.Generic' instances.-data GenericStrategy = GenericStrategy-  { gsEvalDepths :: [CstrShape] -> Q [CstrDepth]-    -- ^ Given the 'CstrShape's for given datatype,-    -- return the 'CstrDepth's for it.-    -- This function should when possible make checks and 'fail', using the-    -- constructors' 'Name' provided by the 'CstrShape'.-  , gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]-    -- ^ Reorder constructors given their names.-  , gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]-    -- ^ Reorder fields given their names, the argument depends on whether-    -- fields are part of record (and thus named) or not (unnamed).-  }---- | Defines how to reorder fields or constructors.-type EntriesReorder = forall a. [(Text, a)] -> Q [a]---- | Defines how to reorder fields when their names are unknown.-type UnnamedEntriesReorder = forall a. [a] -> Q [a]---- | Simple type synonym used (internally) between functions, basically extending--- 'CstrDepth' with the 'Name's of the constructor and its fields.--- For fields it carries both names in the original order and in the order specified--- by the strategy (and the latter is paired with depths).-data NamedCstrDepths = NCD-  { ncdCstrDepth :: Natural-    -- ^ Constructor's depth-  , ncdCstrName :: Name-    -- ^ Constructor's name-  , ncdOrigFieldNames :: [Name]-    -- ^ Names of constructor fields in the original order.-  , ncdFields :: [(Natural, Name)]-    -- ^ Names and depths of constructor fields after the reordering.-  }---- | Reorders entries corresponding to constructors (@a@) and fields (@b@)--- according to some rule.-type EntriesTransp = forall a b. [a] -> Q [([b] -> Q [b], a)]--------------------------------------------------------------------------------- Generic strategies--------------------------------------------------------------------------------- | In this strategy the desired depths of contructors (in the type tree) and--- fields (in each constructor's tree) are provided manually and simply checked--- against the number of actual constructors and fields.-withDepths :: [CstrDepth] -> GenericStrategy-withDepths treeDepths = simpleGenericStrategy $ \cstrShape -> do-  when (length treeDepths /= length cstrShape) $ fail-    "Number of contructors' depths does not match number of data contructors."-  forM_ (zip (map snd treeDepths) cstrShape) $ \(fDepths, (constrName, fldNum)) ->-    when (length fDepths /= fldNum) . fail $-    "Number of fields' depths does not match number of field for data " <>-    "constructor: " <> show constrName-  return treeDepths---- | Strategy to make right-balanced instances (both in constructors and fields).------ This will try its best to produce a flat tree:------ * the balances of all leaves differ no more than by 1;--- * leaves at left will have equal or lesser depth than leaves at right.-rightBalanced :: GenericStrategy-rightBalanced = fromDepthsStrategy makeRightBalDepths---- | Strategy to make left-balanced instances (both in constructors and fields).------ This is the same as symmetrically mapped 'rightBalanced'.-leftBalanced :: GenericStrategy-leftBalanced = fromDepthsStrategy (reverse . makeRightBalDepths)---- | Strategy to make fully right-leaning instances (both in constructors and fields).-rightComb :: GenericStrategy-rightComb = fromDepthsStrategy (reverse . makeLeftCombDepths)---- | Strategy to make fully left-leaning instances (both in constructors and fields).-leftComb :: GenericStrategy-leftComb = fromDepthsStrategy makeLeftCombDepths---- | Strategy to make Haskell's Generics-like instances--- (both in constructors and fields).------ This is similar to 'rightBalanced', except for the "flat" part:------ * for each node, size of the left subtree is equal or less by one than--- size of the right subtree.------ This strategy matches A1.1.------ @customGeneric "T" haskellBalanced@ is equivalent to mere--- @deriving stock Generic T@.-haskellBalanced :: GenericStrategy-haskellBalanced = fromDepthsStrategy makeHaskellDepths---- Order modifiers--------------------------------------------------------------------------------- | Modify given strategy to reorder constructors.------ The reordering will take place before depths are evaluated and structure--- of generic representation is formed.------ Example: @reorderingConstrs alphabetically rightBalanced@.-reorderingConstrs :: EntriesReorder -> GenericStrategy -> GenericStrategy-reorderingConstrs reorder gs = gs-  { gsReorderCstrsOn = reorder-  }---- | Modify given strategy to reorder fields.------ Same notes as for 'reorderingConstrs' apply here.------ Example: @reorderingFields forbidUnnamedFields alphabetically rightBalanced@.-reorderingFields-  :: UnnamedEntriesReorder-  -> EntriesReorder-  -> GenericStrategy -> GenericStrategy-reorderingFields reorderUnnamed reorder gs = gs-  { gsReorderFieldsOn = either reorderUnnamed reorder-  }---- | Modify given strategy to reorder constructors and fields.------ Same notes as for 'reorderingConstrs' apply here.------ Example: @reorderingData forbidUnnamedFields alphabetically rightBalanced@.-reorderingData-  :: UnnamedEntriesReorder-  -> EntriesReorder-  -> GenericStrategy -> GenericStrategy-reorderingData reorderUnnamed reorder =-  reorderingFields reorderUnnamed reorder . reorderingConstrs reorder---- | Sort entries by name alphabetically.-alphabetically :: EntriesReorder-alphabetically = pure . map snd . sortWith fst---- | Leave unnamed fields intact, without any reordering.-leaveUnnamedFields :: UnnamedEntriesReorder-leaveUnnamedFields = pure---- | Fail in case records are unnamed and we cannot figure--- out the necessary reordering.-forbidUnnamedFields :: UnnamedEntriesReorder-forbidUnnamedFields fields =-  if length fields <= 1-  then return fields-  else fail "Encountered unnamed fields, cannot apply reordering"--------------------------------------------------------------------------------- Generic strategies' builders--------------------------------------------------------------------------------- | Construct a strategy that only constructs Generic instance of given--- form, without e.g. changing the order of entries.-simpleGenericStrategy :: ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy-simpleGenericStrategy mkDepths = GenericStrategy-  { gsEvalDepths = mkDepths-  , gsReorderCstrsOn = pure . map snd-  , gsReorderFieldsOn = pure . either id (map snd)-  }---- | Helper to make a strategy that created depths for constructor and fields--- in the same way, just from their number.------ The provided function @f@ must satisfy the following rules:------ * @length (f n) ≡ n@--- * @sum $ (\x -> 2 ^^ (-x)) <$> f n ≡ 1@ (unless @n = 0@)-fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy-fromDepthsStrategy dStrategy = simpleGenericStrategy $ \cShapes -> return $-  zip (dStrategy $ length cShapes) $ map (dStrategy . view _2) cShapes--makeRightBalDepths :: Int -> [Natural]-makeRightBalDepths n = foldr (const addRightBalDepth) [] [1..n]-  where-    addRightBalDepth :: [Natural] -> [Natural]-    addRightBalDepth = \case-      [] -> [0]-      [x] -> [x + 1, x + 1]-      (x : y : xs) | x == y -> x : addRightBalDepth (x : xs)-      (_ : y : xs) -> y : y : y : xs--makeLeftCombDepths :: Int -> [Natural]-makeLeftCombDepths 0 = []-makeLeftCombDepths n = map fromIntegral $ (n - 1) : [n - 1, n - 2..1]--makeHaskellDepths :: Int -> [Natural]-makeHaskellDepths n =-  case nonEmpty (replicate n [0]) of-    Nothing -> []-    Just leaves -> mkGenericTree (\_ l r -> map succ (l ++ r)) leaves--------------------------------------------------------------------------------- Depth usage helpers--------------------------------------------------------------------------------- | Helper for making a constructor depth.------ Note that this is only intended to be more readable than directly using a--- tuple with 'withDepths' and for the ability to be used in places where--- @RebindableSyntax@ overrides the number literal resolution.-cstr :: forall n. KnownNat n => [Natural] -> CstrDepth-cstr flds = (natVal (Proxy @n), flds)---- | Helper for making a field depth.------ Note that this is only intended to be more readable than directly using a--- tuple with 'withDepths' and for the ability to be used in places where--- @RebindableSyntax@ overrides the number literal resolution.-fld :: forall n. KnownNat n => Natural-fld = natVal $ Proxy @n--------------------------------------------------------------------------------- Instance derivation-------------------------------------------------------------------------------{-# ANN module ("HLint: ignore Use snd" :: Text) #-}---- | Derives the 'G.Generic' instance for a type given its name and a--- 'GenericStrategy' to use.------ The strategy is used to calculate the depths of the data-type constructors--- and each constructors' fields.------ The depths are used to generate the tree of the 'G.Generic' representation,--- allowing for a custom one, in contrast with the one derived automatically.------ This only supports "plain" @data@ types (no GADTs, no @newtype@s, etc.) and--- requires the depths to describe a fully and well-defined tree (see 'unbalancedFold').------ For example, this is valid (and uses the 'withDepths' strategy with the 'cstr'--- and 'fld' helpers) and results in a balanced instance, equivalent to the--- auto-derived one:------ @@@--- data CustomType a---   = CustomUp Integer Integer---   | CustomMid {unMid :: Natural}---   | CustomDown a---   | CustomNone------ $(customGeneric "CustomType" $ withDepths---   [ cstr @2 [fld @1, fld @1]---   , cstr @2 [fld @0]---   , cstr @2 [fld @0]---   , cstr @2 []---   ])--- @@@------ and this is a valid, but fully left-leaning one:------ @@@--- $(customGeneric "CustomType" $ withDepths---   [ cstr @3 [fld @1, fld @1]---   , cstr @3 [fld @0]---   , cstr @2 [fld @0]---   , cstr @1 []---   ])--- @@@------ and, just as a demonstration, this is the same fully left-leaning one, but--- made using the simpler 'leftComb' strategy:------ @@@--- $(customGeneric "CustomType" leftComb)--- @@@------ Developers are welcome to provide their own derivation strategies,--- and some useful strategies can be found outside of this module by--- 'GenericStrategy' signature.-customGeneric :: String -> GenericStrategy -> Q [Dec]-customGeneric typeStr genStrategy = do-  -- Implementor's note:-  ---  -- Instead of using a name literal (@customGeneric ''T@), we use a string (@customGeneric "T"@)-  -- and then 'lookupTypeName' for the following reasons:-  ---  -- 1. We can control the error message when 'lookupTypeName' doesn't find the type in scope (as opposed to @''T@)-  -- 2. Most importantly, this was made with Indigo in mind, where we try as much as-  --    possible to use a simple syntax (to appeal to a broader audience) and so to avoid-  --    using more obscure Haskell syntax (like @''T@).--  -- reify the data type-  (typeName, _, mKind, vars, constructors) <- lookupTypeNameOrFail typeStr >>= reifyDataType-  -- obtain info about its constructor and desired tree-  derivedType <- deriveFullType typeName mKind vars-  customGeneric' Nothing typeName derivedType  constructors genStrategy---- | If a 'Rep' type is given, this function will generate a new 'Generic' instance with it,--- and generate the appropriate "to" and "from" methods.------ Otherwise, it'll generate a new 'Rep' instance as well.-customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec]-customGeneric' maybeRepType typeName derivedType constructors genStrategy = do-  cNames <- cstrNames constructors-  let cReordering :: EntriesTransp-      cReordering = reorderCstrs genStrategy cNames-  let cShapes = cNames <&> \(name, fNum, _) -> (name, fNum)-  cShapesSorted <- cReordering cShapes <&> map \(_fReorder, cShape) -> cShape-  treeDepths <- gsEvalDepths genStrategy cShapesSorted-  weightedConstrs <- makeWeightedConstrs cReordering treeDepths cShapes--  -- If no 'Rep' type was given, derive one.-  let repType =-        maybe-          (makeUnbalancedRep typeName treeDepths cReordering (pure derivedType))-          pure-          maybeRepType--  -- produce the Generic instance-  res <- instanceD (pure []) (conT ''G.Generic `appT` pure derivedType)-    [ tySynInstD . tySynEqn Nothing (conT ''G.Rep `appT` pure derivedType) $-        repType-    , makeUnbalancedFrom weightedConstrs-    , makeUnbalancedTo weightedConstrs-    ]-  return [res]---- | Apply a reordering strategy.------ This uses given @[CstrNames]@ to understand how constructors and their--- fields should be reordered, and applies the same transposition to entries--- within 'EntriesTransp'.-reorderCstrs :: GenericStrategy -> [CstrNames] -> EntriesTransp-reorderCstrs GenericStrategy{..} cNames = \cstrEntries ->-  gsReorderCstrsOn $-    zip cNames cstrEntries <&> \(cstrName@(name, _, _), cstrEntry) ->-      (origName name, (fieldsReorder cstrName, cstrEntry))-  where-    fieldsReorder :: CstrNames -> [b] -> Q [b]-    fieldsReorder (_, _, mFieldNames) = \fieldEntries -> do-      gsReorderFieldsOn $-        maybe Left (Right ... zip . map origName) mFieldNames fieldEntries---- | Reifies info from a type name (given as a 'String').--- The lookup happens from the current splice's scope (see 'lookupTypeName') and--- the only accepted result is a "plain" data type (no GADTs).-reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con])-reifyDataType typeName = do-  typeInfo <- reify typeName-  case typeInfo of-    TyConI (DataD decCxt typeName' vars mKind constrs _) ->-      return (typeName', decCxt, mKind, vars, constrs)-    _ -> fail $-      "Only plain datatypes are supported for derivation, but '" <>-      show typeName <> "' instead reifies to:\n" <> show typeInfo---- | Derives, as well as possible, a type definition from its name, its kind--- (where known) and its variables.-deriveFullType :: Name -> Maybe Kind -> [TyVarBndr] -> TypeQ-deriveFullType tName mKind = addTypeSig . foldl appT (conT tName) . makeVarsType-  where-    addTypeSig :: TypeQ -> TypeQ-    addTypeSig = flip sigT $ fromMaybe StarT mKind--    makeVarsType :: [TyVarBndr] -> [TypeQ]-    makeVarsType = map $ \case-      PlainTV vName       -> varT vName-      KindedTV vName kind -> sigT (varT vName) kind---- | Extract the info for each of the given constructors.-cstrNames :: [Con] -> Q [CstrNames]-cstrNames constructors = forM constructors $ \case-  NormalC name lst -> return (name, length lst, Nothing)-  RecC name lst    -> return (name, length lst, Just $ lst ^.. traversed . _1)-  InfixC _ name _  -> return (name, 2, Nothing)-  constr           -> fail $ "Unsupported constructor: " <> show constr---- | Combines depths with constructors, 'fail'ing in case of mismatches, and--- generates 'Name's for the constructors' arguments.-makeWeightedConstrs-  :: EntriesTransp -> [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]-makeWeightedConstrs cReorder treeDepths cShapes = do-  reorderedShapes <- cReorder cShapes-  forM (zip treeDepths reorderedShapes) $-    \((cDepth, fDepths), (fReorder, (cName, fNum))) -> do-      fieldVarsNames <- forM [0 .. fNum - 1] \i -> newName ("v" <> show i)-      reorderedFieldVarNames <- fReorder fieldVarsNames-      return NCD-        { ncdCstrDepth = cDepth-        , ncdCstrName = cName-        , ncdOrigFieldNames = fieldVarsNames-        , ncdFields = zip fDepths reorderedFieldVarNames-        }---- | Creates the 'G.Rep' type for an unbalanced 'G.Generic' instance, for a type--- given its name, constructors' depths and derived full type.------ Note: given that these types definition can be very complex to generate,--- especially in the metadata, here we let @generic-deriving@ make a balanced--- value first (see 'makeRep0Inline') and then de-balance the result.-makeUnbalancedRep :: Name -> [CstrDepth] -> EntriesTransp -> TypeQ -> TypeQ-makeUnbalancedRep typeName treeDepths reorderConstrs derivedType = do-  -- let generic-deriving create the balanced type first-  balRep <- makeRep0Inline typeName derivedType-  -- separate the top-most type metadata from the constructors' trees-  (typeMd, constrTypes) <- dismantleGenericTree [t| G.C1 |] balRep-  -- for each of the constructor's trees-  reorderedConstrTypes <- reorderConstrs constrTypes-  unbalConstrs <- forM (zip reorderedConstrTypes treeDepths) $-    \((reorderFields, constrType), treeDepth) ->-    case treeDepth of-      (n, []) ->-        -- when there are no fields there is no tree to unbalance-        return (n, constrType)-      (n, fieldDepths) -> do-        -- separate the top-most constructor metadata from the fields' trees-        (constrMd, fieldTypes) <- dismantleGenericTree [t| G.S1 |] constrType-        -- build the unbalanced tree of fields-        reorderedFieldTypes <- reorderFields fieldTypes-        unbalConstRes <- unbalancedFold (zip fieldDepths reorderedFieldTypes)-                                        (appT . appT (conT ''(G.:*:)))-        -- return the new unbalanced constructor-        return (n, AppT constrMd unbalConstRes)-  -- build the unbalanced tree of constructors and rebuild the type-  appT (pure typeMd) $ unbalancedFold unbalConstrs (appT . appT (conT ''(G.:+:)))---- | Breaks down a tree of @Generic@ types from the contructor of "nodes" and--- the constructor for "leaves" metadata.------ This expects (and should always be the case) the "root" to be a @Generic@--- metadata contructor, which is returned in the result alongside the list of--- leaves (in order).-dismantleGenericTree :: TypeQ -> Type -> Q (Type, [Type])-dismantleGenericTree leafMetaQ (AppT meta nodes) = do-  leafMeta <- leafMetaQ-  let collectLeafsTypes :: Type -> [Type]-      collectLeafsTypes tp =-        case tp of-          f `AppT` _ `AppT` _ | f == leafMeta -> [tp]-          AppT a b -> collectLeafsTypes a <> collectLeafsTypes b-          _ -> []-  return (meta, collectLeafsTypes nodes)-dismantleGenericTree _ x = fail $-  "Unexpected lack of Generic Metadata: " <> show x---- | Create the unbalanced 'G.from' fuction declaration for a type starting from--- its list of weighted constructors.-makeUnbalancedFrom :: [NamedCstrDepths] -> DecQ-makeUnbalancedFrom wConstrs = do-  (cPatts, cDepthExp) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do-    fDepthExp <- forM wFields $ \(fDepth, fName) -> do-      -- make expression to asseble a Generic Field from its variable-      fExpr <- appE [| G.M1 |] . appE [| G.K1 |] $ varE fName-      return (fDepth, fExpr)-    -- make pattern for this constructor-    fPatts <- mapM varP wOrigFields-    let cPatt = ConP cName fPatts-    -- make expression to assemble its fields as an isolated Generic Constructor-    cExp <- appE [| G.M1 |] $ case fDepthExp of-      [] -> conE 'G.U1-      _  -> unbalancedFold fDepthExp (appE . appE [| (G.:*:) |])-    return (cPatt, (cDepth, [cExp]))-  -- make expressions to assemble all Generic Constructors-  cExps <- mapQ (appE [| G.M1 |]) $ unbalancedFold cDepthExp $ \xs ys ->-    (<>) <$> mapQ (appE [| G.L1 |]) xs <*> mapQ (appE [| G.R1 |]) ys-  -- make function definition-  funD 'G.from $ zipWith (\p e -> clause [pure p] (normalB $ pure e) []) cPatts cExps---- | Create the unbalanced 'G.to' fuction declaration for a type starting from--- its list of weighted constructors.-makeUnbalancedTo :: [NamedCstrDepths] -> DecQ-makeUnbalancedTo wConstrs = do-  (cExps, cDepthPat) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do-    fDepthPat <- forM wFields $ \(fDepth, fName) -> do-      -- make pattern for a Generic Field from its variable-      fPatt <- conP1 'G.M1 . conP1 'G.K1 $ varP fName-      return (fDepth, fPatt)-    -- make pattern for this isolated Generic Constructor-    cPatt <- conP1 'G.M1 $ case fDepthPat of-      [] -> conP 'G.U1 []-      _  -> unbalancedFold fDepthPat (conP2 '(G.:*:))-    -- make expression to assemble this constructor-    fExps <- mapM varE wOrigFields-    let cExp = foldl AppE (ConE cName) fExps-    return (cExp, (cDepth, [cPatt]))-  -- make patterns for all Generic Constructors-  cPatts <- mapQ (conP1 'G.M1) $ unbalancedFold cDepthPat $ \xs ys ->-    (<>) <$> mapQ (conP1 'G.L1) xs <*> mapQ (conP1 'G.R1) ys-  -- make function definition-  funD 'G.to $ zipWith (\p e -> clause [pure p] (normalB $ pure e) []) cPatts cExps---- | Recursively aggregates the values in the given list by merging (with the--- given function) the ones that are adjacent and with the same depth.------ This will fail for every case in which the list cannot be folded into a single--- 0-depth value.-unbalancedFold :: forall a. Eq a => [(Natural, a)] -> (Q a -> Q a -> Q a) -> Q a-unbalancedFold lst f = unbalancedFoldRec lst >>= \case-  [(0, result)] -> return result-  [(n, _)] -> fail $-    "Resulting unbalanced tree has a single root, but of depth " <> show n <>-    " instead of 0. Check your depths definitions."-  _ -> fail $-    "Cannot create a tree from nodes of depths: " <> show (map fst lst) <>-    ". Check your depths definitions."-  where-    unbalancedFoldRec :: [(Natural, a)] -> Q [(Natural, a)]-    unbalancedFoldRec xs = do-      ys <- unbalancedFoldSingle xs-      if xs == ys then return xs else unbalancedFoldRec ys--    unbalancedFoldSingle :: [(Natural, a)] -> Q [(Natural, a)]-    unbalancedFoldSingle = \case-      [] -> return []-      (dx, x) : (dy, y) : xs | dx == dy -> do-        dxy <- f (pure x) (pure y)-        return $ (dx - 1, dxy) : xs-      x : xs -> do-        ys <- unbalancedFoldSingle xs-        return (x : ys)--------------------------------------------------------------------------------- Utility functions-------------------------------------------------------------------------------conP1 :: Name -> PatQ -> PatQ-conP1 name pat = conP name [pat]--conP2 :: Name -> PatQ -> PatQ -> PatQ-conP2 name pat1 pat2 = conP name [pat1, pat2]--mapQ :: (Q a -> Q a) -> Q [a] -> Q [a]-mapQ f qlst = qlst >>= mapM (f . pure)---- | Original name of a constructor or field.-origName :: Name -> Text-origName = toText . nameBase

− src/Util/Default.hs

@@ -1,25 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.Default-  ( permute2Def , permute3Def-  , Default (..)-  ) where--import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)-import Data.Default (Default, def)--{- Permutation Parsers -}--permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a,b)-permute2Def a b = runPermutation $-  (,) <$> toPermutationWithDefault def a-      <*> toPermutationWithDefault def b--permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) =>-                f a -> f b -> f c -> f (a,b,c)-permute3Def a b c = runPermutation $-  (,,) <$> toPermutationWithDefault def a-       <*> toPermutationWithDefault def b-       <*> toPermutationWithDefault def c

− src/Util/Exception.hs

@@ -1,16 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.Exception-  ( -- * General simple helpers-    throwLeft-  ) where---- | If monadic action returns a 'Left' value, it will be--- thrown. Otherwise the returned value will be returned as is.-throwLeft :: (MonadThrow m, Exception e) => m (Either e a) -> m a-throwLeft =-  (>>= \case-      Left e -> throwM e-      Right x -> return x)

− src/Util/Fcf.hs

@@ -1,31 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.Fcf-  ( Over2-  , type (<|>)-  , TyEqSing-  , ApplyConstraints-  , Eval-  ) where--import Data.Singletons.Prelude.Eq (DefaultEq)-import Fcf--data Over2 :: (a -> b -> Exp r) -> (x -> Exp a) -> (x -> Exp b) -> x -> Exp r-type instance Eval (Over2 f g h x) = Eval (LiftM2 f (g x) (h x))--data (<|>) :: f a -> f a -> Exp (f a)-type instance Eval ('Nothing <|> m) = m-type instance Eval ('Just x <|> _) = 'Just x---- | Similar to 'TyEq', but compares types via @DefaultEq@ used in singletons--- comparisons (see "Data.Singletons.Prelude.Eq" module).-data TyEqSing :: a -> b -> Exp Bool-type instance Eval (TyEqSing a b) = DefaultEq a b--data ApplyConstraints :: [a -> Constraint] -> a -> Exp Constraint-type instance Eval (ApplyConstraints '[] _) = (() :: Constraint)-type instance Eval (ApplyConstraints (c ': cs) a) =-  (c a, Eval (ApplyConstraints cs a))

− src/Util/Generic.hs

@@ -1,48 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Generic-related utils.-module Util.Generic-  ( mkGenericTree-  , mkGenericTreeVec--  , GenericTypeName-  ) where--import Control.Exception (assert)-import qualified Data.Vector as V-import qualified GHC.Generics as G-import GHC.TypeLits (Symbol)---- | Rebuild a list into a binary tree of exactly the same form which--- 'Data.Generic' uses to represent datatypes.------ Along with the original list you have to provide constructor for intermediate--- nodes - it accepts zero-based index of the leftmost element of the right tree--- and merged trees themselves.-mkGenericTree :: (Natural -> a -> a -> a) -> NonEmpty a -> a-mkGenericTree mkNode = mkGenericTreeVec id mkNode . V.fromList . toList--mkGenericTreeVec-  :: HasCallStack-  => (a -> b) -> (Natural -> b -> b -> b) -> V.Vector a -> b-mkGenericTreeVec mkLeaf mkNode vector-  | V.null vector = error "Empty vector"-  | otherwise = mkTreeDo 0 vector-  where-    mkTreeDo idxBase es-      | V.length es == 1 = mkLeaf $ V.head es-      | otherwise = assert (V.length es > 1) $-          let mid = V.length es `div` 2-              mid' = idxBase + mid-              (h, t) = V.splitAt mid es-          in mkNode (fromIntegral mid') (mkTreeDo idxBase h) (mkTreeDo mid' t)---- | Extract datatype name via its Generic representation.------ For polymorphic types this throws away all type arguments.-type GenericTypeName a = GTypeName (G.Rep a)--type family GTypeName (x :: Type -> Type) :: Symbol where-  GTypeName (G.D1 ('G.MetaData tyName _ _ _) _) = tyName

− src/Util/Instances.hs

@@ -1,32 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}---- | Missing instances from libraries.-module Util.Instances () where--import Data.Default (Default(..))-import Data.Vinyl (Dict(..), Rec(..), ReifyConstraint(reifyConstraint))-import Data.Vinyl.Functor as Vinyl (Compose(..), (:.))-import Fmt (Buildable(..))--instance Default Natural where-  def = 0--instance Buildable Natural where-  build = build @Integer . fromIntegral--instance Buildable a => (Buildable (Identity a)) where-  build (Identity x) = build x---- I've added this orphan instance to @vinyl@,--- so we'll be able to delete it in the future.--- https://github.com/VinylRecords/Vinyl/pull/149-instance ReifyConstraint NFData f xs => NFData (Rec f xs) where-  rnf = go . reifyConstraint @NFData-    where-      go :: forall elems. Rec (Dict NFData :. f) elems -> ()-      go RNil = ()-      go (Vinyl.Compose (Dict x) :& xs) = rnf x `seq` go xs

− src/Util/Label.hs

@@ -1,47 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Definition of the Label type and utilities-module Util.Label-  ( -- * Definitions-    Label (..)--  -- * Utilities-  , labelToText--  -- * Re-exports-  , IsLabel (..)-  ) where--import Fmt (Buildable(..), pretty)-import Text.Show (Show(..))--import Util.TypeLits------------------------------------------------------------------------------------- Definitions------------------------------------------------------------------------------------- | Proxy for a label type that includes the 'KnownSymbol' constraint-data Label (name :: Symbol) where-  Label :: KnownSymbol name => Label name--deriving stock instance Eq (Label name)--instance Show (Label name) where-  show label = "Label " <> pretty label--instance (KnownSymbol name, s ~ name) => IsLabel s (Label name) where-  fromLabel = Label--instance Buildable (Label name) where-  build Label = build $ symbolVal (Proxy @name)------------------------------------------------------------------------------------- Utilities------------------------------------------------------------------------------------- | Utility function to get the 'Text' representation of a 'Label'-labelToText :: Label name -> Text-labelToText = pretty

− src/Util/Lens.hs

@@ -1,16 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}--module Util.Lens-  ( postfixLFields-  , makeLensesWith-  ) where--import Control.Lens (LensRules, lensField, lensRules, makeLensesWith, mappingNamer)---- | For datatype with "myNyan" field it will create "myNyanL" lens.-postfixLFields :: LensRules-postfixLFields = lensRules & lensField .~ mappingNamer (\s -> [s++"L"])

− src/Util/Main.hs

@@ -1,25 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Functions supposed to be used in the @Main@ module.--module Util.Main-  ( wrapMain-  ) where--import Control.Exception.Uncaught (withDisplayExceptionHandler)-import Main.Utf8 (withUtf8)---- | Some defaults in Haskell are debatable and we typically want--- to customize them in our applications.--- Some customizations are done at the level of @main@.--- Currently we have two of them:------ 1. 'withUtf8' from the @with-utf8@ package.--- 2. 'withDisplayExceptionHandler' from the @uncaught-exception@ package.------ This function is supposed to apply all @main@ customizations that we--- typcally want to do.-wrapMain :: IO () -> IO ()-wrapMain = withUtf8 . withDisplayExceptionHandler

− src/Util/Markdown.hs

@@ -1,156 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | A small Markdown eDSL.-module Util.Markdown-  ( Markdown-  , HeaderLevel (..)-  , Anchor (..)-  , ToAnchor (..)-  , nextHeaderLevel-  , mdHeader-  , mdToc-  , mdSubsection-  , mdSubsectionTitle-  , mdBold-  , mdItalic-  , mdTicked-  , mdRef-  , mdLocalRef-  , mdEscapeAnchor-  , mdAnchor-  , mdSeparator-  , mdSpoiler-  , mdComment-  , md-  ) where--import Data.Char (isAscii)-import qualified Data.String.Interpolate.IsString as Interpolate-import Data.String.Interpolate.Util (unindent)-import Fmt (Builder, build, (+|), (|+))--import Language.Haskell.TH.Quote (QuasiQuoter(..))---- | A piece of markdown document.------ This is opposed to 'Text' type, which in turn is not supposed to contain--- markup elements.-type Markdown = Builder---- | Level of header, starting from 1.-newtype HeaderLevel = HeaderLevel Int---- | Anchor with given text.-newtype Anchor = Anchor { unAnchor :: Text }--instance IsString Anchor where-  -- Avoiding collision with names assigned by autodoc engine-  fromString = Anchor . fromString . ("manual-" <>)---- | Picking anchor for various things.------ What you want here is potentially adding some prefix to ensure anchors uniqueness.--- It is not necessary to preprocess the text to fit anchor format - that will happen--- when the anchor is embedded into 'Markdown'.-class ToAnchor anchor where-  toAnchor :: anchor -> Anchor--instance ToAnchor Anchor where-  toAnchor = id--instance ToAnchor Text where-  toAnchor = Anchor--nextHeaderLevel :: HeaderLevel -> HeaderLevel-nextHeaderLevel (HeaderLevel l) = HeaderLevel (l + 1)--mdHeader :: HeaderLevel -> Markdown -> Markdown-mdHeader (HeaderLevel lvl) text =-  mconcat (replicate lvl "#") +| " " +| text |+ "\n\n"--mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown-mdToc (HeaderLevel lvl) text anchor =-  mconcat (replicate (lvl - 2) "  ") +|-    "- " +| mdLocalRef text anchor |+ "\n"--mdSubsectionTitle :: Markdown -> Markdown-mdSubsectionTitle title = mdBold (title <> ":")--mdSubsection :: Markdown -> Markdown -> Markdown-mdSubsection name txt = mdSubsectionTitle name <> " " <> txt--mdBold :: Markdown -> Markdown-mdBold x = "**" <> x <> "**"--mdItalic :: Markdown -> Markdown-mdItalic x = "*" <> x <> "*"--mdTicked :: Markdown -> Markdown-mdTicked x = "`" +| x |+ "`"--mdEscapeAnchorS :: String -> Markdown-mdEscapeAnchorS = \case-  [] -> ""-  c : s -> escapeChar c <> mdEscapeAnchorS s-  where-    escapeChar = \case-      ' ' -> "-"-      '(' -> "lparen"-      ')' -> "rparen"-      '[' -> "lbracket"-      ']' -> "rbracket"-      '{' -> "lbrace"-      '}' -> "rbrace"-      ',' -> "comma"-      ';' -> "semicolon"-      ':' -> "colon"-      '#' -> "hash"-      c | not (isAscii c) -> "c" <> build (fromEnum c)-        | otherwise -> build [c]---- | Turn text into valid anchor. Human-readability is not preserved.-mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown-mdEscapeAnchor = mdEscapeAnchorS . toString . unAnchor . toAnchor--mdRef :: Markdown -> Markdown -> Markdown-mdRef txt ref = "[" <> txt <> "](" <> ref <> ")"--mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown-mdLocalRef txt anchor = mdRef txt ("#" <> mdEscapeAnchor anchor)--mdAnchor :: ToAnchor anchor => anchor -> Markdown-mdAnchor name = "<a name=\"" <> mdEscapeAnchor name <> "\"></a>\n\n"--mdSeparator :: Markdown-mdSeparator = "---\n\n"---- | Text which is hidden until clicked.-mdSpoiler :: Markdown -> Markdown -> Markdown-mdSpoiler name contents =-  mconcat $ intersperse "\n"-    [ "<details>"-    , "  <summary>" <> htmlBold (build name) <> "</summary>"-    , contents-    , "</details>"-    , "<p>"-    ]-  where-    -- Markdown's bold does not always work within spoiler header-    htmlBold txt = "<b>" <> txt <> "</b>"--mdComment :: Builder -> Builder-mdComment commentText =-  "<!---\n" +| commentText |+ "\n-->"---- | Quasi quoter for Markdown.------ This supports interpolation via @#{expression}@ syntax.-md :: QuasiQuoter-md = QuasiQuoter-  { quoteExp = \s -> [|fromString @Markdown $ unindent $(quoteExp Interpolate.i s) |]-  , quotePat = \_ -> fail "Cannot be used at pattern position"-  , quoteType = \_ -> fail "Cannot be used at type position"-  , quoteDec = \_ -> fail "Cannot be used as declaration"-  }

− src/Util/Named.hs

@@ -1,89 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}---- | Additional functionality for 'named' package.-module Util.Named-  ( (:!)-  , (:?)-  , (.!)-  , (.?)-  , (<.!>)-  , (<.?>)-  , ApplyNamedFunctor-  , NamedInner-  , KnownNamedFunctor (..)-  ) where--import Control.Lens (Iso', Wrapped(..), iso)-import Data.Aeson (FromJSON, ToJSON)-import Data.Data (Data)-import Fmt (Buildable(..))-import GHC.TypeLits (KnownSymbol, symbolVal)-import Named ((:!), (:?), Name, NamedF(..))-import qualified Text.Show--import Util.Label (Label)--(.!) :: Name name -> a -> NamedF Identity a name-(.!) _ = ArgF . Identity--(.?) :: Name name -> Maybe a -> NamedF Maybe a name-(.?) _ = ArgF--(<.!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)-(<.!>) name = fmap (name .!)-infixl 4 <.!>--(<.?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)-(<.?>) name = fmap (name .?)-infixl 4 <.?>--type family ApplyNamedFunctor (f :: Type -> Type) (a :: Type) where-  ApplyNamedFunctor Identity a = a-  ApplyNamedFunctor Maybe a = Maybe a--type family NamedInner (n :: Type) where-  NamedInner (NamedF f a _) = ApplyNamedFunctor f a---- | Isomorphism between named entity and the entity itself wrapped into the--- respective functor.-namedFL :: Label name -> Iso' (NamedF f a name) (f a)-namedFL _ = iso (\(ArgF x) -> x) ArgF--class KnownNamedFunctor f where-  -- | Isomorphism between named entity and the entity itself.-  namedL :: Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a)--instance KnownNamedFunctor Identity where-  namedL l = namedFL l . _Wrapped'--instance KnownNamedFunctor Maybe where-  namedL l = namedFL l--------------------------------------------------------------------------------- Instances-------------------------------------------------------------------------------deriving stock instance Eq (f a) => Eq (NamedF f a name)-deriving stock instance Ord (f a) => Ord (NamedF f a name)--instance (Show a, KnownSymbol name) => Show (NamedF Identity a name) where-  show (ArgF a) = symbolVal (Proxy @name) <> " :! " <> show a--instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where-  build (ArgF a) = build (symbolVal (Proxy @name)) <> ": " <> build a--instance (NFData (f a)) => NFData (NamedF f a name) where-  rnf (ArgF a) = rnf a--deriving stock instance-  (Typeable f, Typeable a, KnownSymbol name, Data (f a)) =>-  Data (NamedF f a name)--deriving newtype instance ToJSON a => ToJSON (NamedF Identity a name)-deriving newtype instance ToJSON a => ToJSON (NamedF Maybe a name)-deriving newtype instance FromJSON a => FromJSON (NamedF Identity a name)-deriving newtype instance FromJSON a => FromJSON (NamedF Maybe a name)

− src/Util/Num.hs

@@ -1,19 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities for numbers.-module Util.Num-  ( fromIntegralChecked-  ) where---- | Convert between integral types, checking for overflows/underflows.-fromIntegralChecked :: (Integral a, Integral b) => a -> Either Text b-fromIntegralChecked a =-  let b = fromIntegral a-  in if toInteger a == toInteger b-    then Right b-    else Left-      if toInteger a > toInteger b-        then "Numeric overflow"-        else "Numeric underflow"

− src/Util/Peano.hs

@@ -1,316 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}-{-# LANGUAGE UndecidableSuperClasses #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Type-nat utilities.------ We take Peano numbers as base for operations because they make it--- much easer to prove things to compiler. Their performance does not--- seem to introduce a problem, because we use nats primarily along with--- stack which is a linked list with similar performance characteristics.------ Many of things we introduce here are covered in @type-natural@ package,--- but unfortunatelly it does not work with GHC 8.6 at the moment of writing--- this module. We use 'Data.Vinyl' as source of Peano @Nat@ for now.-module Util.Peano-  ( -- * General-    Peano-    -- @gromak: I think we should not export Nat, but we want to-    -- export `Z` and `S` and I do not know how to do it without-    -- exporting `Nat`.-  , Nat (Z, S)-  , ToPeano-  , FromPeano-  , SingNat (SZ, SS)--  , Decrement-  , type (>)-  , peanoSing--  -- * Peano Arithmetic-  , type (>=)-  , peanoSingDecrement--  -- * Lists-  , Length-  , At-  , Drop-  , Take--    -- * Morley-specific utils-  , IsLongerThan-  , LongerThan-  , RequireLongerThan-  , IsLongerOrSameLength-  , LongerOrSameLength-  , RequireLongerOrSameLength--  -- * Length constraints 'Dict'ionaries-  , requireLongerThan-  , requireLongerOrSameLength--  -- * Length constraints 'Dict'ionaries-  , isGreaterThan-  , isGreaterEqualThan-  ) where--import Data.Constraint (Dict(..))-import Data.Singletons (Sing, SingI(..))-import Data.Vinyl (Rec(..))-import Data.Vinyl.TypeLevel (Nat(..), RLength)-import GHC.TypeLits (ErrorMessage(..), TypeError)-import GHC.TypeNats (type (+), type (-))-import qualified GHC.TypeNats as GHC-import Unsafe.Coerce (unsafeCoerce)--import Util.Type--------------------------------------------------------------------------------- General--------------------------------------------------------------------------------- | A convenient alias.------ We are going to use 'Peano' numbers for type-dependent logic and--- normal 'Nat's in user API, need to distinguish them somehow.-type Peano = Nat--type family ToPeano (n :: GHC.Nat) :: Peano where-  ToPeano 0 = 'Z-  ToPeano a = 'S (ToPeano (a - 1))--type family FromPeano (n :: Peano) :: GHC.Nat where-  FromPeano 'Z = 0-  FromPeano ('S a) = 1 + FromPeano a---- | Get the peano singleton for a given type-level nat literal.------ >>> peanoSing @2--- SS (SS SZ)-peanoSing :: forall (n :: GHC.Nat). SingI (ToPeano n) => SingNat (ToPeano n)-peanoSing = sing @(ToPeano n)--data SingNat (n :: Nat) where-  SZ :: SingNat 'Z-  SS :: !(SingNat n) -> SingNat ('S n)--deriving stock instance Show (SingNat (n :: Nat))-deriving stock instance Eq (SingNat (n :: Nat))-instance NFData (SingNat (n :: Nat)) where-  rnf SZ = ()-  rnf (SS n) = rnf n--type instance Sing = SingNat--instance SingI 'Z where-  sing = SZ-instance SingI n => SingI ('S n) where-  sing = SS (sing @n)--------------------------------------------------------------------------------- Peano Arithmetic-------------------------------------------------------------------------------type family Decrement (a :: Peano) :: Peano where-  Decrement 'Z = TypeError ('Text "Expected n > 0")-  Decrement ('S n) = n---- | Utility to 'Decrement' a Peano 'Sing'leton.------ Useful when dealing with the constraint-peanoSingDecrement :: Sing n -> Maybe (Sing (Decrement n))-peanoSingDecrement = \case-  SZ -> Nothing-  SS n -> pure n--type family (>) (x :: Peano) (y :: Peano) :: Bool where-  'Z   > _    = 'False-  'S _ > 'Z   = 'True-  'S x > 'S y = x > y--type family (>=) (x :: Peano) (y :: Peano) :: Bool where-  _      >= 'Z     = 'True-  'Z     >= _      = 'False-  ('S x) >= ('S y) = x >= y--------------------------------------------------------------------------------- Lists-------------------------------------------------------------------------------type family Length l :: Peano where-  Length l = RLength l--type family At (n :: Peano) s where-  At 'Z (x ': _) = x-  At ('S n) (_ ': xs) = At n xs-  At a '[] =-    TypeError-      ('Text "You tried to access a non-existing element of the stack, n = " ':<>:-         'ShowType (FromPeano a))--type family Drop (n :: Peano) (s :: [k]) :: [k] where-  Drop  'Z s = s-  Drop ('S _) '[] = '[]-  Drop ('S n) (_ ': s) = Drop n s--type family Take (n :: Peano) (s :: [k]) :: [k] where-  Take  'Z _ = '[]-  Take _ '[] = '[]-  Take ('S n) (a ': s) = a ': Take n s--------------------------------------------------------------------------------- Morley-specific utils--------------------------------------------------------------------------------- Note that we could define type families to return 'Constraint' instead--- of defining standalone constraint in form `c ~ 'True`, but apparently--- such constraint would be weaker, e. g. there is an example when with--- current approach there is no warning, but if we change the approach--- to return 'Constraint' from type family then GHC complains about--- non-exhaustive patterns (@gromak).--- Also we use these `Bool` type families in more than one place, we generate--- two constraints: one gives more information to GHC and another one produces--- better error messages on failure.---- | Comparison of type-level naturals, as a function.------ It is as lazy on the list argument as possible - there is no--- need to know the whole list if the natural argument is small enough.--- This property is important if we want to be able to extract reusable--- parts of code which are aware only of relevant part of stack.-type family IsLongerThan (l :: [k]) (a :: Peano) :: Bool where-  IsLongerThan (_ ': _) 'Z = 'True-  IsLongerThan (_ ': xs) ('S a) = IsLongerThan xs a-  IsLongerThan '[] _ = 'False---- | Comparison of type-level naturals, as a constraint.-type LongerThan l a = IsLongerThan l a ~ 'True---- | Similar to 'IsLongerThan', but returns 'True' when list length--- equals to the passed number.-type family IsLongerOrSameLength (l :: [k]) (a :: Peano) :: Bool where-  IsLongerOrSameLength _ 'Z = 'True-  IsLongerOrSameLength (_ ': xs) ('S a) = IsLongerOrSameLength xs a-  IsLongerOrSameLength '[] ('S _) = 'False---- | 'IsLongerOrSameLength' in form of constraint that gives most--- information to GHC.-type LongerOrSameLength l a = IsLongerOrSameLength l a ~ 'True--{- | Evaluates list length.--This type family is a best-effort attempt to display neat error messages-when list is known only partially.--For instance, when called on @Int ': Int ': s@, the result will be-@OfLengthWithTail 2 s@ - compare with result of simple 'Length' --@1 + 1 + Length s@.--For concrete types this will be identical to calling @FromPeano (Length l)@.--}-type family OfLengthWithTail (acc :: GHC.Nat) (l :: [k]) :: GHC.Nat where-  OfLengthWithTail a '[] = a-  OfLengthWithTail a (_ ': xs) = OfLengthWithTail (a + 1) xs--type LengthWithTail l = OfLengthWithTail 0 l---- | Comparison of type-level naturals, raises human-readable compile error--- when does not hold.------ Here we use the same approach as for 'RequireLongerOrSameLength', this--- type family is internal.-type family RequireLongerThan' (l :: [k]) (a :: Nat) :: Constraint where-  RequireLongerThan' l a =-    If (IsLongerThan l a)-       (() :: Constraint)-       (TypeError-          ('Text "Stack element #" ':<>: 'ShowType (FromPeano a) ':<>:-           'Text " is not accessible" ':$$:-           'Text "Current stack has size of only " ':<>:-           'ShowType (LengthWithTail l) ':<>:-           'Text ":" ':$$: 'ShowType l-           ))--class (RequireLongerThan' l a, LongerThan l a) =>-  RequireLongerThan (l :: [k]) (a :: Peano)-instance (RequireLongerThan' l a, LongerThan l a) =>-  RequireLongerThan l a---- | 'IsLongerOrSameLength' in form of constraint that produces--- good error message. Should be used together with 'LongerThan'--- because 'LongerThan' gives GHC more information.--- We use it in combination, so that it gives enough information to--- GHC and also producess good error messages.-type family RequireLongerOrSameLength' (l :: [k]) (a :: Peano) :: Constraint where-  RequireLongerOrSameLength' l a =-    If (IsLongerOrSameLength l a)-       (() :: Constraint)-       (TypeError-          ('Text "Expected stack with length >= " ':<>: 'ShowType (FromPeano a) ':$$:-           'Text "Current stack has size of only " ':<>:-           'ShowType (LengthWithTail l) ':<>:-           'Text ":" ':$$: 'ShowType l-           ))---- | We can have--- `RequireLongerOrSameLength = (RequireLongerOrSameLength' l a, LongerOrSameLength l a)`,--- but apparently the printed error message can be caused by `LongerOrSameLength`--- rather than `RequireLongerOrSameLength'`.--- We do not know for sure how it all works, but we think that if we require constraint X before--- Y (using multiple `=>`s) then X will always be evaluated first.-class (RequireLongerOrSameLength' l a, LongerOrSameLength l a) =>-  RequireLongerOrSameLength (l :: [k]) (a :: Peano)-instance (RequireLongerOrSameLength' l a, LongerOrSameLength l a) =>-  RequireLongerOrSameLength l a--instance MockableConstraint (RequireLongerOrSameLength l a) where-  unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerOrSameLength '[] 'Z)--instance MockableConstraint (RequireLongerThan l a) where-  unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerThan '[()] 'Z)--------------------------------------------------------------------------------- Length constraints 'Dict'ionaries-------------------------------------------------------------------------------requireLongerThan-  :: Rec any stk-  -> Sing n-  -> Maybe (Dict (RequireLongerThan stk n))-requireLongerThan RNil _           = Nothing-requireLongerThan (_ :& _xs) SZ    = Just Dict-requireLongerThan (_ :& xs) (SS n) = do-  Dict <- requireLongerThan xs n-  return Dict--requireLongerOrSameLength-  :: Rec any stk-  -> Sing n-  -> Maybe (Dict (RequireLongerOrSameLength stk n))-requireLongerOrSameLength _ SZ             = Just Dict-requireLongerOrSameLength RNil (SS _)      = Nothing-requireLongerOrSameLength (_ :& xs) (SS n) = do-  Dict <- requireLongerOrSameLength xs n-  return Dict--------------------------------------------------------------------------------- Arith constraints 'Dict'ionaries-------------------------------------------------------------------------------isGreaterThan-  :: Sing a -> Sing b-  -> Maybe (Dict ((a > b) ~ 'True))-isGreaterThan SZ _          = Nothing-isGreaterThan (SS _) SZ     = pure Dict-isGreaterThan (SS a) (SS b) = isGreaterThan a b--isGreaterEqualThan-  :: Sing a -> Sing b-  -> Maybe (Dict ((a >= b) ~ 'True))-isGreaterEqualThan _ SZ          = pure Dict-isGreaterEqualThan SZ _          = Nothing-isGreaterEqualThan (SS a) (SS b) = isGreaterEqualThan a b

− src/Util/PeanoNatural.hs

@@ -1,90 +0,0 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utility for 'PeanoNatural'------ At the moment, we have no other libriaries with that would--- provide effective implementation of type-level natural--- numbers. So we define our own data type called @PeanoNatural@.--- Using this type one may extract a term-level natural number--- from a type-level one quite simply.-module Util.PeanoNatural-  ( PeanoNatural (Zero, Succ, One, Two)-  , toPeanoNatural-  , toPeanoNatural'-  , fromPeanoNatural-  , singPeanoVal-  ) where--import Data.Singletons (SingI (..))-import Text.PrettyPrint.Leijen.Text (integer)-import Util.Peano (Nat (Z, S), SingNat(..), ToPeano)-import qualified GHC.TypeNats as GHC (Nat)--import Michelson.Printer.Util---- | PeanoNatural data type------ The @PN@ constructor stores @s :: SingNat n@ and @k :: Natural@--- with the following invariant:--- if @PN s k :: PeanoNatural n@, then @k == n@.--- This definition allows extracting values of Natural--- without O(n) conversion from @SingNat n@.-data PeanoNatural (n :: Nat) = PN !(SingNat n) !Natural--deriving stock instance Show (PeanoNatural n)-deriving stock instance Eq (PeanoNatural n)--instance RenderDoc (PeanoNatural n) where-  renderDoc _ = integer . toInteger . fromPeanoNatural--instance NFData (PeanoNatural n) where-  rnf (PN s _) = rnf s--data MatchPS n where-  PS_Match :: PeanoNatural n -> MatchPS ('S n)-  PS_Mismatch :: MatchPS n--matchPS :: PeanoNatural n -> MatchPS n-matchPS (PN (SS m) k) = PS_Match (PN m (k - 1))-matchPS _ = PS_Mismatch---- | Patterns 'Zero' and 'Succ'--- We introduce pattern synonyms 'Zero' and 'Succ' assuming that--- 'Zero' and 'Succ' cover all possible cases that satisfy the invariant.--- Using these patterns, we also avoid cases when `k /= peanoValSing @n s`-pattern Zero :: () => (n ~ 'Z) => PeanoNatural n-pattern Zero = PN SZ 0--pattern Succ :: () => (n ~ 'S m) => PeanoNatural m -> PeanoNatural n-pattern Succ s <- (matchPS -> PS_Match s) where-  Succ (PN n k) = PN (SS n) (k+1)-{-# COMPLETE Zero, Succ #-}---- | The following patterns are introduced for convenience.--- This allow us to avoid writing @Succ (Succ Zero)@ in--- several places.-pattern One :: () => (n ~ ('S 'Z)) => PeanoNatural n-pattern One = Succ Zero--pattern Two :: () => (n ~ ('S ('S 'Z))) => PeanoNatural n-pattern Two = Succ One--fromPeanoNatural :: forall n. PeanoNatural n -> Natural-fromPeanoNatural (PN _ n) = n---- | toPeanoNatural and toPeanoNatural' connect PeanoNatural with--- natural numbers known at run-time.-singPeanoVal :: forall (n :: Nat). SingNat n -> Natural-singPeanoVal = \case-  SZ   -> 0-  SS a -> 1 + singPeanoVal a--toPeanoNatural :: forall n. SingI n => PeanoNatural n-toPeanoNatural = let pSing = sing @n in-  PN pSing $ singPeanoVal pSing--toPeanoNatural'-  :: forall (n :: GHC.Nat). SingI (ToPeano n) => PeanoNatural (ToPeano n)-toPeanoNatural' = toPeanoNatural @(ToPeano n)

− src/Util/Positive.hs

@@ -1,40 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Definition of 'Positive' type and related utilities.-module Util.Positive-  ( Positive (..)-  , mkPositive-  , lengthNE-  , replicateNE-  ) where--import Data.Aeson (FromJSON, ToJSON)-import Data.Data (Data)-import Fmt (Buildable, pretty)--import Util.Instances ()---- | Integer values starting from 1.------ We define our own datatype in order to have 'Data' instance for it,--- which can not be derived for third-party types without exported constructor.-newtype Positive = UnsafePositive { unPositive :: Natural }-  deriving stock (Eq, Ord, Data, Generic)-  deriving newtype (Show, Buildable, ToJSON, FromJSON)--instance NFData Positive--mkPositive :: (Integral i, Buildable i) => i -> Either Text Positive-mkPositive a-  | a > 0     = Right $ UnsafePositive (fromIntegral a)-  | otherwise = Left $ "Number is not positive: " <> pretty a---- | Count length of non-empty list.-lengthNE :: NonEmpty a -> Positive-lengthNE = UnsafePositive . fromIntegral . length---- | Produce a non empty list consisting of the given value.-replicateNE :: Positive -> a -> NonEmpty a-replicateNE (UnsafePositive i) a = a :| replicate (fromIntegral i - 1) a

− src/Util/Sing.hs

@@ -1,93 +0,0 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.Sing-  ( eqI-  , eqParamSing-  , eqParamSing2-  , eqParamSing3-  , castSing-  , SingI1(..)-  ) where--import Data.Type.Equality ((:~:)(..), TestEquality(..))-import Data.Typeable (eqT)-import Data.Singletons (KindOf, Sing, SingI, sing)-import Data.Singletons.Decide (SDecide, decideEquality)---- | Version of 'testEquality' that uses 'SingI'-eqI :: forall a b. (SingI a, SingI b, TestEquality (Sing @(KindOf a))) => Maybe (a :~: b)-eqI = testEquality (sing @a) (sing @b)---- | Suppose you have a data type `X` with parameter `a` and you have--- two values: `x1 :: X a1` and `x2 :: X a2`. You can't compare them--- using '==', because they have different types. However, you can--- compare them using 'eqParamSing' as long as both parameters have--- SingI instances and their kind is `SDecide`.-eqParamSing ::-  forall a1 a2 t.-  ( SingI a1-  , SingI a2-  , SDecide (KindOf a1)-  , Eq (t a1)-  )-  => t a1-  -> t a2-  -> Bool-eqParamSing t1 t2 = isJust @() $ do-  Refl <- sing @a1 `decideEquality` sing @a2-  guard (t1 == t2)---- | Version of 'eqParamSing' for types with 2 parameters.-eqParamSing2 ::-  forall a1 a2 b1 b2 t.-  ( SingI a1-  , SingI a2-  , SingI b1-  , SingI b2-  , SDecide (KindOf a1)-  , SDecide (KindOf b1)-  , Eq (t a1 b2)-  )-  => t a1 b1-  -> t a2 b2-  -> Bool-eqParamSing2 t1 t2 = isJust @() $ do-  Refl <- sing @a1 `decideEquality` sing @a2-  Refl <- sing @b1 `decideEquality` sing @b2-  guard (t1 == t2)---- | Version of 'eqParamSing' for types with 3 parameters.-eqParamSing3 ::-  forall instr1 instr2 a1 a2 b1 b2 t.-  ( Typeable instr1-  , Typeable instr2-  , SingI a1-  , SingI a2-  , SingI b1-  , SingI b2-  , SDecide (KindOf a1)-  , SDecide (KindOf b1)-  , Eq (t instr1 a1 b1)-  )-  => t instr1 a1 b1-  -> t instr2 a2 b2-  -> Bool-eqParamSing3 t1 t2 = isJust @() $ do-  Refl <- eqT @instr1 @instr2-  Refl <- sing @a1 `decideEquality` sing @a2-  Refl <- sing @b1 `decideEquality` sing @b2-  guard (t1 == t2)--castSing :: forall a b t.-  (SingI a, SingI b, SDecide (KindOf a))-  => t a-  -> Maybe (t b)-castSing ca = do-  Refl <- sing @a `decideEquality` sing @b-  return ca---- Second-order analogue of 'SingI'-class SingI1 f where-  withSingI1 :: forall x r. SingI x => (SingI (f x) => r) -> r

− src/Util/TH.hs

@@ -1,57 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.TH-  ( deriveGADTNFData-  , lookupTypeNameOrFail-  ) where--import Language.Haskell.TH---- | Generates an NFData instance for a GADT. /Note:/ This will not generate--- additional constraints to the generated instance if those are required.-deriveGADTNFData :: Name -> Q [Dec]-deriveGADTNFData name = do-  seqQ <- [| seq |]-  unit <- [| () |]-  (TyConI (DataD _ dataName vars _ cons _)) <- reify name-  let-    getNameFromVar (PlainTV n) = n-    getNameFromVar (KindedTV n _) = n--    -- Unfolds multiple constructors of form "A, B, C :: A -> Stuff"-    -- into a list of tuples of constructor names and their data-    unfoldConstructor (GadtC cs bangs _) = map (,bangs) cs-    unfoldConstructor (ForallC _ _ c) = unfoldConstructor c-    unfoldConstructor _ = fail "Non GADT constructors are not supported."--    -- Constructs a clause "rnf (ConName a1 a2 ...) = rnf a1 `seq` rnf a2 `seq` rnf a3 `seq` ..."-    makeClauses (conName, bangs) = do-        varNames <- traverse (\_ -> newName "a") bangs-        let rnfVar = VarE 'rnf-        let rnfExp = AppE rnfVar . VarE-        let infixSeq e1 e2 = InfixE (Just e1) seqQ (Just e2)-        return $-          (Clause-            [ConP conName $ map VarP varNames]-            (NormalB $ foldl' infixSeq unit (map rnfExp varNames))-            []-          )--    nfDataT =-      AppT (ConT $ mkName "NFData") . foldl' AppT (ConT dataName) $-        map (VarT . getNameFromVar) vars--    makeInstance clauses =-      InstanceD Nothing [] nfDataT [FunD (mkName "rnf") clauses]---  clauses <- traverse makeClauses $ cons >>= unfoldConstructor-  return [makeInstance clauses]--lookupTypeNameOrFail :: String -> Q Name-lookupTypeNameOrFail typeStr =-  lookupTypeName typeStr >>= \case-    Nothing -> fail $ "Failed type name lookup for: '" <> typeStr <> "'."-    Just tn -> pure tn

− src/Util/Text.hs

@@ -1,22 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.Text-  ( headToLower-  , surround-  ) where--import Data.Char (toLower)-import qualified Data.Text as T---- | Leads first character of text to lower case.------ For empty text this will throw an error.-headToLower :: HasCallStack => Text -> Text-headToLower txt = case T.uncons txt of-  Nothing -> error "Empty text"-  Just (c, cs) -> T.cons (toLower c) cs--surround :: Semigroup a => a -> a -> a -> a-surround pre post content = pre <> content <> post

− src/Util/Type.hs

@@ -1,239 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE QuantifiedConstraints #-}---- | General type utilities.-module Util.Type-  ( type (==)-  , If-  , type (++)-  , IsElem-  , type (/)-  , type (//)-  , Guard-  , FailWhen-  , FailUnless-  , failUnlessEvi-  , failWhenEvi-  , AllUnique-  , RequireAllUnique-  , ReifyList (..)-  , PatternMatch-  , PatternMatchL-  , KnownList (..)-  , KList (..)-  , RSplit-  , rsplit-  , Some1 (..)-  , recordToSomeList--  , reifyTypeEquality--  , ConcatListOfTypesAssociativity-  , listOfTypesConcatAssociativityAxiom--  , MockableConstraint (..)--  , onFirst-  ) where--import Data.Constraint (Dict(..), (:-)(..), (\\))-import Data.Type.Bool (If, Not, type (&&))-import Data.Type.Equality (type (==))-import Data.Vinyl.Core (Rec(..))-import qualified Data.Vinyl.Functor as Vinyl-import Data.Vinyl.Recursive (recordToList, rmap)-import Data.Vinyl.TypeLevel (type (++))-import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)-import Unsafe.Coerce (unsafeCoerce)--type family IsElem (a :: k) (l :: [k]) :: Bool where-  IsElem _ '[] = 'False-  IsElem a (a ': _) = 'True-  IsElem a (_ ': as) = IsElem a as---- | Remove all occurences of the given element.-type family (l :: [k]) / (a :: k) where-  '[] / _ = '[]-  (a ': xs) / a = xs / a-  (b ': xs) / a = b ': (xs / a)---- | Difference between two lists.-type family (l1 :: [k]) // (l2 :: [k]) :: [k] where-  l // '[] = l-  l // (x ': xs) = (l / x) // xs--type family Guard (cond :: Bool) (a :: k) :: Maybe k where-  Guard 'False _ = 'Nothing-  Guard 'True a = 'Just a---- | Fail with given error if the condition does not hold.-type family FailUnless (cond :: Bool) (msg :: ErrorMessage) :: Constraint where-  FailUnless 'True _ = ()-  FailUnless 'False msg = TypeError msg---- | Fail with given error if the condition holds.-type FailWhen cond msg = FailUnless (Not cond) msg---- | A natural conclusion from the fact that an error has not occurred.-failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True)-failUnlessEvi = Sub unsafeProvideConstraint--failWhenEvi :: forall cond msg. FailWhen cond msg :- (cond ~ 'False)-failWhenEvi = Sub unsafeProvideConstraint--type family AllUnique (l :: [k]) :: Bool where-  AllUnique '[] = 'True-  AllUnique (x : xs) = Not (IsElem x xs) && AllUnique xs--type RequireAllUnique desc l = RequireAllUnique' desc l l--type family RequireAllUnique' (desc :: Symbol) (l :: [k]) (origL ::[k]) :: Constraint where-  RequireAllUnique' _ '[] _ = ()-  RequireAllUnique' desc (x : xs) origL =-    If (IsElem x xs)-       (TypeError ('Text "Duplicated " ':<>: 'Text desc ':<>: 'Text ":" ':$$:-                   'ShowType x ':$$:-                   'Text "Full list: " ':<>:-                   'ShowType origL-                  )-       )-       (RequireAllUnique' desc xs origL)---- | Make sure given type is evaluated.--- This type family fits only for types of 'Type' kind.-type family PatternMatch (a :: Type) :: Constraint where-  PatternMatch Int = ((), ())-  PatternMatch _ = ()--type family PatternMatchL (l :: [k]) :: Constraint where-  PatternMatchL '[] = ((), ())-  PatternMatchL _ = ()---- | Bring type-level list at term-level using given function--- to demote its individual elements.-class ReifyList (c :: k -> Constraint) (l :: [k]) where-  reifyList :: (forall a. c a => Proxy a -> r) -> [r]--instance ReifyList c '[] where-  reifyList _ = []--instance (c x, ReifyList c xs) => ReifyList c (x ': xs) where-  reifyList reifyElem = reifyElem (Proxy @x) : reifyList @_ @c @xs reifyElem---- | Reify type equality from boolean equality.-reifyTypeEquality :: forall a b x. (a == b) ~ 'True => (a ~ b => x) -> x-reifyTypeEquality x = x \\ unsafeProvideConstraint @(a ~ b)---- | Similar to @SingI []@, but does not require individual elements to be also--- instance of @SingI@.-class KnownList l where-  klist :: KList l-instance KnownList '[] where-  klist = KNil-instance KnownList xs => KnownList (x ': xs) where-  klist = KCons Proxy Proxy---- | 'SList' analogy for 'KnownList'.-data KList (l :: [k]) where-  KNil :: KList '[]-  KCons :: KnownList xs => Proxy x -> Proxy xs -> KList (x ': xs)--type RSplit l r = KnownList l---- | Split a record into two pieces.-rsplit-  :: forall k (l :: [k]) (r :: [k]) f.-      (RSplit l r)-  => Rec f (l ++ r) -> (Rec f l, Rec f r)-rsplit = case klist @l of-  KNil -> (RNil, )-  KCons{} -> \(x :& r) ->-    let (x1, r1) = rsplit r-    in (x :& x1, r1)---- | A value of type parametrized with /some/ type parameter.-data Some1 (f :: k -> Type) =-  forall a. Some1 (f a)--deriving stock instance (forall a. Show (f a)) => Show (Some1 f)--recordToSomeList :: Rec f l -> [Some1 f]-recordToSomeList = recordToList . rmap (Vinyl.Const . Some1)--type ConcatListOfTypesAssociativity a b c = ((a ++ b) ++ c) ~ (a ++ (b ++ c))---- | GHC can't deduce this itself because--- in general a type family might be not associative,--- what brings extra difficulties and redundant constraints,--- especially if you have complex types.--- But (++) type family is associative, so let's define this small hack.-listOfTypesConcatAssociativityAxiom :: forall a b c . Dict (ConcatListOfTypesAssociativity a b c)-listOfTypesConcatAssociativityAxiom = unsafeProvideConstraint---- | Constaints that can be provided on demand.------ Needless to say, this is a pretty unsafe operation. This typeclass makes--- using it safer in a sense that getting a segfault becomes harder, but still--- it deceives the type system and should be used only if providing a proper--- proof would be too difficult.-class MockableConstraint (c :: Constraint) where-  -- | Produce a constraint out of thin air.-  unsafeProvideConstraint :: Dict c--instance MockableConstraint (a ~ b) where-  unsafeProvideConstraint = unsafeCoerce $ Dict @(Int ~ Int)---- | In majority of the cases we don't want to mock typeclass constraints--- since coercing instances of typeclasses with methods is utterly unsafe.-instance {-# OVERLAPPABLE #-} c a => MockableConstraint (c a) where-  unsafeProvideConstraint = Dict--instance ( MockableConstraint c1-         , MockableConstraint c2-         ) => MockableConstraint (c1, c2) where-  unsafeProvideConstraint = runIdentity $ do-    Dict <- pure $ unsafeProvideConstraint @c1-    Dict <- pure $ unsafeProvideConstraint @c2-    return Dict-  {-# INLINE unsafeProvideConstraint #-}--instance ( MockableConstraint c1-         , MockableConstraint c2-         , MockableConstraint c3-         ) => MockableConstraint (c1, c2, c3) where-  unsafeProvideConstraint = runIdentity $ do-    Dict <- pure $ unsafeProvideConstraint @(c1, c2)-    Dict <- pure $ unsafeProvideConstraint @c3-    return Dict-  {-# INLINE unsafeProvideConstraint #-}--instance ( MockableConstraint c1-         , MockableConstraint c2-         , MockableConstraint c3-         , MockableConstraint c4-         ) => MockableConstraint (c1, c2, c3, c4) where-  unsafeProvideConstraint = runIdentity $ do-    Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3)-    Dict <- pure $ unsafeProvideConstraint @c4-    return Dict-  {-# INLINE unsafeProvideConstraint #-}--instance ( MockableConstraint c1-         , MockableConstraint c2-         , MockableConstraint c3-         , MockableConstraint c4-         , MockableConstraint c5-         ) => MockableConstraint (c1, c2, c3, c4, c5) where-  unsafeProvideConstraint = runIdentity $ do-    Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3, c4)-    Dict <- pure $ unsafeProvideConstraint @c5-    return Dict-  {-# INLINE unsafeProvideConstraint #-}---- | Utility function to help transform the first argument of a binfunctor.-onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c-onFirst = flip first

− src/Util/TypeLits.hs

@@ -1,102 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-redundant-constraints #-}---- | Re-exports 'GHC.TypeLits', modifying it considering our practices.-module Util.TypeLits-  ( Symbol-  , KnownSymbol-  , AppendSymbol-  , symbolVal-  , symbolValT-  , symbolValT'--  , TypeError-  , ErrorMessage (..)--  , TypeErrorUnless-  , AssertTypesEqual-  ) where--import GHC.TypeLits-import Data.Type.Equality--symbolValT :: forall s. KnownSymbol s => Proxy s -> Text-symbolValT = toText . symbolVal--symbolValT' :: forall s. KnownSymbol s => Text-symbolValT' = symbolValT (Proxy @s)---- | Conditional type error.------ There is a very subtle difference between 'TypeErrorUnless' and the following type family:------ > type family TypeErrorUnlessAlternative (cond :: Bool) (err :: ErrorMessage) :: Constraint where--- >   TypeErrorUnlessAlternative cond err =--- >     ( If cond--- >         (() :: Constraint)--- >         (TypeError err)--- >     , cond ~ 'True--- >     )------ If @cond@ cannot be fully reduced (e.g. it's a stuck type family), then:------ * @TypeErrorUnless@ will state that the constraint cannot be deduced.--- * @TypeErrorUnlessAlternative@ will fail with the given error message @err@.------ For example:------ > -- Partial function--- > type family IsZero (n :: Peano) :: Bool where--- >   IsZero ('S _) = 'False--- >--- > f1 :: TypeErrorUnless (IsZero n) ('Text "Expected zero") => ()--- > f1 = ()--- >--- > f2 :: TypeErrorUnlessAlternative (IsZero n) ('Text "Expected zero") => ()--- > f2 = ()--- >--- >--- > f1res = f1 @'Z--- > -- • Couldn't match type ‘IsZero 'Z’ with ‘'True’--- >--- > f2res = f2 @'Z--- > -- • Expected zero------ As you can see, the error message in @f2res@ is misleading (because the type argument--- actually _is_ zero), so it's preferable to fail with the standard GHC error message.-type TypeErrorUnless (cond :: Bool) (err :: ErrorMessage) =-  ( TypeErrorUnlessHelper cond err-  -- Note: the '~' constraint below might seem redundant, but, without it,-  -- GHC would warn that the following pattern match is not exhaustive (even though it is):-  ---  -- > f :: TypeErrorUnless (n >= ToPeano 2) "some err msg" => Sing n -> ()-  -- > f = \case-  -- >   SS (SS SZ) -> ()-  -- >   SS (SS _) -> ()-  ---  -- GHC needs to "see" the type equality '~' in order to actually "learn" something from a-  -- type family's result.-  , cond ~ 'True-  )--type family TypeErrorUnlessHelper (cond :: Bool) (err :: ErrorMessage) :: Constraint where-  TypeErrorUnlessHelper 'True _ = ()-  TypeErrorUnlessHelper 'False err = TypeError err---- | Condition Error helper to check if two types are equal------ >>> :k! AssertTypesEqual Int Int ('Text "This should not result in a failure")--- AssertTypesEqual Int Int ('Text "This should not result in a failure") :: Constraint--- = (() :: Constraint, Int ~ Int)------ >>> :k! AssertTypesEqual Bool Int ('Text "This should result in a failure")--- AssertTypesEqual Bool Int ('Text "This should result in a failure") :: Constraint--- = ((TypeError ...), Bool ~ Int)-type AssertTypesEqual a b (err :: ErrorMessage) =-  ( TypeErrorUnlessHelper (a == b) err-  -- The reasons for the constraint below are the same as those in @TypeErrorUnless@ constructor-  , a ~ b-  )

− src/Util/TypeTuple.hs

@@ -1,11 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Conversions between tuples and list-like types.-module Util.TypeTuple-  ( RecFromTuple (..)-  ) where--import Util.TypeTuple.Class-import Util.TypeTuple.Instances ()

− src/Util/TypeTuple/Class.hs

@@ -1,17 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.TypeTuple.Class-  ( RecFromTuple (..)-  ) where---- | Building a record from tuple.------ It differs from similar typeclass in 'Data.Vinyl.FromTuple' module in that--- it allows type inference outside-in - knowing desired 'Rec' you know which--- tuple should be provided - this improves error messages when constructing--- concrete 'Rec' objects.-class RecFromTuple r where-  type IsoRecTuple r :: Type-  recFromTuple :: IsoRecTuple r -> r

− src/Util/TypeTuple/Instances.hs

@@ -1,19 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}--module Util.TypeTuple.Instances () where--import Data.Vinyl.Core (Rec(..))--import Util.TypeTuple.Class-import Util.TypeTuple.TH--concatMapM deriveRecFromTuple (0 : [2..25])--- ↑ We skip 1-ary tuple because it is GHC.Tuple.Unit, and we don't want it.--instance RecFromTuple (Rec f '[a]) where-  type IsoRecTuple (Rec f '[a]) = f a-  recFromTuple a = a :& RNil

− src/Util/TypeTuple/TH.hs

@@ -1,39 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE QuasiQuotes #-}---- | Template haskell generator for 'RecFromTuple', in a separate module--- because of staging restrictions.-module Util.TypeTuple.TH-  ( deriveRecFromTuple-  ) where--import Data.Vinyl.Core (Rec(..))-import qualified Language.Haskell.TH as TH--import Util.TypeTuple.Class---- | Produce 'RecFromTuple' instance for tuple of the given length.-deriveRecFromTuple :: Word -> TH.Q [TH.Dec]-deriveRecFromTuple (fromIntegral -> n) = do-  fVar <- TH.VarT <$> TH.newName "f"-  tyVars <- replicateM n $ TH.VarT <$> TH.newName "x"--  let consTy ty lty = TH.promotedConsT `TH.appT` pure ty `TH.appT` lty-  let tyList = foldr consTy TH.promotedNilT tyVars--  let tupleConsTy acc ty = acc `TH.appT` (pure fVar `TH.appT` pure ty)-  let tyTuple = foldl tupleConsTy (TH.tupleT n) tyVars--  vars <- replicateM n $ TH.newName "a"-  let tyPat = pure . TH.TupP $ map TH.VarP vars--  let consRec var acc = [e|(:&)|] `TH.appE` TH.varE var `TH.appE` acc-  let recRes = foldr consRec [e|RNil|] vars--  [d| instance RecFromTuple (Rec ($(pure fVar) :: u -> Type) $tyList) where-        type IsoRecTuple (Rec $(pure fVar) $tyList) = $tyTuple-        recFromTuple $tyPat = $recRes-    |]

− src/Util/Typeable.hs

@@ -1,148 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# LANGUAGE QuantifiedConstraints #-}---- | Utility for 'Typeable'.-module Util.Typeable-  ( eqParam1-  , eqParam2-  , eqParam3-  , eqExt-  , compareExt-  , castIgnoringPhantom-  , eqTypeIgnoringPhantom-    -- * Re-exports-  , (:~:) (..)-  , eqT-  ) where--import Data.Coerce (coerce)-import Data.Typeable (eqT, typeRep, (:~:)(..))-import qualified Type.Reflection as Refl---- | Suppose you have a data type `X` with parameter `a` and you have--- two values: `x1 :: X a1` and `x2 :: X a2`. You can't compare them--- using '==', because they have different types. However, you can--- compare them using 'eqParam1' as long as both parameters are--- 'Typeable'.-eqParam1 ::-     forall a1 a2 t.-     ( Typeable a1-     , Typeable a2-     , Eq (t a1)-     )-  => t a1-  -> t a2-  -> Bool-eqParam1 t1 t2 = isJust @() $ do-  Refl <- eqT @a1 @a2-  guard (t1 == t2)---- | Version of 'eqParam1' for types with 2 parameters.-eqParam2 ::-     forall a1 a2 b1 b2 t.-     ( Typeable a1-     , Typeable a2-     , Typeable b1-     , Typeable b2-     , Eq (t a1 b2)-     )-  => t a1 b1-  -> t a2 b2-  -> Bool-eqParam2 t1 t2 = isJust @() $ do-  Refl <- eqT @a1 @a2-  Refl <- eqT @b1 @b2-  guard (t1 == t2)---- | Version of 'eqParam1' for types with 3 parameters.-eqParam3 ::-     forall a1 a2 b1 b2 c1 c2 t.-     ( Typeable a1-     , Typeable a2-     , Typeable b1-     , Typeable b2-     , Typeable c1-     , Typeable c2-     , Eq (t a1 b1 c1)-     )-  => t a1 b1 c1-  -> t a2 b2 c2-  -> Bool-eqParam3 t1 t2 = isJust @() $ do-  Refl <- eqT @a1 @a2-  Refl <- eqT @b1 @b2-  Refl <- eqT @c1 @c2-  guard (t1 == t2)---- | Compare two entries of completely different types.-eqExt ::-     forall a1 a2.-     ( Typeable a1-     , Typeable a2-     , Eq a1-     )-  => a1-  -> a2-  -> Bool-eqExt a1 a2 = isJust @() $ do-  Refl <- eqT @a1 @a2-  guard (a1 == a2)---- | Extension of 'eqExt' to 'compare' function.-compareExt ::-     forall a1 a2.-     ( Typeable a1-     , Typeable a2-     , Ord a1-     )-  => a1-  -> a2-  -> Ordering-compareExt t1 t2 =-  case eqT @a1 @a2 of-    Nothing -> typeRep (Proxy @a1) `compare` typeRep (Proxy @a2)-    Just Refl -> t1 `compare` t2--{- | Cast to a type with phantom type argument without matching this argument.-The phantom type must be the last type argument of the type.--Example of use: imagine a type--@-data MyType a = MyType-@--Normally, if object of this type was hidden under existential quantification with-'Typeable' constraint, then in order to get it back with 'cast' you need to know-the exact type of the hidden object, including its phantom type parameter.-With 'castIgnoringPhantom' you get a way to extract this object no matter which-phantom argument it had.--}-castIgnoringPhantom-  :: forall c x.-     ( Typeable x, Typeable c-     , forall phantom1 phantom2. Coercible (c phantom1) (c phantom2)-     )-  => x -> Maybe (c DummyPhantomType)-castIgnoringPhantom x = do-  Refl.App x1Rep _ <- pure $ Refl.typeOf x-  let cRep = Refl.typeRep @c-  Refl.HRefl <- Refl.eqTypeRep x1Rep cRep-  return (coerce x)--type family DummyPhantomType :: k where---- | Match given type against another type of @* -> *@ kind without caring--- about its type argument.-eqTypeIgnoringPhantom-  :: forall c x r.-     (Typeable x, Typeable c)-  => (forall a. Typeable a => (c a :~: x) -> Proxy a -> r) -> Maybe r-eqTypeIgnoringPhantom cont = do-  Refl.App x1Rep xArgRep <- pure $ Refl.typeRep @x-  let cRep = Refl.typeRep @c-  Refl.HRefl <- Refl.eqTypeRep x1Rep cRep-  return $ Refl.withTypeable xArgRep (cont Refl Proxy)