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

-- | Backend of the statements to create and modify variables
module Indigo.Backend.Var
  ( newVar
  , setVar
  , setField
  , updateVar
  ) where

import Indigo.Backend.Prelude
import Indigo.Internal
import Indigo.Lorentz
import qualified Lorentz.Instr as L
import Michelson.Typed.Haskell.Instr.Product (GetFieldType)
import Util.Type (type (++))

-- | Create a new variable with passed expression as an initial value.
newVar :: IsExpr ex x => ex -> IndigoState inp (x & inp) (Var x)
newVar :: ex -> IndigoState inp (x & inp) (Var x)
newVar e :: ex
e = ex -> IndigoState inp (ExprType ex & inp) ()
forall a (inp :: [*]).
ToExpr a =>
a -> IndigoState inp (ExprType a & inp) ()
compileToExpr ex
e IndigoState inp (x & inp) ()
-> IndigoState (x & inp) (x & inp) (Var x)
-> IndigoState inp (x & inp) (Var x)
forall (inp :: [*]) (out :: [*]) a (out1 :: [*]) b.
IndigoState inp out a
-> IndigoState out out1 b -> IndigoState inp out1 b
>> IndigoState (x & inp) (x & inp) (Var x)
forall x (inp :: [*]).
KnownValue x =>
IndigoState (x & inp) (x & inp) (Var x)
makeTopVar

-- | Set the variable to a new value.
--
-- If a variable is a cell on the stack,
-- we just compile passed expression and replace variable cell on stack.
-- If a variable is decomposed, we decompose passed expression
-- and call 'setVar' recursively from its fields.
setVar
  :: forall a ex inp . ex :~> a
  => Var a -> ex -> IndigoState inp inp ()
setVar :: Var a -> ex -> IndigoState inp inp ()
setVar (Cell refId :: RefId
refId) e :: ex
e = do
  MetaData s :: StackVars inp
s _ <- IndigoState inp inp (MetaData inp)
forall (inp :: [*]). IndigoState inp inp (MetaData inp)
iget
  ex -> ((a & inp) :-> inp) -> IndigoState inp inp ()
forall n ex (inp :: [*]).
IsExpr ex n =>
ex -> ((n & inp) :-> inp) -> IndigoState inp inp ()
unaryOpFlat ex
e (((a & inp) :-> inp) -> IndigoState inp inp ())
-> ((a & inp) :-> inp) -> IndigoState inp inp ()
forall a b. (a -> b) -> a -> b
$ RefId -> StackVars inp -> (a & inp) :-> inp
forall a (stk :: [*]).
KnownValue a =>
RefId -> StackVars stk -> (a & stk) :-> stk
varActionSet RefId
refId StackVars inp
s
setVar (Decomposed fields :: Rec (NamedFieldVar a) (ConstructorFieldNames a)
fields) ex :: ex
ex = case Expr a -> ExprDecomposition inp a
forall a (inp :: [*]).
ComplexObjectC a =>
Expr a -> ExprDecomposition inp a
decomposeExpr (ex -> Expr (ExprType ex)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr ex
ex) of
  ExprFields fieldsExpr :: Rec Expr (FieldTypes a)
fieldsExpr ->
    Rec TypedFieldVar (FieldTypes a)
-> Rec Expr (FieldTypes a) -> IndigoState inp inp ()
forall (rs :: [*]).
Rec TypedFieldVar rs -> Rec Expr rs -> IndigoState inp inp ()
rmapZipM ((forall (name :: Symbol).
 NamedFieldVar a name -> TypedFieldVar (GetFieldType a name))
-> Rec (NamedFieldVar a) (ConstructorFieldNames a)
-> Rec TypedFieldVar (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 a (name :: Symbol).
NamedFieldVar a name -> TypedFieldVar (GetFieldType a name)
forall (name :: Symbol).
NamedFieldVar a name -> TypedFieldVar (GetFieldType a name)
namedToTypedFieldVar Rec (NamedFieldVar a) (ConstructorFieldNames a)
fields) Rec Expr (FieldTypes a)
fieldsExpr
  Deconstructed comp :: IndigoState inp (FieldTypes a ++ inp) ()
comp ->
    (MetaData inp -> GenCode inp inp ()) -> IndigoState inp inp ()
forall (inp :: [*]) (out :: [*]) a.
(MetaData inp -> GenCode inp out a) -> IndigoState inp out a
IndigoState ((MetaData inp -> GenCode inp inp ()) -> IndigoState inp inp ())
-> (MetaData inp -> GenCode inp inp ()) -> IndigoState inp inp ()
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md ->
      let GenCode _ decomposeMd :: MetaData (FieldTypes a ++ inp)
decomposeMd decomposeExCd :: inp :-> (FieldTypes a ++ inp)
decomposeExCd _ = MetaData inp
-> IndigoState inp (FieldTypes a ++ inp) ()
-> GenCode inp (FieldTypes a ++ inp) ()
forall (inp :: [*]) (out :: [*]) a.
MetaData inp -> IndigoState inp out a -> GenCode inp out a
usingIndigoState MetaData inp
md IndigoState inp (FieldTypes a ++ inp) ()
comp in
      let setAllFieldsCd :: (FieldTypes a ++ inp) :-> inp
setAllFieldsCd = Rec TypedFieldVar (FieldTypes a)
-> MetaData (FieldTypes a ++ inp) -> (FieldTypes a ++ inp) :-> inp
forall (rs :: [*]).
Rec TypedFieldVar rs -> MetaData (rs ++ inp) -> (rs ++ inp) :-> inp
setFieldsOnStack ((forall (name :: Symbol).
 NamedFieldVar a name -> TypedFieldVar (GetFieldType a name))
-> Rec (NamedFieldVar a) (ConstructorFieldNames a)
-> Rec TypedFieldVar (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 a (name :: Symbol).
NamedFieldVar a name -> TypedFieldVar (GetFieldType a name)
forall (name :: Symbol).
NamedFieldVar a name -> TypedFieldVar (GetFieldType a name)
namedToTypedFieldVar Rec (NamedFieldVar a) (ConstructorFieldNames a)
fields) MetaData (FieldTypes a ++ inp)
decomposeMd in
      ()
-> MetaData inp
-> (inp :-> inp)
-> (inp :-> inp)
-> GenCode inp inp ()
forall (inp :: [*]) (out :: [*]) a.
a
-> MetaData out
-> (inp :-> out)
-> (out :-> inp)
-> GenCode inp out a
GenCode () MetaData inp
md (inp :-> (FieldTypes a ++ inp)
decomposeExCd (inp :-> (FieldTypes a ++ inp))
-> ((FieldTypes a ++ inp) :-> inp) -> inp :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (FieldTypes a ++ inp) :-> inp
setAllFieldsCd) inp :-> inp
forall (s :: [*]). s :-> s
L.nop
  where
    -- Set fields, if they are decomposed on stack.
    setFieldsOnStack :: forall rs . Rec TypedFieldVar rs -> MetaData (rs ++ inp) -> (rs ++ inp) :-> inp
    setFieldsOnStack :: Rec TypedFieldVar rs -> MetaData (rs ++ inp) -> (rs ++ inp) :-> inp
setFieldsOnStack RNil _ = (rs ++ inp) :-> inp
forall (s :: [*]). s :-> s
L.nop
    setFieldsOnStack (TypedFieldVar f :: Var r
f :& vs :: Rec TypedFieldVar rs
vs) md :: MetaData (rs ++ inp)
md =
      let (val :: Var r
val, setVarMd :: MetaData (r & (rs ++ inp))
setVarMd) = MetaData (rs ++ inp) -> (Var r, MetaData (r & (rs ++ inp)))
forall x (stk :: [*]).
KnownValue x =>
MetaData stk -> (Var x, MetaData (x & stk))
pushRefMd (MetaData (r & (rs ++ inp)) -> MetaData (rs ++ inp)
forall a (inp :: [*]). MetaData (a & inp) -> MetaData inp
popNoRefMd MetaData (r & (rs ++ inp))
MetaData (rs ++ inp)
md) in
      let setVarCd :: (r & (rs ++ inp)) :-> (r & (rs ++ inp))
setVarCd = GenCode (r & (rs ++ inp)) (r & (rs ++ inp)) ()
-> (r & (rs ++ inp)) :-> (r & (rs ++ inp))
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> inp :-> out
gcCode (GenCode (r & (rs ++ inp)) (r & (rs ++ inp)) ()
 -> (r & (rs ++ inp)) :-> (r & (rs ++ inp)))
-> GenCode (r & (rs ++ inp)) (r & (rs ++ inp)) ()
-> (r & (rs ++ inp)) :-> (r & (rs ++ inp))
forall a b. (a -> b) -> a -> b
$ MetaData (r & (rs ++ inp))
-> IndigoState (r & (rs ++ inp)) (r & (rs ++ inp)) ()
-> GenCode (r & (rs ++ inp)) (r & (rs ++ inp)) ()
forall (inp :: [*]) (out :: [*]) a.
MetaData inp -> IndigoState inp out a -> GenCode inp out a
usingIndigoState MetaData (r & (rs ++ inp))
setVarMd (IndigoState (r & (rs ++ inp)) (r & (rs ++ inp)) ()
 -> GenCode (r & (rs ++ inp)) (r & (rs ++ inp)) ())
-> IndigoState (r & (rs ++ inp)) (r & (rs ++ inp)) ()
-> GenCode (r & (rs ++ inp)) (r & (rs ++ inp)) ()
forall a b. (a -> b) -> a -> b
$ Var r
-> Expr r -> IndigoState (r & (rs ++ inp)) (r & (rs ++ inp)) ()
forall a ex (inp :: [*]).
(ex :~> a) =>
Var a -> ex -> IndigoState inp inp ()
setVar Var r
f (Var r -> Expr r
forall a. KnownValue a => Var a -> Expr a
V Var r
val) in
      (r & (rs ++ inp)) :-> (r & (rs ++ inp))
setVarCd ((r & (rs ++ inp)) :-> (r & (rs ++ inp)))
-> ((r & (rs ++ inp)) :-> (rs ++ inp))
-> (r & (rs ++ inp)) :-> (rs ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      (r & (rs ++ inp)) :-> (rs ++ inp)
forall a (s :: [*]). (a & s) :-> s
L.drop ((r & (rs ++ inp)) :-> (rs ++ inp))
-> ((rs ++ inp) :-> inp) -> (r & (rs ++ inp)) :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      Rec TypedFieldVar rs -> MetaData (rs ++ inp) -> (rs ++ inp) :-> inp
forall (rs :: [*]).
Rec TypedFieldVar rs -> MetaData (rs ++ inp) -> (rs ++ inp) :-> inp
setFieldsOnStack Rec TypedFieldVar rs
vs (MetaData (r & (rs ++ inp)) -> MetaData (rs ++ inp)
forall a (inp :: [*]). MetaData (a & inp) -> MetaData inp
popNoRefMd MetaData (r & (rs ++ inp))
MetaData (rs ++ inp)
md)

    -- Take list of fields (variables, referring to them)
    -- and list of corresponding expressions and call 'setVar' recursively.
    rmapZipM :: Rec TypedFieldVar rs -> Rec Expr rs -> IndigoState inp inp ()
    rmapZipM :: Rec TypedFieldVar rs -> Rec Expr rs -> IndigoState inp inp ()
rmapZipM RNil RNil = () -> IndigoState inp inp ()
forall a (inp :: [*]). a -> IndigoState inp inp a
return ()
    rmapZipM (TypedFieldVar f :: Var r
f :& flds :: Rec TypedFieldVar rs
flds) (e :: Expr r
e :& exprs :: Rec Expr rs
exprs) = Var r -> Expr r -> IndigoState inp inp ()
forall a ex (inp :: [*]).
(ex :~> a) =>
Var a -> ex -> IndigoState inp inp ()
setVar Var r
f Expr r
e IndigoState inp inp ()
-> IndigoState inp inp () -> IndigoState inp inp ()
forall (inp :: [*]) (out :: [*]) a (out1 :: [*]) b.
IndigoState inp out a
-> IndigoState out out1 b -> IndigoState inp out1 b
>> Rec TypedFieldVar rs -> Rec Expr rs -> IndigoState inp inp ()
forall (rs :: [*]).
Rec TypedFieldVar rs -> Rec Expr rs -> IndigoState inp inp ()
rmapZipM Rec TypedFieldVar rs
flds Rec Expr rs
Rec Expr rs
exprs

-- | Set the field (direct or indirect) of a complex object.
setField ::
  forall dt fname ftype ex inp .
  ( ex :~> ftype
  , IsObject dt
  , IsObject ftype
  , HasField dt fname ftype
  )
  => Var dt -> Label fname -> ex -> IndigoState inp inp ()
setField :: Var dt -> Label fname -> ex -> IndigoState inp inp ()
setField v :: Var dt
v@(Cell _) lb :: Label fname
lb ex :: ex
ex = ('[ftype, dt] :-> '[dt]) -> Var dt -> ex -> IndigoState inp inp ()
forall ey y x (inp :: [*]).
(IsExpr ey y, IsObject x) =>
('[y, x] :-> '[x]) -> Var x -> ey -> IndigoState inp inp ()
updateVar (StoreFieldOps dt fname ftype
-> Label fname -> '[ftype, dt] :-> '[dt]
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField (FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
forall dt (fname :: Symbol) ftype.
FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO FieldLens dt fname ftype
forall dt (fname :: Symbol) ftype.
HasField dt fname ftype =>
FieldLens dt fname ftype
fieldLens) Label fname
lb) Var dt
v ex
ex
setField (Decomposed fields :: Rec (NamedFieldVar dt) (ConstructorFieldNames dt)
fields) targetLb :: Label fname
targetLb ex :: ex
ex = case HasField dt fname ftype => FieldLens dt fname ftype
forall dt (fname :: Symbol) ftype.
HasField dt fname ftype =>
FieldLens dt fname ftype
fieldLens @dt @fname @ftype of
  TargetField lb :: Label fname
lb _ ->
    case Label fname
-> Rec (NamedFieldVar dt) (ConstructorFieldNames dt)
-> NamedFieldVar dt fname
forall a (name :: Symbol) (f :: Symbol -> *)
       (proxy :: Symbol -> *).
AccessFieldC a name =>
proxy name -> Rec f (ConstructorFieldNames a) -> f name
fetchField @dt Label fname
lb Rec (NamedFieldVar dt) (ConstructorFieldNames dt)
fields of
      NamedFieldVar v :: Var (GetFieldType dt fname)
v ->
        Var ftype -> ex -> IndigoState inp inp ()
forall a ex (inp :: [*]).
(ex :~> a) =>
Var a -> ex -> IndigoState inp inp ()
setVar Var ftype
Var (GetFieldType dt fname)
v ex
ex
  DeeperField (Label fname
lb :: Label fnameInterm) _ ->
    case Label fname
-> Rec (NamedFieldVar dt) (ConstructorFieldNames dt)
-> NamedFieldVar dt fname
forall a (name :: Symbol) (f :: Symbol -> *)
       (proxy :: Symbol -> *).
AccessFieldC a name =>
proxy name -> Rec f (ConstructorFieldNames a) -> f name
fetchField @dt Label fname
lb Rec (NamedFieldVar dt) (ConstructorFieldNames dt)
fields of
      NamedFieldVar vf :: Var (GetFieldType dt fname)
vf ->
        Var (GetFieldType dt fname)
-> Label fname -> ex -> IndigoState inp inp ()
forall dt (fname :: Symbol) ftype ex (inp :: [*]).
(ex :~> ftype, IsObject dt, IsObject ftype,
 HasField dt fname ftype) =>
Var dt -> Label fname -> ex -> IndigoState inp inp ()
setField @(GetFieldType dt fnameInterm) @fname @ftype Var (GetFieldType dt fname)
vf Label fname
targetLb ex
ex

-- | Call binary operator with constant argument to update variable in-place.
updateVar
  :: (IsExpr ey y, IsObject x)
  => [y, x] :-> '[x]
  -> Var x
  -> ey
  -> IndigoState inp inp ()
updateVar :: ('[y, x] :-> '[x]) -> Var x -> ey -> IndigoState inp inp ()
updateVar action :: '[y, x] :-> '[x]
action (Cell refId :: RefId
refId) e :: ey
e = do
  MetaData s :: StackVars inp
s _ <- IndigoState inp inp (MetaData inp)
forall (inp :: [*]). IndigoState inp inp (MetaData inp)
iget
  ey -> ((y & inp) :-> inp) -> IndigoState inp inp ()
forall n ex (inp :: [*]).
IsExpr ex n =>
ex -> ((n & inp) :-> inp) -> IndigoState inp inp ()
unaryOpFlat ey
e (((y & inp) :-> inp) -> IndigoState inp inp ())
-> ((y & inp) :-> inp) -> IndigoState inp inp ()
forall a b. (a -> b) -> a -> b
$ RefId -> StackVars inp -> ('[y, x] :-> '[x]) -> (y & inp) :-> inp
forall a b (stk :: [*]).
(KnownValue a, KnownValue b) =>
RefId -> StackVars stk -> ('[b, a] :-> '[a]) -> (b : stk) :-> stk
varActionUpdate RefId
refId StackVars inp
s '[y, x] :-> '[x]
action
-- This function doesn't have to be called for complex data types,
-- it's only supposed to be used for assign-like statements
-- (+=), (-=), etc.
-- But it's implemented just in case.
updateVar action :: '[y, x] :-> '[x]
action v :: Var x
v@(Decomposed _) e :: ey
e = (MetaData inp -> GenCode inp inp ()) -> IndigoState inp inp ()
forall (inp :: [*]) (out :: [*]) a.
(MetaData inp -> GenCode inp out a) -> IndigoState inp out a
IndigoState ((MetaData inp -> GenCode inp inp ()) -> IndigoState inp inp ())
-> (MetaData inp -> GenCode inp inp ()) -> IndigoState inp inp ()
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md ->
  let (var :: Var x
var, newMd :: MetaData (x & inp)
newMd) = MetaData inp -> (Var x, MetaData (x & inp))
forall x (stk :: [*]).
KnownValue x =>
MetaData stk -> (Var x, MetaData (x & stk))
pushRefMd MetaData inp
md in
  MetaData inp -> IndigoState inp inp () -> GenCode inp inp ()
forall (inp :: [*]) (out :: [*]) a.
MetaData inp -> IndigoState inp out a -> GenCode inp out a
usingIndigoState MetaData inp
md (IndigoState inp inp () -> GenCode inp inp ())
-> IndigoState inp inp () -> GenCode inp inp ()
forall a b. (a -> b) -> a -> b
$ ey -> Expr x -> ((y & (x & inp)) :-> inp) -> IndigoState inp inp ()
forall n m ex1 ex2 (inp :: [*]).
AreExprs ex1 ex2 n m =>
ex1 -> ex2 -> ((n & (m & inp)) :-> inp) -> IndigoState inp inp ()
binaryOpFlat ey
e (Var x -> Expr x
forall a. KnownValue a => Var a -> Expr a
V Var x
v) (((y & (x & inp)) :-> inp) -> IndigoState inp inp ())
-> ((y & (x & inp)) :-> inp) -> IndigoState inp inp ()
forall a b. (a -> b) -> a -> b
$
    ('[y, x] :-> '[x]) -> ('[y, x] ++ inp) :-> ('[x] ++ inp)
forall (s :: [*]) (i :: [*]) (o :: [*]).
(KnownList i, KnownList o) =>
(i :-> o) -> (i ++ s) :-> (o ++ s)
L.framed '[y, x] :-> '[x]
action ((y & (x & inp)) :-> (x & inp))
-> ((x & inp) :-> (x & inp)) -> (y & (x & inp)) :-> (x & inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
    GenCode (x & inp) (x & inp) () -> (x & inp) :-> (x & inp)
forall (inp :: [*]) (out :: [*]) a.
GenCode inp out a -> inp :-> out
gcCode (MetaData (x & inp)
-> IndigoState (x & inp) (x & inp) ()
-> GenCode (x & inp) (x & inp) ()
forall (inp :: [*]) (out :: [*]) a.
MetaData inp -> IndigoState inp out a -> GenCode inp out a
usingIndigoState MetaData (x & inp)
newMd (Var x -> Expr x -> IndigoState (x & inp) (x & inp) ()
forall a ex (inp :: [*]).
(ex :~> a) =>
Var a -> ex -> IndigoState inp inp ()
setVar Var x
v (Var x -> Expr x
forall a. KnownValue a => Var a -> Expr a
V Var x
var))) ((y & (x & inp)) :-> (x & inp))
-> ((x & inp) :-> inp) -> (y & (x & inp)) :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
    (x & inp) :-> inp
forall a (s :: [*]). (a & s) :-> s
L.drop