-- 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 :: KnownValue x => Expr x -> IndigoState inp (x & inp) (Var x)
newVar :: Expr x -> IndigoState inp (x & inp) (Var x)
newVar e :: Expr x
e = Expr x -> IndigoState inp (x & inp) ()
forall a (inp :: [*]). Expr a -> IndigoState inp (a & inp) ()
compileExpr Expr x
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 inp. Var a -> Expr a -> IndigoState inp inp ()
setVar :: Var a -> Expr a -> IndigoState inp inp ()
setVar (Cell refId :: RefId
refId) e :: Expr a
e = do
  MetaData s :: StackVars inp
s _ <- IndigoState inp inp (MetaData inp)
forall (inp :: [*]). IndigoState inp inp (MetaData inp)
iget
  Expr a -> ((a & inp) :-> inp) -> IndigoState inp inp ()
forall n (inp :: [*]).
Expr n -> ((n & inp) :-> inp) -> IndigoState inp inp ()
unaryOpFlat Expr a
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 :: Expr a
ex = case Expr a -> ExprDecomposition inp a
forall a (inp :: [*]).
ComplexObjectC a =>
Expr a -> ExprDecomposition inp a
decomposeExpr (Expr a -> Expr (ExprType (Expr a))
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr Expr a
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 (inp :: [*]). Var a -> Expr a -> 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 (inp :: [*]). Var a -> Expr a -> IndigoState inp inp ()
setVar Var r
f Expr r
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 inp .
     ( IsObject dt
     , IsObject ftype
     , HasField dt fname ftype
     )
  => Var dt -> Label fname -> Expr ftype -> IndigoState inp inp ()
setField :: Var dt -> Label fname -> Expr ftype -> IndigoState inp inp ()
setField v :: Var dt
v@(Cell _) lb :: Label fname
lb ex :: Expr ftype
ex = ('[ftype, dt] :-> '[dt])
-> Var dt -> Expr ftype -> IndigoState inp inp ()
forall x y (inp :: [*]).
(IsObject x, KnownValue y) =>
('[y, x] :-> '[x]) -> Var x -> Expr y -> 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 Expr ftype
ex
setField (Decomposed fields :: Rec (NamedFieldVar dt) (ConstructorFieldNames dt)
fields) targetLb :: Label fname
targetLb ex :: Expr ftype
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 -> Expr ftype -> IndigoState inp inp ()
forall a (inp :: [*]). Var a -> Expr a -> IndigoState inp inp ()
setVar Var ftype
Var (GetFieldType dt fname)
v Expr ftype
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 -> Expr ftype -> IndigoState inp inp ()
forall dt (fname :: Symbol) ftype (inp :: [*]).
(IsObject dt, IsObject ftype, HasField dt fname ftype) =>
Var dt -> Label fname -> Expr ftype -> IndigoState inp inp ()
setField @(GetFieldType dt fnameInterm) @fname @ftype Var (GetFieldType dt fname)
vf Label fname
targetLb Expr ftype
ex

-- | Call binary operator with constant argument to update variable in-place.
updateVar
  :: (IsObject x, KnownValue y)
  => [y, x] :-> '[x]
  -> Var x
  -> Expr y
  -> IndigoState inp inp ()
updateVar :: ('[y, x] :-> '[x]) -> Var x -> Expr y -> IndigoState inp inp ()
updateVar action :: '[y, x] :-> '[x]
action (Cell refId :: RefId
refId) e :: Expr y
e = do
  MetaData s :: StackVars inp
s _ <- IndigoState inp inp (MetaData inp)
forall (inp :: [*]). IndigoState inp inp (MetaData inp)
iget
  Expr y -> ((y & inp) :-> inp) -> IndigoState inp inp ()
forall n (inp :: [*]).
Expr n -> ((n & inp) :-> inp) -> IndigoState inp inp ()
unaryOpFlat Expr y
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 :: Expr y
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
$ Expr y
-> Expr x -> ((y & (x & inp)) :-> inp) -> IndigoState inp inp ()
forall n m (inp :: [*]).
Expr n
-> Expr m -> ((n & (m & inp)) :-> inp) -> IndigoState inp inp ()
binaryOpFlat Expr y
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 (inp :: [*]). Var a -> Expr a -> 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