Decompose.hs

-- 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 (ConstructWithoutNamed fields) = ExprFields fields
decomposeExpr (V v) = decomposeObjectF (\(NamedFieldVar vr) -> V vr) v
decomposeExpr (ObjMan objMan) = case runObjectManipulation objMan of
  StillObject obj -> decomposeObjectF unNamedFieldExpr obj
  OnStack comp -> deconstructOnStack comp
decomposeExpr ex = deconstructOnStack $ compileExpr 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
  | Just Dict <- complexObjectDict @a = SomeIndigoState $ \md ->
      let decomposedMd = fst (noRefGenCode @(FieldTypes a) $ popNoRefMd md) in
      runSIS (decomposeComposeFields @(FieldTypes a)) decomposedMd $ \gc ->
        SomeGenCode $ GenCode
          { gcOut = Decomposed (typedToNamedRec @a typedToNamedFieldVar (gcOut gc))
          , gcMeta = gcMeta gc
          , gcCode = L.deconstruct @a @(FieldTypes a) # gcCode gc
          , gcClear = gcClear gc # L.constructStack @a  @(FieldTypes a)
          }
  | otherwise = SomeIndigoState $ SomeGenCode . runIndigoState makeTopVar
  where
    decomposeComposeFields
      :: forall flds . (KnownList flds, AllConstrained IsObject flds)
      => SomeIndigoState (flds ++ inp) (Rec TypedFieldVar flds)
    decomposeComposeFields = case klist @flds of
      KNil -> returnSIS RNil
      KCons (_ :: Proxy r) (_ :: Proxy rest) -> SomeIndigoState $ \md ->
        runSIS (decomposeComposeFields @rest) (popNoRefMd md) $ \restGc ->
          runSIS (deepDecomposeCompose @r) (pushNoRefMd $ gcMeta restGc) $ \curGc ->
            SomeGenCode $ GenCode
              { gcOut = TypedFieldVar (gcOut curGc) :& gcOut restGc
              , gcMeta = gcMeta curGc
              , gcCode = L.dip (gcCode restGc) # gcCode curGc
              , gcClear = gcClear curGc # L.dip (gcClear 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 _ (Cell refId) =
  deconstructOnStack $
    IndigoState $ \md -> GenCode () (pushNoRefMd md) (varActionGet @a refId (mdStack md)) L.drop
decomposeObjectF unF (Decomposed fields) =
  ExprFields $ namedToTypedRec @a unF 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 fetchFld =
  Deconstructed $ IndigoState $ \md ->
    let (newMd, clean) = noRefGenCode @(FieldTypes a) md in
    GenCode () newMd (gcCode (runIndigoState fetchFld md) # L.deconstruct @a @(FieldTypes a)) 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 md = case klist @rs of
  KNil -> (md, L.nop)
  KCons Proxy (_ :: Proxy rest) -> bimap pushNoRefMd (L.drop #) (noRefGenCode @rest md)