module Indigo.Compilation.Sequential.Types
( Block
, Instruction (..)
, IndigoSeqCaseClause (..)
, CaseBranch (..)
, SequentialHooks (..)
, InstrCollector (..)
, stmtHookL
) where
import Prelude
import Lens.Micro.TH (makeLensesFor)
import Lorentz.Entrypoints.Helpers (RequireSumType)
import Lorentz.Run qualified as L (Contract)
import Morley.Michelson.Typed.Haskell.Instr.Sum (CaseClauseParam(..), CtorField(..))
import Morley.Michelson.Untyped.Annotation (FieldAnn)
import Morley.Util.TypeLits (AppendSymbol)
import Indigo.Backend
import Indigo.Common.Expr (Expr)
import Indigo.Common.Field (HasField)
import Indigo.Common.SIS
import Indigo.Common.Var
import Indigo.Lorentz hiding (comment)
type Block = [Instruction]
data Instruction where
LiftIndigoState :: (forall inp. SomeIndigoState inp) -> Instruction
:: Text -> Instruction
AssignVar :: KnownValue x => Var x -> Expr x -> Instruction
SetVar :: KnownValue x => Var x -> Expr x -> Instruction
VarModification
:: (IsObject x, KnownValue y)
=> [y, x] :-> '[x]
-> Var x
-> Expr y
-> Instruction
SetField
:: ( HasField store fname ftype
, IsObject store
, IsObject ftype
)
=> Var store -> Label fname -> Expr ftype -> Instruction
LambdaCall1
:: LambdaKind st arg ret extra
-> String
-> Expr arg
-> Var arg
-> Block
-> ret
-> RetVars ret
-> Instruction
CreateLambda1
:: CreateLambda1CGeneric extra arg ret
=> StackVars (arg : extra)
-> Var arg
-> Block
-> ret
-> Var (Lambda1Generic extra arg ret)
-> Instruction
ExecLambda1
:: LambdaKind st arg ret extra
-> Proxy ret
-> Expr arg
-> Var (Lambda1Generic extra arg ret)
-> RetVars ret
-> Instruction
Scope
:: ScopeCodeGen ret
=> Block
-> ret
-> RetVars ret
-> Instruction
If
:: IfConstraint a b
=> Expr Bool
-> Block
-> a
-> Block
-> b
-> RetVars a
-> Instruction
IfSome
:: (IfConstraint a b, KnownValue x)
=> Expr (Maybe x)
-> Var x
-> Block
-> a
-> Block
-> b
-> RetVars a
-> Instruction
IfRight
:: (IfConstraint a b, KnownValue r, KnownValue l)
=> Expr (Either l r)
-> Var r
-> Block
-> a
-> Var l
-> Block
-> b
-> RetVars a
-> Instruction
IfCons
:: (IfConstraint a b, KnownValue x)
=> Expr (List x)
-> Var x
-> Var (List x)
-> Block
-> a
-> Block
-> b
-> RetVars a
-> Instruction
Case
:: CaseCommon dt ret clauses
=> Expr dt
-> clauses
-> RetVars ret
-> Instruction
EntryCase
:: ( CaseCommon dt ret clauses
, DocumentEntrypoints entryPointKind dt
)
=> Proxy entryPointKind
-> Expr dt
-> clauses
-> RetVars ret
-> Instruction
EntryCaseSimple
:: ( CaseCommon dt ret clauses
, DocumentEntrypoints PlainEntrypointsKind dt
, NiceParameterFull dt
, RequireFlatParamEps dt
)
=> Expr dt
-> clauses
-> RetVars ret
-> Instruction
While
:: Expr Bool
-> Block
-> Instruction
WhileLeft
:: (KnownValue l, KnownValue r)
=> Expr (Either l r)
-> Var l
-> Block
-> Var r
-> Instruction
ForEach
:: (IterOpHs a, KnownValue (IterOpElHs a))
=> Expr a
-> Var (IterOpElHs a)
-> Block
-> Instruction
ContractName
:: Text
-> Block
-> Instruction
DocGroup
:: forall di. DocItem di
=> (SubDoc -> di)
-> Block
-> Instruction
ContractGeneral
:: Block
-> Instruction
FinalizeParamCallingDoc
:: (NiceParameterFull cp, RequireSumType cp)
=> Var cp
-> Block
-> Expr cp
-> Instruction
TransferTokens
:: (NiceParameter p, HasSideEffects, IsNotInView)
=> Expr p
-> Expr Mutez
-> Expr (ContractRef p)
-> Instruction
SetDelegate
:: (HasSideEffects, IsNotInView)
=> Expr (Maybe KeyHash)
-> Instruction
CreateContract
:: ( HasSideEffects, NiceStorage s, NiceParameterFull p
, NiceViewsDescriptor vd, Typeable vd, IsNotInView
)
=> L.Contract p s vd
-> Expr (Maybe KeyHash)
-> Expr Mutez
-> Expr s
-> Var Address
-> Instruction
SelfCalling
:: ( NiceParameterFull p
, KnownValue (GetEntrypointArgCustom p mname)
, IsoValue (ContractRef (GetEntrypointArgCustom p mname))
, IsNotInView
)
=> Proxy p
-> EntrypointRef mname
-> Var (ContractRef (GetEntrypointArgCustom p mname))
-> Instruction
ContractCalling
:: ( HasEntrypointArg cp epRef epArg
, ToTAddress cp vd addr
, ToT addr ~ ToT Address
, KnownValue epArg
, IsoValue (ContractRef epArg)
)
=> Proxy (cp, vd)
-> epRef
-> Expr addr
-> Var (Maybe (ContractRef epArg))
-> Instruction
Emit :: (HasSideEffects, NicePackedValue a, HasAnnotation a) => FieldAnn -> Expr a -> Instruction
Fail
:: (forall inp. SomeIndigoState inp)
-> Instruction
FailOver
:: (forall inp. Expr a -> SomeIndigoState inp)
-> Expr a
-> Instruction
data InstrCollector = InstrCollector
{ InstrCollector -> RefId
nextRef :: RefId
, InstrCollector -> Block
instrList :: Block
, InstrCollector -> SequentialHooks
seqHooks :: SequentialHooks
}
newtype SequentialHooks = SequentialHooks {
SequentialHooks -> CallStack -> Block -> State InstrCollector ()
shStmtHook :: CallStack -> Block -> State InstrCollector ()
}
instance Semigroup SequentialHooks where
SequentialHooks CallStack -> Block -> State InstrCollector ()
s <> :: SequentialHooks -> SequentialHooks -> SequentialHooks
<> SequentialHooks CallStack -> Block -> State InstrCollector ()
s1 = (CallStack -> Block -> State InstrCollector ()) -> SequentialHooks
SequentialHooks (\CallStack
t -> CallStack -> Block -> State InstrCollector ()
s CallStack
t (Block -> State InstrCollector ())
-> (Block -> State InstrCollector ())
-> Block
-> State InstrCollector ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CallStack -> Block -> State InstrCollector ()
s1 CallStack
t)
instance Monoid SequentialHooks where
mempty :: SequentialHooks
mempty = (CallStack -> Block -> State InstrCollector ()) -> SequentialHooks
SequentialHooks ((Block -> State InstrCollector ())
-> CallStack -> Block -> State InstrCollector ()
forall a b. a -> b -> a
const ((Block -> State InstrCollector ())
-> CallStack -> Block -> State InstrCollector ())
-> (Block -> State InstrCollector ())
-> CallStack
-> Block
-> State InstrCollector ()
forall a b. (a -> b) -> a -> b
$ Block -> State InstrCollector ()
appendNewInstrs (Block -> State InstrCollector ())
-> (Block -> Block) -> Block -> State InstrCollector ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Block
forall a. [a] -> [a]
reverse)
appendNewInstrs :: Block -> State InstrCollector ()
appendNewInstrs :: Block -> State InstrCollector ()
appendNewInstrs Block
blk = (InstrCollector -> InstrCollector) -> State InstrCollector ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InstrCollector -> InstrCollector) -> State InstrCollector ())
-> (InstrCollector -> InstrCollector) -> State InstrCollector ()
forall a b. (a -> b) -> a -> b
$ \InstrCollector
iColl -> InstrCollector
iColl {instrList :: Block
instrList = Block
blk Block -> Block -> Block
forall a. [a] -> [a] -> [a]
++ InstrCollector -> Block
instrList InstrCollector
iColl}
type CaseCommon dt ret clauses = CaseCommonF IndigoSeqCaseClause dt ret clauses
data IndigoSeqCaseClause ret (param :: CaseClauseParam) where
OneFieldIndigoSeqCaseClause
:: (AppendSymbol "c" ctor ~ name)
=> Label name
-> CaseBranch x ret
-> IndigoSeqCaseClause ret ('CaseClauseParam ctor ('OneField x))
data CaseBranch x ret where
CaseBranch
:: ( KnownValue x
, ScopeCodeGen retBr
, ret ~ RetExprs retBr
, RetOutStack ret ~ RetOutStack retBr
)
=> Var x
-> Block
-> retBr
-> CaseBranch x ret
makeLensesFor [ ("shStmtHook", "stmtHookL")] ''SequentialHooks