-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | 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.Internal.Expr.Decompose
  ( decomposeExpr
  , deepDecomposeCompose
  , ExprDecomposition (..)
  , IsObject
  ) where

import Data.Constraint (Dict(..))
import Data.Vinyl.TypeLevel
import Prelude (fst)

import Indigo.Internal.Expr.Compilation
import Indigo.Internal.Expr.Types
import Indigo.Internal.Lookup
import Indigo.Internal.Object
import Indigo.Internal.SIS
import Indigo.Internal.State
import Indigo.Lorentz
import Indigo.Prelude
import qualified Lorentz.ADT as L
import qualified Lorentz.Instr as L
import Michelson.Typed.Haskell.Instr.Product (GetFieldType)
import Util.Type

-- | 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 an expression to list of its direct fields.
decomposeExpr :: ComplexObjectC a => Expr a -> ExprDecomposition inp a
decomposeExpr :: Expr a -> ExprDecomposition inp a
decomposeExpr (ConstructWithoutNamed fields :: 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 (V v :: Var a
v) = (forall (name :: Symbol).
 NamedFieldVar a name -> Expr (GetFieldType a name))
-> Var 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 (\(NamedFieldVar vr) -> Var
  (LnrFieldType (LNRequireFound name a (GLookupNamed name (Rep a))))
-> Expr
     (LnrFieldType (LNRequireFound name a (GLookupNamed name (Rep a))))
forall a. KnownValue a => Var a -> Expr a
V Var
  (LnrFieldType (LNRequireFound name a (GLookupNamed name (Rep a))))
vr) Var a
v
decomposeExpr (ObjMan objMan :: ObjectManipulation a
objMan) = case ObjectManipulation a -> ObjManipulationRes inp a
forall x (inp :: [*]).
ObjectManipulation x -> ObjManipulationRes inp x
runObjectManipulation ObjectManipulation a
objMan of
  StillObject obj :: 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 comp :: 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 ex :: 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

-- | 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
  => SomeIndigoState (a & inp) (Var a)
deepDecomposeCompose :: SomeIndigoState (a & inp) (Var a)
deepDecomposeCompose
  | Just Dict <- IsObject a => Maybe (Dict (ComplexObjectC a))
forall a. IsObject a => Maybe (Dict (ComplexObjectC a))
complexObjectDict @a = (MetaData (a & inp) -> SomeGenCode (a & inp) (Var a))
-> SomeIndigoState (a & inp) (Var a)
forall (inp :: [*]) a.
(MetaData inp -> SomeGenCode inp a) -> SomeIndigoState inp a
SomeIndigoState ((MetaData (a & inp) -> SomeGenCode (a & inp) (Var a))
 -> SomeIndigoState (a & inp) (Var a))
-> (MetaData (a & inp) -> SomeGenCode (a & inp) (Var a))
-> SomeIndigoState (a & inp) (Var a)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData (a & inp)
md ->
      let decomposedMd :: MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp)
decomposedMd = (MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp),
 (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> inp)
-> MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp)
forall a b. (a, b) -> a
fst (forall (inp :: [*]).
(KnownList (MapGFT a (GFieldNames (Rep a))),
 AllConstrained KnownValue (MapGFT a (GFieldNames (Rep a)))) =>
MetaData inp
-> (MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp),
    (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> inp)
forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
MetaData inp -> (MetaData (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @(FieldTypes a) (MetaData inp
 -> (MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp),
     (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> inp))
-> MetaData inp
-> (MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp),
    (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> inp)
forall a b. (a -> b) -> a -> b
$ MetaData (a & inp) -> MetaData inp
forall a (inp :: [*]). MetaData (a & inp) -> MetaData inp
popNoRefMd MetaData (a & inp)
md) in
      SomeIndigoState
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
-> MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp)
-> (forall (out :: [*]).
    GenCode
      (MapGFT a (GFieldNames (Rep a)) ++ inp)
      out
      (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
    -> SomeGenCode (a & inp) (Var a))
-> SomeGenCode (a & inp) (Var a)
forall (inp :: [*]) a r.
SomeIndigoState inp a
-> MetaData inp
-> (forall (out :: [*]). GenCode inp out a -> r)
-> r
runSIS ((KnownList (MapGFT a (GFieldNames (Rep a))),
 AllConstrained IsObject (MapGFT a (GFieldNames (Rep a)))) =>
SomeIndigoState
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
forall (flds :: [*]).
(KnownList flds, AllConstrained IsObject flds) =>
SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds)
decomposeComposeFields @(FieldTypes a)) MetaData (MapGFT a (GFieldNames (Rep a)) ++ inp)
decomposedMd ((forall (out :: [*]).
  GenCode
    (MapGFT a (GFieldNames (Rep a)) ++ inp)
    out
    (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
  -> SomeGenCode (a & inp) (Var a))
 -> SomeGenCode (a & inp) (Var a))
-> (forall (out :: [*]).
    GenCode
      (MapGFT a (GFieldNames (Rep a)) ++ inp)
      out
      (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
    -> SomeGenCode (a & inp) (Var a))
-> SomeGenCode (a & inp) (Var a)
forall a b. (a -> b) -> a -> b
$ \gc :: GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
gc ->
        GenCode (a & inp) out (Var a) -> SomeGenCode (a & inp) (Var a)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> SomeGenCode inp a
SomeGenCode (GenCode (a & inp) out (Var a) -> SomeGenCode (a & inp) (Var a))
-> GenCode (a & inp) out (Var a) -> SomeGenCode (a & inp) (Var a)
forall a b. (a -> b) -> a -> b
$ $WGenCode :: forall (inp :: [*]) (out :: [*]) a.
a
-> MetaData out
-> (inp :-> out)
-> (out :-> inp)
-> GenCode inp out a
GenCode
          { gcOut :: Var a
gcOut = Rec (NamedFieldVar a) (GFieldNames (Rep a)) -> Var a
forall a (f :: Symbol -> *).
ComplexObjectC a =>
Rec f (ConstructorFieldNames a) -> IndigoObjectF f a
Decomposed ((forall (name :: Symbol).
 TypedFieldVar (GetFieldType a name) -> NamedFieldVar a name)
-> Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a)))
-> Rec (NamedFieldVar a) (GFieldNames (Rep a))
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).
TypedFieldVar (GetFieldType a name) -> NamedFieldVar a name
forall (name :: Symbol).
TypedFieldVar (GetFieldType a name) -> NamedFieldVar a name
typedToNamedFieldVar (GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
-> Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a)))
forall (inp :: [*]) (out :: [*]) a. GenCode inp out a -> a
gcOut GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
gc))
          , gcMeta :: MetaData out
gcMeta = GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
-> MetaData out
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> MetaData out
gcMeta GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
gc
          , gcCode :: (a & inp) :-> out
gcCode = forall (st :: [*]).
(InstrDeconstructC a, KnownList (MapGFT a (GFieldNames (Rep a))),
 ToTs (MapGFT a (GFieldNames (Rep a)))
 ~ ToTs (ConstructorFieldTypes a)) =>
(a & st) :-> (MapGFT a (GFieldNames (Rep a)) ++ st)
forall dt (fields :: [*]) (st :: [*]).
(InstrDeconstructC dt, KnownList fields,
 ToTs fields ~ ToTs (ConstructorFieldTypes dt)) =>
(dt & st) :-> (fields ++ st)
L.deconstruct @a @(FieldTypes a) ((a & inp) :-> (MapGFT a (GFieldNames (Rep a)) ++ inp))
-> ((MapGFT a (GFieldNames (Rep a)) ++ inp) :-> out)
-> (a & inp) :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
-> (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> out
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> inp :-> out
gcCode GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
gc
          , gcClear :: out :-> (a & inp)
gcClear = GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
-> out :-> (MapGFT a (GFieldNames (Rep a)) ++ inp)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> out :-> inp
gcClear GenCode
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  out
  (Rec TypedFieldVar (MapGFT a (GFieldNames (Rep a))))
gc (out :-> (MapGFT a (GFieldNames (Rep a)) ++ inp))
-> ((MapGFT a (GFieldNames (Rep a)) ++ inp) :-> (a & inp))
-> out :-> (a & inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall (st :: [*]).
(InstrConstructC a,
 ToTs (MapGFT a (GFieldNames (Rep a)))
 ~ ToTs (ConstructorFieldTypes a),
 KnownList (MapGFT a (GFieldNames (Rep a)))) =>
(MapGFT a (GFieldNames (Rep a)) ++ st) :-> (a & st)
forall dt (fields :: [*]) (st :: [*]).
(InstrConstructC dt, ToTs fields ~ ToTs (ConstructorFieldTypes dt),
 KnownList fields) =>
(fields ++ st) :-> (dt & st)
L.constructStack @a  @(FieldTypes a)
          }
  | Bool
otherwise = (MetaData (a & inp) -> SomeGenCode (a & inp) (Var a))
-> SomeIndigoState (a & inp) (Var a)
forall (inp :: [*]) a.
(MetaData inp -> SomeGenCode inp a) -> SomeIndigoState inp a
SomeIndigoState ((MetaData (a & inp) -> SomeGenCode (a & inp) (Var a))
 -> SomeIndigoState (a & inp) (Var a))
-> (MetaData (a & inp) -> SomeGenCode (a & inp) (Var a))
-> SomeIndigoState (a & inp) (Var a)
forall a b. (a -> b) -> a -> b
$ GenCode (a & inp) (a & inp) (Var a)
-> SomeGenCode (a & inp) (Var a)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> SomeGenCode inp a
SomeGenCode (GenCode (a & inp) (a & inp) (Var a)
 -> SomeGenCode (a & inp) (Var a))
-> (MetaData (a & inp) -> GenCode (a & inp) (a & inp) (Var a))
-> MetaData (a & inp)
-> SomeGenCode (a & inp) (Var a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndigoState (a & inp) (a & inp) (Var a)
-> MetaData (a & inp) -> GenCode (a & inp) (a & inp) (Var a)
forall (inp :: [*]) (out :: [*]) a.
IndigoState inp out a -> MetaData inp -> GenCode inp out a
runIndigoState IndigoState (a & inp) (a & inp) (Var a)
forall x (inp :: [*]).
KnownValue x =>
IndigoState (x & inp) (x & inp) (Var x)
makeTopVar
  where
    decomposeComposeFields
      :: forall flds . (KnownList flds, AllConstrained IsObject flds)
      => SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds)
    decomposeComposeFields :: SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds)
decomposeComposeFields = case KnownList flds => KList flds
forall k (l :: [k]). KnownList l => KList l
klist @flds of
      KNil -> Rec TypedFieldVar '[]
-> SomeIndigoState inp (Rec TypedFieldVar '[])
forall a (inp :: [*]). a -> SomeIndigoState inp a
returnSIS Rec TypedFieldVar '[]
forall u (a :: u -> *). Rec a '[]
RNil
      KCons (Proxy x
_ :: Proxy r) (Proxy xs
_ :: Proxy rest) -> (MetaData (x & (xs ++ inp))
 -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds)
forall (inp :: [*]) a.
(MetaData inp -> SomeGenCode inp a) -> SomeIndigoState inp a
SomeIndigoState ((MetaData (x & (xs ++ inp))
  -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
 -> SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds))
-> (MetaData (x & (xs ++ inp))
    -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData (x & (xs ++ inp))
md ->
        SomeIndigoState (xs ++ inp) (Rec TypedFieldVar xs)
-> MetaData (xs ++ inp)
-> (forall (out :: [*]).
    GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
    -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds)
forall (inp :: [*]) a r.
SomeIndigoState inp a
-> MetaData inp
-> (forall (out :: [*]). GenCode inp out a -> r)
-> r
runSIS ((KnownList xs, AllConstrained IsObject xs) =>
SomeIndigoState (xs ++ inp) (Rec TypedFieldVar xs)
forall (flds :: [*]).
(KnownList flds, AllConstrained IsObject flds) =>
SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds)
decomposeComposeFields @rest) (MetaData (x & (xs ++ inp)) -> MetaData (xs ++ inp)
forall a (inp :: [*]). MetaData (a & inp) -> MetaData inp
popNoRefMd MetaData (x & (xs ++ inp))
md) ((forall (out :: [*]).
  GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
  -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
 -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> (forall (out :: [*]).
    GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
    -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds)
forall a b. (a -> b) -> a -> b
$ \restGc :: GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
restGc ->
          SomeIndigoState (x & out) (Var x)
-> MetaData (x & out)
-> (forall (out :: [*]).
    GenCode (x & out) out (Var x)
    -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds)
forall (inp :: [*]) a r.
SomeIndigoState inp a
-> MetaData inp
-> (forall (out :: [*]). GenCode inp out a -> r)
-> r
runSIS (forall (inp :: [*]).
IsObject x =>
SomeIndigoState (x & inp) (Var x)
forall a (inp :: [*]).
IsObject a =>
SomeIndigoState (a & inp) (Var a)
deepDecomposeCompose @r) (MetaData out -> MetaData (x & out)
forall a (inp :: [*]).
KnownValue a =>
MetaData inp -> MetaData (a & inp)
pushNoRefMd (MetaData out -> MetaData (x & out))
-> MetaData out -> MetaData (x & out)
forall a b. (a -> b) -> a -> b
$ GenCode (xs ++ inp) out (Rec TypedFieldVar xs) -> MetaData out
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> MetaData out
gcMeta GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
restGc) ((forall (out :: [*]).
  GenCode (x & out) out (Var x)
  -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
 -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> (forall (out :: [*]).
    GenCode (x & out) out (Var x)
    -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds)
forall a b. (a -> b) -> a -> b
$ \curGc :: GenCode (x & out) out (Var x)
curGc ->
            GenCode (x & (xs ++ inp)) out (Rec TypedFieldVar (x : xs))
-> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> SomeGenCode inp a
SomeGenCode (GenCode (x & (xs ++ inp)) out (Rec TypedFieldVar (x : xs))
 -> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds))
-> GenCode (x & (xs ++ inp)) out (Rec TypedFieldVar (x : xs))
-> SomeGenCode (x & (xs ++ inp)) (Rec TypedFieldVar flds)
forall a b. (a -> b) -> a -> b
$ $WGenCode :: forall (inp :: [*]) (out :: [*]) a.
a
-> MetaData out
-> (inp :-> out)
-> (out :-> inp)
-> GenCode inp out a
GenCode
              { gcOut :: Rec TypedFieldVar (x : xs)
gcOut = Var x -> TypedFieldVar x
forall a. IsObject a => Var a -> TypedFieldVar a
TypedFieldVar (GenCode (x & out) out (Var x) -> Var x
forall (inp :: [*]) (out :: [*]) a. GenCode inp out a -> a
gcOut GenCode (x & out) out (Var x)
curGc) TypedFieldVar x
-> Rec TypedFieldVar xs -> Rec TypedFieldVar (x : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
-> Rec TypedFieldVar xs
forall (inp :: [*]) (out :: [*]) a. GenCode inp out a -> a
gcOut GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
restGc
              , gcMeta :: MetaData out
gcMeta = GenCode (x & out) out (Var x) -> MetaData out
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> MetaData out
gcMeta GenCode (x & out) out (Var x)
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 (Rec TypedFieldVar xs)
-> (xs ++ inp) :-> out
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> inp :-> out
gcCode GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
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 (Var x) -> (x & out) :-> out
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> inp :-> out
gcCode GenCode (x & out) out (Var x)
curGc
              , gcClear :: out :-> (x & (xs ++ inp))
gcClear = GenCode (x & out) out (Var x) -> out :-> (x & out)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> out :-> inp
gcClear GenCode (x & out) out (Var x)
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 (Rec TypedFieldVar xs)
-> out :-> (xs ++ inp)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> out :-> inp
gcClear GenCode (xs ++ inp) out (Rec TypedFieldVar xs)
restGc)
              }

-- | Decompose any 'IndigoObjectF' having 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 (name :: Symbol). f name -> Expr (GetFieldType a name))
-> IndigoObjectF f a -> ExprDecomposition inp a
decomposeObjectF _ (Cell refId :: 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 :: [*]) a.
(MetaData inp -> GenCode inp out a) -> IndigoState inp out a
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
$ \md :: MetaData inp
md -> ()
-> MetaData (a & inp)
-> (inp :-> (a & inp))
-> ((a & inp) :-> inp)
-> GenCode inp (a & inp) ()
forall (inp :: [*]) (out :: [*]) a.
a
-> MetaData out
-> (inp :-> out)
-> (out :-> inp)
-> GenCode inp out a
GenCode () (MetaData inp -> MetaData (a & inp)
forall a (inp :: [*]).
KnownValue a =>
MetaData inp -> MetaData (a & inp)
pushNoRefMd MetaData inp
md) (RefId -> StackVars inp -> inp :-> (a & inp)
forall a (stk :: [*]).
KnownValue a =>
RefId -> StackVars stk -> stk :-> (a & stk)
varActionGet @a RefId
refId (MetaData inp -> StackVars inp
forall (stk :: [*]). MetaData stk -> StackVars stk
mdStack MetaData inp
md)) (a & inp) :-> inp
forall a (s :: [*]). (a & s) :-> s
L.drop
decomposeObjectF unF :: forall (name :: Symbol). f name -> Expr (GetFieldType a name)
unF (Decomposed fields :: Rec f (ConstructorFieldNames 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 (name :: Symbol). f name -> Expr (GetFieldType a name))
-> Rec f (ConstructorFieldNames a) -> Rec Expr (FieldTypes a)
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 (ConstructorFieldNames 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 :: IndigoState inp (a & inp) () -> ExprDecomposition inp a
deconstructOnStack fetchFld :: 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 (FieldTypes a ++ inp) ())
-> IndigoState inp (FieldTypes a ++ inp) ()
forall (inp :: [*]) (out :: [*]) a.
(MetaData inp -> GenCode inp out a) -> IndigoState inp out a
IndigoState ((MetaData inp -> GenCode inp (FieldTypes a ++ inp) ())
 -> IndigoState inp (FieldTypes a ++ inp) ())
-> (MetaData inp -> GenCode inp (FieldTypes a ++ inp) ())
-> IndigoState inp (FieldTypes a ++ inp) ()
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md ->
    let (newMd :: MetaData (FieldTypes a ++ inp)
newMd, clean :: (FieldTypes a ++ inp) :-> inp
clean) = MetaData inp
-> (MetaData (FieldTypes a ++ inp), (FieldTypes a ++ inp) :-> inp)
forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
MetaData inp -> (MetaData (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @(FieldTypes a) MetaData inp
md in
    ()
-> MetaData (FieldTypes a ++ inp)
-> (inp :-> (FieldTypes a ++ inp))
-> ((FieldTypes a ++ inp) :-> inp)
-> GenCode inp (FieldTypes a ++ inp) ()
forall (inp :: [*]) (out :: [*]) a.
a
-> MetaData out
-> (inp :-> out)
-> (out :-> inp)
-> GenCode inp out a
GenCode () MetaData (FieldTypes a ++ inp)
newMd (GenCode inp (a & inp) () -> inp :-> (a & inp)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> inp :-> out
gcCode (IndigoState inp (a & inp) ()
-> MetaData inp -> GenCode inp (a & inp) ()
forall (inp :: [*]) (out :: [*]) a.
IndigoState inp out a -> MetaData inp -> GenCode inp out a
runIndigoState IndigoState inp (a & inp) ()
fetchFld MetaData inp
md) (inp :-> (a & inp))
-> ((a & inp) :-> (FieldTypes a ++ inp))
-> inp :-> (FieldTypes a ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall (st :: [*]).
(InstrDeconstructC a, KnownList (FieldTypes a),
 ToTs (FieldTypes a) ~ ToTs (ConstructorFieldTypes a)) =>
(a & st) :-> (FieldTypes a ++ st)
forall dt (fields :: [*]) (st :: [*]).
(InstrDeconstructC dt, KnownList fields,
 ToTs fields ~ ToTs (ConstructorFieldTypes dt)) =>
(dt & st) :-> (fields ++ st)
L.deconstruct @a @(FieldTypes a)) (FieldTypes a ++ inp) :-> inp
clean

-- | Push the passed stack cells without references to them.
noRefGenCode
  :: forall rs inp . (KnownList rs, AllConstrained KnownValue rs)
  => MetaData inp -> (MetaData (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode :: MetaData inp -> (MetaData (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode md :: MetaData inp
md = case KnownList rs => KList rs
forall k (l :: [k]). KnownList l => KList l
klist @rs of
  KNil -> (MetaData inp
MetaData (rs ++ inp)
md, (rs ++ inp) :-> inp
forall (s :: [*]). s :-> s
L.nop)
  KCons Proxy (Proxy xs
_ :: Proxy rest) -> (MetaData (xs ++ inp) -> MetaData (x & (xs ++ inp)))
-> (((xs ++ inp) :-> inp) -> (x & (xs ++ inp)) :-> inp)
-> (MetaData (xs ++ inp), (xs ++ inp) :-> inp)
-> (MetaData (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 MetaData (xs ++ inp) -> MetaData (x & (xs ++ inp))
forall a (inp :: [*]).
KnownValue a =>
MetaData inp -> MetaData (a & inp)
pushNoRefMd ((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
#) (MetaData inp -> (MetaData (xs ++ inp), (xs ++ inp) :-> inp)
forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
MetaData inp -> (MetaData (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @rest MetaData inp
md)