-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Decompose a complex value into its fields
-- to be used in 'setVar'.
-- Also functionality to generate code to deconstruct storage
-- into primitive fields the storage consists of
-- and to construct it back.
module Indigo.Backend.Expr.Decompose
  ( decomposeExpr
  , deepDecomposeCompose
  , ExprDecomposition (..)
  , IsObject
  ) where

import Prelude

import Data.Constraint (Dict(..))
import Data.Vinyl.TypeLevel hiding (type (++))

import Indigo.Backend.Expr.Compilation
import Indigo.Backend.Lookup
import Indigo.Common.Expr
import Indigo.Common.Object
import Indigo.Common.SIS
import Indigo.Common.State
import Indigo.Common.Var
import Indigo.Lorentz
import Lorentz.ADT qualified as L
import Lorentz.Instr qualified as L
import Morley.Michelson.Typed.Haskell.Instr.Product (GetFieldType)
import Morley.Util.Type

-----------------------------------------
-- Object decomposition
-----------------------------------------

-- | Alike 'SomeIndigoState' datatype but without objects argument
type SIS' stk a = RefId -> StackVars stk -> (a, RefId, SomeGenCode stk)

-- | For given element on stack, generate code which
-- decomposes it to list of its deep non-decomposable fields.
-- Clean up code of 'SomeIndigoState' composes the value back.
deepDecomposeCompose
  :: forall a inp . IsObject a
  => SIS' (a : inp) (Object a)
deepDecomposeCompose :: forall a (inp :: [*]). IsObject a => SIS' (a : inp) (Object a)
deepDecomposeCompose
  | Just Dict (ComplexObjectC a)
Dict <- forall a. IsObject a => Maybe (Dict (ComplexObjectC a))
complexObjectDict @a = \RefId
refId StackVars (a : inp)
st ->
      let decomposedSt :: StackVars (ConstructorFieldTypes a ++ inp)
decomposedSt = (StackVars (ConstructorFieldTypes a ++ inp),
 (ConstructorFieldTypes a ++ inp) :-> inp)
-> StackVars (ConstructorFieldTypes a ++ inp)
forall a b. (a, b) -> a
fst (forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @(FieldTypes a) (StackVars inp
 -> (StackVars (FieldTypes a ++ inp),
     (FieldTypes a ++ inp) :-> inp))
-> StackVars inp
-> (StackVars (FieldTypes a ++ inp), (FieldTypes a ++ inp) :-> inp)
forall a b. (a -> b) -> a -> b
$ StackVars (a : inp) -> StackVars inp
forall a (inp :: [*]). StackVars (a : inp) -> StackVars inp
popNoRef StackVars (a : inp)
st)
      in forall a (st :: [*]) r.
InstrDeconstructCGeneral a =>
(InstrDeconstructCClass a st => r) -> r
withInstrDeconstructC @a @inp ((InstrDeconstructCClass a inp =>
  (Object a, RefId, SomeGenCode (a : inp)))
 -> (Object a, RefId, SomeGenCode (a : inp)))
-> (InstrDeconstructCClass a inp =>
    (Object a, RefId, SomeGenCode (a : inp)))
-> (Object a, RefId, SomeGenCode (a : inp))
forall a b. (a -> b) -> a -> b
$
        RefId
-> StackVars (ConstructorFieldTypes a ++ inp)
-> SIS'
     (ConstructorFieldTypes a ++ inp)
     (Rec TypedFieldObj (ConstructorFieldTypes a))
-> (forall (out :: [*]).
    (Rec TypedFieldObj (ConstructorFieldTypes a), RefId,
     GenCode (ConstructorFieldTypes a ++ inp) out)
    -> (Object a, RefId, SomeGenCode (a : inp)))
-> (Object a, RefId, SomeGenCode (a : inp))
forall (inp :: [*]) a r.
RefId
-> StackVars inp
-> SIS' inp a
-> (forall (out :: [*]). (a, RefId, GenCode inp out) -> r)
-> r
withStack RefId
refId StackVars (ConstructorFieldTypes a ++ inp)
decomposedSt (forall (flds :: [*]).
(KnownList flds, AllConstrained IsObject flds) =>
SIS' (flds ++ inp) (Rec TypedFieldObj flds)
decomposeComposeFields @(FieldTypes a)) ((forall (out :: [*]).
  (Rec TypedFieldObj (ConstructorFieldTypes a), RefId,
   GenCode (ConstructorFieldTypes a ++ inp) out)
  -> (Object a, RefId, SomeGenCode (a : inp)))
 -> (Object a, RefId, SomeGenCode (a : inp)))
-> (forall (out :: [*]).
    (Rec TypedFieldObj (ConstructorFieldTypes a), RefId,
     GenCode (ConstructorFieldTypes a ++ inp) out)
    -> (Object a, RefId, SomeGenCode (a : inp)))
-> (Object a, RefId, SomeGenCode (a : inp))
forall a b. (a -> b) -> a -> b
$
          \(Rec TypedFieldObj (ConstructorFieldTypes a)
result, RefId
newRefId, GenCode (ConstructorFieldTypes a ++ inp) out
gc) ->
            ( Rec (NamedFieldObj a) (ConstructorFieldNames a) -> Object a
forall a (f :: Symbol -> *).
ComplexObjectC a =>
Rec f (ConstructorFieldNames a) -> IndigoObjectF f a
Decomposed (forall a (f :: * -> *) (g :: Symbol -> *).
KnownList (ConstructorFieldNames a) =>
(forall (name :: Symbol). f (GetFieldType a name) -> g name)
-> Rec f (FieldTypes a) -> Rec g (ConstructorFieldNames a)
typedToNamedRec @a forall a (name :: Symbol).
TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name
forall (name :: Symbol).
TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name
typedToNamedFieldObj Rec TypedFieldObj (ConstructorFieldTypes a)
Rec TypedFieldObj (FieldTypes a)
result)
            , RefId
newRefId
            , GenCode (a : inp) out -> SomeGenCode (a : inp)
forall (inp :: [*]) (out :: [*]).
GenCode inp out -> SomeGenCode inp
SomeGenCode (GenCode (a : inp) out -> SomeGenCode (a : inp))
-> GenCode (a : inp) out -> SomeGenCode (a : inp)
forall a b. (a -> b) -> a -> b
$ GenCode :: forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode
              { gcStack :: StackVars out
gcStack = GenCode (ConstructorFieldTypes a ++ inp) out -> StackVars out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> StackVars out
gcStack GenCode (ConstructorFieldTypes a ++ inp) out
gc
              , gcCode :: (a : inp) :-> out
gcCode = forall dt (fields :: [*]) (st :: [*]).
(InstrDeconstructC dt (ToTs st), fields ~ GFieldTypes (Rep dt) '[],
 (ToTs fields ++ ToTs st) ~ ToTs (fields ++ st)) =>
(dt : st) :-> (fields ++ st)
L.deconstruct @a @(FieldTypes a) ((a : inp) :-> (ConstructorFieldTypes a ++ inp))
-> ((ConstructorFieldTypes a ++ inp) :-> out) -> (a : inp) :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# GenCode (ConstructorFieldTypes a ++ inp) out
-> (ConstructorFieldTypes a ++ inp) :-> out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode GenCode (ConstructorFieldTypes a ++ inp) out
gc
              , gcClear :: out :-> (a : inp)
gcClear = GenCode (ConstructorFieldTypes a ++ inp) out
-> out :-> (ConstructorFieldTypes a ++ inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> out :-> inp
gcClear GenCode (ConstructorFieldTypes a ++ inp) out
gc (out :-> (ConstructorFieldTypes a ++ inp))
-> ((ConstructorFieldTypes a ++ inp) :-> (a : inp))
-> out :-> (a : inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall dt (fields :: [*]) (st :: [*]).
(InstrConstructC dt, fields ~ ConstructorFieldTypes dt,
 (ToTs fields ++ ToTs st) ~ ToTs (fields ++ st)) =>
(fields ++ st) :-> (dt : st)
L.constructStack @a  @(FieldTypes a)
              }
            )
  | Bool
otherwise =
      \RefId
refId StackVars (a : inp)
stk -> (RefId -> Object a
forall a (f :: Symbol -> *).
KnownValue a =>
RefId -> IndigoObjectF f a
Cell RefId
refId, RefId
refId RefId -> RefId -> RefId
forall a. Num a => a -> a -> a
+ RefId
1, GenCode (a : inp) (a : inp) -> SomeGenCode (a : inp)
forall (inp :: [*]) (out :: [*]).
GenCode inp out -> SomeGenCode inp
SomeGenCode (GenCode (a : inp) (a : inp) -> SomeGenCode (a : inp))
-> GenCode (a : inp) (a : inp) -> SomeGenCode (a : inp)
forall a b. (a -> b) -> a -> b
$
                      MetaData (a : inp)
-> IndigoState (a : inp) (a : inp) -> GenCode (a : inp) (a : inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState (StackVars (a : inp)
-> DecomposedObjects -> GenCodeHooks -> MetaData (a : inp)
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> GenCodeHooks -> MetaData inp
MetaData StackVars (a : inp)
stk DecomposedObjects
forall a. Monoid a => a
mempty GenCodeHooks
emptyGenCodeHooks) (Var a -> IndigoState (a : inp) (a : inp)
forall x (inp :: [*]).
KnownValue x =>
Var x -> IndigoState (x : inp) (x : inp)
assignTopVar (Var a -> IndigoState (a : inp) (a : inp))
-> Var a -> IndigoState (a : inp) (a : inp)
forall a b. (a -> b) -> a -> b
$ RefId -> Var a
forall {k} (a :: k). RefId -> Var a
Var RefId
refId) )
  where
    decomposeComposeFields
      :: forall flds . (KnownList flds, AllConstrained IsObject flds)
      => SIS' (flds ++ inp) (Rec TypedFieldObj flds)
    decomposeComposeFields :: forall (flds :: [*]).
(KnownList flds, AllConstrained IsObject flds) =>
SIS' (flds ++ inp) (Rec TypedFieldObj flds)
decomposeComposeFields = case forall (l :: [*]). KnownList l => KList l
forall {k} (l :: [k]). KnownList l => KList l
klist @flds of
      KList flds
KNil -> \RefId
refId StackVars (flds ++ inp)
stk -> (Rec TypedFieldObj flds
forall {u} (a :: u -> *). Rec a '[]
RNil, RefId
refId, GenCode inp inp -> SomeGenCode inp
forall (inp :: [*]) (out :: [*]).
GenCode inp out -> SomeGenCode inp
SomeGenCode (GenCode inp inp -> SomeGenCode inp)
-> GenCode inp inp -> SomeGenCode inp
forall a b. (a -> b) -> a -> b
$ StackVars inp -> (inp :-> inp) -> (inp :-> inp) -> GenCode inp inp
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars inp
StackVars (flds ++ inp)
stk inp :-> inp
forall (s :: [*]). s :-> s
L.nop inp :-> inp
forall (s :: [*]). s :-> s
L.nop)
      KCons (Proxy x
_ :: Proxy r) (Proxy xs
_ :: Proxy rest) -> \RefId
refId StackVars (flds ++ inp)
st ->
        RefId
-> StackVars (xs ++ inp)
-> SIS' (xs ++ inp) (Rec TypedFieldObj xs)
-> (forall (out :: [*]).
    (Rec TypedFieldObj xs, RefId, GenCode (xs ++ inp) out)
    -> (Rec TypedFieldObj (x : xs), RefId,
        SomeGenCode (x : (xs ++ inp))))
-> (Rec TypedFieldObj (x : xs), RefId,
    SomeGenCode (x : (xs ++ inp)))
forall (inp :: [*]) a r.
RefId
-> StackVars inp
-> SIS' inp a
-> (forall (out :: [*]). (a, RefId, GenCode inp out) -> r)
-> r
withStack RefId
refId (StackVars (x : (xs ++ inp)) -> StackVars (xs ++ inp)
forall a (inp :: [*]). StackVars (a : inp) -> StackVars inp
popNoRef StackVars (x : (xs ++ inp))
StackVars (flds ++ inp)
st) (forall (flds :: [*]).
(KnownList flds, AllConstrained IsObject flds) =>
SIS' (flds ++ inp) (Rec TypedFieldObj flds)
decomposeComposeFields @rest) ((forall (out :: [*]).
  (Rec TypedFieldObj xs, RefId, GenCode (xs ++ inp) out)
  -> (Rec TypedFieldObj (x : xs), RefId,
      SomeGenCode (x : (xs ++ inp))))
 -> (Rec TypedFieldObj (x : xs), RefId,
     SomeGenCode (x : (xs ++ inp))))
-> (forall (out :: [*]).
    (Rec TypedFieldObj xs, RefId, GenCode (xs ++ inp) out)
    -> (Rec TypedFieldObj (x : xs), RefId,
        SomeGenCode (x : (xs ++ inp))))
-> (Rec TypedFieldObj (x : xs), RefId,
    SomeGenCode (x : (xs ++ inp)))
forall a b. (a -> b) -> a -> b
$ \(Rec TypedFieldObj xs
resultRest, RefId
refId', GenCode (xs ++ inp) out
restGc) ->
          RefId
-> StackVars (x : out)
-> SIS' (x : out) (Object x)
-> (forall (out :: [*]).
    (Object x, RefId, GenCode (x : out) out)
    -> (Rec TypedFieldObj (x : xs), RefId,
        SomeGenCode (x : (xs ++ inp))))
-> (Rec TypedFieldObj (x : xs), RefId,
    SomeGenCode (x : (xs ++ inp)))
forall (inp :: [*]) a r.
RefId
-> StackVars inp
-> SIS' inp a
-> (forall (out :: [*]). (a, RefId, GenCode inp out) -> r)
-> r
withStack RefId
refId' (StackVars out -> StackVars (x : out)
forall a (inp :: [*]).
KnownValue a =>
StackVars inp -> StackVars (a : inp)
pushNoRef (StackVars out -> StackVars (x : out))
-> StackVars out -> StackVars (x : out)
forall a b. (a -> b) -> a -> b
$ GenCode (xs ++ inp) out -> StackVars out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> StackVars out
gcStack GenCode (xs ++ inp) out
restGc) (forall a (inp :: [*]). IsObject a => SIS' (a : inp) (Object a)
deepDecomposeCompose @r) ((forall (out :: [*]).
  (Object x, RefId, GenCode (x : out) out)
  -> (Rec TypedFieldObj (x : xs), RefId,
      SomeGenCode (x : (xs ++ inp))))
 -> (Rec TypedFieldObj (x : xs), RefId,
     SomeGenCode (x : (xs ++ inp))))
-> (forall (out :: [*]).
    (Object x, RefId, GenCode (x : out) out)
    -> (Rec TypedFieldObj (x : xs), RefId,
        SomeGenCode (x : (xs ++ inp))))
-> (Rec TypedFieldObj (x : xs), RefId,
    SomeGenCode (x : (xs ++ inp)))
forall a b. (a -> b) -> a -> b
$ \(Object x
resultCur, RefId
newRefId, GenCode (x : out) out
curGc) ->
            ( Object x -> TypedFieldObj x
forall a. IsObject a => Object a -> TypedFieldObj a
TypedFieldObj Object x
resultCur TypedFieldObj x
-> Rec TypedFieldObj xs -> Rec TypedFieldObj (x : xs)
forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec TypedFieldObj xs
resultRest
            , RefId
newRefId
            , GenCode (x : (xs ++ inp)) out -> SomeGenCode (x : (xs ++ inp))
forall (inp :: [*]) (out :: [*]).
GenCode inp out -> SomeGenCode inp
SomeGenCode (GenCode (x : (xs ++ inp)) out -> SomeGenCode (x : (xs ++ inp)))
-> GenCode (x : (xs ++ inp)) out -> SomeGenCode (x : (xs ++ inp))
forall a b. (a -> b) -> a -> b
$ GenCode :: forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode
              { gcStack :: StackVars out
gcStack = GenCode (x : out) out -> StackVars out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> StackVars out
gcStack GenCode (x : out) out
curGc
              , gcCode :: (x : (xs ++ inp)) :-> out
gcCode = ((xs ++ inp) :-> out) -> (x : (xs ++ inp)) :-> (x : out)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (GenCode (xs ++ inp) out -> (xs ++ inp) :-> out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode GenCode (xs ++ inp) out
restGc) ((x : (xs ++ inp)) :-> (x : out))
-> ((x : out) :-> out) -> (x : (xs ++ inp)) :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# GenCode (x : out) out -> (x : out) :-> out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode GenCode (x : out) out
curGc
              , gcClear :: out :-> (x : (xs ++ inp))
gcClear = GenCode (x : out) out -> out :-> (x : out)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> out :-> inp
gcClear GenCode (x : out) out
curGc (out :-> (x : out))
-> ((x : out) :-> (x : (xs ++ inp))) -> out :-> (x : (xs ++ inp))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (out :-> (xs ++ inp)) -> (x : out) :-> (x : (xs ++ inp))
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (GenCode (xs ++ inp) out -> out :-> (xs ++ inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> out :-> inp
gcClear GenCode (xs ++ inp) out
restGc)
              }
            )

withStack
  :: RefId
  -> StackVars inp
  -> SIS' inp a
  -> (forall out . (a, RefId, GenCode inp out) -> r)
  -> r
withStack :: forall (inp :: [*]) a r.
RefId
-> StackVars inp
-> SIS' inp a
-> (forall (out :: [*]). (a, RefId, GenCode inp out) -> r)
-> r
withStack RefId
refId StackVars inp
stk SIS' inp a
sis forall (out :: [*]). (a, RefId, GenCode inp out) -> r
f = case SIS' inp a
sis RefId
refId StackVars inp
stk of
  (a
res, RefId
newRefId, SomeGenCode GenCode inp out
genCode) -> (a, RefId, GenCode inp out) -> r
forall (out :: [*]). (a, RefId, GenCode inp out) -> r
f (a
res, RefId
newRefId, GenCode inp out
genCode)

-----------------------------------------
-- Expr decomposition
-----------------------------------------

-- | Datatype representing decomposition of 'Expr'.
data ExprDecomposition inp a where
  ExprFields :: Rec Expr (FieldTypes a) -> ExprDecomposition inp a
  Deconstructed :: IndigoState inp (FieldTypes a ++ inp) -> ExprDecomposition inp a

-- | Decompose (shallowly) an expression to list of its direct fields.
decomposeExpr :: ComplexObjectC a => DecomposedObjects -> Expr a -> ExprDecomposition inp a
decomposeExpr :: forall a (inp :: [*]).
ComplexObjectC a =>
DecomposedObjects -> Expr a -> ExprDecomposition inp a
decomposeExpr DecomposedObjects
_ (ConstructWithoutNamed Proxy a
_ Rec Expr (FieldTypes a)
fields) = Rec Expr (FieldTypes a) -> ExprDecomposition inp a
forall a (inp :: [*]).
Rec Expr (FieldTypes a) -> ExprDecomposition inp a
ExprFields Rec Expr (FieldTypes a)
fields
decomposeExpr DecomposedObjects
objs (V Var a
v) = DecomposedObjects
-> Var a
-> (Object a -> ExprDecomposition inp a)
-> ExprDecomposition inp a
forall a r.
KnownValue a =>
DecomposedObjects -> Var a -> (Object a -> r) -> r
withObject DecomposedObjects
objs Var a
v ((Object a -> ExprDecomposition inp a) -> ExprDecomposition inp a)
-> (Object a -> ExprDecomposition inp a) -> ExprDecomposition inp a
forall a b. (a -> b) -> a -> b
$ (forall (name :: Symbol).
 NamedFieldObj a name -> Expr (GetFieldType a name))
-> Object a -> ExprDecomposition inp a
forall a (inp :: [*]) (f :: Symbol -> *).
ComplexObjectC a =>
(forall (name :: Symbol). f name -> Expr (GetFieldType a name))
-> IndigoObjectF f a -> ExprDecomposition inp a
decomposeObjectF forall x (name :: Symbol).
NamedFieldObj x name -> Expr (GetFieldType x name)
forall (name :: Symbol).
NamedFieldObj a name -> Expr (GetFieldType a name)
namedToExpr
decomposeExpr DecomposedObjects
objs (ObjMan ObjectManipulation a
objMan) = case DecomposedObjects
-> ObjectManipulation a -> ObjManipulationRes inp a
forall x (inp :: [*]).
DecomposedObjects
-> ObjectManipulation x -> ObjManipulationRes inp x
runObjectManipulation DecomposedObjects
objs ObjectManipulation a
objMan of
  StillObject ObjectExpr a
obj -> (forall (name :: Symbol).
 NamedFieldExpr a name -> Expr (GetFieldType a name))
-> ObjectExpr a -> ExprDecomposition inp a
forall a (inp :: [*]) (f :: Symbol -> *).
ComplexObjectC a =>
(forall (name :: Symbol). f name -> Expr (GetFieldType a name))
-> IndigoObjectF f a -> ExprDecomposition inp a
decomposeObjectF forall a (name :: Symbol).
NamedFieldExpr a name -> Expr (GetFieldType a name)
forall (name :: Symbol).
NamedFieldExpr a name -> Expr (GetFieldType a name)
unNamedFieldExpr ObjectExpr a
obj
  OnStack IndigoState inp (a : inp)
comp -> IndigoState inp (a : inp) -> ExprDecomposition inp a
forall a (inp :: [*]).
ComplexObjectC a =>
IndigoState inp (a : inp) -> ExprDecomposition inp a
deconstructOnStack IndigoState inp (a : inp)
comp
decomposeExpr DecomposedObjects
_ Expr a
ex = IndigoState inp (a : inp) -> ExprDecomposition inp a
forall a (inp :: [*]).
ComplexObjectC a =>
IndigoState inp (a : inp) -> ExprDecomposition inp a
deconstructOnStack (IndigoState inp (a : inp) -> ExprDecomposition inp a)
-> IndigoState inp (a : inp) -> ExprDecomposition inp a
forall a b. (a -> b) -> a -> b
$ Expr a -> IndigoState inp (a : inp)
forall a (inp :: [*]). Expr a -> IndigoState inp (a : inp)
compileExpr Expr a
ex

-- | Decompose any 'IndigoObjectF' with regards to decomposer for field.
decomposeObjectF
  :: forall a inp f . ComplexObjectC a
  => (forall name . f name -> Expr (GetFieldType a name))
  -> IndigoObjectF f a
  -> ExprDecomposition inp a
decomposeObjectF :: forall a (inp :: [*]) (f :: Symbol -> *).
ComplexObjectC a =>
(forall (name :: Symbol). f name -> Expr (GetFieldType a name))
-> IndigoObjectF f a -> ExprDecomposition inp a
decomposeObjectF forall (name :: Symbol). f name -> Expr (GetFieldType a name)
_ (Cell RefId
refId) =
  IndigoState inp (a : inp) -> ExprDecomposition inp a
forall a (inp :: [*]).
ComplexObjectC a =>
IndigoState inp (a : inp) -> ExprDecomposition inp a
deconstructOnStack (IndigoState inp (a : inp) -> ExprDecomposition inp a)
-> IndigoState inp (a : inp) -> ExprDecomposition inp a
forall a b. (a -> b) -> a -> b
$
    (MetaData inp -> GenCode inp (a : inp))
-> IndigoState inp (a : inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (a : inp))
 -> IndigoState inp (a : inp))
-> (MetaData inp -> GenCode inp (a : inp))
-> IndigoState inp (a : inp)
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md -> StackVars (a : inp)
-> (inp :-> (a : inp))
-> ((a : inp) :-> inp)
-> GenCode inp (a : inp)
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode (StackVars inp -> StackVars (a : inp)
forall a (inp :: [*]).
KnownValue a =>
StackVars inp -> StackVars (a : inp)
pushNoRef (StackVars inp -> StackVars (a : inp))
-> StackVars inp -> StackVars (a : inp)
forall a b. (a -> b) -> a -> b
$ MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md) (forall a (stk :: [*]).
KnownValue a =>
RefId -> StackVars stk -> stk :-> (a : stk)
varActionGet @a RefId
refId (StackVars inp -> inp :-> (a : inp))
-> StackVars inp -> inp :-> (a : inp)
forall a b. (a -> b) -> a -> b
$ MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md) (a : inp) :-> inp
forall a (s :: [*]). (a : s) :-> s
L.drop
decomposeObjectF forall (name :: Symbol). f name -> Expr (GetFieldType a name)
unF (Decomposed Rec f (GFieldNames (Rep a))
fields) =
  Rec Expr (FieldTypes a) -> ExprDecomposition inp a
forall a (inp :: [*]).
Rec Expr (FieldTypes a) -> ExprDecomposition inp a
ExprFields (Rec Expr (FieldTypes a) -> ExprDecomposition inp a)
-> Rec Expr (FieldTypes a) -> ExprDecomposition inp a
forall a b. (a -> b) -> a -> b
$ forall a (f :: Symbol -> *) (g :: * -> *).
(forall (name :: Symbol). f name -> g (GetFieldType a name))
-> Rec f (ConstructorFieldNames a) -> Rec g (FieldTypes a)
namedToTypedRec @a forall (name :: Symbol). f name -> Expr (GetFieldType a name)
unF Rec f (GFieldNames (Rep a))
fields

-- | Deconstruct top element of the stack and return it
-- wrapped into 'Deconstructed' constructor.
deconstructOnStack
  :: forall a inp . ComplexObjectC a
  => IndigoState inp (a : inp)
  -> ExprDecomposition inp a
deconstructOnStack :: forall a (inp :: [*]).
ComplexObjectC a =>
IndigoState inp (a : inp) -> ExprDecomposition inp a
deconstructOnStack IndigoState inp (a : inp)
fetchFld =
  IndigoState inp (FieldTypes a ++ inp) -> ExprDecomposition inp a
forall (inp :: [*]) a.
IndigoState inp (FieldTypes a ++ inp) -> ExprDecomposition inp a
Deconstructed (IndigoState inp (FieldTypes a ++ inp) -> ExprDecomposition inp a)
-> IndigoState inp (FieldTypes a ++ inp) -> ExprDecomposition inp a
forall a b. (a -> b) -> a -> b
$ (MetaData inp -> GenCode inp (ConstructorFieldTypes a ++ inp))
-> IndigoState inp (ConstructorFieldTypes a ++ inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (ConstructorFieldTypes a ++ inp))
 -> IndigoState inp (ConstructorFieldTypes a ++ inp))
-> (MetaData inp -> GenCode inp (ConstructorFieldTypes a ++ inp))
-> IndigoState inp (ConstructorFieldTypes a ++ inp)
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md ->
    let (StackVars (ConstructorFieldTypes a ++ inp)
newSt, (ConstructorFieldTypes a ++ inp) :-> inp
clean) = forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @(FieldTypes a) (MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md) in
    forall a (st :: [*]) r.
InstrDeconstructCGeneral a =>
(InstrDeconstructCClass a st => r) -> r
withInstrDeconstructC @a @inp ((InstrDeconstructCClass a inp =>
  GenCode inp (ConstructorFieldTypes a ++ inp))
 -> GenCode inp (ConstructorFieldTypes a ++ inp))
-> (InstrDeconstructCClass a inp =>
    GenCode inp (ConstructorFieldTypes a ++ inp))
-> GenCode inp (ConstructorFieldTypes a ++ inp)
forall a b. (a -> b) -> a -> b
$
      StackVars (ConstructorFieldTypes a ++ inp)
-> (inp :-> (ConstructorFieldTypes a ++ inp))
-> ((ConstructorFieldTypes a ++ inp) :-> inp)
-> GenCode inp (ConstructorFieldTypes a ++ inp)
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars (ConstructorFieldTypes a ++ inp)
newSt (GenCode inp (a : inp) -> inp :-> (a : inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (IndigoState inp (a : inp) -> MetaData inp -> GenCode inp (a : inp)
forall (inp :: [*]) (out :: [*]).
IndigoState inp out -> MetaData inp -> GenCode inp out
runIndigoState IndigoState inp (a : inp)
fetchFld MetaData inp
md) (inp :-> (a : inp))
-> ((a : inp) :-> (ConstructorFieldTypes a ++ inp))
-> inp :-> (ConstructorFieldTypes a ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall dt (fields :: [*]) (st :: [*]).
(InstrDeconstructC dt (ToTs st), fields ~ GFieldTypes (Rep dt) '[],
 (ToTs fields ++ ToTs st) ~ ToTs (fields ++ st)) =>
(dt : st) :-> (fields ++ st)
L.deconstruct @a @(FieldTypes a)) (ConstructorFieldTypes a ++ inp) :-> inp
clean

-----------------------------------------
-- Helpers
-----------------------------------------

-- | Push the passed stack cells without references to them.
noRefGenCode
  :: forall rs inp . (KnownList rs, AllConstrained KnownValue rs)
  => StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode :: forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode StackVars inp
md = case forall (l :: [*]). KnownList l => KList l
forall {k} (l :: [k]). KnownList l => KList l
klist @rs of
  KList rs
KNil -> (StackVars inp
StackVars (rs ++ inp)
md, (rs ++ inp) :-> inp
forall (s :: [*]). s :-> s
L.nop)
  KCons Proxy x
Proxy (Proxy xs
_ :: Proxy rest) -> (StackVars (xs ++ inp) -> StackVars (x : (xs ++ inp)))
-> (((xs ++ inp) :-> inp) -> (x : (xs ++ inp)) :-> inp)
-> (StackVars (xs ++ inp), (xs ++ inp) :-> inp)
-> (StackVars (x : (xs ++ inp)), (x : (xs ++ inp)) :-> inp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap StackVars (xs ++ inp) -> StackVars (x : (xs ++ inp))
forall a (inp :: [*]).
KnownValue a =>
StackVars inp -> StackVars (a : inp)
pushNoRef ((x : (xs ++ inp)) :-> (xs ++ inp)
forall a (s :: [*]). (a : s) :-> s
L.drop ((x : (xs ++ inp)) :-> (xs ++ inp))
-> ((xs ++ inp) :-> inp) -> (x : (xs ++ inp)) :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#) (forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @rest StackVars inp
md)