{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Indigo.Backend.Case
( caseRec
, entryCaseRec
, entryCaseSimpleRec
, IndigoCaseClauseL
, IndigoClause (..)
, CaseCommonF
) where
import Data.Vinyl.Core (RMap(..))
import Util.Type (type (++))
import Util.TypeLits (AppendSymbol)
import Indigo.Backend.Prelude
import Indigo.Backend.Scope
import Indigo.Internal
import Indigo.Lorentz
import qualified Lorentz.ADT as L
import qualified Lorentz.Entrypoints.Doc as L
import qualified Lorentz.Instr as L
import Michelson.Typed.Haskell.Instr.Sum
(CaseClauseParam(..), CaseClauses, CtorField(..), InstrCaseC)
data IndigoCaseClauseL ret (param :: CaseClauseParam) where
OneFieldIndigoCaseClauseL
:: (forall inp .
MetaData inp
-> CaseClauseL inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x)))
-> IndigoCaseClauseL ret ('CaseClauseParam ctor ('OneField x))
data IndigoClause x ret where
IndigoClause
:: ( KnownValue x
, ScopeCodeGen retBr
, ret ~ RetExprs retBr
, RetOutStack ret ~ RetOutStack retBr
)
=> Var x
-> (forall inp. SomeIndigoState (x : inp))
-> retBr
-> IndigoClause x ret
instance
(name ~ AppendSymbol "c" ctor, KnownValue x)
=>
CaseArrow
name
(IndigoClause x ret)
(IndigoCaseClauseL ret ('CaseClauseParam ctor ('OneField x)))
where
/-> :: Label name
-> IndigoClause x ret
-> IndigoCaseClauseL ret ('CaseClauseParam ctor ('OneField x))
(/->) _ (IndigoClause varCase :: Var x
varCase sIndSt :: forall (inp :: [*]). SomeIndigoState (x : inp)
sIndSt (retBr
ret :: retBr)) =
(forall (inp :: [*]).
MetaData inp
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x)))
-> IndigoCaseClauseL ret ('CaseClauseParam ctor ('OneField x))
forall ret (ctor :: Symbol) x.
(forall (inp :: [*]).
MetaData inp
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x)))
-> IndigoCaseClauseL ret ('CaseClauseParam ctor ('OneField x))
OneFieldIndigoCaseClauseL ((forall (inp :: [*]).
MetaData inp
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x)))
-> IndigoCaseClauseL ret ('CaseClauseParam ctor ('OneField x)))
-> (forall (inp :: [*]).
MetaData inp
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x)))
-> IndigoCaseClauseL ret ('CaseClauseParam ctor ('OneField x))
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md@MetaData{..} -> case SomeIndigoState (x : inp)
forall (inp :: [*]). SomeIndigoState (x : inp)
sIndSt of
(SomeIndigoState body :: MetaData (x : inp) -> SomeGenCode (x : inp)
body :: SomeIndigoState (x : inp)) ->
case MetaData (x : inp) -> SomeGenCode (x : inp)
body (Var x -> MetaData inp -> MetaData (x : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> MetaData inp -> MetaData (a & inp)
pushRefMd Var x
varCase MetaData inp
md) of
SomeGenCode gc :: GenCode (x : inp) out
gc ->
(AppendCtorField ('OneField x) inp
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ inp))
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x))
forall (x :: CtorField) (inp :: [*]) (out :: [*]) (ctor :: Symbol).
(AppendCtorField x inp :-> out)
-> CaseClauseL inp out ('CaseClauseParam ctor x)
CaseClauseL ((AppendCtorField ('OneField x) inp
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ inp))
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x)))
-> (AppendCtorField ('OneField x) inp
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ inp))
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x))
forall a b. (a -> b) -> a -> b
$
DecomposedObjects
-> GenCode (x : inp) out
-> retBr
-> (x : inp)
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ (x : inp))
forall ret (inp :: [*]) (xs :: [*]).
ScopeCodeGen ret =>
DecomposedObjects
-> GenCode inp xs -> ret -> inp :-> (RetOutStack ret ++ inp)
compileScope @retBr DecomposedObjects
mdObjects GenCode (x : inp) out
gc retBr
ret ((x : inp)
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ (x : inp)))
-> ((RetOutStack' (ClassifyReturnValue retBr) retBr ++ (x : inp))
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ inp))
-> (x : inp)
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
((x : inp) :-> inp)
-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ (x : inp))
:-> (RetOutStack' (ClassifyReturnValue retBr) retBr ++ inp)
forall ret (inp :: [*]) (xs :: [*]).
ScopeCodeGen ret =>
(xs :-> inp)
-> (RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp)
liftClear @retBr @inp @(x : inp) (x : inp) :-> inp
forall a (s :: [*]). (a & s) :-> s
L.drop
type CaseCommonF f dt ret clauses =
( InstrCaseC dt
, RMap (CaseClauses dt)
, clauses ~ Rec (f ret) (CaseClauses dt)
, ScopeCodeGen ret
)
type CaseCommon dt ret clauses = CaseCommonF IndigoCaseClauseL dt ret clauses
caseRec
:: forall dt inp ret clauses . CaseCommon dt ret clauses
=> Expr dt
-> clauses
-> RetVars ret
-> IndigoState inp (RetOutStack ret ++ inp)
caseRec :: Expr dt
-> clauses
-> RetVars ret
-> IndigoState inp (RetOutStack ret ++ inp)
caseRec g :: Expr dt
g cls :: clauses
cls vars :: RetVars ret
vars = (MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp))
-> (MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md ->
let cdG :: inp :-> (dt & inp)
cdG = GenCode inp (dt & inp) -> inp :-> (dt & inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (GenCode inp (dt & inp) -> inp :-> (dt & inp))
-> GenCode inp (dt & inp) -> inp :-> (dt & inp)
forall a b. (a -> b) -> a -> b
$ MetaData inp
-> IndigoState inp (dt & inp) -> GenCode inp (dt & inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md (Expr dt -> IndigoState inp (dt & inp)
forall a (inp :: [*]). Expr a -> IndigoState inp (a & inp)
compileExpr Expr dt
g) in
StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
forall ret (inp :: [*]).
ScopeCodeGen ret =>
StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
finalizeStatement @ret (MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md) RetVars ret
vars (inp :-> (dt & inp)
cdG (inp :-> (dt & inp))
-> ((dt & inp) :-> (RetOutStack ret ++ inp))
-> inp :-> (RetOutStack ret ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Rec (CaseClauseL inp (RetOutStack ret ++ inp)) (CaseClauses dt)
-> (dt & inp) :-> (RetOutStack ret ++ inp)
forall dt (out :: [*]) (inp :: [*]).
(InstrCaseC dt, RMap (CaseClauses dt)) =>
Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt & inp) :-> out
L.case_ (MetaData inp
-> Rec (IndigoCaseClauseL ret) (CaseClauses dt)
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) (CaseClauses dt)
forall (inp :: [*]) ret (cs :: [CaseClauseParam]).
MetaData inp
-> Rec (IndigoCaseClauseL ret) cs
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) cs
toCaseClauseL MetaData inp
md clauses
Rec (IndigoCaseClauseL ret) (CaseClauses dt)
cls))
entryCaseRec
:: forall dt entrypointKind inp ret clauses .
( CaseCommon dt ret clauses
, DocumentEntrypoints entrypointKind dt
)
=> Proxy entrypointKind
-> Expr dt
-> clauses
-> RetVars ret
-> IndigoState inp (RetOutStack ret ++ inp)
entryCaseRec :: Proxy entrypointKind
-> Expr dt
-> clauses
-> RetVars ret
-> IndigoState inp (RetOutStack ret ++ inp)
entryCaseRec proxy :: Proxy entrypointKind
proxy g :: Expr dt
g cls :: clauses
cls vars :: RetVars ret
vars = (MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp))
-> (MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md ->
let cdG :: inp :-> (dt & inp)
cdG = GenCode inp (dt & inp) -> inp :-> (dt & inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (GenCode inp (dt & inp) -> inp :-> (dt & inp))
-> GenCode inp (dt & inp) -> inp :-> (dt & inp)
forall a b. (a -> b) -> a -> b
$ MetaData inp
-> IndigoState inp (dt & inp) -> GenCode inp (dt & inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md (Expr dt -> IndigoState inp (dt & inp)
forall a (inp :: [*]). Expr a -> IndigoState inp (a & inp)
compileExpr Expr dt
g) in
StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
forall ret (inp :: [*]).
ScopeCodeGen ret =>
StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
finalizeStatement @ret (MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md) RetVars ret
vars(inp :-> (dt & inp)
cdG (inp :-> (dt & inp))
-> ((dt & inp) :-> (RetOutStack ret ++ inp))
-> inp :-> (RetOutStack ret ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Proxy entrypointKind
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) (CaseClauses dt)
-> (dt & inp) :-> (RetOutStack ret ++ inp)
forall dt entrypointKind (out :: [*]) (inp :: [*]).
(InstrCaseC dt, RMap (CaseClauses dt),
DocumentEntrypoints entrypointKind dt) =>
Proxy entrypointKind
-> Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt & inp) :-> out
L.entryCase_ Proxy entrypointKind
proxy (MetaData inp
-> Rec (IndigoCaseClauseL ret) (CaseClauses dt)
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) (CaseClauses dt)
forall (inp :: [*]) ret (cs :: [CaseClauseParam]).
MetaData inp
-> Rec (IndigoCaseClauseL ret) cs
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) cs
toCaseClauseL MetaData inp
md clauses
Rec (IndigoCaseClauseL ret) (CaseClauses dt)
cls))
entryCaseSimpleRec
:: forall dt inp ret clauses .
( CaseCommon dt ret clauses
, DocumentEntrypoints PlainEntrypointsKind dt
, NiceParameterFull dt
, RequireFlatParamEps dt
)
=> Expr dt
-> clauses
-> RetVars ret
-> IndigoState inp (RetOutStack ret ++ inp)
entryCaseSimpleRec :: Expr dt
-> clauses
-> RetVars ret
-> IndigoState inp (RetOutStack ret ++ inp)
entryCaseSimpleRec g :: Expr dt
g cls :: clauses
cls vars :: RetVars ret
vars = (MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp))
-> (MetaData inp -> GenCode inp (RetOutStack ret ++ inp))
-> IndigoState inp (RetOutStack ret ++ inp)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md ->
let cdG :: inp :-> (dt & inp)
cdG = GenCode inp (dt & inp) -> inp :-> (dt & inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (GenCode inp (dt & inp) -> inp :-> (dt & inp))
-> GenCode inp (dt & inp) -> inp :-> (dt & inp)
forall a b. (a -> b) -> a -> b
$ MetaData inp
-> IndigoState inp (dt & inp) -> GenCode inp (dt & inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md (Expr dt -> IndigoState inp (dt & inp)
forall a (inp :: [*]). Expr a -> IndigoState inp (a & inp)
compileExpr Expr dt
g) in
StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
forall ret (inp :: [*]).
ScopeCodeGen ret =>
StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
finalizeStatement @ret (MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md) RetVars ret
vars (inp :-> (dt & inp)
cdG (inp :-> (dt & inp))
-> ((dt & inp) :-> (RetOutStack ret ++ inp))
-> inp :-> (RetOutStack ret ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Rec (CaseClauseL inp (RetOutStack ret ++ inp)) (CaseClauses dt)
-> (dt & inp) :-> (RetOutStack ret ++ inp)
forall cp (out :: [*]) (inp :: [*]).
(InstrCaseC cp, RMap (CaseClauses cp),
DocumentEntrypoints PlainEntrypointsKind cp, NiceParameterFull cp,
RequireFlatParamEps cp) =>
Rec (CaseClauseL inp out) (CaseClauses cp) -> (cp & inp) :-> out
L.entryCaseSimple_ (MetaData inp
-> Rec (IndigoCaseClauseL ret) (CaseClauses dt)
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) (CaseClauses dt)
forall (inp :: [*]) ret (cs :: [CaseClauseParam]).
MetaData inp
-> Rec (IndigoCaseClauseL ret) cs
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) cs
toCaseClauseL MetaData inp
md clauses
Rec (IndigoCaseClauseL ret) (CaseClauses dt)
cls))
toCaseClauseL
:: forall inp ret cs .
MetaData inp
-> Rec (IndigoCaseClauseL ret) cs
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) cs
toCaseClauseL :: MetaData inp
-> Rec (IndigoCaseClauseL ret) cs
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) cs
toCaseClauseL _ RNil = Rec (CaseClauseL inp (RetOutStack ret ++ inp)) cs
forall u (a :: u -> *). Rec a '[]
RNil
toCaseClauseL md :: MetaData inp
md (OneFieldIndigoCaseClauseL fn :: forall (inp :: [*]).
MetaData inp
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x))
fn :& rest :: Rec (IndigoCaseClauseL ret) rs
rest) = MetaData inp
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x))
forall (inp :: [*]).
MetaData inp
-> CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x))
fn MetaData inp
md CaseClauseL
inp (RetOutStack ret ++ inp) ('CaseClauseParam ctor ('OneField x))
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) rs
-> Rec
(CaseClauseL inp (RetOutStack ret ++ inp))
('CaseClauseParam ctor ('OneField x) : rs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& MetaData inp
-> Rec (IndigoCaseClauseL ret) rs
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) rs
forall (inp :: [*]) ret (cs :: [CaseClauseParam]).
MetaData inp
-> Rec (IndigoCaseClauseL ret) cs
-> Rec (CaseClauseL inp (RetOutStack ret ++ inp)) cs
toCaseClauseL MetaData inp
md Rec (IndigoCaseClauseL ret) rs
rest