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

-- | This module contains the high-level compilation of Indigo to Lorentz,
-- including plain Indigo code, as well as Indigo contracts.

module Indigo.Compilation
  ( compileIndigo
  , compileIndigoContract
  ) where

import qualified Data.Map as M

import Indigo.Compilation.Field
import Indigo.Compilation.Lambda
import Indigo.Compilation.Params
import Indigo.Compilation.Sequential
import Indigo.Frontend.Program (IndigoContract)
import Indigo.Internal hiding (SetField, (>>))
import Indigo.Lorentz
import Indigo.Prelude
import qualified Lorentz.Instr as L
import qualified Lorentz.Macro as L

-- | Compile Indigo code to Lorentz.
--
-- Note: it is necessary to specify the number of parameters (using the first
-- type variable) of the Indigo function. Also, these should be on the top of
-- the input stack in inverse order (see 'IndigoWithParams').
compileIndigoImpl
  :: forall n inp a. (AreIndigoParams n inp, KnownValue a, Default (StackVars inp))
  => IndigoWithParams n inp a
  -> (StackVars inp -> (Block, RefId) -> (inp :-> inp))
  -> inp :-> inp
compileIndigoImpl :: IndigoWithParams n inp a
-> (StackVars inp -> (Block, RefId) -> inp :-> inp) -> inp :-> inp
compileIndigoImpl paramCode :: IndigoWithParams n inp a
paramCode runner :: StackVars inp -> (Block, RefId) -> inp :-> inp
runner =
    StackVars inp -> (Block, RefId) -> inp :-> inp
runner StackVars inp
initMd (Block, RefId)
optimized
  where
    (code :: IndigoM a
code, initMd :: StackVars inp
initMd, nextRef :: RefId
nextRef) = IndigoWithParams n inp a -> (IndigoM a, StackVars inp, RefId)
forall (n :: Nat) a (inp :: [*]).
(AreIndigoParams n inp, KnownValue a, Default (StackVars inp)) =>
IndigoWithParams n inp a -> (IndigoM a, StackVars inp, RefId)
fromIndigoWithParams @n @a IndigoWithParams n inp a
paramCode
    optimized :: (Block, RefId)
optimized = RefId -> IndigoM a -> (Block, RefId)
forall a. RefId -> IndigoM a -> (Block, RefId)
indigoMtoSequential RefId
nextRef IndigoM a
code
      (Block, RefId)
-> ((Block, RefId) -> (Block, RefId)) -> (Block, RefId)
forall a b. a -> (a -> b) -> b
& (Block, RefId) -> (Block, RefId)
compileLambdas
      (Block, RefId)
-> ((Block, RefId) -> (Block, RefId)) -> (Block, RefId)
forall a b. a -> (a -> b) -> b
& (Block, RefId) -> (Block, RefId)
optimizeFields

-- | Specialiasation of 'compileIndigoImpl' without var decompositions.
compileIndigo
  :: forall n inp a. (AreIndigoParams n inp, KnownValue a, Default (StackVars inp))
  => IndigoWithParams n inp a
  -> inp :-> inp
compileIndigo :: IndigoWithParams n inp a -> inp :-> inp
compileIndigo paramCode :: IndigoWithParams n inp a
paramCode =
  IndigoWithParams n inp a
-> (StackVars inp -> (Block, RefId) -> inp :-> inp) -> inp :-> inp
forall (n :: Nat) (inp :: [*]) a.
(AreIndigoParams n inp, KnownValue a, Default (StackVars inp)) =>
IndigoWithParams n inp a
-> (StackVars inp -> (Block, RefId) -> inp :-> inp) -> inp :-> inp
compileIndigoImpl @n @inp @a IndigoWithParams n inp a
paramCode (\stk :: StackVars inp
stk block :: (Block, RefId)
block -> MetaData inp -> (Block, RefId) -> inp :-> inp
forall (inp :: [*]). MetaData inp -> (Block, RefId) -> inp :-> inp
sequentialToLorentz (StackVars inp -> DecomposedObjects -> MetaData inp
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> MetaData inp
MetaData StackVars inp
stk DecomposedObjects
forall a. Monoid a => a
mempty) (Block, RefId)
block)

-- | Compile Indigo code to Lorentz contract.
-- Drop elements from the stack to return only @[Operation]@ and @storage@.
compileIndigoContract
  :: forall param st .
  ( KnownValue param
  , IsObject st
  )
  => IndigoContract param st
  -> ContractCode param st
compileIndigoContract :: IndigoContract param st -> ContractCode param st
compileIndigoContract code :: IndigoContract param st
code =
  ('[param, st, Ops] :-> '[param, st, Ops]) -> ContractCode param st
prepare (('[param, st, Ops] :-> '[param, st, Ops])
 -> ContractCode param st)
-> ('[param, st, Ops] :-> '[param, st, Ops])
-> ContractCode param st
forall a b. (a -> b) -> a -> b
$ IndigoWithParams 3 '[param, st, Ops] ()
-> (StackVars '[param, st, Ops]
    -> (Block, RefId) -> '[param, st, Ops] :-> '[param, st, Ops])
-> '[param, st, Ops] :-> '[param, st, Ops]
forall (n :: Nat) (inp :: [*]) a.
(AreIndigoParams n inp, KnownValue a, Default (StackVars inp)) =>
IndigoWithParams n inp a
-> (StackVars inp -> (Block, RefId) -> inp :-> inp) -> inp :-> inp
compileIndigoImpl @3 @'[param, st, Ops] (IndigoContract param st -> IndigoWithParams 3 '[param, st, Ops] ()
forall param st.
KnownValue st =>
IndigoContract param st -> IndigoWithParams 3 '[param, st, Ops] ()
contractToIndigoWithParams IndigoContract param st
code) ((StackVars '[param, st, Ops]
  -> (Block, RefId) -> '[param, st, Ops] :-> '[param, st, Ops])
 -> '[param, st, Ops] :-> '[param, st, Ops])
-> (StackVars '[param, st, Ops]
    -> (Block, RefId) -> '[param, st, Ops] :-> '[param, st, Ops])
-> '[param, st, Ops] :-> '[param, st, Ops]
forall a b. (a -> b) -> a -> b
$
    \(parRef :: StkEl r
parRef :& storageRef :: StkEl r
storageRef :& opsStack :: Rec StkEl rs
opsStack) (block :: Block
block, nextRef :: RefId
nextRef) ->
      let stRef :: RefId
stRef = case StkEl r
storageRef of
                    NoRef -> Text -> RefId
forall a. HasCallStack => Text -> a
error "Storage variable hasn't been assigned"
                    Ref r :: RefId
r -> RefId
r in
      -- during code Indigo code compilation the stack will look like:
      -- [var_10, var_9, ... , var_3, param_var_2, storage_field_11, storage_field_12, ..., storage_field_20, ops_var_0]
      -- var_1 will represent storage and passed to DecomposedObjects
      let (storageObj :: Object st
storageObj, nextRef' :: RefId
nextRef', someGen :: SomeGenCode (st & rs)
someGen) = SIS' (st & rs) (Object st)
forall a (inp :: [*]). IsObject a => SIS' (a & inp) (Object a)
deepDecomposeCompose RefId
nextRef (StkEl st
forall a. KnownValue a => StkEl a
NoRef StkEl st -> Rec StkEl rs -> Rec StkEl (st & rs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec StkEl rs
opsStack) in
      case SomeGenCode (st & rs)
someGen of
        SomeGenCode (GenCode decompStk :: StackVars out
decompStk decompose :: (st & rs) :-> out
decompose composeBack :: out :-> (st & rs)
composeBack) ->
          let md :: MetaData (r : out)
md = StackVars (r : out) -> DecomposedObjects -> MetaData (r : out)
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> MetaData inp
MetaData (StkEl r
parRef StkEl r -> StackVars out -> StackVars (r : out)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& StackVars out
decompStk) (DecomposedObjects -> MetaData (r : out))
-> DecomposedObjects -> MetaData (r : out)
forall a b. (a -> b) -> a -> b
$ RefId -> SomeObject -> DecomposedObjects
forall k a. k -> a -> Map k a
M.singleton RefId
stRef (Object st -> SomeObject
forall a. IsObject a => Object a -> SomeObject
SomeObject Object st
storageObj)
              indigoCode :: (r : out) :-> (r : out)
indigoCode = MetaData (r : out) -> (Block, RefId) -> (r : out) :-> (r : out)
forall (inp :: [*]). MetaData inp -> (Block, RefId) -> inp :-> inp
sequentialToLorentz MetaData (r : out)
md (Block
block, RefId
nextRef') in
          ((st & rs) :-> out) -> (r & (st & rs)) :-> (r : out)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a & s) :-> (a & s')
L.dip (st & rs) :-> out
decompose ((r & (st & rs)) :-> (r : out))
-> ((r : out) :-> (r : out)) -> (r & (st & rs)) :-> (r : out)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# -- decompose storage
          (r : out) :-> (r : out)
indigoCode ((r & (st & rs)) :-> (r : out))
-> ((r : out) :-> (r & (st & rs)))
-> (r & (st & rs)) :-> (r & (st & rs))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# -- run indigo code
          (out :-> (st & rs)) -> (r : out) :-> (r & (st & rs))
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a & s) :-> (a & s')
L.dip out :-> (st & rs)
composeBack
  where
    prepare :: ('[param, st, Ops] :-> '[param, st, Ops]) -> ('[(param, st)] :-> '[(Ops, st)])
    prepare :: ('[param, st, Ops] :-> '[param, st, Ops]) -> ContractCode param st
prepare cd :: '[param, st, Ops] :-> '[param, st, Ops]
cd =
      ((param, st) & '[]) :-> (Ops & ((param, st) & '[]))
forall p (s :: [*]). KnownValue p => s :-> (List p & s)
L.nil (((param, st) & '[]) :-> (Ops & ((param, st) & '[])))
-> ((Ops & ((param, st) & '[])) :-> ((param, st) & '[Ops]))
-> ((param, st) & '[]) :-> ((param, st) & '[Ops])
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (Ops & ((param, st) & '[])) :-> ((param, st) & '[Ops])
forall a b (s :: [*]). (a & (b & s)) :-> (b & (a & s))
L.swap (((param, st) & '[]) :-> ((param, st) & '[Ops]))
-> (((param, st) & '[Ops]) :-> '[param, st, Ops])
-> ((param, st) & '[]) :-> '[param, st, Ops]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((param, st) & '[Ops]) :-> '[param, st, Ops]
forall a b (s :: [*]). ((a, b) & s) :-> (a & (b & s))
L.unpair (((param, st) & '[]) :-> '[param, st, Ops])
-> ('[param, st, Ops] :-> '[param, st, Ops])
-> ((param, st) & '[]) :-> '[param, st, Ops]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      '[param, st, Ops] :-> '[param, st, Ops]
cd (((param, st) & '[]) :-> '[param, st, Ops])
-> ('[param, st, Ops] :-> '[st, Ops])
-> ((param, st) & '[]) :-> '[st, Ops]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      '[param, st, Ops] :-> '[st, Ops]
forall a (s :: [*]). (a & s) :-> s
L.drop (((param, st) & '[]) :-> '[st, Ops])
-> ('[st, Ops] :-> (Ops & (st & '[])))
-> ((param, st) & '[]) :-> (Ops & (st & '[]))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# -- drop param
      '[st, Ops] :-> (Ops & (st & '[]))
forall a b (s :: [*]). (a & (b & s)) :-> (b & (a & s))
L.swap (((param, st) & '[]) :-> (Ops & (st & '[])))
-> ((Ops & (st & '[])) :-> ((Ops, st) & '[]))
-> ContractCode param st
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (Ops & (st & '[])) :-> ((Ops, st) & '[])
forall a b (s :: [*]). (a & (b & s)) :-> ((a, b) & s)
L.pair