-- 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 Prelude

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

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.Internal.Var
import Indigo.Lorentz
import qualified Lorentz.ADT as L
import qualified Lorentz.Instr as L
import Michelson.Typed.Haskell.Instr.Product (GetFieldType)
import 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 :: SIS' (a : inp) (Object a)
deepDecomposeCompose
  | Just Dict <- IsObject a => Maybe (Dict (ComplexObjectC a))
forall a. IsObject a => Maybe (Dict (ComplexObjectC a))
complexObjectDict @a = \refId :: RefId
refId st :: StackVars (a : inp)
st ->
      let decomposedSt :: StackVars (MapGFT a (GFieldNames (Rep a)) ++ inp)
decomposedSt = (StackVars (MapGFT a (GFieldNames (Rep a)) ++ inp),
 (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> inp)
-> StackVars (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)))) =>
StackVars inp
-> (StackVars (MapGFT a (GFieldNames (Rep a)) ++ inp),
    (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> inp)
forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @(FieldTypes a) (StackVars inp
 -> (StackVars (MapGFT a (GFieldNames (Rep a)) ++ inp),
     (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> inp))
-> StackVars inp
-> (StackVars (MapGFT a (GFieldNames (Rep a)) ++ inp),
    (MapGFT a (GFieldNames (Rep 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
      RefId
-> StackVars (MapGFT a (GFieldNames (Rep a)) ++ inp)
-> SIS'
     (MapGFT a (GFieldNames (Rep a)) ++ inp)
     (Rec TypedFieldObj (MapGFT a (GFieldNames (Rep a))))
-> (forall (out :: [*]).
    (Rec TypedFieldObj (MapGFT a (GFieldNames (Rep a))), RefId,
     GenCode (MapGFT a (GFieldNames (Rep 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 (MapGFT a (GFieldNames (Rep a)) ++ inp)
decomposedSt ((KnownList (MapGFT a (GFieldNames (Rep a))),
 AllConstrained IsObject (MapGFT a (GFieldNames (Rep a)))) =>
SIS'
  (MapGFT a (GFieldNames (Rep a)) ++ inp)
  (Rec TypedFieldObj (MapGFT a (GFieldNames (Rep a))))
forall (flds :: [*]).
(KnownList flds, AllConstrained IsObject flds) =>
SIS' (flds ++ inp) (Rec TypedFieldObj flds)
decomposeComposeFields @(FieldTypes a)) ((forall (out :: [*]).
  (Rec TypedFieldObj (MapGFT a (GFieldNames (Rep a))), RefId,
   GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out)
  -> (Object a, RefId, SomeGenCode (a : inp)))
 -> (Object a, RefId, SomeGenCode (a : inp)))
-> (forall (out :: [*]).
    (Rec TypedFieldObj (MapGFT a (GFieldNames (Rep a))), RefId,
     GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out)
    -> (Object a, RefId, SomeGenCode (a : inp)))
-> (Object a, RefId, SomeGenCode (a : inp))
forall a b. (a -> b) -> a -> b
$ \(result :: Rec TypedFieldObj (MapGFT a (GFieldNames (Rep a)))
result, newRefId :: RefId
newRefId, gc :: GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out
gc) ->
        ( Rec (NamedFieldObj a) (GFieldNames (Rep a)) -> Object a
forall a (f :: Symbol -> *).
ComplexObjectC a =>
Rec f (ConstructorFieldNames a) -> IndigoObjectF f a
Decomposed ((forall (name :: Symbol).
 TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name)
-> Rec TypedFieldObj (MapGFT a (GFieldNames (Rep a)))
-> Rec (NamedFieldObj 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).
TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name
forall (name :: Symbol).
TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name
typedToNamedFieldObj Rec TypedFieldObj (MapGFT a (GFieldNames (Rep 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
$ $WGenCode :: forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode
          { gcStack :: StackVars out
gcStack = GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out
-> StackVars out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> StackVars out
gcStack GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out
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
-> (MapGFT a (GFieldNames (Rep a)) ++ inp) :-> out
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out
gc
          , gcClear :: out :-> (a : inp)
gcClear = GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out
-> out :-> (MapGFT a (GFieldNames (Rep a)) ++ inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> out :-> inp
gcClear GenCode (MapGFT a (GFieldNames (Rep a)) ++ inp) out
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 =
      \refId :: RefId
refId stk :: 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
+ 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 :: SIS' (flds ++ inp) (Rec TypedFieldObj flds)
decomposeComposeFields = case KnownList flds => KList flds
forall k (l :: [k]). KnownList l => KList l
klist @flds of
      KNil -> \refId :: RefId
refId stk :: StackVars (flds ++ inp)
stk -> (Rec TypedFieldObj flds
forall u (a :: u -> *). Rec a '[]
RNil, RefId
refId, GenCode inp inp -> SomeGenCode (flds ++ inp)
forall (inp :: [*]) (out :: [*]).
GenCode inp out -> SomeGenCode inp
SomeGenCode (GenCode inp inp -> SomeGenCode (flds ++ inp))
-> GenCode inp inp -> SomeGenCode (flds ++ 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
refId st :: 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) ((KnownList xs, AllConstrained IsObject xs) =>
SIS' (xs ++ inp) (Rec TypedFieldObj xs)
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 flds, RefId, SomeGenCode (flds ++ inp)))
-> (forall (out :: [*]).
    (Rec TypedFieldObj xs, RefId, GenCode (xs ++ inp) out)
    -> (Rec TypedFieldObj (x : xs), RefId,
        SomeGenCode (x : (xs ++ inp))))
-> (Rec TypedFieldObj flds, RefId, SomeGenCode (flds ++ inp))
forall a b. (a -> b) -> a -> b
$ \(resultRest :: Rec TypedFieldObj xs
resultRest, refId' :: RefId
refId', restGc :: 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 (inp :: [*]). IsObject x => SIS' (x : inp) (Object x)
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
$ \(resultCur :: Object x
resultCur, newRefId :: RefId
newRefId, curGc :: 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
$ $WGenCode :: 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 :: RefId
-> StackVars inp
-> SIS' inp a
-> (forall (out :: [*]). (a, RefId, GenCode inp out) -> r)
-> r
withStack refId :: RefId
refId stk :: StackVars inp
stk sis :: SIS' inp a
sis f :: forall (out :: [*]). (a, RefId, GenCode inp out) -> r
f = case SIS' inp a
sis RefId
refId StackVars inp
stk of
  (res :: a
res, newRefId :: RefId
newRefId, SomeGenCode genCode :: 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 :: DecomposedObjects -> 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 objs :: DecomposedObjects
objs (V 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 objs :: DecomposedObjects
objs (ObjMan 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 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

-- | 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 (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 :: [*]).
(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
$ \md :: 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) (RefId -> StackVars inp -> inp :-> (a : inp)
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 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 :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
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 (newSt :: StackVars (FieldTypes a ++ inp)
newSt, clean :: (FieldTypes a ++ inp) :-> inp
clean) = StackVars inp
-> (StackVars (FieldTypes a ++ inp), (FieldTypes a ++ inp) :-> inp)
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
    StackVars (FieldTypes a ++ inp)
-> (inp :-> (FieldTypes a ++ inp))
-> ((FieldTypes a ++ inp) :-> inp)
-> GenCode inp (FieldTypes a ++ inp)
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars (FieldTypes 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) :-> (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

-----------------------------------------
-- 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 :: StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode md :: StackVars inp
md = case KnownList rs => KList rs
forall k (l :: [k]). KnownList l => KList l
klist @rs of
  KNil -> (StackVars inp
StackVars (rs ++ inp)
md, (rs ++ inp) :-> inp
forall (s :: [*]). s :-> s
L.nop)
  KCons 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
#) (StackVars inp -> (StackVars (xs ++ inp), (xs ++ inp) :-> inp)
forall (rs :: [*]) (inp :: [*]).
(KnownList rs, AllConstrained KnownValue rs) =>
StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)
noRefGenCode @rest StackVars inp
md)